home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Club Amiga de Montreal - CAM
/
CAM_CD_1.iso
/
files
/
382.lha
/
ConZap
/
conzap.4th
< prev
next >
Wrap
Text File
|
1990-05-30
|
6KB
|
269 lines
\ ConZap 1.0
\ Copyright 1989 Warren Block.
\ Written in Amiga Multi-Forth, Copyright 1986 Creative Solutions Inc.
DECIMAL
\ Various ugly incantations to make the smallest turnkey possible.
\ And ugly it is...sheesh.
\ Typical Forth code doesn't look like this...but I never said I
\ was typical!
\
\ QUICK.VOCAB OFF
\ FORGET QUICK
\ 28 +OBJECT OFF
\ 0 36 +object @ +object c!
\ tokens? last.token @ last.token 4- @ - 6 / - tokens
\ objhandle @ handle.size object.room - 128 + resize.object
\ Whew! Now on to some clearer code that makes more sense.
\ Program constants and other miscellanea.
CREATE Req$ 0," REQ"
CREATE NoReq$ 0," NOREQ"
CREATE Raw$ 0," RAW"
CREATE Cooked$ 0," COOKED"
CREATE ConsoleName$ 0," *"
\ Structure size and offset declarations. Normally, the system provides
\ these, but eliminating everything provided by the system allows you to
\ create the smallest possible turnkey.
: NULL 0 ;
68 WCONSTANT StandardPacket
34 WCONSTANT MsgPort
1 WCONSTANT MEMF_PUBLIC
65536 CONSTANT MEMF_CLEAR
4 WCONSTANT NT_MSGPORT
0 WCONSTANT PA_SIGNAL
: +spPkt 20 + ;
: +spMsg ;
: +mnNode ;
: +mpFlags 14 + ;
: +mpNode ;
: +mpMsgList 20 + ;
: +mpSigBit 15 + ;
: +mpSigTask 16+ ;
: +lhHead ;
: +lnName 10+ ;
: +lnPri 9 + ;
: +lnType 8+ ;
: +dpLink ;
: +dpPort 4+ ;
: +dpType 8+ ;
: +dpArg1 20 + ;
: +dpRes1 12 + ;
: +fhType 8+ ;
: +prWindowPtr 184 + ;
: | OR ;
\ Exec routine words. Again, these are normally provided by the system,
\ but I throw out most of the system declarations to make a small turnkey.
HEX
CREATE NewList ( list -- ) -4 ALLOT
205F w, 2088 w, 5890 w, 42A8 w, 0004 w,
2148 w, 0008 w, 361A w, 4EF6 w, 3018 w,
DECIMAL
: AllocMem ( bytes flags --- mem )
!D1 !D0 EXEC@ 33 ;
: FreeMem ( addr size --- )
!D0 !A1 EXEC 35 ;
: AllocSignal ( signal or -1 --- signal )
!D0 EXEC@ 55 ;
: FreeSignal ( signal --- )
!D0 EXEC 56 ;
: ePutMsg ( msgport msg --- )
!A1 !A0 EXEC 61 ;
: eGetMsg ( msgport --- msg )
!A0 EXEC@ 62 ;
: eWaitPort ( msgport --- msg )
!A0 EXEC@ 64 ;
: AddPort ( msgport --- )
!A1 EXEC 59 ;
: RemPort ( msgport -- )
!A1 EXEC 60 ;
: FindTask ( --- task )
!A1 EXEC@ 49 ;
\ CreatePort, DeletePort routines.
: CreatePort ( 0$ priority --- msgport )
0 NULL LOCALS| port sigbit pri name |
-1 AllocSignal TO sigbit
sigbit -1 = IF
FALSE
EXIT
THEN
MsgPort MEMF_PUBLIC MEMF_CLEAR | AllocMem TO port
port NOT IF
sigbit FreeSignal
FALSE
EXIT
THEN
name port +mpNode +lnName !
pri port +mpNode +lnPri C!
NT_MSGPORT port +mpNode +lnType C!
PA_SIGNAL port +mpFlags C!
sigbit port +mpSigBit C!
0 FindTask port +mpSigTask !
name IF
port AddPort
ELSE
port +mpMsgList NewList
THEN
port ;
: DeletePort ( port --- )
LOCALS| port |
port +mpNode +lnName @ IF
port RemPort
THEN
255 port +mpNode +lnType C!
-1 port +mpMsgList +lhHead !
port +mpSigBit FreeSignal
port MsgPort FreeMem ;
\ Raw mode stuff.
994 CONSTANT ACTION_SCREEN_MODE
: SendPacket ( msgport action arg --- res1 ) \ Send a DOS packet.
NULL NULL LOCALS| packet replyport arg action pid |
NULL 0 CreatePort TO replyport
replyport NOT IF
FALSE
EXIT
THEN
StandardPacket MEMF_PUBLIC MEMF_CLEAR | AllocMem TO packet
packet NOT IF
replyport DeletePort
FALSE
EXIT
THEN
packet +spPkt packet +spMsg +mnNode +lnName !
packet +spMsg packet +spPkt +dpLink !
replyport packet +spPkt +dpPort !
action packet +spPkt +dpType !
\ This implementation of SendPacket only sends one argument...
arg packet +spPkt +dpArg1 !
pid packet ePutMsg
replyport eWaitPort DROP
replyport eGetMsg DROP
packet +spPkt +dpRes1 @
packet StandardPacket FreeMem
replyport DeletePort ;
\ Raw mode switching stuff.
: SetRaw ( f --- ) \ Set the current console raw mode.
ConsoleName$ OPEN LOCALS| confh rawflag |
confh IF
confh 4* +fhType @ ACTION_SCREEN_MODE rawflag SendPacket DROP
confh CLOSE
THEN ;
\ Requester control stuff.
: SetReq ( f --- ) \ Set AmigaDOS requesters on/off.
NOT 0 FindTask +prWindowPtr ! ;
\ Command line parsing stuff.
10 WCONSTANT LF \ linefeed ASCII value
10 WCONSTANT ArgSize
CREATE Arg1 ArgSize ALLOT
CREATE Arg2 ArgSize ALLOT
GLOBAL ArgLoc
GLOBAL ArgLen
: SkipSpaces ( --- ) \ Skip over spaces on a command line.
BEGIN
ArgLoc C@ BL =
ArgLen 0> AND
WHILE
ArgLoc 1+ TO ArgLoc
ArgLen 1- TO ArgLen
REPEAT ;
: GetArg ( arg$ --- ) \ Get a CLI argument.
0 0 0 LOCALS| maxsize movechar moveloc arg$ |
SkipSpaces
ArgLen ArgSize 1- MIN TO maxsize
BEGIN
ArgLoc moveloc + C@ TO movechar
movechar arg$ moveloc + C!
moveloc 1+ TO moveloc
ArgLen 1- TO ArgLen
movechar BL = movechar LF = OR moveloc maxsize > OR UNTIL
0 arg$ moveloc 1- + C!
ArgLoc moveloc + TO ArgLoc ;
\ Program-dependent argument checking.
: CheckArg ( arg$ --- f ) \ Check to see if argument string is valid.
LOCALS| arg$ | \ If it is, perform the function.
arg$ DUP 0$LEN UPPER \ make argument upper case
arg$ Req$ DUP 0$LEN SWAP -TEXT 0= DUP IF TRUE SetReq THEN
arg$ NoReq$ DUP 0$LEN SWAP -TEXT 0= DUP IF FALSE SetReq THEN OR
arg$ Raw$ DUP 0$LEN SWAP -TEXT 0= DUP IF TRUE SetRaw THEN OR
arg$ Cooked$ DUP 0$LEN SWAP -TEXT 0= DUP IF FALSE SetRaw THEN OR ;
\ Program-independent CLI parsing.
: GetArgs ( --- ) \ Get two CLI arguments.
Arg1 ArgSize ERASE
Arg2 ArgSize ERASE
TIBPTR @ TO ArgLoc
TIBLEN @ TO ArgLen
Arg1 GetArg
Arg2 GetArg ;
: CheckArgs ( --- f ) \ Get the args and check them for validity.
GetArgs
Arg1 CheckArg
Arg2 CheckArg OR ;
\ Main program.
: ShowInfo ( --- ) \ Print out CLI information.
." ConZap 1.0 Copyright 1989 Warren Block" CR
." Written in Multi-Forth, Copyright 1986 Creative Solutions" CR
." Usage: ConZap [Req|NoReq] [Raw|Cooked]" CR ;
: Main ( --- ) \ Turnkey procedure.
CheckArgs NOT IF
ShowInfo
THEN
?Turnkey IF BYE THEN ;