5 : FLAG_IMMEDIATE 64 ;
\r
8 latest dup c@ flag_immediate OR
\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
17 : \ ( <line> -- , comment out rest of line )
\r
21 \ 1 echo ! \ Uncomment this line to echo Forth code while compiling.
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
29 \ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom
\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
41 : COUNT dup 1+ swap c@ ;
\r
43 \ Miscellaneous support words
\r
44 : ON ( addr -- , set true )
\r
47 : OFF ( addr -- , set false )
\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
55 : CELL+ ( n -- n+cell ) cell + ;
\r
56 : CELL- ( n -- n+cell ) cell - ;
\r
57 : CELLS ( n -- n*cell ) 2 lshift ;
\r
59 : CHAR+ ( n -- n+size_of_char ) 1+ ;
\r
60 : CHARS ( n -- n*size_of_char , don't do anything) ; immediate
\r
62 \ useful stack manipulation words
\r
63 : -ROT ( a b c -- c a b )
\r
66 : 3DUP ( a b c -- a b c a b c )
\r
67 2 pick 2 pick 2 pick
\r
75 : TUCK ( a b -- b a b )
\r
79 : <= ( a b -- f , true if A <= b )
\r
82 : >= ( a b -- f , true if A >= b )
\r
86 : INVERT ( n -- 1'comp )
\r
90 : NOT ( n -- !n , logical negation )
\r
94 : NEGATE ( n -- -n )
\r
98 : DNEGATE ( d -- -d , negate by doing 0-d )
\r
103 \ --------------------------------------------------------------------
\r
109 : DECIMAL 10 base ! ;
\r
112 : BINARY 2 base ! ;
\r
118 : $MOVE ( $src $dst -- )
\r
121 : BETWEEN ( n lo hi -- flag , true if between lo & hi )
\r
125 : [ ( -- , enter interpreter mode )
\r
128 : ] ( -- enter compile mode )
\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
137 : ALIGN ( -- , align DP ) dp @ aligned dp ! ;
\r
138 : ALLOT ( nbytes -- , allot space in dictionary ) dp +! ( align ) ;
\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
144 \ Dictionary conversions ------------------------------------------
\r
146 : N>NEXTLINK ( nfa -- nextlink , traverses name field )
\r
147 dup c@ 31 and 1+ + aligned
\r
150 : NAMEBASE ( -- base-of-names )
\r
153 : CODEBASE ( -- base-of-code dictionary )
\r
157 : NAMELIMIT ( -- limit-of-names )
\r
160 : CODELIMIT ( -- limit-of-code, last address in dictionary )
\r
164 : NAMEBASE+ ( rnfa -- nfa , convert relocatable nfa to actual )
\r
168 : >CODE ( xt -- secondary_code_address, not valid for primitives )
\r
172 : CODE> ( secondary_code_address -- xt , not valid for primitives )
\r
176 : N>LINK ( nfa -- lfa )
\r
180 : >BODY ( xt -- pfa )
\r
181 >code body_offset +
\r
184 : BODY> ( pfa -- xt )
\r
185 body_offset - code>
\r
188 \ convert between addresses useable by @, and relocatable addresses.
\r
189 : USE->REL ( useable_addr -- rel_addr )
\r
192 : REL->USE ( rel_addr -- useable_addr )
\r
197 \ : >REL ( adr -- adr ) ; immediate
\r
198 \ : >ABS ( adr -- adr ) ; immediate
\r
200 : X@ ( addr -- xt , fetch execution token from relocatable ) @ ;
\r
201 : X! ( addr -- xt , store execution token as relocatable ) ! ;
\r
203 \ Compiler support ------------------------------------------------
\r
204 : COMPILE, ( xt -- , compile call to xt )
\r
208 ( Compiler support , based on FIG )
\r
209 : [COMPILE] ( <name> -- , compile now even if immediate )
\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
217 [ ' compile, ] literal \ compile call to compile,
\r
221 : COMPILE ( <name> -- , save xt and compile later )
\r
226 : :NONAME ( -- xt , begin compilation of headerless secondary )
\r
228 here code> \ convert here to execution token
\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
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
250 : ?COMP ( -- , error if not compiling )
\r
251 state @ 0= err_executing ?error
\r
253 : ?PAIRS ( n m -- )
\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
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
270 : ['] ( <name> -- xt , define compile time tick )
\r
271 ?comp ' [compile] literal
\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
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
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
294 :noname ( addrz xt )
\r
295 swap ! \ save execution token in literal
\r
298 : VARIABLE ( <name> -- )
\r
299 CREATE 0 , \ IMMEDIATE
\r
300 \ DOES> [compile] aliteral \ %Q This could be optimised
\r
303 : 2VARIABLE ( <name> -c- ) ( -x- addr )
\r
307 : CONSTANT ( n <name> -c- ) ( -x- n )
\r
317 : 2! ( x1 x2 addr -- , store x2 followed by x1 )
\r
318 swap over ! cell+ !
\r
320 : 2@ ( addr -- x1 x2 )
\r
330 : DABS ( d -- |d| )
\r
336 : S>D ( s -- d , extend signed single precision to double )
\r
343 : D>S ( d -- s ) drop ;
\r
345 : /MOD ( a b -- rem quo , unsigned version, FIXME )
\r
349 : MOD ( a b -- rem )
\r
361 2* over 31 rshift or swap
\r
365 \ define some useful constants ------------------------------
\r
366 1 0= constant FALSE
\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
375 : IF.REL->USE ( rel -- use , preserve zero )
\r
376 dup IF rel->use THEN
\r
379 : A! ( dictionary_address addr -- )
\r
380 >r if.use->rel r> !
\r
382 : A@ ( addr -- dictionary_address )
\r
386 : A, ( dictionary_address -- )
\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
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
404 : >STACK ( n stack -- , push onto stack, postincrement )
\r
405 dup @ 2dup cell+ swap ! ( -- n stack offset )
\r
409 : STACK> ( stack -- n , pop , predecrement )
\r
410 dup @ cell- 2dup swap !
\r
414 : STACK@ ( stack -- n , copy )
\r
418 : STACK.PICK ( index stack -- n , grab Nth from top of stack )
\r
420 swap cells - \ offset for index
\r
423 : STACKP ( stack -- ptr , to next empty location on stack )
\r
427 : 0STACKP ( stack -- , clear stack)
\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
441 \ DO LOOP ------------------------------------------------
\r
444 4 constant leave_flag
\r
445 5 constant ?do_flag
\r
447 : DO ( -- , loop-back do_flag jump-from ?do_flag )
\r
450 here >us do_flag >us ( for backward branch )
\r
453 : ?DO ( -- , loop-back do_flag jump-from ?do_flag , on user stack )
\r
455 ( leave address to set for forward branch )
\r
458 here >us do_flag >us ( for backward branch )
\r
459 >us ( for forward branch ) ?do_flag >us
\r
462 : LEAVE ( -- addr leave_flag )
\r
468 : LOOP-FORWARD ( -us- jump-from ?do_flag -- )
\r
476 us> here over - cell+ swap !
\r
485 : LOOP-BACK ( loop-addr do_flag -us- )
\r
492 : LOOP ( -- , loop-back do_flag jump-from ?do_flag )
\r
494 loop-forward loop-back
\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
501 : +LOOP ( -- , loop-back do_flag jump-from ?do_flag )
\r
503 loop-forward loop-back
\r
506 : UNLOOP ( loop-sys -r- )
\r
507 r> \ save return pointer
\r
512 : RECURSE ( ? -- ? , call the word currently being defined )
\r
513 latest name> compile,
\r
519 : SPACES 512 min 0 max 0 ?DO space LOOP ;
\r
520 : 0SP depth 0 ?do drop loop ;
\r
522 : >NEWLINE ( -- , CR if needed )
\r
529 \ Support for DEFER --------------------
\r
530 : CHECK.DEFER ( xt -- , error if not a deferred word by comparing to type )
\r
536 : >is ( xt -- address_of_vector )
\r
541 : (IS) ( xt_do xt_deferred -- )
\r
545 : IS ( xt <name> -- , act like normal IS )
\r
549 IF [compile] literal compile (is)
\r
554 : (WHAT'S) ( xt -- xt_do )
\r
557 : WHAT'S ( <name> -- xt , what will deferred word call? )
\r
561 IF [compile] literal compile (what's)
\r
566 : /STRING ( addr len n -- addr' len' )
\r
567 over min rot over + -rot -
\r
569 : PLACE ( addr len to -- , move string )
\r
570 3dup 1+ swap cmove c! drop
\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
577 : PARSE ( char -- addr len )
\r
578 >r source >in @ /string over swap r> scan
\r
579 >r over - dup r> 0<> - >in +!
\r
582 : LWORD ( char -- addr )
\r
583 parse-word here place here \ 00002 , use PARSE-WORD
\r
586 : ASCII ( <char> -- char , state smart )
\r
589 IF [compile] literal
\r
593 : CHAR ( <char> -- char , interpret mode )
\r
597 : [CHAR] ( <char> -- char , for compile mode )
\r
598 char [compile] literal
\r
601 : $TYPE ( $string -- )
\r
605 : 'word ( -- addr ) here ;
\r
607 : EVEN ( addr -- addr' ) dup 1 and + ;
\r
609 : (C") ( -- $addr , some Forths return addr AND count, OBSOLETE?)
\r
610 r> dup count + aligned >r
\r
612 : (S") ( -- c-addr cnt )
\r
613 r> count 2dup + aligned >r
\r
616 : (.") ( -- , type following string )
\r
617 r> count 2dup + aligned >r type
\r
620 : ", ( adr len -- , place string into dictionary )
\r
621 tuck 'word place 1+ allot align
\r
627 : .( ( <string> -- , type string delimited by parentheses )
\r
628 [CHAR] ) PARSE TYPE
\r
631 : ." ( <string> -- , type string )
\r
634 ELSE [char] " parse type
\r
639 : .' ( <string> -- , type string delimited by single quote )
\r
641 IF compile (.") [char] ' parse ",
\r
642 ELSE [char] ' parse type
\r
646 : C" ( <string> -- addr , return string address, ANSI )
\r
649 ELSE [char] " parse pad place pad
\r
653 : S" ( <string> -- , -- addr , return string address, ANSI )
\r
656 ELSE [char] " parse pad place pad count
\r
660 : " ( <string> -- , -- addr , return string address )
\r
663 : P" ( <string> -- , -- addr , return string address )
\r
667 : "" ( <string> -- addr )
\r
673 bl parse-word pad place pad
\r
677 : SLITERAL ( addr cnt -- , compile string )
\r
682 : $APPEND ( addr count $1 -- , append text to $1 )
\r
685 count + ( -- a2 c2 end1 )
\r
687 r> dup c@ ( a1 c1 )
\r
688 r> + ( -- a1 totalcount )
\r
693 \ ANSI word to replace [COMPILE] and COMPILE ----------------
\r
694 : POSTPONE ( <name> -- )
\r
698 ." Postpone could not find " count type cr abort
\r
701 IF compile, \ immediate
\r
702 ELSE (compile) \ normal
\r
707 \ -----------------------------------------------------------------
\r
708 \ Auto Initialization
\r
710 \ Kernel finds AUTO.INIT and executes it after loading dictionary.
\r
711 \ ." Begin AUTO.INIT ------" cr
\r
714 \ Kernel finds AUTO.TERM and executes it on bye.
\r
715 \ ." End AUTO.TERM ------" cr
\r
718 \ -------------- INCLUDE ------------------------------------------
\r
719 variable TRACE-INCLUDE
\r
721 : INCLUDE.MARK.START ( $filename -- , mark start of include for FILE?)
\r
727 : INCLUDE.MARK.END ( -- , mark end of include )
\r
728 " ;;;;" ['] noop (:)
\r
731 : $INCLUDE ( $filename -- )
\r
735 >newline ." Include " dup count type cr
\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
749 ." Warning: stack depth changed during include!" cr
\r
758 ." include added " here r@ - . ." bytes,"
\r
759 codelimit here - . ." left." cr
\r
764 create INCLUDE-SAVE-NAME 128 allot
\r
765 : INCLUDE ( <fname> -- )
\r
767 dup include-save-name $move \ save for RI
\r
771 : RI ( -- , ReInclude previous file as a convenience )
\r
772 include-save-name $include
\r
775 : INCLUDE? ( <word> <file> -- , load file if word not defined )
\r
777 IF drop bl word drop ( eat word from source )
\r
782 \ desired sizes for dictionary loaded after SAVE-FORTH
\r
783 variable HEADERS-SIZE
\r
788 codelimit codebase - code-size !
\r
789 namelimit namebase - headers-size !
\r
793 : SAVE-FORTH ( $name -- )
\r
795 headers-ptr @ namebase - 65536 + \ NameSize
\r
797 here codebase - 131072 + \ CodeSize
\r
801 ." SAVE-FORTH failed!" cr abort
\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
810 ." TURNKEY failed!" cr abort
\r
814 \ Now that we can load from files, load remainder of dictionary.
\r
819 include loadp4th.fth
\r
823 : ;;;; ; \ Mark end of this file so FILE? can find things in here.
\r
824 FREEZE \ prevent forgetting below this point
\r
826 .( Dictionary compiled, save in "pforth.dic".) cr
\r
827 c" pforth.dic" save-forth
\r
829 \ Save the dictionary in "pfdicdat.h" file so pForth can be compiled for standalone mode.
\r