projects / pforth / blame
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Add -m32 and -x c to Makefile for 64-bit Snow Leopard.
[pforth] / fth / system.fth
CommitLineData
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
970d32b5 20
21\ 1 echo ! \ Uncomment this line to echo Forth code while compiling.
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
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
3140 1- constant -1\r
3150 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
3661 0= constant FALSE\r
3670 0= constant TRUE\r
36832 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
43132 :stack ustack\r
432ustack 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
4433 constant do_flag\r
4444 constant leave_flag\r
4455 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
719variable 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
764create 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
783variable HEADERS-SIZE \r
784variable 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
791auto.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
970d32b5 814\ Now that we can load from files, load remainder of dictionary.\r
bb6b2dcd 815\r
816trace-include on\r
817trace-stack on\r
818\r
819include loadp4th.fth\r
820\r
821decimal\r
822\r
823: ;;;; ; \ Mark end of this file so FILE? can find things in here.\r
824FREEZE \ prevent forgetting below this point\r
825\r
826.( Dictionary compiled, save in "pforth.dic".) cr\r
827c" pforth.dic" save-forth\r
970d32b5 828
829\ Save the dictionary in "pfdicdat.h" file so pForth can be compiled for standalone mode.\r
bb6b2dcd 830SDAD\r
Fork of 'github/philburk/pforth', a portable ANS-like Forth written in ANSI C.