home *** CD-ROM | disk | FTP | other *** search
/ ftp.whtech.com / ftp.whtech.com.7z / ftp.whtech.com / emulators / v9t9 / linux / sources / V9t9 / tools / Forth / compile.fs < prev    next >
Encoding:
FORTH Source  |  2006-10-19  |  7.6 KB  |  663 lines
  1. \ Compiler
  2. \
  3.  
  4. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  5.  
  6. \    Words required by cross-compiler, not in standard.
  7.  
  8. \    noop lit :dodoes :docol :dovar :douser :docon ;s branch ?branch
  9.  
  10. [IFUNDEF] noop
  11. : noop ;
  12. [THEN]
  13.  
  14. [IFUNDEF] lit
  15. error" need prim lit"
  16. [THEN]
  17.  
  18. [IFUNDEF] :dodoes
  19. error" need prim :dodoes"
  20. [THEN]
  21.  
  22. [IFUNDEF] :docol
  23. error" need prim :docol"
  24. [THEN]
  25.  
  26. [IFUNDEF] :dovar
  27. error" need prim :dovar"
  28. [THEN]
  29.  
  30. [IFUNDEF] :douser
  31. error" need prim :douser"
  32. [THEN]
  33.  
  34. [IFUNDEF] :docon
  35. error" need prim :docon"
  36. [THEN]
  37.  
  38. [IFUNDEF] :dodefer
  39. error" need prim :dodefer"
  40. [THEN]
  41.  
  42. [IFUNDEF] ;s
  43. error" need prim ;s"
  44. [THEN]
  45.  
  46. [IFUNDEF] branch
  47. error" need prim branch"
  48. [THEN]
  49.  
  50. [IFUNDEF] ?branch
  51. error" need prim ?branch"
  52. [THEN]
  53.  
  54. [IFUNDEF] (.")
  55. : (.")    ( PFA: cstring -- )
  56. \    Warning: this assumes that the IP is stored on the return stack,
  57. \    due to this being a colon definition.
  58. \
  59.     r@ 
  60.     dup c@ $80 >= if 
  61.         dup @ $7fff and >r
  62.         2+
  63.     else
  64.         dup c@ >r
  65.         1+
  66.     then
  67.     r@ type r> r> + 1+ aligned >r
  68. ;
  69. [THEN]
  70.  
  71. \ \\\\\\\\\\\\\\\\\\\
  72.  
  73. : lastxt
  74.     latest lfa>nfa nfa>xt
  75. ;
  76.  
  77. 1 include common.fs
  78.  
  79. has? standard-threading [if]
  80.  
  81. \    For a word pushing pfa
  82. : does,    ( code -- addr )
  83.     ,
  84. ;
  85.  
  86. \    For a code word
  87. : code,    ( -- )
  88.     here ,
  89. ;
  90.  
  91. : docol!  ( cfa -- )
  92.     ['] :docol swap ! 
  93. ;
  94.  
  95. : xt!    ( addr cfa -- )
  96.     !
  97. ;
  98.  
  99. : docol,
  100.     ['] :docol ,
  101.     0  ,        \ mysterious blank
  102. ;
  103.  
  104. [else]
  105.  
  106. : does!    ( addr cfa -- )
  107.     bl-dodoes over !
  108.     cell+ !
  109. ;
  110.  
  111. \    For a word which pushes the PFA
  112. : does,    ( code -- )
  113.     here does! 2 cells allot
  114. ;
  115.  
  116. \    For a code word
  117. : code, ( addr -- )
  118.     ,
  119. ;
  120.  
  121. : docol!    ( cfa -- )
  122.     bl-docol swap !
  123.     -2 dp +!            \ lose extra CFA word
  124. ;
  125.  
  126. : xt! ( addr cfa -- )
  127.     cell+ !
  128. ;
  129.  
  130. : docol,    ( addr -- )
  131.     bl-docol ,
  132. ;
  133.  
  134. : dodefer!    ( cfa -- )
  135.     BL-@ swap !
  136.     -2 dp +!
  137.     ['] :dodefer ,
  138. ;
  139.  
  140. [THEN]
  141.  
  142. [IFUNDEF] (compile)
  143. \    compile the following word in the IP stream
  144. \    (needed cross compiler)
  145. : (compile)
  146.     r> dup cell+ >r @ ,    
  147. ;
  148. [THEN]
  149.  
  150.  
  151. \ \\\\\\\\\\\\\\\\\\\\\\\\
  152.  
  153. : message        ( flag # -- )
  154.     dup -&13 = if ." undefined" else
  155. \    dup 4 = if ." already defined" else
  156. \    dup 9 = if ." interpreting mode only" else
  157.     dup -&14 = if ." compilation mode only" else
  158.     dup -&16 = if ." using a zero-length name" else
  159.     dup -&22 = if ." control structures mismatched" else
  160.     ." ?" dup .
  161.     then then then then \ then
  162.     drop
  163.     cr
  164. ;
  165.  
  166. : ?error
  167.     swap if
  168.         message quit
  169.     else
  170.         drop
  171.     then
  172. ;
  173.  
  174. \ : ?exec
  175. \     state @ -14 ?error
  176. \ ;
  177.  
  178. : ?comp
  179.     state @ 0= -&14 ?error
  180. ;
  181.  
  182. \    Differs from old version:
  183. \    set $80 for visible definition.
  184. \    Note: this affects xt>nfa, since it stops when
  185. \    the LFA's length byte has $80.  
  186. \    If we for some reason to "latest xt>nfa" while compiling
  187. \    a word, it will fail...  ;)
  188. : smudge
  189.     latest lfa>nfa dict-name-smudge toggle
  190. ;
  191.  
  192. \    Given an address inside the current bank the desired
  193. \    gap space, return 0 if there is enough room, else
  194. \    return start address of new bank.
  195.  
  196. 0 [if]
  197.  
  198. : (bank+)      ( addr gap -- 0 | bank )
  199.     >r
  200.     dup (dp0  dp0) 1fff or  within if
  201.         dp0) r@ -  >= if 
  202.                (dp1
  203.         else
  204.             0
  205.         then
  206.     else
  207.         drop 0
  208.     then
  209.     rdrop
  210. ;
  211.  
  212. \    Adjust DP to the next bank if necessary
  213. : (bank?)
  214.     .s
  215.     here $180 (bank+) dup .s if                    \ $80 word, $100 tib
  216.         ." Switching RAM banks to " dup u. cr
  217.         dp ! .s
  218.     else
  219.         drop
  220.     then
  221.     \ here ." [" u. ." ]"
  222. ;
  223.  
  224. [then]
  225.  
  226. : CREATE
  227. \    (bank?)
  228.  
  229.     align
  230.  
  231. [ has? profiling [if] ]
  232.     \ Space for profiling 
  233.     here  >r 0 ,
  234. [ [then] ]
  235.  
  236.     \ Put LFA --> ptr to previous LFA
  237.     here latest ,
  238.  
  239.     \ Get name
  240.     bl parse 
  241.     ?dup 0= if
  242.         -&16 message quit
  243.     then
  244.  
  245.     (lookup)
  246.     if
  247.         id.
  248.         space ." already defined" cr
  249.     then 
  250.  
  251.     \ Get space for name
  252.     here c@ width min
  253.     1+ aligned allot            
  254.  
  255. [ has? profiling [if] ]
  256.     \ Add profiling point
  257.     r> ,
  258. [ [then] ]
  259.  
  260.     \ current @ !        \ !!!
  261.     >latest !
  262.     smudge
  263.  
  264.     \ lay down CFA
  265.     ['] :dovar does,
  266. ;
  267.  
  268. \ \\\\\\\\\\\\\
  269.  
  270. 8 constant per-line
  271.  
  272. : 2u.
  273.     0 <# # # #> type
  274. ;
  275.  
  276. : 4u.
  277.     0 <# # # # # #> type
  278. ;
  279.  
  280. : (dump) ( addr cnt xt -- )
  281.     base @ >r hex cr
  282.     >r                    \ outer loop executes once with k==xt
  283.     over + swap ?do
  284.         i 4u. space [char] = emit space
  285.         i' i per-line + min dup i ?do 
  286.             i k execute 2u. space
  287.         loop    
  288.         i - 
  289.         dup
  290.             per-line swap - 0 ?do 3 spaces loop
  291.         dup
  292.             0 ?do j i + k execute dup $20 $7f within 0= 
  293.                 if drop [char] . then emit 
  294.             loop
  295.         cr
  296.         (pause?) if drop unloop leave then
  297.     +loop
  298.     rdrop
  299.     r> base !
  300. ;
  301.  
  302. : dump
  303.     ['] c@ (dump)
  304. ;
  305.  
  306. : vdump
  307.     ['] vc@ (dump)
  308. ;
  309.  
  310. \ \\\\\\\\\\\\\\\\\\\\\\
  311.  
  312. [IFUNDEF] STATE
  313. User STATE
  314. [THEN]
  315.  
  316. [IFUNDEF] [
  317. : [
  318.     0 state !
  319. ; immediate
  320. [THEN]
  321.  
  322.  
  323. [IFUNDEF] [COMPILE]
  324. : [COMPILE]
  325.     bl word find
  326.     if
  327.         postpone literal compile,
  328.     else
  329.         huh?
  330.     then
  331. ; immediate
  332. [THEN]
  333.  
  334. [IFUNDEF] POSTPONE
  335. : POSTPONE
  336.     bl word find
  337.     if
  338.         compile,
  339.     else
  340.         huh?
  341.     then        
  342. ; immediate
  343. [THEN]
  344.  
  345. [IFUNDEF] COMPILE,
  346. : COMPILE,
  347.     ,
  348. ;
  349. [THEN]
  350.  
  351.  
  352.  
  353. User csp
  354.  
  355. User leave-list        \ pointer to linked list of leaves, 
  356.                     \ @ branch pos of last leave
  357.  
  358. : !csp
  359.     sp@ csp !
  360.     0 leave-list !
  361. ;
  362.  
  363. : ?csp
  364.     sp@ csp @ - -&22 ?error
  365. ;
  366.  
  367. : :
  368.     \ ?exec 
  369.     !csp
  370.     create smudge ]
  371.     lastxt docol!
  372. ;
  373.  
  374. : ;
  375.     ?csp
  376.     [compile] ;s
  377.     smudge postpone [
  378. ; immediate
  379.  
  380. \    change the cfa of the newly created word to
  381. \    jump to the code inside the creating word after does>
  382. : (does>)
  383.     r> lastxt xt!        \ drops a level, so code following dodoes> 
  384.                         \ is not executed during create stage
  385. ;
  386.  
  387. : DOES>
  388.     [compile] (does>)
  389.     docol,
  390. ; immediate
  391.  
  392. : ?pairs    ( i*x tag tag' -- )
  393.     - -&22 ?error
  394. ;
  395.  
  396. \ is there an official name for this?
  397. [IFUNDEF] BACK
  398. : BACK 
  399.     here - ,
  400. ;
  401. [THEN]
  402.  
  403. [IFUNDEF] BEGIN
  404. : BEGIN
  405.     ?comp here 1 
  406. ; immediate
  407. [THEN]
  408.  
  409. [IFUNDEF] IF
  410. : IF
  411.     ?comp
  412.     [compile] ?branch
  413.     here 0 ,
  414.     2
  415. ; immediate
  416. [THEN]
  417.  
  418. [IFUNDEF] ELSE
  419. : ELSE
  420.     ?comp
  421.     2 ?pairs
  422.     [compile] branch
  423.     here 0 ,
  424.     swap 2
  425.     postpone then 2
  426. ; immediate
  427. [THEN]
  428.  
  429. [IFUNDEF] THEN
  430. : THEN
  431.     ?comp 
  432.     2 ?pairs
  433.     here over - swap !
  434. ; immediate
  435. [THEN]
  436.  
  437. [IFUNDEF] DO
  438. : DO
  439.     ?comp
  440.     [compile] (do)
  441.     here 3
  442. ; immediate
  443. [THEN]
  444.  
  445. [IFUNDEF] LOOP
  446. : leave-resolve
  447. \    handle LEAVE references 
  448.  
  449.     leave-list @
  450.     begin        
  451.          dup            \ ( pos pos )
  452.     while
  453.         dup @ swap            \ ( new-pos pos )
  454.         here over -          \ ( new-pos pos jmp )
  455.         swap !
  456.     repeat
  457.     leave-list !
  458. ;
  459.  
  460. : loop-compile
  461. \    normal loop part
  462.  
  463.     swap 3 ?pairs 
  464.     compile,
  465.     back
  466. \    [compile] unloop
  467.  
  468.     leave-resolve
  469. ;
  470.  
  471. : LOOP
  472.     ?comp
  473.     ['] (loop) loop-compile
  474. ; immediate
  475.  
  476. : +LOOP
  477.     ?comp
  478.     ['] (+loop) loop-compile
  479. ; immediate
  480. [THEN]
  481.  
  482. [IFUNDEF] UNLOOP
  483. : UNLOOP
  484.     r> rdrop rdrop >r
  485. ;
  486. [THEN]
  487. test" unloop 3 >r 2 1 do loop r> 3 ="
  488.  
  489.  
  490. [IFUNDEF] LEAVE
  491. : LEAVE
  492.     ?comp
  493.  
  494.     [compile] unloop
  495.     [compile] branch
  496.  
  497.     here
  498.     leave-list @ ,        \ store last fixup addr
  499.     leave-list !        \ store new addr
  500.  
  501. ; immediate
  502. [THEN]
  503.  
  504. [IFUNDEF] BEGIN
  505. : BEGIN
  506.     ?comp
  507.     here 1
  508. ; immediate
  509. [THEN]
  510.  
  511. [IFUNDEF] UNTIL
  512. : UNTIL
  513.     ?comp
  514.     1 ?pairs
  515.     [compile] ?branch
  516.     back
  517. ; immediate
  518. [THEN]
  519.  
  520. [IFUNDEF] AGAIN
  521. : AGAIN
  522.     ?comp
  523.     1 ?pairs
  524.     [compile] branch
  525.     back
  526. ; immediate
  527. [THEN]
  528.  
  529. [IFUNDEF] WHILE
  530. : WHILE
  531.     postpone if
  532.     2+
  533. ; immediate
  534. [THEN]
  535.  
  536. [IFUNDEF] REPEAT
  537. : REPEAT
  538.     ?comp
  539.     >r >r postpone again
  540.     r> r> 2- 
  541.     postpone then
  542. ; immediate
  543. [THEN]
  544.  
  545. [IFUNDEF] CASE
  546. : CASE
  547.     ?comp
  548.     csp @         \ save old params
  549.     !csp 
  550.     4
  551. ; immediate
  552. [THEN]
  553.  
  554. [IFUNDEF] OF
  555. : OF
  556.     ?comp
  557.     4 ?pairs
  558.     [compile] (of)
  559.     here 0 , 
  560.     5
  561. ; immediate
  562. [THEN]
  563.  
  564. [IFUNDEF] ENDOF
  565. : ENDOF
  566.     ?comp
  567.     5 ?pairs
  568.     [compile] branch
  569.     here 0 , 
  570.     swap 2 postpone then
  571.     4
  572. ; immediate
  573. [THEN]
  574.  
  575. [IFUNDEF] ENDCASE
  576. : ENDCASE
  577.     ?comp
  578.     4 ?pairs
  579.     [compile] drop
  580.     begin
  581.         sp@ csp @ = 0= 
  582.     while
  583.         2 postpone then
  584.     repeat
  585.     csp !
  586. ; immediate
  587. [THEN]
  588.  
  589. [IFUNDEF] RECURSE
  590. : RECURSE
  591.     lastxt compile,
  592. ; immediate
  593. [THEN]
  594.  
  595. [IFUNDEF] EXIT
  596. : EXIT
  597.     ?comp
  598.     [compile] ;s
  599. ; immediate
  600. [THEN]
  601.  
  602. [IFUNDEF] DEFER
  603. : DEFER
  604.     create lastxt dodefer!
  605.     ['] noop ,
  606. ;
  607. [THEN]
  608.  
  609. [IFUNDEF] IS
  610. : isrom?
  611.     dup $2000 <
  612.     over $6000 >=
  613.     over $8000 < and
  614.     or
  615. ;
  616. : (IS)
  617.     cell+ 
  618.     isrom? if @ then
  619.     !
  620. ;
  621. : IS
  622.     ' cell+ (IS)
  623. ;
  624. [THEN]
  625.  
  626. [IFUNDEF] CONSTANT
  627. : CONSTANT
  628.     create ,
  629.     ['] :docon lastxt xt!
  630. ;
  631. [THEN]
  632.  
  633. [IFUNDEF] VARIABLE
  634. : VARIABLE
  635.     create 0 ,
  636.     ['] :dovar lastxt xt!
  637. ;
  638. [THEN]
  639.  
  640. [IFUNDEF] :NONAME
  641. : :NONAME
  642.     align
  643.  
  644.     \ LFA
  645.     here latest ,
  646.  
  647.     \ NFA
  648.     $0000 ,
  649.  
  650.     \ link
  651.     >latest !
  652.  
  653.     ]
  654.    
  655.     \ CFA
  656.     here docol,
  657.  
  658.     !csp
  659. ;
  660. [THEN]
  661.  
  662.  
  663.