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