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