forth/bootstrap/interpreter.fs

   1 \ tag: forth interpreter
   2 \
   3 \ Copyright (C) 2003 Stefan Reinauer
   4 \
   5 \ See the file "COPYING" for further information about
   6 \ the copyright and warranty status of this work.
   7 \
   8
   9
  10 \
  11 \ 7.3.4.6 Display pause
  12 \
  13
  14 0 value interactive?
  15 0 value terminate?
  16
  17 : exit?
  18   interactive? 0= if
  19     false exit
  20   then
  21   false \ FIXME we should check whether to interrupt output
  22         \ and ask the user how to proceed.
  23   ;
  24
  25
  26 \
  27 \ 7.3.9.1 Defining words
  28 \
  29
  30 : forget
  31   s" This word is obsolescent." type cr
  32   ['] ' execute
  33   cell - dup
  34   @ dup
  35   last ! latest !
  36   here!
  37   ;
  38
  39 \
  40 \ 7.3.9.2.4 Miscellaneous dictionary
  41 \
  42
  43 \ interpreter. This word checks whether the interpreted word
  44 \ is a word in dictionary or a number. It honours compile mode
  45 \ and immediate/compile-only words.
  46
  47 : interpret
  48   0 >in !
  49   begin
  50     parse-word dup 0> \ was there a word at all?
  51   while
  52     $find
  53     if
  54       dup flags? 0<> state @ 0= or if
  55         execute
  56       else
  57         ,             \ compile mode && !immediate
  58       then
  59     else              \ word is not known. maybe it's a number
  60       2dup $number
  61       if
  62         span @ >in !  \ if we encountered an error, don't continue parsing
  63         type 3a emit
  64         -13 throw
  65       else
  66         -rot 2drop 1 handle-lit
  67       then
  68     then
  69     depth 200 >=  if -3 throw then
  70     depth 0<      if -4 throw then
  71     rdepth 200 >= if -5 throw then
  72     rdepth 0<     if -6 throw then
  73   repeat
  74   2drop
  75   ;
  76
  77 : refill ( -- )
  78         ib #ib @ expect 0 >in ! ;
  79
  80 : print-status  ( exception -- )
  81   space
  82   ?dup if
  83     dup sys-debug \ system debug hook
  84     case
  85        -1 of s" Aborted." type endof
  86        -2 of s" Aborted." type endof
  87        -3 of s" Stack Overflow." type 0 depth! endof
  88        -4 of s" Stack Underflow." type 0 depth! endof
  89        -5 of s" Return Stack Overflow." type endof
  90        -6 of s" Return Stack Underflow." type endof
  91       -13 of s" undefined word." type endof
  92       -15 of s" out of memory." type endof
  93       -21 of s" undefined method." type endof
  94       -22 of s" no such device." type endof
  95       dup s" Exception #" type .
  96       0 state !
  97     endcase
  98   else
  99     state @ 0= if
 100       s" ok"
 101     else
 102       s" compiled"
 103     then
 104     type
 105   then
 106   cr
 107   ;
 108
 109 defer status
 110 ['] noop ['] status (to)
 111
 112 : print-prompt
 113   status
 114   depth . 3e emit space
 115   ;
 116
 117 defer outer-interpreter
 118 :noname
 119   cr
 120   begin
 121     print-prompt
 122     source 0 fill           \ clean input buffer
 123     refill
 124
 125     ['] interpret catch print-status
 126     terminate?
 127   until
 128 ; ['] outer-interpreter (to)
 129
 130 \
 131 \ 7.3.8.5 Other control flow commands
 132 \
 133
 134 : save-source  ( -- )
 135   r>               \ fetch our caller
 136   ib >r #ib @ >r   \ save current input buffer
 137   source-id >r     \ and all variables
 138   span @ >r        \ associated with it.
 139   >in @ >r
 140   >r               \ move back our caller
 141   ;
 142
 143 : restore-source ( -- )
 144   r>
 145   r> >in !
 146   r> span !
 147   r> ['] source-id (to)
 148   r> #ib !
 149   r> ['] ib (to)
 150   >r
 151   ;
 152
 153 : (evaluate) ( str len -- ??? )
 154   save-source
 155   -1 ['] source-id (to)
 156   dup
 157   #ib ! span !
 158   ['] ib (to)
 159   interpret
 160   restore-source
 161   ;
 162
 163 : evaluate ( str len -- ?? )
 164   2dup + -rot
 165   over + over do
 166     i c@ 0a = if
 167       i over -
 168       (evaluate)
 169       i 1+
 170     then
 171   loop
 172   swap over - (evaluate)
 173   ;
 174
 175 : eval evaluate ;