home *** CD-ROM | disk | FTP | other *** search
/ Club Amiga de Montreal - CAM / CAM_CD_1.iso / files / 382.lha / ConZap / conzap.4th < prev    next >
Text File  |  1990-05-30  |  6KB  |  269 lines
  1. \ ConZap 1.0
  2. \ Copyright 1989 Warren Block.
  3. \ Written in Amiga Multi-Forth, Copyright 1986 Creative Solutions Inc.
  4.  
  5. DECIMAL
  6.  
  7. \ Various ugly incantations to make the smallest turnkey possible.
  8. \ And ugly it is...sheesh.
  9. \ Typical Forth code doesn't look like this...but I never said I
  10. \ was typical!
  11. \
  12. \ QUICK.VOCAB OFF
  13. \ FORGET QUICK
  14. \ 28 +OBJECT OFF
  15. \ 0 36 +object @ +object c!
  16.  
  17. \ tokens? last.token @ last.token 4- @ - 6 / - tokens
  18. \ objhandle @ handle.size object.room - 128 + resize.object
  19.  
  20. \ Whew!  Now on to some clearer code that makes more sense.
  21.  
  22. \ Program constants and other miscellanea.
  23.  
  24. CREATE Req$          0," REQ"
  25. CREATE NoReq$        0," NOREQ"
  26. CREATE Raw$          0," RAW"
  27. CREATE Cooked$       0," COOKED"
  28. CREATE ConsoleName$  0," *"
  29.  
  30. \ Structure size and offset declarations.  Normally, the system provides
  31. \ these, but eliminating everything provided by the system allows you to
  32. \ create the smallest possible turnkey.
  33.  
  34. : NULL   0 ;
  35.  
  36. 68 WCONSTANT StandardPacket
  37. 34 WCONSTANT MsgPort
  38.  
  39. 1     WCONSTANT MEMF_PUBLIC
  40. 65536  CONSTANT MEMF_CLEAR
  41.  
  42. 4 WCONSTANT NT_MSGPORT
  43. 0 WCONSTANT PA_SIGNAL
  44.  
  45. : +spPkt          20 + ;
  46. : +spMsg               ;
  47. : +mnNode              ;
  48. : +mpFlags        14 + ;
  49. : +mpNode              ;
  50. : +mpMsgList      20 + ;
  51. : +mpSigBit       15 + ;
  52. : +mpSigTask       16+ ;
  53. : +lhHead              ;
  54. : +lnName          10+ ;
  55. : +lnPri           9 + ;
  56. : +lnType           8+ ;
  57. : +dpLink              ;
  58. : +dpPort           4+ ;
  59. : +dpType           8+ ;
  60. : +dpArg1         20 + ;
  61. : +dpRes1         12 + ;
  62. : +fhType           8+ ;
  63. : +prWindowPtr   184 + ;
  64.  
  65. : |   OR ;
  66.  
  67. \ Exec routine words.  Again, these are normally provided by the system,
  68. \ but I throw out most of the system declarations to make a small turnkey.
  69.  
  70. HEX
  71.  
  72. CREATE NewList   ( list -- )   -4 ALLOT
  73.   205F w, 2088 w, 5890 w, 42A8 w, 0004 w,
  74.   2148 w, 0008 w, 361A w, 4EF6 w, 3018 w,
  75.  
  76. DECIMAL
  77.  
  78. : AllocMem   ( bytes flags --- mem )
  79.    !D1 !D0 EXEC@ 33 ;
  80.  
  81. : FreeMem   ( addr size --- )
  82.    !D0 !A1 EXEC 35 ;
  83.  
  84. : AllocSignal   ( signal or -1 --- signal )
  85.    !D0 EXEC@ 55 ;
  86.  
  87. : FreeSignal   ( signal --- )
  88.    !D0 EXEC 56 ;
  89.  
  90. : ePutMsg   ( msgport msg --- )
  91.    !A1 !A0 EXEC 61 ;
  92.  
  93. : eGetMsg   ( msgport --- msg )
  94.    !A0 EXEC@ 62 ;
  95.  
  96. : eWaitPort ( msgport --- msg )
  97.    !A0 EXEC@ 64 ;
  98.  
  99. : AddPort   ( msgport --- )
  100.    !A1 EXEC 59 ;
  101.  
  102. : RemPort   ( msgport -- )
  103.    !A1 EXEC 60 ;
  104.  
  105. : FindTask ( --- task )
  106.    !A1 EXEC@ 49 ;
  107.  
  108. \ CreatePort, DeletePort routines.
  109.  
  110. : CreatePort   ( 0$ priority --- msgport )
  111.    0 NULL LOCALS| port sigbit pri name |
  112.    -1 AllocSignal TO sigbit
  113.    sigbit -1 = IF
  114.      FALSE
  115.      EXIT
  116.    THEN
  117.  
  118.    MsgPort MEMF_PUBLIC MEMF_CLEAR | AllocMem TO port
  119.    port NOT IF
  120.      sigbit FreeSignal
  121.      FALSE
  122.      EXIT
  123.    THEN
  124.  
  125.    name       port +mpNode +lnName !
  126.    pri        port +mpNode +lnPri  C!
  127.    NT_MSGPORT port +mpNode +lnType C!
  128.    PA_SIGNAL  port +mpFlags        C!
  129.    sigbit     port +mpSigBit       C!
  130.    0 FindTask port +mpSigTask      !
  131.  
  132.    name IF
  133.      port AddPort
  134.    ELSE
  135.      port +mpMsgList NewList
  136.    THEN
  137.    port ;
  138.  
  139. : DeletePort   ( port --- )
  140.    LOCALS| port |
  141.    port +mpNode +lnName @ IF
  142.      port RemPort
  143.    THEN
  144.    255 port +mpNode    +lnType C!
  145.    -1  port +mpMsgList +lhHead !
  146.    port +mpSigBit FreeSignal
  147.    port MsgPort FreeMem ;
  148.  
  149. \ Raw mode stuff.
  150.  
  151. 994 CONSTANT ACTION_SCREEN_MODE
  152.  
  153. : SendPacket   ( msgport action arg --- res1 )  \ Send a DOS packet.
  154.    NULL NULL LOCALS| packet replyport arg action pid |
  155.  
  156.    NULL 0 CreatePort TO replyport
  157.    replyport NOT IF
  158.      FALSE
  159.      EXIT
  160.    THEN
  161.  
  162.    StandardPacket MEMF_PUBLIC MEMF_CLEAR | AllocMem TO packet
  163.    packet NOT IF
  164.      replyport DeletePort
  165.      FALSE
  166.      EXIT
  167.    THEN
  168.  
  169.    packet +spPkt packet +spMsg +mnNode +lnName !
  170.    packet +spMsg packet +spPkt +dpLink !
  171.    replyport     packet +spPkt +dpPort !
  172.    action        packet +spPkt +dpType !
  173.  
  174.    \ This implementation of SendPacket only sends one argument...
  175.    arg packet +spPkt +dpArg1 !
  176.  
  177.    pid packet ePutMsg
  178.    replyport  eWaitPort DROP
  179.    replyport  eGetMsg   DROP
  180.  
  181.    packet +spPkt +dpRes1 @
  182.  
  183.    packet StandardPacket FreeMem
  184.    replyport DeletePort ;
  185.  
  186. \ Raw mode switching stuff.
  187.  
  188. : SetRaw   ( f --- )  \ Set the current console raw mode.
  189.    ConsoleName$ OPEN LOCALS| confh rawflag |
  190.    confh IF
  191.      confh 4* +fhType @ ACTION_SCREEN_MODE rawflag SendPacket DROP
  192.      confh CLOSE
  193.    THEN ;
  194.  
  195. \ Requester control stuff.
  196.  
  197. : SetReq   ( f --- )  \ Set AmigaDOS requesters on/off.
  198.    NOT 0 FindTask +prWindowPtr ! ;
  199.  
  200. \ Command line parsing stuff.
  201.  
  202. 10 WCONSTANT LF                \ linefeed ASCII value
  203. 10 WCONSTANT ArgSize
  204.  
  205. CREATE Arg1  ArgSize ALLOT
  206. CREATE Arg2  ArgSize ALLOT
  207. GLOBAL ArgLoc
  208. GLOBAL ArgLen
  209.  
  210. : SkipSpaces   ( --- )  \ Skip over spaces on a command line.
  211.    BEGIN
  212.      ArgLoc C@ BL =
  213.      ArgLen 0> AND
  214.    WHILE
  215.      ArgLoc 1+ TO ArgLoc
  216.      ArgLen 1- TO ArgLen
  217.    REPEAT ;
  218.  
  219. : GetArg   ( arg$ --- )  \ Get a CLI argument.
  220.    0 0 0 LOCALS| maxsize movechar moveloc arg$ |
  221.    SkipSpaces
  222.    ArgLen ArgSize 1- MIN TO maxsize
  223.    BEGIN
  224.      ArgLoc moveloc + C@ TO movechar
  225.      movechar arg$ moveloc + C!
  226.      moveloc 1+ TO moveloc
  227.      ArgLen 1- TO ArgLen
  228.    movechar BL =  movechar LF = OR  moveloc maxsize > OR  UNTIL
  229.    0 arg$ moveloc 1- + C!
  230.    ArgLoc moveloc + TO ArgLoc ;
  231.  
  232. \ Program-dependent argument checking.
  233.  
  234. : CheckArg   ( arg$ --- f )  \ Check to see if argument string is valid.
  235.    LOCALS| arg$ |            \ If it is, perform the function.
  236.    arg$ DUP 0$LEN UPPER      \ make argument upper case
  237.    arg$ Req$    DUP 0$LEN SWAP -TEXT 0= DUP  IF  TRUE  SetReq  THEN
  238.    arg$ NoReq$  DUP 0$LEN SWAP -TEXT 0= DUP  IF  FALSE SetReq  THEN OR
  239.    arg$ Raw$    DUP 0$LEN SWAP -TEXT 0= DUP  IF  TRUE  SetRaw  THEN OR
  240.    arg$ Cooked$ DUP 0$LEN SWAP -TEXT 0= DUP  IF  FALSE SetRaw  THEN OR ;
  241.  
  242. \ Program-independent CLI parsing.
  243.  
  244. : GetArgs   ( --- )  \ Get two CLI arguments.
  245.    Arg1 ArgSize ERASE
  246.    Arg2 ArgSize ERASE
  247.    TIBPTR @ TO ArgLoc
  248.    TIBLEN @ TO ArgLen
  249.    Arg1 GetArg
  250.    Arg2 GetArg ;
  251.  
  252. : CheckArgs   ( --- f )  \ Get the args and check them for validity.
  253.    GetArgs
  254.    Arg1 CheckArg
  255.    Arg2 CheckArg OR ;
  256.  
  257. \ Main program.
  258.  
  259. : ShowInfo   ( --- )  \ Print out CLI information.
  260.    ." ConZap 1.0 Copyright 1989 Warren Block"                    CR
  261.    ." Written in Multi-Forth, Copyright 1986 Creative Solutions" CR
  262.    ." Usage: ConZap [Req|NoReq] [Raw|Cooked]"                    CR ;
  263.  
  264. : Main   ( --- )  \ Turnkey procedure.
  265.    CheckArgs NOT IF
  266.      ShowInfo
  267.    THEN
  268.    ?Turnkey IF  BYE  THEN ;
  269.