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