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 \ 1 echo ! \ Uncomment this line to echo Forth code while compiling.
23 \ *********************************************************************
24 \ This is another style of comment that is common in Forth.
25 \ pFORTH - Portable Forth System
29 \ Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
31 \ Permission to use, copy, modify, and/or distribute this
32 \ software for any purpose with or without fee is hereby granted.
34 \ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
35 \ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
36 \ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL
37 \ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
38 \ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING
39 \ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF
40 \ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
41 \ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
42 \ *********************************************************************
44 : COUNT dup 1+ swap c@ ;
46 \ Miscellaneous support words
47 : ON ( addr -- , set true )
50 : OFF ( addr -- , set false )
54 : CELL+ ( n -- n+cell ) cell + ;
55 : CELL- ( n -- n+cell ) cell - ;
56 : CELL* ( n -- n*cell ) cells ;
58 : CHAR+ ( n -- n+size_of_char ) 1+ ;
59 : CHARS ( n -- n*size_of_char , don't do anything) ; immediate
61 \ useful stack manipulation words
62 : -ROT ( a b c -- c a b )
65 : 3DUP ( a b c -- a b c a b c )
74 : TUCK ( a b -- b a b )
78 : <= ( a b -- f , true if A <= b )
81 : >= ( a b -- f , true if A >= b )
85 : INVERT ( n -- 1'comp )
89 : NOT ( n -- !n , logical negation )
97 : DNEGATE ( d -- -d , negate by doing 0-d )
102 \ --------------------------------------------------------------------
108 : DECIMAL 10 base ! ;
117 : $MOVE ( $src $dst -- )
120 : BETWEEN ( n lo hi -- flag , true if between lo & hi )
124 : [ ( -- , enter interpreter mode )
127 : ] ( -- enter compile mode )
131 : EVEN-UP ( n -- n | n+1 , make even ) dup 1 and + ;
132 : ALIGNED ( addr -- a-addr )
133 [ cell 1- ] literal +
134 [ cell 1- invert ] literal and
136 : ALIGN ( -- , align DP ) dp @ aligned dp ! ;
137 : ALLOT ( nbytes -- , allot space in dictionary ) dp +! ( align ) ;
139 : C, ( c -- ) here c! 1 chars dp +! ;
140 : W, ( w -- ) dp @ even-up dup dp ! w! 2 chars dp +! ;
141 : , ( n -- , lay into dictionary ) align here ! cell allot ;
143 \ Dictionary conversions ------------------------------------------
145 : N>NEXTLINK ( nfa -- nextlink , traverses name field )
146 dup c@ 31 and 1+ + aligned
149 : NAMEBASE ( -- base-of-names )
152 : CODEBASE ( -- base-of-code dictionary )
156 : NAMELIMIT ( -- limit-of-names )
159 : CODELIMIT ( -- limit-of-code, last address in dictionary )
163 : NAMEBASE+ ( rnfa -- nfa , convert relocatable nfa to actual )
167 : >CODE ( xt -- secondary_code_address, not valid for primitives )
171 : CODE> ( secondary_code_address -- xt , not valid for primitives )
175 : N>LINK ( nfa -- lfa )
179 : >BODY ( xt -- pfa )
183 : BODY> ( pfa -- xt )
187 \ convert between addresses useable by @, and relocatable addresses.
188 : USE->REL ( useable_addr -- rel_addr )
191 : REL->USE ( rel_addr -- useable_addr )
196 \ : >REL ( adr -- adr ) ; immediate
197 \ : >ABS ( adr -- adr ) ; immediate
199 : X@ ( addr -- xt , fetch execution token from relocatable ) @ ;
200 : X! ( addr -- xt , store execution token as relocatable ) ! ;
202 \ Compiler support ------------------------------------------------
203 : COMPILE, ( xt -- , compile call to xt )
207 ( Compiler support , based on FIG )
208 : [COMPILE] ( <name> -- , compile now even if immediate )
212 : (COMPILE) ( xt -- , postpone compilation of token )
213 [compile] literal ( compile a call to literal )
214 ( store xt of word to be compiled )
216 [ ' compile, ] literal \ compile call to compile,
220 : COMPILE ( <name> -- , save xt and compile later )
225 : :NONAME ( -- xt , begin compilation of headerless secondary )
227 here code> \ convert here to execution token
231 \ Error codes defined in ANSI Exception word set.
232 : ERR_ABORT -1 ; \ general abort
233 : ERR_ABORTQ -2 ; \ for abort"
234 : ERR_EXECUTING -14 ; \ compile time word while not compiling
235 : ERR_PAIRS -22 ; \ mismatch in conditional
236 : ERR_DEFER -258 ; \ not a deferred word
242 \ Conditionals in '83 form -----------------------------------------
243 : CONDITIONAL_KEY ( -- , lazy constant ) 29521 ;
244 : ?CONDITION ( f -- ) conditional_key - err_pairs ?error ;
245 : >MARK ( -- addr ) here 0 , ;
246 : >RESOLVE ( addr -- ) here over - swap ! ;
247 : <MARK ( -- addr ) here ;
248 : <RESOLVE ( addr -- ) here - , ;
250 : ?COMP ( -- , error if not compiling )
251 state @ 0= err_executing ?error
256 \ conditional primitives
257 : IF ( -- f orig ) ?comp compile 0branch conditional_key >mark ; immediate
258 : THEN ( f orig -- ) swap ?condition >resolve ; immediate
259 : BEGIN ( -- f dest ) ?comp conditional_key <mark ; immediate
260 : AGAIN ( f dest -- ) compile branch swap ?condition <resolve ; immediate
261 : UNTIL ( f dest -- ) compile 0branch swap ?condition <resolve ; immediate
262 : AHEAD ( -- f orig ) compile branch conditional_key >mark ; immediate
264 \ conditionals built from primitives
265 : ELSE ( f orig1 -- f orig2 )
266 [compile] AHEAD 2swap [compile] THEN ; immediate
267 : WHILE ( f dest -- f orig f dest ) [compile] if 2swap ; immediate
268 : REPEAT ( -- f orig f dest ) [compile] again [compile] then ; immediate
270 : ['] ( <name> -- xt , define compile time tick )
271 ?comp ' [compile] literal
275 \ compile time: compile create , (does>) then ;
276 \ execution time: create <name>, ',' data, then patch pi to point to @
277 \ : con create , does> @ ;
281 : (DOES>) ( xt -- , modify previous definition to execute code at xt )
282 latest name> >code \ get address of code for new word
283 cell + \ offset to second cell in create word
284 ! \ store execution token of DOES> code in new word
287 : DOES> ( -- , define execution code for CREATE word )
288 0 [compile] literal \ dummy literal to hold xt
289 here cell- \ address of zero in literal
290 compile (does>) \ call (DOES>) from new creation word
291 >r \ move addrz to return stack so ; doesn't see stack garbage
292 [compile] ; \ terminate part of code before does>
295 swap ! \ save execution token in literal
298 : VARIABLE ( <name> -- )
299 CREATE 0 , \ IMMEDIATE
300 \ DOES> [compile] aliteral \ %Q This could be optimised
303 : 2VARIABLE ( <name> -c- ) ( -x- addr )
307 : CONSTANT ( n <name> -c- ) ( -x- n )
317 : 2! ( x1 x2 addr -- , store x2 followed by x1 )
320 : 2@ ( addr -- x1 x2 )
324 : 2CONSTANT ( n1 n2 <name> -c- ) ( -x- n1 n2 )
325 CREATE , , ( n1 n2 -- )
326 DOES> 2@ ( -- n1 n2 )
340 : S>D ( s -- d , extend signed single precision to double )
347 : D>S ( d -- s ) drop ;
349 : /MOD ( a b -- rem quo , unsigned version, FIXME )
366 cell 8 * 1- rshift or swap
370 : D= ( xd1 xd2 -- flag )
374 : D< ( d1 d2 -- flag )
378 : D> ( d1 d2 -- flag )
382 \ define some useful constants ------------------------------
388 \ Store and Fetch relocatable data addresses. ---------------
389 : IF.USE->REL ( use -- rel , preserve zero )
392 : IF.REL->USE ( rel -- use , preserve zero )
396 : A! ( dictionary_address addr -- )
399 : A@ ( addr -- dictionary_address )
403 : A, ( dictionary_address -- )
407 \ Stack data structure ----------------------------------------
408 \ This is a general purpose stack utility used to implement necessary
409 \ stacks for the compiler or the user. Not real fast.
410 \ These stacks grow up which is different then normal.
411 \ cell 0 - stack pointer, offset from pfa of word
412 \ cell 1 - limit for range checking
413 \ cell 2 - first data location
415 : :STACK ( #cells -- )
416 CREATE 2 cells , ( offset of first data location )
417 dup , ( limit for range checking, not currently used )
418 cells cell+ allot ( allot an extra cell for safety )
421 : >STACK ( n stack -- , push onto stack, postincrement )
422 dup @ 2dup cell+ swap ! ( -- n stack offset )
426 : STACK> ( stack -- n , pop , predecrement )
427 dup @ cell- 2dup swap !
431 : STACK@ ( stack -- n , copy )
435 : STACK.PICK ( index stack -- n , grab Nth from top of stack )
437 swap cells - \ offset for index
440 : STACKP ( stack -- ptr , to next empty location on stack )
444 : 0STACKP ( stack -- , clear stack)
451 \ Define JForth like words.
452 : >US ustack >stack ;
453 : US> ustack stack> ;
454 : US@ ustack stack@ ;
455 : 0USP ustack 0stackp ;
458 \ DO LOOP ------------------------------------------------
461 4 constant leave_flag
464 : DO ( -- , loop-back do_flag jump-from ?do_flag )
467 here >us do_flag >us ( for backward branch )
470 : ?DO ( -- , loop-back do_flag jump-from ?do_flag , on user stack )
472 ( leave address to set for forward branch )
475 here >us do_flag >us ( for backward branch )
476 >us ( for forward branch ) ?do_flag >us
479 : LEAVE ( -- addr leave_flag )
485 : LOOP-FORWARD ( -us- jump-from ?do_flag -- )
493 us> here over - cell+ swap !
502 : LOOP-BACK ( loop-addr do_flag -us- )
509 : LOOP ( -- , loop-back do_flag jump-from ?do_flag )
511 loop-forward loop-back
514 \ : DOTEST 5 0 do 333 . loop 888 . ;
515 \ : ?DOTEST0 0 0 ?do 333 . loop 888 . ;
516 \ : ?DOTEST1 5 0 ?do 333 . loop 888 . ;
518 : +LOOP ( -- , loop-back do_flag jump-from ?do_flag )
520 loop-forward loop-back
523 : UNLOOP ( loop-sys -r- )
524 r> \ save return pointer
529 : RECURSE ( ? -- ? , call the word currently being defined )
530 latest name> compile,
536 : SPACES 512 min 0 max 0 ?DO space LOOP ;
537 : 0SP depth 0 ?do drop loop ;
539 : >NEWLINE ( -- , CR if needed )
546 \ Support for DEFER --------------------
547 : CHECK.DEFER ( xt -- , error if not a deferred word by comparing to type )
553 : >is ( xt -- address_of_vector )
558 : (IS) ( xt_do xt_deferred -- )
562 : IS ( xt <name> -- , act like normal IS )
566 IF [compile] literal compile (is)
571 : (WHAT'S) ( xt -- xt_do )
574 : WHAT'S ( <name> -- xt , what will deferred word call? )
578 IF [compile] literal compile (what's)
583 : /STRING ( addr len n -- addr' len' )
584 over min rot over + -rot -
586 : PLACE ( addr len to -- , move string )
587 3dup 1+ swap cmove c! drop
590 : PARSE-WORD ( char -- addr len )
591 >r source tuck >in @ /string r@ skip over swap r> scan
592 >r over - rot r> dup 0<> + - >in !
594 : PARSE ( char -- addr len )
595 >r source >in @ /string over swap r> scan
596 >r over - dup r> 0<> - >in +!
599 : LWORD ( char -- addr )
600 parse-word here place here \ 00002 , use PARSE-WORD
603 : ASCII ( <char> -- char , state smart )
610 : CHAR ( <char> -- char , interpret mode )
614 : [CHAR] ( <char> -- char , for compile mode )
615 char [compile] literal
618 : $TYPE ( $string -- )
622 : 'word ( -- addr ) here ;
624 : EVEN ( addr -- addr' ) dup 1 and + ;
626 : (C") ( -- $addr , some Forths return addr AND count, OBSOLETE?)
627 r> dup count + aligned >r
629 : (S") ( -- c-addr cnt )
630 r> count 2dup + aligned >r
633 : (.") ( -- , type following string )
634 r> count 2dup + aligned >r type
637 : ", ( adr len -- , place string into dictionary )
638 tuck 'word place 1+ allot align
644 : .( ( <string> -- , type string delimited by parentheses )
648 : ." ( <string> -- , type string )
651 ELSE [char] " parse type
656 : .' ( <string> -- , type string delimited by single quote )
658 IF compile (.") [char] ' parse ",
659 ELSE [char] ' parse type
663 : C" ( <string> -- addr , return string address, ANSI )
666 ELSE [char] " parse pad place pad
670 : S" ( <string> -- , -- addr , return string address, ANSI )
673 ELSE [char] " parse pad place pad count
677 : " ( <string> -- , -- addr , return string address )
680 : P" ( <string> -- , -- addr , return string address )
684 : "" ( <string> -- addr )
690 bl parse-word pad place pad
694 : SLITERAL ( addr cnt -- , compile string )
699 : $APPEND ( addr count $1 -- , append text to $1 )
702 count + ( -- a2 c2 end1 )
705 r> + ( -- a1 totalcount )
710 \ ANSI word to replace [COMPILE] and COMPILE ----------------
711 : POSTPONE ( <name> -- )
715 ." Postpone could not find " count type cr abort
718 IF compile, \ immediate
719 ELSE (compile) \ normal
724 \ -----------------------------------------------------------------
725 \ Auto Initialization
727 \ Kernel finds AUTO.INIT and executes it after loading dictionary.
728 \ ." Begin AUTO.INIT ------" cr
731 \ Kernel finds AUTO.TERM and executes it on bye.
732 \ ." End AUTO.TERM ------" cr
735 \ -------------- INCLUDE ------------------------------------------
736 variable TRACE-INCLUDE
738 : INCLUDE.MARK.START ( c-addr u -- , mark start of include for FILE?)
739 dup 5 + allocate throw >r
746 : INCLUDE.MARK.END ( -- , mark end of include )
750 : INCLUDED ( c-addr u -- )
754 >newline ." Include " 2dup type cr
758 IF ( -- c-addr u bad-fid )
759 drop ." Could not find file " type cr abort
760 ELSE ( -- c-addr u good-fid )
761 -rot include.mark.start
763 include-file \ will also close the file
766 ." Warning: stack depth changed during include!" cr
774 ." include added " here r@ - . ." bytes,"
775 codelimit here - . ." left." cr
780 defer MAP.FILENAME ( $filename1 -- $filename2 , modify name )
781 ' noop is map.filename
783 : $INCLUDE ( $filename -- )
788 create INCLUDE-SAVE-NAME 128 allot
789 : INCLUDE ( <fname> -- )
791 dup include-save-name $move \ save for RI
795 : RI ( -- , ReInclude previous file as a convenience )
796 include-save-name $include
799 : INCLUDE? ( <word> <file> -- , load file if word not defined )
801 IF drop bl word drop ( eat word from source )
806 \ desired sizes for dictionary loaded after SAVE-FORTH
807 variable HEADERS-SIZE
812 codelimit codebase - code-size !
813 namelimit namebase - headers-size !
817 : SAVE-FORTH ( $name -- )
819 headers-ptr @ namebase - 65536 + \ NameSize
821 here codebase - 131072 + \ CodeSize
825 ." SAVE-FORTH failed!" cr abort
829 : TURNKEY ( $name entry-token-- )
830 0 \ NameSize = 0, names not saved in turnkey dictionary
831 here codebase - 131072 + \ CodeSize, remember that base is HEX
834 ." TURNKEY failed!" cr abort
838 \ Now that we can load from files, load remainder of dictionary.
841 \ Turn this OFF if you do not want to see the contents of the stack after each entry.
848 : ;;;; ; \ Mark end of this file so FILE? can find things in here.
849 FREEZE \ prevent forgetting below this point
851 .( Dictionary compiled, save in "pforth.dic".) cr
852 \ 300000 headers-size !
854 c" pforth.dic" save-forth