bb6b2dcd |
1 | : FIRST_COLON ;\r |
2 | \r |
3 | : LATEST context @ ;\r |
4 | \r |
5 | : FLAG_IMMEDIATE 64 ;\r |
6 | \r |
7 | : IMMEDIATE\r |
8 | latest dup c@ flag_immediate OR\r |
9 | swap c!\r |
10 | ;\r |
11 | \r |
12 | : ( 41 word drop ; immediate\r |
13 | ( That was the definition for the comment word. )\r |
14 | ( Now we can add comments to what we are doing! )\r |
15 | ( Note that we are in decimal numeric input mode. )\r |
16 | \r |
17 | : \ ( <line> -- , comment out rest of line )\r |
18 | EOL word drop\r |
19 | ; immediate\r |
1cb310e6 |
20 | \r |
21 | \ 1 echo ! \ Uncomment this line to echo Forth code while compiling.\r |
bb6b2dcd |
22 | \r |
23 | \ *********************************************************************\r |
24 | \ This is another style of comment that is common in Forth.\r |
25 | \ pFORTH - Portable Forth System\r |
26 | \ Based on HMSL Forth\r |
27 | \\r |
28 | \ Author: Phil Burk\r |
29 | \ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom\r |
30 | \\r |
31 | \ The pForth software code is dedicated to the public domain,\r |
32 | \ and any third party may reproduce, distribute and modify\r |
33 | \ the pForth software code or any derivative works thereof\r |
34 | \ without any compensation or license. The pForth software\r |
35 | \ code is provided on an "as is" basis without any warranty\r |
36 | \ of any kind, including, without limitation, the implied\r |
37 | \ warranties of merchantability and fitness for a particular\r |
38 | \ purpose and their equivalents under the laws of any jurisdiction.\r |
39 | \ *********************************************************************\r |
40 | \r |
41 | : COUNT dup 1+ swap c@ ;\r |
42 | \r |
43 | \ Miscellaneous support words\r |
44 | : ON ( addr -- , set true )\r |
45 | -1 swap !\r |
46 | ;\r |
47 | : OFF ( addr -- , set false )\r |
48 | 0 swap !\r |
49 | ;\r |
50 | \r |
bb6b2dcd |
51 | : CELL+ ( n -- n+cell ) cell + ;\r |
52 | : CELL- ( n -- n+cell ) cell - ;\r |
1cb310e6 |
53 | : CELL* ( n -- n*cell ) cells ; |
bb6b2dcd |
54 | \r |
55 | : CHAR+ ( n -- n+size_of_char ) 1+ ;\r |
56 | : CHARS ( n -- n*size_of_char , don't do anything) ; immediate\r |
57 | \r |
58 | \ useful stack manipulation words\r |
59 | : -ROT ( a b c -- c a b )\r |
60 | rot rot\r |
61 | ;\r |
62 | : 3DUP ( a b c -- a b c a b c )\r |
63 | 2 pick 2 pick 2 pick\r |
64 | ;\r |
65 | : 2DROP ( a b -- )\r |
66 | drop drop\r |
67 | ;\r |
68 | : NIP ( a b -- b )\r |
69 | swap drop\r |
70 | ;\r |
71 | : TUCK ( a b -- b a b )\r |
72 | swap over\r |
73 | ;\r |
74 | \r |
75 | : <= ( a b -- f , true if A <= b )\r |
76 | > 0=\r |
77 | ;\r |
78 | : >= ( a b -- f , true if A >= b )\r |
79 | < 0=\r |
80 | ;\r |
81 | \r |
82 | : INVERT ( n -- 1'comp )\r |
83 | -1 xor\r |
84 | ;\r |
85 | \r |
86 | : NOT ( n -- !n , logical negation )\r |
87 | 0=\r |
88 | ;\r |
89 | \r |
90 | : NEGATE ( n -- -n )\r |
91 | 0 swap -\r |
92 | ;\r |
93 | \r |
94 | : DNEGATE ( d -- -d , negate by doing 0-d )\r |
95 | 0 0 2swap d-\r |
96 | ;\r |
97 | \r |
98 | \r |
99 | \ --------------------------------------------------------------------\r |
100 | \r |
101 | : ID. ( nfa -- )\r |
102 | count 31 and type\r |
103 | ;\r |
104 | \r |
105 | : DECIMAL 10 base ! ;\r |
106 | : OCTAL 8 base ! ;\r |
107 | : HEX 16 base ! ;\r |
108 | : BINARY 2 base ! ;\r |
109 | \r |
110 | : PAD ( -- addr )\r |
111 | here 128 +\r |
112 | ;\r |
113 | \r |
114 | : $MOVE ( $src $dst -- )\r |
115 | over c@ 1+ cmove\r |
116 | ;\r |
117 | : BETWEEN ( n lo hi -- flag , true if between lo & hi )\r |
118 | >r over r> > >r\r |
119 | < r> or 0=\r |
120 | ;\r |
121 | : [ ( -- , enter interpreter mode )\r |
122 | 0 state !\r |
123 | ; immediate\r |
124 | : ] ( -- enter compile mode )\r |
125 | 1 state !\r |
126 | ;\r |
127 | \r |
128 | : EVEN-UP ( n -- n | n+1 , make even ) dup 1 and + ;\r |
129 | : ALIGNED ( addr -- a-addr )\r |
130 | [ cell 1- ] literal +\r |
131 | [ cell 1- invert ] literal and\r |
132 | ;\r |
133 | : ALIGN ( -- , align DP ) dp @ aligned dp ! ;\r |
134 | : ALLOT ( nbytes -- , allot space in dictionary ) dp +! ( align ) ;\r |
135 | \r |
136 | : C, ( c -- ) here c! 1 chars dp +! ;\r |
137 | : W, ( w -- ) dp @ even-up dup dp ! w! 2 chars dp +! ;\r |
138 | : , ( n -- , lay into dictionary ) align here ! cell allot ;\r |
139 | \r |
140 | \ Dictionary conversions ------------------------------------------\r |
141 | \r |
142 | : N>NEXTLINK ( nfa -- nextlink , traverses name field )\r |
143 | dup c@ 31 and 1+ + aligned\r |
144 | ;\r |
145 | \r |
146 | : NAMEBASE ( -- base-of-names )\r |
147 | Headers-Base @\r |
148 | ;\r |
149 | : CODEBASE ( -- base-of-code dictionary )\r |
150 | Code-Base @\r |
151 | ;\r |
152 | \r |
153 | : NAMELIMIT ( -- limit-of-names )\r |
154 | Headers-limit @\r |
155 | ;\r |
156 | : CODELIMIT ( -- limit-of-code, last address in dictionary )\r |
157 | Code-limit @\r |
158 | ;\r |
159 | \r |
160 | : NAMEBASE+ ( rnfa -- nfa , convert relocatable nfa to actual )\r |
161 | namebase +\r |
162 | ;\r |
163 | \r |
164 | : >CODE ( xt -- secondary_code_address, not valid for primitives )\r |
165 | codebase +\r |
166 | ;\r |
167 | \r |
168 | : CODE> ( secondary_code_address -- xt , not valid for primitives )\r |
169 | codebase -\r |
170 | ;\r |
171 | \r |
172 | : N>LINK ( nfa -- lfa )\r |
1cb310e6 |
173 | 2 CELLS -\r |
bb6b2dcd |
174 | ;\r |
175 | \r |
176 | : >BODY ( xt -- pfa )\r |
177 | >code body_offset +\r |
178 | ;\r |
179 | \r |
180 | : BODY> ( pfa -- xt )\r |
181 | body_offset - code>\r |
182 | ;\r |
183 | \r |
184 | \ convert between addresses useable by @, and relocatable addresses.\r |
185 | : USE->REL ( useable_addr -- rel_addr )\r |
186 | codebase -\r |
187 | ;\r |
188 | : REL->USE ( rel_addr -- useable_addr )\r |
189 | codebase +\r |
190 | ;\r |
191 | \r |
192 | \ for JForth code\r |
193 | \ : >REL ( adr -- adr ) ; immediate\r |
194 | \ : >ABS ( adr -- adr ) ; immediate\r |
195 | \r |
196 | : X@ ( addr -- xt , fetch execution token from relocatable ) @ ;\r |
197 | : X! ( addr -- xt , store execution token as relocatable ) ! ;\r |
198 | \r |
199 | \ Compiler support ------------------------------------------------\r |
200 | : COMPILE, ( xt -- , compile call to xt )\r |
201 | ,\r |
202 | ;\r |
203 | \r |
204 | ( Compiler support , based on FIG )\r |
205 | : [COMPILE] ( <name> -- , compile now even if immediate )\r |
206 | ' compile,\r |
207 | ; IMMEDIATE\r |
208 | \r |
209 | : (COMPILE) ( xt -- , postpone compilation of token )\r |
210 | [compile] literal ( compile a call to literal )\r |
211 | ( store xt of word to be compiled )\r |
212 | \r |
213 | [ ' compile, ] literal \ compile call to compile,\r |
214 | compile,\r |
215 | ;\r |
216 | \r |
217 | : COMPILE ( <name> -- , save xt and compile later )\r |
218 | ' (compile)\r |
219 | ; IMMEDIATE\r |
220 | \r |
221 | \r |
222 | : :NONAME ( -- xt , begin compilation of headerless secondary )\r |
223 | align\r |
224 | here code> \ convert here to execution token\r |
225 | ]\r |
226 | ;\r |
227 | \r |
228 | \ Error codes defined in ANSI Exception word set.\r |
229 | : ERR_ABORT -1 ; \ general abort\r |
230 | : ERR_EXECUTING -14 ; \ compile time word while not compiling\r |
231 | : ERR_PAIRS -22 ; \ mismatch in conditional\r |
232 | : ERR_DEFER -258 ; \ not a deferred word\r |
233 | \r |
234 | : ABORT ( i*x -- )\r |
235 | ERR_ABORT throw\r |
236 | ;\r |
237 | \r |
238 | \ Conditionals in '83 form -----------------------------------------\r |
239 | : CONDITIONAL_KEY ( -- , lazy constant ) 29521 ;\r |
240 | : ?CONDITION ( f -- ) conditional_key - err_pairs ?error ;\r |
241 | : >MARK ( -- addr ) here 0 , ;\r |
242 | : >RESOLVE ( addr -- ) here over - swap ! ;\r |
243 | : <MARK ( -- addr ) here ;\r |
244 | : <RESOLVE ( addr -- ) here - , ;\r |
245 | \r |
246 | : ?COMP ( -- , error if not compiling )\r |
247 | state @ 0= err_executing ?error\r |
248 | ;\r |
249 | : ?PAIRS ( n m -- )\r |
250 | - err_pairs ?error\r |
251 | ;\r |
252 | \ conditional primitives\r |
253 | : IF ( -- f orig ) ?comp compile 0branch conditional_key >mark ; immediate\r |
254 | : THEN ( f orig -- ) swap ?condition >resolve ; immediate\r |
255 | : BEGIN ( -- f dest ) ?comp conditional_key <mark ; immediate\r |
256 | : AGAIN ( f dest -- ) compile branch swap ?condition <resolve ; immediate\r |
257 | : UNTIL ( f dest -- ) compile 0branch swap ?condition <resolve ; immediate\r |
258 | : AHEAD ( -- f orig ) compile branch conditional_key >mark ; immediate\r |
259 | \r |
260 | \ conditionals built from primitives\r |
261 | : ELSE ( f orig1 -- f orig2 )\r |
262 | [compile] AHEAD 2swap [compile] THEN ; immediate\r |
263 | : WHILE ( f dest -- f orig f dest ) [compile] if 2swap ; immediate\r |
264 | : REPEAT ( -- f orig f dest ) [compile] again [compile] then ; immediate\r |
265 | \r |
266 | : ['] ( <name> -- xt , define compile time tick )\r |
267 | ?comp ' [compile] literal\r |
268 | ; immediate\r |
269 | \r |
270 | \ for example:\r |
271 | \ compile time: compile create , (does>) then ;\r |
272 | \ execution time: create <name>, ',' data, then patch pi to point to @\r |
273 | \ : con create , does> @ ;\r |
274 | \ 345 con pi\r |
275 | \ pi\r |
276 | \ \r |
277 | : (DOES>) ( xt -- , modify previous definition to execute code at xt )\r |
278 | latest name> >code \ get address of code for new word\r |
279 | cell + \ offset to second cell in create word\r |
280 | ! \ store execution token of DOES> code in new word\r |
281 | ;\r |
282 | \r |
283 | : DOES> ( -- , define execution code for CREATE word )\r |
284 | 0 [compile] literal \ dummy literal to hold xt\r |
285 | here cell- \ address of zero in literal\r |
286 | compile (does>) \ call (DOES>) from new creation word\r |
287 | >r \ move addrz to return stack so ; doesn't see stack garbage\r |
288 | [compile] ; \ terminate part of code before does>\r |
289 | r>\r |
290 | :noname ( addrz xt )\r |
291 | swap ! \ save execution token in literal\r |
292 | ; immediate\r |
293 | \r |
294 | : VARIABLE ( <name> -- )\r |
295 | CREATE 0 , \ IMMEDIATE\r |
296 | \ DOES> [compile] aliteral \ %Q This could be optimised\r |
297 | ;\r |
298 | \r |
299 | : 2VARIABLE ( <name> -c- ) ( -x- addr )\r |
300 | create 0 , 0 ,\r |
301 | ;\r |
302 | \r |
303 | : CONSTANT ( n <name> -c- ) ( -x- n )\r |
304 | CREATE , ( n -- )\r |
305 | DOES> @ ( -- n )\r |
306 | ;\r |
307 | \r |
308 | \r |
309 | \r |
310 | 0 1- constant -1\r |
311 | 0 2- constant -2\r |
312 | \r |
313 | : 2! ( x1 x2 addr -- , store x2 followed by x1 )\r |
314 | swap over ! cell+ !\r |
315 | ;\r |
316 | : 2@ ( addr -- x1 x2 )\r |
317 | dup cell+ @ swap @\r |
318 | ;\r |
319 | \r |
320 | \r |
321 | : ABS ( n -- |n| )\r |
322 | dup 0<\r |
323 | IF negate\r |
324 | THEN\r |
325 | ;\r |
326 | : DABS ( d -- |d| )\r |
327 | dup 0<\r |
328 | IF dnegate\r |
329 | THEN\r |
330 | ;\r |
331 | \r |
332 | : S>D ( s -- d , extend signed single precision to double )\r |
333 | dup 0<\r |
334 | IF -1\r |
335 | ELSE 0\r |
336 | THEN\r |
337 | ;\r |
338 | \r |
339 | : D>S ( d -- s ) drop ;\r |
340 | \r |
341 | : /MOD ( a b -- rem quo , unsigned version, FIXME )\r |
342 | >r s>d r> um/mod\r |
343 | ;\r |
344 | \r |
345 | : MOD ( a b -- rem )\r |
346 | /mod drop\r |
347 | ;\r |
348 | \r |
349 | : 2* ( n -- n*2 )\r |
350 | 1 lshift\r |
351 | ;\r |
352 | : 2/ ( n -- n/2 )\r |
353 | 1 arshift\r |
354 | ;\r |
355 | \r |
356 | : D2* ( d -- d*2 )\r |
1cb310e6 |
357 | 2* over |
358 | cell 8 * 1- rshift or swap\r |
bb6b2dcd |
359 | 2* swap\r |
360 | ;\r |
361 | \r |
362 | \ define some useful constants ------------------------------\r |
363 | 1 0= constant FALSE\r |
364 | 0 0= constant TRUE\r |
365 | 32 constant BL\r |
366 | \r |
367 | \r |
368 | \ Store and Fetch relocatable data addresses. ---------------\r |
369 | : IF.USE->REL ( use -- rel , preserve zero )\r |
370 | dup IF use->rel THEN\r |
371 | ;\r |
372 | : IF.REL->USE ( rel -- use , preserve zero )\r |
373 | dup IF rel->use THEN\r |
374 | ;\r |
375 | \r |
376 | : A! ( dictionary_address addr -- )\r |
377 | >r if.use->rel r> !\r |
378 | ;\r |
379 | : A@ ( addr -- dictionary_address )\r |
380 | @ if.rel->use\r |
381 | ;\r |
382 | \r |
383 | : A, ( dictionary_address -- )\r |
384 | if.use->rel ,\r |
385 | ;\r |
386 | \r |
387 | \ Stack data structure ----------------------------------------\r |
388 | \ This is a general purpose stack utility used to implement necessary\r |
389 | \ stacks for the compiler or the user. Not real fast.\r |
390 | \ These stacks grow up which is different then normal.\r |
391 | \ cell 0 - stack pointer, offset from pfa of word\r |
392 | \ cell 1 - limit for range checking\r |
393 | \ cell 2 - first data location\r |
394 | \r |
395 | : :STACK ( #cells -- )\r |
396 | CREATE 2 cells , ( offset of first data location )\r |
397 | dup , ( limit for range checking, not currently used )\r |
398 | cells cell+ allot ( allot an extra cell for safety )\r |
399 | ;\r |
400 | \r |
401 | : >STACK ( n stack -- , push onto stack, postincrement )\r |
402 | dup @ 2dup cell+ swap ! ( -- n stack offset )\r |
403 | + !\r |
404 | ;\r |
405 | \r |
406 | : STACK> ( stack -- n , pop , predecrement )\r |
407 | dup @ cell- 2dup swap !\r |
408 | + @\r |
409 | ;\r |
410 | \r |
411 | : STACK@ ( stack -- n , copy )\r |
412 | dup @ cell- + @ \r |
413 | ;\r |
414 | \r |
415 | : STACK.PICK ( index stack -- n , grab Nth from top of stack )\r |
416 | dup @ cell- +\r |
417 | swap cells - \ offset for index\r |
418 | @ \r |
419 | ;\r |
420 | : STACKP ( stack -- ptr , to next empty location on stack )\r |
421 | dup @ +\r |
422 | ;\r |
423 | \r |
424 | : 0STACKP ( stack -- , clear stack)\r |
425 | 8 swap !\r |
426 | ;\r |
427 | \r |
428 | 32 :stack ustack\r |
429 | ustack 0stackp\r |
430 | \r |
431 | \ Define JForth like words.\r |
432 | : >US ustack >stack ;\r |
433 | : US> ustack stack> ;\r |
434 | : US@ ustack stack@ ;\r |
435 | : 0USP ustack 0stackp ;\r |
436 | \r |
437 | \r |
438 | \ DO LOOP ------------------------------------------------\r |
439 | \r |
440 | 3 constant do_flag\r |
441 | 4 constant leave_flag\r |
442 | 5 constant ?do_flag\r |
443 | \r |
444 | : DO ( -- , loop-back do_flag jump-from ?do_flag )\r |
445 | ?comp\r |
446 | compile (do)\r |
447 | here >us do_flag >us ( for backward branch )\r |
448 | ; immediate\r |
449 | \r |
450 | : ?DO ( -- , loop-back do_flag jump-from ?do_flag , on user stack )\r |
451 | ?comp\r |
452 | ( leave address to set for forward branch )\r |
453 | compile (?do)\r |
454 | here 0 ,\r |
455 | here >us do_flag >us ( for backward branch )\r |
456 | >us ( for forward branch ) ?do_flag >us\r |
457 | ; immediate\r |
458 | \r |
459 | : LEAVE ( -- addr leave_flag )\r |
460 | compile (leave)\r |
461 | here 0 , >us\r |
462 | leave_flag >us\r |
463 | ; immediate\r |
464 | \r |
465 | : LOOP-FORWARD ( -us- jump-from ?do_flag -- )\r |
466 | BEGIN\r |
467 | us@ leave_flag =\r |
468 | us@ ?do_flag =\r |
469 | OR\r |
470 | WHILE\r |
471 | us> leave_flag =\r |
472 | IF\r |
473 | us> here over - cell+ swap !\r |
474 | ELSE\r |
475 | us> dup\r |
476 | here swap -\r |
477 | cell+ swap !\r |
478 | THEN\r |
479 | REPEAT\r |
480 | ;\r |
481 | \r |
482 | : LOOP-BACK ( loop-addr do_flag -us- )\r |
483 | us> do_flag ?pairs\r |
484 | us> here - here\r |
485 | !\r |
486 | cell allot\r |
487 | ;\r |
488 | \r |
489 | : LOOP ( -- , loop-back do_flag jump-from ?do_flag )\r |
490 | compile (loop)\r |
491 | loop-forward loop-back\r |
492 | ; immediate\r |
493 | \r |
494 | \ : DOTEST 5 0 do 333 . loop 888 . ;\r |
495 | \ : ?DOTEST0 0 0 ?do 333 . loop 888 . ;\r |
496 | \ : ?DOTEST1 5 0 ?do 333 . loop 888 . ;\r |
497 | \r |
498 | : +LOOP ( -- , loop-back do_flag jump-from ?do_flag )\r |
499 | compile (+loop)\r |
500 | loop-forward loop-back\r |
501 | ; immediate\r |
502 | \r |
503 | : UNLOOP ( loop-sys -r- )\r |
504 | r> \ save return pointer\r |
505 | rdrop rdrop\r |
506 | >r\r |
507 | ;\r |
508 | \r |
509 | : RECURSE ( ? -- ? , call the word currently being defined )\r |
510 | latest name> compile,\r |
511 | ; immediate\r |
512 | \r |
513 | \r |
514 | \r |
515 | : SPACE bl emit ;\r |
516 | : SPACES 512 min 0 max 0 ?DO space LOOP ;\r |
517 | : 0SP depth 0 ?do drop loop ;\r |
518 | \r |
519 | : >NEWLINE ( -- , CR if needed )\r |
520 | out @ 0>\r |
521 | IF cr\r |
522 | THEN\r |
523 | ;\r |
524 | \r |
525 | \r |
526 | \ Support for DEFER --------------------\r |
527 | : CHECK.DEFER ( xt -- , error if not a deferred word by comparing to type )\r |
528 | >code @\r |
529 | ['] emit >code @\r |
530 | - err_defer ?error\r |
531 | ;\r |
532 | \r |
533 | : >is ( xt -- address_of_vector )\r |
534 | >code\r |
535 | cell +\r |
536 | ;\r |
537 | \r |
538 | : (IS) ( xt_do xt_deferred -- )\r |
539 | >is !\r |
540 | ;\r |
541 | \r |
542 | : IS ( xt <name> -- , act like normal IS )\r |
543 | ' \ xt\r |
544 | dup check.defer \r |
545 | state @\r |
546 | IF [compile] literal compile (is)\r |
547 | ELSE (is)\r |
548 | THEN\r |
549 | ; immediate\r |
550 | \r |
551 | : (WHAT'S) ( xt -- xt_do )\r |
552 | >is @\r |
553 | ;\r |
554 | : WHAT'S ( <name> -- xt , what will deferred word call? )\r |
555 | ' \ xt\r |
556 | dup check.defer\r |
557 | state @\r |
558 | IF [compile] literal compile (what's)\r |
559 | ELSE (what's)\r |
560 | THEN\r |
561 | ; immediate\r |
562 | \r |
563 | : /STRING ( addr len n -- addr' len' )\r |
564 | over min rot over + -rot -\r |
565 | ;\r |
566 | : PLACE ( addr len to -- , move string )\r |
567 | 3dup 1+ swap cmove c! drop\r |
568 | ;\r |
569 | \r |
570 | : PARSE-WORD ( char -- addr len )\r |
571 | >r source tuck >in @ /string r@ skip over swap r> scan\r |
572 | >r over - rot r> dup 0<> + - >in !\r |
573 | ;\r |
574 | : PARSE ( char -- addr len )\r |
575 | >r source >in @ /string over swap r> scan\r |
576 | >r over - dup r> 0<> - >in +!\r |
577 | ;\r |
578 | \r |
579 | : LWORD ( char -- addr )\r |
580 | parse-word here place here \ 00002 , use PARSE-WORD\r |
581 | ;\r |
582 | \r |
583 | : ASCII ( <char> -- char , state smart )\r |
584 | bl parse drop c@\r |
585 | state @\r |
586 | IF [compile] literal\r |
587 | THEN\r |
588 | ; immediate\r |
589 | \r |
590 | : CHAR ( <char> -- char , interpret mode )\r |
591 | bl parse drop c@\r |
592 | ;\r |
593 | \r |
594 | : [CHAR] ( <char> -- char , for compile mode )\r |
595 | char [compile] literal\r |
596 | ; immediate\r |
597 | \r |
598 | : $TYPE ( $string -- )\r |
599 | count type\r |
600 | ;\r |
601 | \r |
602 | : 'word ( -- addr ) here ;\r |
603 | \r |
604 | : EVEN ( addr -- addr' ) dup 1 and + ;\r |
605 | \r |
606 | : (C") ( -- $addr , some Forths return addr AND count, OBSOLETE?)\r |
607 | r> dup count + aligned >r\r |
608 | ;\r |
609 | : (S") ( -- c-addr cnt )\r |
610 | r> count 2dup + aligned >r\r |
611 | ;\r |
612 | \r |
613 | : (.") ( -- , type following string )\r |
614 | r> count 2dup + aligned >r type\r |
615 | ;\r |
616 | \r |
617 | : ", ( adr len -- , place string into dictionary )\r |
618 | tuck 'word place 1+ allot align\r |
619 | ;\r |
620 | : ," ( -- )\r |
621 | [char] " parse ",\r |
622 | ;\r |
623 | \r |
624 | : .( ( <string> -- , type string delimited by parentheses )\r |
625 | [CHAR] ) PARSE TYPE\r |
626 | ; IMMEDIATE\r |
627 | \r |
628 | : ." ( <string> -- , type string )\r |
629 | state @\r |
630 | IF compile (.") ,"\r |
631 | ELSE [char] " parse type\r |
632 | THEN\r |
633 | ; immediate\r |
634 | \r |
635 | \r |
636 | : .' ( <string> -- , type string delimited by single quote )\r |
637 | state @\r |
638 | IF compile (.") [char] ' parse ",\r |
639 | ELSE [char] ' parse type\r |
640 | THEN\r |
641 | ; immediate\r |
642 | \r |
643 | : C" ( <string> -- addr , return string address, ANSI )\r |
644 | state @\r |
645 | IF compile (c") ,"\r |
646 | ELSE [char] " parse pad place pad\r |
647 | THEN\r |
648 | ; immediate\r |
649 | \r |
650 | : S" ( <string> -- , -- addr , return string address, ANSI )\r |
651 | state @\r |
652 | IF compile (s") ,"\r |
653 | ELSE [char] " parse pad place pad count\r |
654 | THEN\r |
655 | ; immediate\r |
656 | \r |
657 | : " ( <string> -- , -- addr , return string address )\r |
658 | [compile] C"\r |
659 | ; immediate\r |
660 | : P" ( <string> -- , -- addr , return string address )\r |
661 | [compile] C"\r |
662 | ; immediate\r |
663 | \r |
664 | : "" ( <string> -- addr )\r |
665 | state @\r |
666 | IF \r |
667 | compile (C")\r |
668 | bl parse-word ",\r |
669 | ELSE\r |
670 | bl parse-word pad place pad\r |
671 | THEN\r |
672 | ; immediate\r |
673 | \r |
674 | : SLITERAL ( addr cnt -- , compile string )\r |
675 | compile (S")\r |
676 | ",\r |
677 | ; IMMEDIATE\r |
678 | \r |
679 | : $APPEND ( addr count $1 -- , append text to $1 )\r |
680 | over >r\r |
681 | dup >r\r |
682 | count + ( -- a2 c2 end1 )\r |
683 | swap cmove\r |
684 | r> dup c@ ( a1 c1 )\r |
685 | r> + ( -- a1 totalcount )\r |
686 | swap c!\r |
687 | ;\r |
688 | \r |
689 | \r |
690 | \ ANSI word to replace [COMPILE] and COMPILE ----------------\r |
691 | : POSTPONE ( <name> -- )\r |
692 | bl word find\r |
693 | dup 0=\r |
694 | IF\r |
695 | ." Postpone could not find " count type cr abort\r |
696 | ELSE\r |
697 | 0>\r |
698 | IF compile, \ immediate\r |
699 | ELSE (compile) \ normal\r |
700 | THEN\r |
701 | THEN\r |
702 | ; immediate\r |
703 | \r |
704 | \ -----------------------------------------------------------------\r |
705 | \ Auto Initialization\r |
706 | : AUTO.INIT ( -- )\r |
707 | \ Kernel finds AUTO.INIT and executes it after loading dictionary.\r |
708 | \ ." Begin AUTO.INIT ------" cr\r |
709 | ;\r |
710 | : AUTO.TERM ( -- )\r |
711 | \ Kernel finds AUTO.TERM and executes it on bye.\r |
712 | \ ." End AUTO.TERM ------" cr\r |
713 | ;\r |
714 | \r |
715 | \ -------------- INCLUDE ------------------------------------------\r |
716 | variable TRACE-INCLUDE\r |
717 | \r |
718 | : INCLUDE.MARK.START ( $filename -- , mark start of include for FILE?)\r |
719 | " ::::" pad $MOVE\r |
720 | count pad $APPEND\r |
721 | pad ['] noop (:)\r |
722 | ;\r |
723 | \r |
724 | : INCLUDE.MARK.END ( -- , mark end of include )\r |
725 | " ;;;;" ['] noop (:)\r |
726 | ;\r |
727 | \r |
728 | : $INCLUDE ( $filename -- )\r |
729 | \ Print messages.\r |
730 | trace-include @\r |
731 | IF\r |
732 | >newline ." Include " dup count type cr\r |
733 | THEN\r |
734 | here >r\r |
735 | dup\r |
736 | count r/o open-file \r |
737 | IF ( -- $filename bad-fid )\r |
738 | drop ." Could not find file " $type cr abort\r |
739 | ELSE ( -- $filename good-fid )\r |
740 | swap include.mark.start\r |
bb6b2dcd |
741 | depth >r\r |
90975d26 |
742 | include-file \ will also close the file\r |
bb6b2dcd |
743 | depth 1+ r> -\r |
744 | IF\r |
745 | ." Warning: stack depth changed during include!" cr\r |
746 | .s cr\r |
747 | 0sp\r |
748 | THEN\r |
bb6b2dcd |
749 | include.mark.end\r |
750 | THEN\r |
751 | trace-include @\r |
752 | IF\r |
753 | ." include added " here r@ - . ." bytes,"\r |
754 | codelimit here - . ." left." cr\r |
755 | THEN\r |
756 | rdrop\r |
757 | ;\r |
758 | \r |
759 | create INCLUDE-SAVE-NAME 128 allot\r |
760 | : INCLUDE ( <fname> -- )\r |
761 | BL lword\r |
762 | dup include-save-name $move \ save for RI\r |
763 | $include\r |
764 | ;\r |
765 | \r |
766 | : RI ( -- , ReInclude previous file as a convenience )\r |
767 | include-save-name $include\r |
768 | ;\r |
769 | \r |
770 | : INCLUDE? ( <word> <file> -- , load file if word not defined )\r |
771 | bl word find\r |
772 | IF drop bl word drop ( eat word from source )\r |
773 | ELSE drop include\r |
774 | THEN\r |
775 | ;\r |
776 | \r |
777 | \ desired sizes for dictionary loaded after SAVE-FORTH\r |
778 | variable HEADERS-SIZE \r |
779 | variable CODE-SIZE\r |
780 | \r |
781 | : AUTO.INIT\r |
782 | auto.init\r |
783 | codelimit codebase - code-size !\r |
784 | namelimit namebase - headers-size !\r |
785 | ;\r |
786 | auto.init\r |
787 | \r |
788 | : SAVE-FORTH ( $name -- )\r |
789 | 0 \ Entry point\r |
790 | headers-ptr @ namebase - 65536 + \ NameSize\r |
791 | headers-size @ MAX\r |
792 | here codebase - 131072 + \ CodeSize\r |
793 | code-size @ MAX\r |
794 | (save-forth)\r |
795 | IF\r |
796 | ." SAVE-FORTH failed!" cr abort\r |
797 | THEN\r |
798 | ;\r |
799 | \r |
800 | : TURNKEY ( $name entry-token-- )\r |
801 | 0 \ NameSize = 0, names not saved in turnkey dictionary\r |
802 | here codebase - 131072 + \ CodeSize, remember that base is HEX\r |
803 | (save-forth)\r |
804 | IF\r |
805 | ." TURNKEY failed!" cr abort\r |
806 | THEN\r |
807 | ;\r |
808 | \r |
970d32b5 |
809 | \ Now that we can load from files, load remainder of dictionary.\r |
bb6b2dcd |
810 | \r |
811 | trace-include on\r |
812 | trace-stack on\r |
813 | \r |
814 | include loadp4th.fth\r |
815 | \r |
816 | decimal\r |
817 | \r |
818 | : ;;;; ; \ Mark end of this file so FILE? can find things in here.\r |
819 | FREEZE \ prevent forgetting below this point\r |
820 | \r |
821 | .( Dictionary compiled, save in "pforth.dic".) cr\r |
822 | c" pforth.dic" save-forth\r |
1cb310e6 |
823 | \r |
970d32b5 |
824 | \ Save the dictionary in "pfdicdat.h" file so pForth can be compiled for standalone mode.\r |
bb6b2dcd |
825 | SDAD\r |