comparison examples_forth/extend09.4 @ 57:2088fd998865

sbc09 directry clean up
author Shinji KONO <kono@ie.u-ryukyu.ac.jp>
date Mon, 23 Jul 2018 16:07:12 +0900
parents
children
comparison
equal deleted inserted replaced
56:4fa2bdb0c457 57:2088fd998865
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