8 latest dup c@ flag_immediate OR
12 : ( 41 word drop ; immediate
13 ( That was the definition for the comment word. )
14 ( Now we can add comments to what we are doing! )
15 ( Note that we are in decimal numeric input mode. )
17 : \ ( <line> -- , comment out rest of line )
21 \ This is another style of comment that is common in Forth.
23 \ @(#) system.fth 98/01/26 1.4
24 \ *********************************************************************
25 \ pFORTH - Portable Forth System
29 \ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom
31 \ The pForth software code is dedicated to the public domain,
32 \ and any third party may reproduce, distribute and modify
33 \ the pForth software code or any derivative works thereof
34 \ without any compensation or license. The pForth software
35 \ code is provided on an "as is" basis without any warranty
36 \ of any kind, including, without limitation, the implied
37 \ warranties of merchantability and fitness for a particular
38 \ purpose and their equivalents under the laws of any jurisdiction.
39 \ *********************************************************************
41 : COUNT dup 1+ swap c@ ;
43 \ Miscellaneous support words
44 : ON ( addr -- , set true )
47 : OFF ( addr -- , set false )
52 \ FIXME - move these into 'C' code for portability ????
53 : CELL ( -- size_of_stack_item ) 4 ;
55 : CELL+ ( n -- n+cell ) cell + ;
56 : CELL- ( n -- n+cell ) cell - ;
57 : CELLS ( n -- n*cell ) 2 lshift ;
59 : CHAR+ ( n -- n+size_of_char ) 1+ ;
60 : CHARS ( n -- n*size_of_char , don't do anything) ; immediate
62 \ useful stack manipulation words
63 : -ROT ( a b c -- c a b )
66 : 3DUP ( a b c -- a b c a b c )
75 : TUCK ( a b -- b a b )
79 : <= ( a b -- f , true if A <= b )
82 : >= ( a b -- f , true if A >= b )
86 : INVERT ( n -- 1'comp )
90 : NOT ( n -- !n , logical negation )
98 : DNEGATE ( d -- -d , negate by doing 0-d )
103 \ --------------------------------------------------------------------
109 : DECIMAL 10 base ! ;
118 : $MOVE ( $src $dst -- )
121 : BETWEEN ( n lo hi -- flag , true if between lo & hi )
125 : [ ( -- , enter interpreter mode )
128 : ] ( -- enter compile mode )
132 : EVEN-UP ( n -- n | n+1 , make even ) dup 1 and + ;
133 : ALIGNED ( addr -- a-addr )
134 [ cell 1- ] literal +
135 [ cell 1- invert ] literal and
137 : ALIGN ( -- , align DP ) dp @ aligned dp ! ;
138 : ALLOT ( nbytes -- , allot space in dictionary ) dp +! ( align ) ;
140 : C, ( c -- ) here c! 1 chars dp +! ;
141 : W, ( w -- ) dp @ even-up dup dp ! w! 2 chars dp +! ;
142 : , ( n -- , lay into dictionary ) align here ! cell allot ;
144 \ Dictionary conversions ------------------------------------------
146 : N>NEXTLINK ( nfa -- nextlink , traverses name field )
147 dup c@ 31 and 1+ + aligned
150 : NAMEBASE ( -- base-of-names )
153 : CODEBASE ( -- base-of-code dictionary )
157 : NAMELIMIT ( -- limit-of-names )
160 : CODELIMIT ( -- limit-of-code, last address in dictionary )
164 : NAMEBASE+ ( rnfa -- nfa , convert relocatable nfa to actual )
168 : >CODE ( xt -- secondary_code_address, not valid for primitives )
172 : CODE> ( secondary_code_address -- xt , not valid for primitives )
176 : N>LINK ( nfa -- lfa )
180 : >BODY ( xt -- pfa )
184 : BODY> ( pfa -- xt )
188 \ convert between addresses useable by @, and relocatable addresses.
189 : USE->REL ( useable_addr -- rel_addr )
192 : REL->USE ( rel_addr -- useable_addr )
197 \ : >REL ( adr -- adr ) ; immediate
198 \ : >ABS ( adr -- adr ) ; immediate
200 : X@ ( addr -- xt , fetch execution token from relocatable ) @ ;
201 : X! ( addr -- xt , store execution token as relocatable ) ! ;
203 \ Compiler support ------------------------------------------------
204 : COMPILE, ( xt -- , compile call to xt )
208 ( Compiler support , based on FIG )
209 : [COMPILE] ( <name> -- , compile now even if immediate )
213 : (COMPILE) ( xt -- , postpone compilation of token )
214 [compile] literal ( compile a call to literal )
215 ( store xt of word to be compiled )
217 [ ' compile, ] literal \ compile call to compile,
221 : COMPILE ( <name> -- , save xt and compile later )
226 : :NONAME ( -- xt , begin compilation of headerless secondary )
228 here code> \ convert here to execution token
233 : ERR_ABORT -1 ; \ general abort
234 : ERR_CONDITIONAL -2 ; \ stack error during conditional
235 : ERR_EXECUTING -3 ; \ compile time word while not compiling
236 : ERR_PAIRS -4 ; \ mismatch in conditional
237 : ERR_DEFER -5 ; \ not a deferred word
240 \ Conditionals in '83 form -----------------------------------------
241 : CONDITIONAL_KEY ( -- , lazy constant ) 29521 ;
242 : ?CONDITION ( f -- ) conditional_key - err_conditional ?error ;
243 : >MARK ( -- addr ) here 0 , ;
244 : >RESOLVE ( addr -- ) here over - swap ! ;
245 : <MARK ( -- addr ) here ;
246 : <RESOLVE ( addr -- ) here - , ;
248 : ?COMP ( -- , error if not compiling )
249 state @ 0= err_executing ?error
254 \ conditional primitives
255 : IF ( -- f orig ) ?comp compile 0branch conditional_key >mark ; immediate
256 : THEN ( f orig -- ) swap ?condition >resolve ; immediate
257 : BEGIN ( -- f dest ) ?comp conditional_key <mark ; immediate
258 : AGAIN ( f dest -- ) compile branch swap ?condition <resolve ; immediate
259 : UNTIL ( f dest -- ) compile 0branch swap ?condition <resolve ; immediate
260 : AHEAD ( -- f orig ) compile branch conditional_key >mark ; immediate
262 \ conditionals built from primitives
263 : ELSE ( f orig1 -- f orig2 )
264 [compile] AHEAD 2swap [compile] THEN ; immediate
265 : WHILE ( f dest -- f orig f dest ) [compile] if 2swap ; immediate
266 : REPEAT ( -- f orig f dest ) [compile] again [compile] then ; immediate
268 : ['] ( <name> -- xt , define compile time tick )
269 ?comp ' [compile] literal
273 \ compile time: compile create , (does>) then ;
274 \ execution time: create <name>, ',' data, then patch pi to point to @
275 \ : con create , does> @ ;
279 : (DOES>) ( xt -- , modify previous definition to execute code at xt )
280 latest name> >code \ get address of code for new word
281 cell + \ offset to second cell in create word
282 ! \ store execution token of DOES> code in new word
285 : DOES> ( -- , define execution code for CREATE word )
286 0 [compile] literal \ dummy literal to hold xt
287 here cell- \ address of zero in literal
288 compile (does>) \ call (DOES>) from new creation word
289 [compile] ; \ terminate part of code before does>
291 swap ! \ save execution token in literal
294 : VARIABLE ( <name> -- )
295 CREATE 0 , \ IMMEDIATE
296 \ DOES> [compile] aliteral \ %Q This could be optimised
299 : 2VARIABLE ( <name> -c- ) ( -x- addr )
303 : CONSTANT ( n <name> -c- ) ( -x- n )
311 : 2! ( x1 x2 addr -- , store x2 followed by x1 )
314 : 2@ ( addr -- x1 x2 )
330 : S>D ( s -- d , extend signed single precision to double )
337 : D>S ( d -- s ) drop ;
339 : /MOD ( a b -- rem quo , unsigned version, FIXME )
355 2* over 31 rshift or swap
359 \ define some useful constants ------------------------------
364 \ Store and Fetch relocatable data addresses. ---------------
365 : IF.USE->REL ( use -- rel , preserve zero )
368 : IF.REL->USE ( rel -- use , preserve zero )
372 : A! ( dictionary_address addr -- )
375 : A@ ( addr -- dictionary_address )
379 : A, ( dictionary_address -- )
383 \ Stack data structure ----------------------------------------
384 \ This is a general purpose stack utility used to implement necessary
385 \ stacks for the compiler or the user. Not real fast.
386 \ These stacks grow up which is different then normal.
387 \ cell 0 - stack pointer, offset from pfa of word
388 \ cell 1 - limit for range checking
389 \ cell 2 - first data location
391 : :STACK ( #cells -- )
392 CREATE 2 cells , ( offset of first data location )
393 dup , ( limit for range checking, not currently used )
394 cells cell+ allot ( allot an extra cell for safety )
397 : >STACK ( n stack -- , push onto stack, postincrement )
398 dup @ 2dup cell+ swap ! ( -- n stack offset )
402 : STACK> ( stack -- n , pop , predecrement )
403 dup @ cell- 2dup swap !
407 : STACK@ ( stack -- n , copy )
411 : STACK.PICK ( index stack -- n , grab Nth from top of stack )
413 swap cells - \ offset for index
416 : STACKP ( stack -- ptr , to next empty location on stack )
420 : 0STACKP ( stack -- , clear stack)
427 \ Define JForth like words.
428 : >US ustack >stack ;
429 : US> ustack stack> ;
430 : US@ ustack stack@ ;
431 : 0USP ustack 0stackp ;
434 \ DO LOOP ------------------------------------------------
437 4 constant leave_flag
440 : DO ( -- , loop-back do_flag jump-from ?do_flag )
443 here >us do_flag >us ( for backward branch )
446 : ?DO ( -- , loop-back do_flag jump-from ?do_flag , on user stack )
448 ( leave address to set for forward branch )
451 here >us do_flag >us ( for backward branch )
452 >us ( for forward branch ) ?do_flag >us
455 : LEAVE ( -- addr leave_flag )
461 : LOOP-FORWARD ( -us- jump-from ?do_flag -- )
469 us> here over - cell+ swap !
478 : LOOP-BACK ( loop-addr do_flag -us- )
485 : LOOP ( -- , loop-back do_flag jump-from ?do_flag )
487 loop-forward loop-back
490 \ : DOTEST 5 0 do 333 . loop 888 . ;
491 \ : ?DOTEST0 0 0 ?do 333 . loop 888 . ;
492 \ : ?DOTEST1 5 0 ?do 333 . loop 888 . ;
494 : +LOOP ( -- , loop-back do_flag jump-from ?do_flag )
496 loop-forward loop-back
499 : UNLOOP ( loop-sys -r- )
500 r> \ save return pointer
505 : RECURSE ( ? -- ? , call the word currently being defined )
506 latest name> compile,
510 : SPACES 512 min 0 max 0 ?DO space LOOP ;
511 : 0SP depth 0 ?do drop loop ;
513 : >NEWLINE ( -- , CR if needed )
520 \ Support for DEFER --------------------
521 : CHECK.DEFER ( xt -- , error if not a deferred word by comparing to type )
527 : >is ( xt -- address_of_vector )
532 : (IS) ( xt_do xt_deferred -- )
536 : IS ( xt <name> -- , act like normal IS )
540 IF [compile] literal compile (is)
545 : (WHAT'S) ( xt -- xt_do )
548 : WHAT'S ( <name> -- xt , what will deferred word call? )
552 IF [compile] literal compile (what's)
557 defer ABORT \ will default to QUIT
559 : /STRING ( addr len n -- addr' len' )
560 over min rot over + -rot -
562 : PLACE ( addr len to -- , move string )
563 3dup 1+ swap cmove c! drop
566 : PARSE-WORD ( char -- addr len )
567 >r source tuck >in @ /string r@ skip over swap r> scan
568 >r over - rot r> dup 0<> + - >in !
570 : PARSE ( char -- addr len )
571 >r source >in @ /string over swap r> scan
572 >r over - dup r> 0<> - >in +!
575 : LWORD ( char -- addr )
576 parse-word here place here \ 00002 , use PARSE-WORD
579 : ASCII ( <char> -- char , state smart )
586 : CHAR ( <char> -- char , interpret mode )
590 : [CHAR] ( <char> -- char , for compile mode )
591 char [compile] literal
594 : $TYPE ( $string -- )
598 : 'word ( -- addr ) here ;
600 : EVEN ( addr -- addr' ) dup 1 and + ;
602 : (C") ( -- $addr , some Forths return addr AND count, OBSOLETE?)
603 r> dup count + aligned >r
605 : (S") ( -- c-addr cnt )
606 r> count 2dup + aligned >r
609 : (.") ( -- , type following string )
610 r> count 2dup + aligned >r type
613 : ", ( adr len -- , place string into dictionary )
614 tuck 'word place 1+ allot align
620 : .( ( <string> -- , type string delimited by parentheses )
624 : ." ( <string> -- , type string )
627 ELSE [char] " parse type
632 : .' ( <string> -- , type string delimited by single quote )
634 IF compile (.") [char] ' parse ",
635 ELSE [char] ' parse type
639 : C" ( <string> -- addr , return string address, ANSI )
642 ELSE [char] " parse pad place pad
646 : S" ( <string> -- , -- addr , return string address, ANSI )
649 ELSE [char] " parse pad place pad count
653 : " ( <string> -- , -- addr , return string address )
656 : P" ( <string> -- , -- addr , return string address )
660 : "" ( <string> -- addr )
666 bl parse-word pad place pad
670 : SLITERAL ( addr cnt -- , compile string )
675 : $APPEND ( addr count $1 -- , append text to $1 )
678 count + ( -- a2 c2 end1 )
681 r> + ( -- a1 totalcount )
685 \ -----------------------------------------------------------------
686 \ Auto Initialization
688 \ Kernel finds AUTO.INIT and executes it after loading dictionary.
689 ." Begin AUTO.INIT ------" cr
692 \ Kernel finds AUTO.TERM and executes it on bye.
693 ." End AUTO.TERM ------" cr
696 \ -------------- INCLUDE ------------------------------------------
697 variable TRACE-INCLUDE
699 : INCLUDE.MARK.START ( $filename -- , mark start of include for FILE?)
705 : INCLUDE.MARK.END ( -- , mark end of include )
709 : $INCLUDE ( $filename -- )
713 >newline ." Include " dup count type cr
718 IF ( -- $filename bad-fid )
719 drop ." Could not find file " $type cr abort
720 ELSE ( -- $filename good-fid )
721 swap include.mark.start
722 dup >r \ save fid for close-file
727 ." Warning: stack depth changed during include!" cr
736 ." include added " here r@ - . ." bytes,"
737 codelimit here - . ." left." cr
742 create INCLUDE-SAVE-NAME 128 allot
743 : INCLUDE ( <fname> -- )
745 dup include-save-name $move \ save for RI
749 : RI ( -- , ReInclude previous file as a convenience )
750 include-save-name $include
753 : INCLUDE? ( <word> <file> -- , load file if word not defined )
755 IF drop bl word drop ( eat word from source )
760 \ desired sizes for dictionary loaded after SAVE-FORTH
761 variable HEADERS-SIZE
766 codelimit codebase - code-size !
767 namelimit namebase - headers-size !
771 : SAVE-FORTH ( $name -- )
773 headers-ptr @ namebase - 65536 + \ NameSize
775 here codebase - 131072 + \ CodeSize
779 ." SAVE-FORTH failed!" cr abort
783 : TURNKEY ( $name entry-token-- )
784 0 \ NameSize = 0, names not saved in turnkey dictionary
785 here codebase - 131072 + \ CodeSize, remember that base is HEX
788 ." TURNKEY failed!" cr abort
792 \ load remainder of dictionary
801 : ;;;; ; \ Mark end of this file so FILE? can find things in here.
802 FREEZE \ prevent forgetting below this point
804 .( Dictionary compiled, save in "pforth.dic".) cr
805 c" pforth.dic" save-forth