57
|
1 \ Extensions to sod Forth kernel to make a complete Forth system.
|
|
2 \ created 1994 by L.C. Benschop.
|
|
3 \ copyleft (c) 1994-2014 by the sbc09 team, see AUTHORS for more details.
|
|
4 \ license: GNU General Public License version 2, see LICENSE for more details.
|
|
5
|
|
6 : \G POSTPONE \ ; IMMEDIATE
|
|
7 \G comment till end of line for inclusion in glossary.
|
|
8
|
|
9 \ PART 1: MISCELLANEOUS WORDS.
|
|
10
|
|
11 : COMPARE ( addr1 u1 addr2 u2 --- diff )
|
|
12 \G Compare two strings. diff is negative if addr1 u1 is smaller, 0 if it
|
|
13 \G is equal and positive if it is greater than addr2 u2.
|
|
14 ROT 2DUP - >R
|
|
15 MIN DUP IF
|
|
16 >R
|
|
17 BEGIN
|
|
18 OVER C@ OVER C@ - IF
|
|
19 SWAP C@ SWAP C@ - R> DROP R> DROP EXIT
|
|
20 THEN
|
|
21 1+ SWAP 1+ SWAP
|
|
22 R> 1- DUP >R 0=
|
|
23 UNTIL R>
|
|
24 THEN DROP
|
|
25 DROP DROP R> NEGATE
|
|
26 ;
|
|
27
|
|
28 : ERASE 0 FILL ;
|
|
29
|
|
30 : <= ( n1 n2 --- f)
|
|
31 \G f is true if and only if n1 is less than or equal to n2.
|
|
32 > 0= ;
|
|
33
|
|
34 : 0<= ( n1 --- f)
|
|
35 \G f is true if and only if n1 is less than zero.
|
|
36 0 <= ;
|
|
37
|
|
38 : >=
|
|
39 < 0= ;
|
|
40
|
|
41 : 0<>
|
|
42 0= 0= ;
|
|
43
|
|
44 : BOUNDS ( addr1 n --- addr2 addr1)
|
|
45 \G Convert address and length to two bounds addresses for DO LOOP
|
|
46 OVER + SWAP ;
|
|
47
|
|
48 : WITHIN ( u1 u2 u3 --- f)
|
|
49 \G f is true if u1 is greater or equal to u2 and less than u3
|
|
50 2 PICK U> ROT ROT U< 0= AND ;
|
|
51
|
|
52 : -TRAILING ( c-addr1 u1 --- c-addr2 u2)
|
|
53 \G Adjust the length of the string such that trailing spaces are excluded.
|
|
54 BEGIN
|
|
55 2DUP + 1- C@ BL =
|
|
56 WHILE
|
|
57 1-
|
|
58 REPEAT
|
|
59 ;
|
|
60
|
|
61 : NIP ( x1 x2 --- x2)
|
|
62 \G Discard the second item on the stack.
|
|
63 SWAP DROP ;
|
|
64
|
|
65 \ PART 2: SEARCH ORDER WORDLIST
|
|
66
|
|
67 : GET-ORDER ( --- w1 w2 ... wn n )
|
|
68 \G Return all wordlists in the search order, followed by the count.
|
|
69 #ORDER @ 0 ?DO CONTEXT I CELLS + @ LOOP #ORDER @ ;
|
|
70
|
|
71 : SET-ORDER ( w1 w2 ... wn n --- )
|
|
72 \G Set the search order to the n wordlists given on the stack.
|
|
73 #ORDER ! 0 #ORDER @ 1- DO CONTEXT I CELLS + ! -1 +LOOP ;
|
|
74
|
|
75 : ALSO ( --- )
|
|
76 \G Duplicate the last wordlist in the search order.
|
|
77 CONTEXT #ORDER @ CELLS + DUP CELL- @ SWAP ! 1 #ORDER +! ;
|
|
78
|
|
79 : PREVIOUS ( --- )
|
|
80 \G Remove the last wordlist from search order.
|
|
81 -1 #ORDER +! ;
|
|
82
|
|
83 VARIABLE #THREADS ( --- a-addr)
|
|
84 \G This variable holds the number of threads a word list will have.
|
|
85
|
|
86 : WORDLIST ( --- wid)
|
|
87 \G Make a new wordlist and give its address.
|
|
88 HERE #THREADS @ , #THREADS @ CELLS ALLOT HERE #THREADS @ CELLS -
|
|
89 #THREADS @ CELLS ERASE ;
|
|
90
|
|
91 : DEFINITIONS ( --- )
|
|
92 \G Set the definitions wordlist to the last wordlist in the search order.
|
|
93 CONTEXT #ORDER @ 1- CELLS + @ CURRENT ! ;
|
|
94
|
|
95 : FORTH ( --- )
|
|
96 \G REplace the last wordlist in the search order with FORTH-WORDLIST
|
|
97 FORTH-WORDLIST CONTEXT #ORDER @ 1- CELLS + ! ;
|
|
98
|
|
99 1 #THREADS !
|
|
100 WORDLIST
|
|
101 CONSTANT ROOT-WORDLIST ( --- wid )
|
|
102 \G Minimal wordlist for ONLY
|
|
103
|
|
104 4 #THREADS !
|
|
105
|
|
106 : ONLY ( --- )
|
|
107 \G Set the search order to the minimal wordlist.
|
|
108 1 #ORDER ! ROOT-WORDLIST CONTEXT ! ;
|
|
109
|
|
110 : VOCABULARY ( --- )
|
|
111 \G Make a definition that will replace the last word in the search order
|
|
112 \G by its wordlist.
|
|
113 WORDLIST CREATE , \ Make a new wordlist and store it in def.
|
|
114 DOES> >R \ Replace last item in the search order.
|
|
115 GET-ORDER SWAP DROP R> @ SWAP SET-ORDER ;
|
|
116
|
|
117
|
|
118 \ PART 3: SOME UTILITIES, DUMP .S WORDS
|
|
119
|
|
120 : DL ( addr1 --- addr2 )
|
|
121 \G hex/ascii dump in one line of 16 bytes at addr1 addr2 is addr1+16
|
|
122 BASE @ >R 16 BASE ! CR
|
|
123 DUP 0 <# # # # # #> TYPE ." : "
|
|
124 16 0 DO
|
|
125 DUP I + C@ 0 <# # # #> TYPE SPACE
|
|
126 LOOP
|
|
127 16 0 DO
|
|
128 DUP I + C@ DUP 127 AND 31 < IF DROP ." ." ELSE EMIT THEN
|
|
129 LOOP
|
|
130 16 + R> BASE ! ;
|
|
131
|
|
132
|
|
133 : DUMP ( addr len --- )
|
|
134 \G Show a hex/ascii dump of the memory block of len bytes at addr
|
|
135 15 + 4 RSHIFT 0 DO
|
|
136 DL
|
|
137 LOOP DROP ;
|
|
138
|
|
139 : .S ( --- )
|
|
140 \G Show the contents of the stack.
|
|
141 DEPTH IF
|
|
142 0 DEPTH 2 - DO I PICK . -1 +LOOP
|
|
143 ELSE ." Empty " THEN ;
|
|
144
|
|
145
|
|
146 : ID. ( nfa --- )
|
|
147 \G Show the name of the word with name field address nfa.
|
|
148 COUNT 31 AND TYPE SPACE ;
|
|
149
|
|
150 : WORDS ( --- )
|
|
151 \G Show all words in the last wordlist of the search order.
|
|
152 CONTEXT #ORDER @ 1- CELLS + @
|
|
153 DUP @ >R \ number of threads to return stack.
|
|
154 CELL+ R@ 0 DO DUP I CELLS + @ SWAP LOOP DROP \ All thread pointers to stack.
|
|
155 BEGIN
|
|
156 0 0
|
|
157 R@ 0 DO
|
|
158 I 2 + PICK OVER U> IF
|
|
159 DROP DROP I I 1 + PICK
|
|
160 THEN
|
|
161 LOOP \ Find the thread pointer with the highest address.
|
|
162 WHILE
|
|
163 DUP 1+ PICK DUP ID. \ Print the name.
|
|
164 CELL- @ \ Link to previous.
|
|
165 SWAP 2 + CELLS SP@ + ! \ Update the right thread pointer.
|
|
166 REPEAT
|
|
167 DROP R> 0 DO DROP LOOP \ Drop the thread pointers.
|
|
168 ;
|
|
169
|
|
170
|
|
171 ROOT-WORDLIST CURRENT !
|
|
172 : FORTH FORTH ;
|
|
173 : ALSO ALSO ;
|
|
174 : ONLY ONLY ;
|
|
175 : PREVIOUS PREVIOUS ;
|
|
176 : DEFINITIONS DEFINITIONS ;
|
|
177 : WORDS WORDS ;
|
|
178 DEFINITIONS
|
|
179 \ Fill the ROOT wordlist.
|
|
180
|
|
181 \ PART 4: ERROR MESSAGES
|
|
182
|
|
183 : MESS" ( n "cccq" --- )
|
|
184 \G Create an error message for throw code n.
|
|
185 ALIGN , ERRORS @ , HERE 2 CELLS - ERRORS ! 34 WORD C@ 1+ ALLOT ;
|
|
186
|
|
187 -3 MESS" Stack overflow"
|
|
188 -4 MESS" Stack underflow"
|
|
189 -10 MESS" Divide overflow"
|
|
190 -13 MESS" Undefined word"
|
|
191 -22 MESS" Incomplete control structure"
|
|
192 -28 MESS" BREAK key pressed"
|
|
193 -37 MESS" File I/O error"
|
|
194 -38 MESS" File does not exist"
|
|
195
|
|
196 : 2CONSTANT ( d --- )
|
|
197 \G Create a new definition that has the following runtime behavior.
|
|
198 \G Runtime: ( --- d) push the constant double number on the stack.
|
|
199 CREATE HERE 2! 2 CELLS ALLOT DOES> 2@ ;
|
|
200
|
|
201 : D.R ( d n --- )
|
|
202 \G Print double number d right-justified in a field of width n.
|
|
203 >R SWAP OVER DABS <# #S ROT SIGN #> R> OVER - 0 MAX SPACES TYPE ;
|
|
204
|
|
205 : U.R ( u n --- )
|
|
206 \G Print unsigned number u right-justified in a field of width n.
|
|
207 >R 0 R> D.R ;
|
|
208
|
|
209 : .R ( n1 n2 --- )
|
|
210 \G Print number n1 right-justified in a field of width n2.
|
|
211 >R S>D R> D.R ;
|
|
212
|
|
213 : AT-XY ( x y --- )
|
|
214 \G Put screen cursor at location (x,y) (0,0) is upper left corner.
|
|
215 27 EMIT [CHAR] [ EMIT SWAP 1+ SWAP 0 .R [CHAR] ; EMIT
|
|
216 1+ 0 .R [CHAR] H EMIT ;
|
|
217
|
|
218 : PAGE
|
|
219 \G Clear the screen.
|
|
220 27 EMIT ." [2J" 0 0 AT-XY ;
|
|
221
|
|
222 : VALUE ( n --- )
|
|
223 CREATE , DOES> @ ;
|
|
224
|
|
225 : TO
|
|
226 ' >BODY STATE @ IF
|
|
227 POSTPONE LITERAL POSTPONE !
|
|
228 ELSE
|
|
229 !
|
|
230 THEN
|
|
231 ; IMMEDIATE
|
|
232
|
|
233 : D- ( d1 d2 --- d3)
|
|
234 DNEGATE D+ ;
|
|
235
|
|
236 : D0=
|
|
237 OR 0= ;
|
|
238
|
|
239 : D=
|
|
240 D- D0= ;
|
|
241
|
|
242 : BLANK
|
|
243 32 FILL ;
|
|
244
|
|
245 : AGAIN
|
|
246 POSTPONE 0 POSTPONE UNTIL ; IMMEDIATE
|
|
247
|
|
248 : CASE
|
|
249 CSP @ SP@ CSP ! ; IMMEDIATE
|
|
250 : OF
|
|
251 POSTPONE OVER POSTPONE = POSTPONE IF POSTPONE DROP ; IMMEDIATE
|
|
252 : ENDOF
|
|
253 POSTPONE ELSE ; IMMEDIATE
|
|
254 : ENDCASE
|
|
255 POSTPONE DROP BEGIN SP@ CSP @ - WHILE POSTPONE THEN REPEAT
|
|
256 CSP ! ; IMMEDIATE
|
|
257
|
|
258
|
|
259 : MS ( n --- )
|
|
260 \G Delay for n milliseconds.
|
|
261 5 + 20 / $2B @ + BEGIN DUP $2B @ = UNTIL DROP ;
|
|
262
|
|
263 CAPS ON
|
|
264
|