home *** CD-ROM | disk | FTP | other *** search
/ ftp.whtech.com / ftp.whtech.com.7z / ftp.whtech.com / emulators / v9t9 / linux / sources / V9t9 / tools / Forth / interp.fs < prev    next >
Encoding:
FORTH Source  |  2006-10-19  |  4.5 KB  |  307 lines
  1.  
  2. \
  3. \    Interpreter
  4. \
  5.  
  6. [IFUNDEF] (
  7. : (
  8.     $39 parse 2drop
  9. ;    immediate
  10. [THEN]
  11.  
  12. [IFUNDEF] >IN
  13. user >IN
  14. [THEN]
  15.  
  16. [IFUNDEF] CHAR
  17. : CHAR    ( -- c )
  18.     bl (parse-word)
  19.     drop c@
  20. ;
  21. [THEN]
  22.  
  23. [IFUNDEF] REFILL
  24. : REFILL    ( -- flag )
  25.  
  26. \   Attempt to fill the input buffer from the input source, returning a true flag if successful.
  27. \
  28. \   When the input source is the user input device, attempt to receive input into the terminal input buffer. If successful,
  29. \   make the result the input buffer, set >IN to zero, and return true. Receipt of a line containing no characters is
  30. \   considered successful. If there is no input available from the current input source, return false.
  31. \
  32. \   When the input source is a string from EVALUATE, return false and perform no other action.
  33.  
  34.     source-id
  35.     dup -1 = if            \ evaluate string
  36.         drop false        \ end.
  37.     else ?dup 0= if            \ user input device
  38.         (tib0) $100 accept #tib !
  39.         (tib0) >tib !
  40.         0 >in ! 
  41.         bl emit
  42.         true
  43.     else 
  44.         ( fileid )
  45.         (tib0) $100 rot read-line s" file read error" (abort")
  46.         if
  47.  
  48. \ ." [" (tib0) over type ." ]" cr
  49.  
  50.             #tib !
  51.             (tib0) >tib !
  52.             0 >in !
  53.             true
  54.         else
  55. \            ." end of file" cr
  56.             drop false
  57.         then
  58.     then then
  59. ;
  60. [THEN]
  61.  
  62. [IFUNDEF] QUERY
  63. \ : QUERY
  64. \ ;
  65. [THEN]
  66.  
  67. [IFUNDEF] RESTORE-INPUT
  68. : RESTORE-INPUT    ( xn ... x1 n -- )
  69.     6 <> abort" invalid restore-input"
  70.     >in !
  71.     blk !
  72.     #tib ! >tib !
  73.     loadline ! loadfile !
  74. ;
  75. [THEN]
  76.  
  77. [IFUNDEF] SAVE-INPUT
  78. : SAVE-INPUT    ( -- xn ... x1 n )
  79.     loadfile @ loadline @
  80.     >tib @ #tib @
  81.     blk @
  82.     >in @
  83.     6
  84. ;
  85. [THEN]
  86.  
  87. [IFUNDEF] SOURCE-ID
  88. : SOURCE-ID
  89.     loadline @ 0< if
  90.         -1
  91.     else
  92.         loadfile @
  93.     then
  94. ;
  95. [THEN]
  96.  
  97. [IFUNDEF] TIB
  98. User >tib
  99. : TIB
  100.     >tib @
  101. ;
  102. [THEN]
  103.  
  104.  
  105. [IFUNDEF] INTERPRET
  106.  
  107. \    INTERPRETER
  108. \    ===========
  109.  
  110. \    Source state is represented as follows:
  111. \    If blk=0, 'source-id' is 0 for keyboard, -1 for evaluate string, >0 for text file.
  112. \    else blk=blk # for source.
  113. \    For non-block stuff, we use loadfile/loadline to keep track of file source,
  114. \    and >tib/#tib for all input strings.
  115. \    loadfile=0 for user input, loadline<0 for evaluate string.
  116.  
  117. User loadfile
  118. User loadline
  119.  
  120. \    Push the input state.
  121. : <input        ( xn ... x1 n -- R: xn ... x1 n )
  122.     r>
  123.     loadfile @ >r loadline @ >r
  124.     >tib @ >r    #tib @ >r
  125.     blk @ >r    
  126.     >in @ >r
  127.     >r    
  128. ;
  129.  
  130. : input>
  131.     r>
  132.     r> >in !
  133.     r> blk !
  134.     r> #tib !    r> >tib !
  135.     r> loadline ! r> loadfile !
  136.     >r
  137. ;
  138.  
  139. : (>c)        ( caddr u naddr -- )
  140. \    make counted string at naddr
  141.     2dup c!                \ set length byte
  142.     1+ swap cmove>        \ move data
  143. ;
  144.  
  145. : (lookup)        ( c-addr u -- 0 | nfa 1|-1 )
  146.     here (>c)    \ make counted string + NFA
  147. \ context @ @ (find) dup 0= if ... 
  148.  
  149. [ 1 [if] ]
  150.     here latest \ ( here nfa )
  151.     (find)
  152. [ [else] ]
  153.     here find dup >r if xt>nfa else drop then r>
  154.     
  155. [ [then] ]
  156. ;
  157.  
  158. : ?stack
  159.     depth 0< if
  160.         ." stack empty!" cr
  161.         abort
  162.     then
  163. ;
  164.  
  165. : huh?    ( caddr -- )
  166.     count type space
  167.     ." undefined" cr
  168. ;
  169.  
  170. \    Interpret counted string as number,
  171. \    and store decimal point location in DPL.
  172.  
  173. User dpl
  174. : number    ( addr -- ud )
  175. \    .s
  176.     0.0 rot count 
  177.  
  178.     \ check for base conversion
  179.     base @ >r                \ save original base
  180.     over c@ [char] $ = if
  181.         hex    (skip)            \ use hex for '$'
  182.     else over c@ [char] & = if
  183.         decimal    (skip)        \ use decimal for '&'
  184.     then then
  185.  
  186.     \ see if first char is '-'
  187.     over c@ [char] - = dup 
  188.     >r                        \ store sign flag
  189.     if (skip) then
  190.  
  191.     -1 dpl !
  192.  
  193. \    .s
  194.     >number
  195.     dup if        \ any invalid chars?
  196.         over c@ $2E = if    \ did we stop at '.'?
  197.             over dpl !        \ don't store offset... too much work ;)
  198.             (skip)            \ skip '.'
  199.             >number
  200.         then
  201.         dup if 
  202.             here huh? 2drop 2drop quit     \ error
  203.         then
  204.     then
  205.     2drop
  206.  
  207.     r>                \ sign flag
  208.     if dnegate then
  209.  
  210.     r> base !        \ original base
  211. \    .s
  212. ;
  213.  
  214. : interpreter
  215. \        ( i*x c-addr u -- j*x )
  216. \
  217. \    Interpret one word
  218.  
  219.     (lookup)        \ ( 0 | nfa 1 )
  220.     if
  221.         dup nfa>imm? 0=
  222.         state @ and     \ compiling and not immediate?
  223.         if
  224.             nfa>xt compile,
  225.         else
  226.             nfa>xt execute
  227.         then
  228.     else
  229.         here number dpl @ 1+ if
  230.             postpone dliteral
  231.         else 
  232.             d>s postpone literal
  233.         then 
  234.     then
  235. ;
  236.  
  237. : interpret
  238.     begin
  239.         ?stack
  240.         bl (parse-word)    
  241.         dup
  242.     while
  243.         interpreter
  244.     repeat
  245.     2drop
  246. ;
  247.  
  248. : EVALUATE    ( i*x c-addr u -- j*x )
  249.     <input
  250.     -1 loadline !
  251.     0 loadfile !
  252.     0 blk !
  253.     #tib !     >tib !  
  254.     0 >in !
  255.     interpret
  256.     input>
  257. ;
  258. [THEN]
  259.  
  260. [IFUNDEF] QUIT
  261.  
  262. : QUIT
  263.     begin
  264.         (clrsrc)
  265.         postpone [     
  266.         rp0 @ rp!
  267.         .s cr
  268.         begin
  269.             refill
  270.         while
  271.             interpret
  272.  
  273.             \ print comments only when using user input
  274.             source-id 0= if 
  275.                 state @ if
  276.                     cr
  277.                 else
  278.                     ."  ok" .s
  279.                 then
  280.                 cr
  281.             then
  282.         repeat
  283.     again
  284. ;
  285. [THEN]
  286.  
  287. [IFUNDEF] SOURCE
  288. : SOURCE    ( -- caddr u )
  289.     blk @ ?dup if
  290.         0 chars/block     \ block chars/block    \ !!!
  291.     else
  292.         >tib @ #tib @
  293.     then
  294. ;
  295. [THEN]
  296.  
  297. [IFUNDEF] [CHAR]
  298. : [CHAR]
  299.     state @ if
  300.         postpone [char]
  301.     else
  302.         bl parse drop c@
  303.     then
  304. ;
  305. [THEN]
  306.  
  307.