← Back to branch summary

~pmdj/ubuntu/trusty/qemu/2.9+applesmc+fadtv3

« back to all changes in this revision

Viewing changes to roms/openbios/forth/bootstrap/interpreter.fs

  • Committer: Phil Dennis-Jordan
  • Date: 2017-07-21 08:03:43 UTC
  • mfrom: (1.1.1)
  • Revision ID: phil@philjordan.eu-20170721080343-2yr2vdj7713czahv
New upstream release 2.9.0.

Show diffs side-by-side

added added

removed removed

Lines of Context:
roms/openbios/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@ dup 0a = swap 0d = or if
 
167
      i over - 
 
168
      rot >r
 
169
      (evaluate)
 
170
      r>
 
171
      i 1+ 
 
172
    then 
 
173
  loop 
 
174
  swap over - (evaluate)
 
175
  ;
 
176
  
 
177
: eval evaluate ;