Commit | Line | Data |
---|---|---|
8e9db35f PB |
1 | \ @(#) misc1.fth 98/01/26 1.2 |
2 | \ miscellaneous words | |
3 | \ | |
4 | \ Author: Phil Burk | |
1a088514 | 5 | \ Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom |
8e9db35f | 6 | \ |
1f99f95d S |
7 | \ Permission to use, copy, modify, and/or distribute this |
8 | \ software for any purpose with or without fee is hereby granted. | |
9 | \ | |
10 | \ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL | |
11 | \ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED | |
12 | \ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL | |
13 | \ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR | |
14 | \ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING | |
15 | \ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF | |
16 | \ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF | |
17 | \ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. | |
8e9db35f PB |
18 | |
19 | anew task-misc1.fth | |
20 | decimal | |
21 | ||
22 | : >> rshift ; | |
23 | : << lshift ; | |
24 | ||
25 | : (WARNING") ( flag $message -- ) | |
26 | swap | |
27 | IF count type | |
28 | ELSE drop | |
29 | THEN | |
30 | ; | |
31 | ||
32 | : WARNING" ( flag <message> -- , print warning if true. ) | |
33 | [compile] " ( compile message ) | |
34 | state @ | |
35 | IF compile (warning") | |
36 | ELSE (warning") | |
37 | THEN | |
38 | ; IMMEDIATE | |
39 | ||
40 | : (ABORT") ( flag $message -- ) | |
41 | swap | |
42 | IF | |
43 | count type cr | |
44 | err_abortq throw | |
45 | ELSE drop | |
46 | THEN | |
47 | ; | |
48 | ||
49 | : ABORT" ( flag <message> -- , print warning if true. ) | |
50 | [compile] " ( compile message ) | |
51 | state @ | |
52 | IF compile (abort") | |
53 | ELSE (abort") | |
54 | THEN | |
55 | ; IMMEDIATE | |
56 | ||
57 | ||
58 | : ?PAUSE ( -- , Pause if key hit. ) | |
59 | ?terminal | |
60 | IF key drop cr ." Hit space to continue, any other key to abort:" | |
61 | key dup emit BL = not abort" Terminated" | |
62 | THEN | |
63 | ; | |
64 | ||
65 | 60 constant #cols | |
66 | ||
67 | : CR? ( -- , do CR if near end ) | |
68 | OUT @ #cols 16 - 10 max > | |
69 | IF cr | |
70 | THEN | |
71 | ; | |
72 | ||
73 | : CLS ( -- clear screen ) | |
74 | 40 0 do cr loop | |
75 | ; | |
76 | : PAGE ( -- , clear screen, compatible with Brodie ) | |
77 | cls | |
78 | ; | |
79 | ||
80 | : $ ( <number> -- N , convert next number as hex ) | |
81 | base @ hex | |
82 | bl lword number? num_type_single = not | |
83 | abort" Not a single number!" | |
84 | swap base ! | |
85 | state @ | |
86 | IF [compile] literal | |
87 | THEN | |
88 | ; immediate | |
89 | ||
90 | : .HX ( nibble -- ) | |
91 | dup 9 > | |
92 | IF $ 37 | |
93 | ELSE $ 30 | |
94 | THEN + emit | |
95 | ; | |
96 | ||
97 | variable TAB-WIDTH 8 TAB-WIDTH ! | |
98 | : TAB ( -- , tab over to next stop ) | |
99 | out @ tab-width @ mod | |
100 | tab-width @ swap - spaces | |
101 | ; | |
102 | ||
103 | \ Vocabulary listing | |
104 | : WORDS ( -- ) | |
105 | 0 latest | |
106 | BEGIN dup 0<> | |
107 | WHILE dup id. tab cr? ?pause | |
108 | prevname | |
109 | swap 1+ swap | |
110 | REPEAT drop | |
111 | cr . ." words" cr | |
112 | ; | |
113 | ||
114 | : VLIST words ; | |
115 | ||
116 | variable CLOSEST-NFA | |
117 | variable CLOSEST-XT | |
118 | ||
119 | : >NAME ( xt -- nfa , scans dictionary for closest nfa, SLOW! ) | |
120 | 0 closest-nfa ! | |
121 | 0 closest-xt ! | |
122 | latest | |
123 | BEGIN dup 0<> | |
124 | IF ( -- addr nfa ) 2dup name> ( addr nfa addr xt ) < | |
125 | IF true ( addr below this cfa, can't be it) | |
126 | ELSE ( -- addr nfa ) | |
127 | 2dup name> ( addr nfa addr xt ) = | |
128 | IF ( found it ! ) dup closest-nfa ! false | |
129 | ELSE dup name> closest-xt @ > | |
130 | IF dup closest-nfa ! dup name> closest-xt ! | |
131 | THEN | |
132 | true | |
133 | THEN | |
134 | THEN | |
135 | ELSE false | |
136 | THEN | |
137 | WHILE | |
138 | prevname | |
139 | REPEAT ( -- cfa nfa ) | |
140 | 2drop | |
141 | closest-nfa @ | |
142 | ; | |
143 | ||
144 | : @EXECUTE ( addr -- , execute if non-zero ) | |
145 | x@ ?dup | |
146 | IF execute | |
147 | THEN | |
148 | ; | |
149 | ||
150 | : TOLOWER ( char -- char_lower ) | |
151 | dup ascii [ < | |
152 | IF dup ascii @ > | |
153 | IF ascii A - ascii a + | |
154 | THEN | |
155 | THEN | |
156 | ; | |
157 | ||
158 | : EVALUATE ( i*x c-addr num -- j*x , evaluate string of Forth ) | |
159 | \ save current input state and switch to passed in string | |
160 | source >r >r | |
161 | set-source | |
162 | -1 push-source-id | |
163 | >in @ >r | |
164 | 0 >in ! | |
165 | \ interpret the string | |
166 | interpret | |
167 | \ restore input state | |
168 | pop-source-id drop | |
169 | r> >in ! | |
170 | r> r> set-source | |
171 | ; | |
172 | ||
173 | : \S ( -- , comment out rest of file ) | |
174 | source-id | |
175 | IF | |
176 | BEGIN \ using REFILL is safer than popping SOURCE-ID | |
177 | refill 0= | |
178 | UNTIL | |
179 | THEN | |
180 | ; |