home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / zen / compiler.src < prev    next >
Text File  |  1990-01-25  |  8KB  |  340 lines
  1. \*
  2.  *   ZEN 1.10  Compiler operators
  3.  *     C 1990  by Martin Tracy
  4.  *             Last modified  1.1.90
  5.  *\
  6.  
  7. \ Allocate n bytes of array memory.
  8. : ALLOT ( n) \ CORE
  9.    VP +! ;
  10.  
  11. \ Add low byte of w to table memory.
  12. : C, ( w) \ CORE
  13.    TP @ C!  1 TP +! ;
  14.  
  15. \ Add w to table memory.
  16. : , ( w) \ CORE
  17.    TP @ !  CELL TP +! ;
  18.  
  19.  
  20. \ Read one byte from CODE space at address a.
  21. CODE XC@ ( a - b)
  22.         mov   bl,cs:[bx]
  23.         sub   bh,bh
  24.         NEXT
  25. END-CODE
  26.  
  27. \ Write lower byte into CODE space at address a.
  28. CODE XC! ( w a)
  29.         pop   ax
  30.         mov   cs:[bx],al
  31.         pop   bx
  32.         NEXT
  33. END-CODE
  34.  
  35. \ Read one word from CODE space at address a.
  36. CODE X@ ( a - w)
  37.         mov   bx,cs:[bx]
  38.         NEXT
  39. END-CODE
  40.  
  41. \ Write word into CODE space at address a.
  42. CODE X! ( w a)
  43.         pop   cs:[bx]
  44.         pop   bx
  45.         NEXT
  46. END-CODE
  47.  
  48. \ Force the dictionary to the next aligned address.
  49. : ALIGN
  50.    ;
  51. IMMEDIATE
  52.  
  53.  
  54. \ Compile execution token.
  55. : ['] ( "ccc ") ( - w) \ CORE
  56.    '  POSTPONE Tic  X, ;
  57. IMMEDIATE
  58.  
  59. \ Convert execution token into data field address.
  60. : >BODY ( w - a) \ CORE
  61.    PFA X@ ;
  62.  
  63. \ Parse ccc and compile the integer value of its first character.
  64. : [CHAR] ( "ccc ") ( - c) \ CORE
  65.    CHAR  POSTPONE LITERAL ;
  66. IMMEDIATE
  67.  
  68.  
  69. \ Parse a character-delimited string.
  70. : PARSE ( c "xxxc" - a u)
  71.    >R  SOURCE  >IN @ /STRING  OVER SWAP
  72.    R> SCAN  >R  OVER -  DUP R> IF  1+  THEN  >IN +! ;
  73.  
  74. \ Scratch string area.
  75. : PAD ( - a) \ EXT CORE
  76.    THERE 34 + ;
  77.  
  78. : ", ( a u)
  79.    HERE  OVER 1+ TP +!  PLACE ( ALIGN) ;
  80.  
  81. \ String literal, eg " ccc"
  82. : " ( 'ccc"') ( - a u) \ CORE
  83.    [CHAR] " PARSE
  84.    STATE @ IF  POSTPONE SLit  HERE X,  ",
  85.            ELSE  PAD PLACE  PAD COUNT  THEN ;
  86. IMMEDIATE
  87.  
  88. \ Message literal, eg ." ccc"
  89. : ." ( 'ccc"') \ CORE
  90.    POSTPONE "  POSTPONE TYPE ;
  91. IMMEDIATE
  92.  
  93. \ Compile error handler and message.
  94. : ABORT" ( 'ccc"') ( ) \ CORE
  95.    POSTPONE IF  POSTPONE "  POSTPONE ERR  POSTPONE THEN ;
  96. IMMEDIATE
  97.  
  98. \ Comments
  99. : ( \ CORE
  100.    [CHAR] ) PARSE  2DROP ;
  101. IMMEDIATE
  102.  
  103. \ Messages
  104. : .( \ CORE
  105.    [CHAR] ) PARSE  TYPE ;
  106. IMMEDIATE
  107.  
  108.  
  109. 2VARIABLE 'WARN   \ Redefinition and locate field actions
  110. 2VARIABLE  LAST   \ Newest lfa and cfa
  111.  
  112. \ Create link and name fields.
  113. : HEADER ( "<name> ")
  114.    ( ALIGN)  BL WORD  COUNT DUP HUH?  2DUP UPCASE
  115.    'WARN       PERFORM ( Redefinition?)
  116.    'WARN CELL+ PERFORM ( Locate field )
  117.    DP @  DUP LAST !  CURRENT @ DUP @ X, !  ( link field)
  118.    DP @  1+ SWAP  DUP >R  0                ( name field)
  119.    DO  OVER C@ OVER XC!  SWAP 1+ SWAP 1+  LOOP  2DROP
  120.    R@ 1+ DP +!  R> 128 OR  LAST @ CELL+ XC! ;
  121.  
  122. \ Marks the newest dictionary entry as immediate.
  123. : IMMEDIATE ( ) \ CORE
  124.    LAST @ CELL+  DUP XC@ BL ( ie 32) OR  SWAP XC! ;
  125.  
  126.  
  127. | 233 CONSTANT #JMP   \ JMP  Op code
  128. | 232 CONSTANT #CALL  \ CALL Op code
  129.  
  130. \ Build code field as JMP or CALL to 'code.
  131. | : CODE, ( 'code op)
  132.    DP @  DUP LAST CELL+ !  XC!  1 DP +!  DP @ CELL+ -  X, ;
  133.  
  134. \ Make 'code the new action of the given code field.
  135. : PATCH ( 'code cfa)
  136.    #JMP  OVER XC!  1+  DUP >R  CELL+ -  R> X! ;
  137.  
  138.  
  139. \ Create a table.
  140. : CREATE ( "<name> ") ( - a) \ CORE
  141.    HEADER  ['] DoCreate  #JMP CODE,
  142.    HERE X, ;
  143.  
  144. \ Create a variable or array
  145. : VARIABLE ( "<name> ") ( - a) \ CORE
  146.    HEADER  ['] DoVariable  #JMP CODE,
  147.    THERE X,  THERE OFF  CELL ALLOT ;
  148.  
  149. \ Create a constant
  150. : CONSTANT ( w "<name> " ) ( - w) \ CORE
  151.    HEADER  ['] DoConstant  #JMP CODE,
  152.    X, ;
  153.  
  154.  
  155. VOX? \*IF
  156. \ Create a vocabulary
  157. : VOCABULARY   \ VOCABULARY
  158.    VARIABLE
  159.    DOES> CONTEXT ! ;
  160. *\
  161.  
  162. \ Create a value
  163. : VALUE ( "<name> " ) ( - w) \ CORE EXT
  164.    HEADER  ['] DoValue  #JMP CODE,
  165.            ['] DoValTo  #JMP CODE,
  166.    THERE X,  0 THERE !  CELL ALLOT ;
  167.  
  168.  
  169. \ Store w into the data field of the VALUE or LOCAL .  State-smart.
  170. : TO ( "<name> ") ( w)
  171.    '  PFA  STATE @ IF  X,  ELSE  EXECUTE  THEN ;
  172. IMMEDIATE
  173.  
  174.  
  175. LOX? \*IF
  176. | CODE LOCT
  177. ISLOCAL 0
  178. ISLOCAL 1
  179. ISLOCAL 2
  180. ISLOCAL 3
  181. ISLOCAL 4
  182. ISLOCAL 5
  183. ISLOCAL 6
  184. ISLOCAL 7
  185. END-CODE
  186.  
  187. | VARIABLE XFrame   \ Local : or DOES> code field
  188.  
  189. \ Return stack frame support for locals.
  190. | : SF
  191.    XFrame @  LAST CELL+ @ 1+  DUP >R  CELL+ -  R> X! ;
  192.  
  193. : LOCAL
  194.    BL WORD COUNT  2DUP UPCASE  TUCK  LOC$ @ PLACE  1+ LOC$ +!
  195.    ['] LOCT LOCS @ [ #CFA 2* ] LITERAL * + PFA X,  1  LOCS +! ;
  196. IMMEDIATE
  197. *\
  198.  
  199.  
  200. \ Keep together
  201. | VARIABLE BAL    \ Compiler security.
  202. | VARIABLE BAL2   \ Used by  RAKE
  203.  
  204. \ Start support.
  205. | : ::
  206. [ LOX? ] \IF  LOCS OFF  LOC$ CELL+ LOC$ !
  207.    0 0 BAL 2!  ] ;
  208.  
  209. \ Start a colon definition.
  210. : : ( "<name> " ) ( ) \ CORE
  211.    HEADER     ['] DoColon  #CALL CODE,
  212. [ LOX? ] \IF  ['] DoFrame  XFrame !
  213.    LAST @ X@ CURRENT @ !  ::  ] ;
  214.  
  215. \ End support.
  216. | : ;;
  217. [ LOX? ] \IF  LOCS @ IF  SF  THEN
  218.    BAL 2@ OR ABORT" Unbalanced" ;
  219.  
  220. \ Terminate a colon definition.
  221. : ; ( ) \ CORE
  222.    ;;  LAST @ CURRENT @ !  POSTPONE EXIT  POSTPONE [ ;
  223. IMMEDIATE
  224.  
  225.  
  226. \ Connect the most recently defined word to the following code.
  227. | : PIPE ( )
  228.    R> LAST CELL+ @ PATCH ;
  229.  
  230. \ Add action to most recently defined word.
  231. : DOES> ( ) ( - a) \ CORE
  232.    ;;  POSTPONE PIPE  ['] DoDoes  #CALL CODE,
  233. [ LOX? ] \IF          ['] DoFramD XFrame !
  234.    :: ;
  235. IMMEDIATE
  236.  
  237.  
  238. \ Begin an indefinite loop.
  239. : BEGIN ( - sys) ( ) \ CORE
  240.    DP @  1 BAL +! ;
  241. IMMEDIATE
  242.  
  243. \ Decrement BAL factor.
  244. | : -BAL ( )
  245.   -1 BAL +! ;
  246.  
  247. \ Begin IF ... ELSE ... THEN
  248. : IF ( - sys) ( f) \ CORE
  249.    POSTPONE ZBranch  POSTPONE BEGIN  0 X, ;
  250. IMMEDIATE
  251.  
  252. \ End IF ... ELSE ... THEN
  253. : THEN ( sys) ( ) \ CORE
  254.    -BAL  DP @ SWAP X! ;
  255. IMMEDIATE
  256.  
  257. \ Used in IF ... ELSE ... THEN
  258. : ELSE ( sys - sys2) ( ) \ CORE
  259.    POSTPONE Branch  POSTPONE BEGIN  0 X,  SWAP  POSTPONE THEN ;
  260. IMMEDIATE
  261.  
  262. \ End BEGIN ... UNTIL
  263. : UNTIL ( sys) ( f) \ CORE
  264.    -BAL  POSTPONE ZBranch  X, ;
  265. IMMEDIATE
  266.  
  267. \ End BEGIN ... AGAIN
  268. : AGAIN ( sys) ( ) \ EXT CORE
  269.    -BAL  POSTPONE Branch  X, ;
  270. IMMEDIATE
  271.  
  272. \ Used in BEGIN ... WHILE ... REPEAT
  273. : WHILE ( sys - sys2) ( f) \ CORE
  274.    BAL @ HUH?  POSTPONE IF  SWAP ;
  275. IMMEDIATE
  276.  
  277. \ End BEGIN ... WHILE ... REPEAT
  278. : REPEAT ( sys) ( ) \ CORE
  279.    POSTPONE AGAIN  POSTPONE THEN ;
  280. IMMEDIATE
  281.  
  282.  
  283. \ Begin a definite loop
  284. : DO ( - sys) ( n n2; R: n n2) \ CORE
  285.    POSTPONE BEGIN  POSTPONE RDo ;
  286. IMMEDIATE
  287.  
  288. \ Begin a definite loop if indices are unequal.
  289. : ?DO ( - sys) ( n n2; R: n n2) \ CORE
  290.    POSTPONE ?>  POSTPONE ZBranch
  291.    BAL2 @ X,  DP @ BAL2 !
  292.    POSTPONE DO  ;  IMMEDIATE
  293.  
  294. \ Terminate definite loop immediately.
  295. : LEAVE ( sys - sys2) ( ) \ CORE
  296.    POSTPONE UNLOOP  POSTPONE Branch
  297.    DP @  BAL2 @ X,  BAL2 ! ;
  298. IMMEDIATE
  299.  
  300. \ Gathers LEAVEs.  Courtesy of Wil Baden.
  301. | : RAKE ( sys) ( 'RDo)
  302.    DUP CELL+ X,  BAL2 @
  303.    BEGIN  2DUP 1+ U<
  304.    WHILE  2DUP = CELL AND -  DUP X@ DP @ ROT X!
  305.    REPEAT  BAL2 ! DROP ;
  306.  
  307. \ End DO ... LOOP
  308. : LOOP ( sys) ( ; R: | n n2) \ CORE
  309.    -BAL  POSTPONE RLoop  RAKE ;
  310. IMMEDIATE
  311.  
  312. \ End DO ... +LOOP
  313. : +LOOP ( sys) ( n; R: | n n2) \ CORE
  314.    -BAL  POSTPONE PLoop  RAKE ;
  315. IMMEDIATE
  316.  
  317.  
  318. \ Compile a self-reference.
  319. : RECURSE ( ?) \ CORE
  320.    LAST CELL+ @ X, ;
  321. IMMEDIATE
  322.  
  323. \ Postpone execution of this word.
  324. : POSTPONE ( "ccc ") ( ?) \ CORE
  325.    BL WORD  DUP C@ HUH?  FIND  DUP HUH?  0<
  326.    IF  POSTPONE LITERAL  POSTPONE X,  ELSE  X,  THEN ;
  327. IMMEDIATE
  328.  
  329.  
  330. \ Display words in search order.
  331. : WORDS ( ) \ RESERVED
  332.    CONTEXT @ @
  333.    BEGIN  ?DUP
  334.    WHILE  CR  DUP CELL+  THERE  OVER XC@ 31 AND  DUP THERE C!  0
  335.      DO  SWAP 1+ SWAP 1+  OVER XC@ OVER C!  LOOP  2DROP
  336.      THERE COUNT TYPE
  337.      ?KEY IF  2DROP EXIT  THEN
  338.      DUP X@
  339.    REPEAT ;
  340.