annotate examples_forth/extend09.4 @ 178:4d83154d2a78

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