-\r
-: CHAR+ ( n -- n+size_of_char ) 1+ ;\r
-: CHARS ( n -- n*size_of_char , don't do anything) ; immediate\r
-\r
-\ useful stack manipulation words\r
-: -ROT ( a b c -- c a b )\r
- rot rot\r
-;\r
-: 3DUP ( a b c -- a b c a b c )\r
- 2 pick 2 pick 2 pick\r
-;\r
-: 2DROP ( a b -- )\r
- drop drop\r
-;\r
-: NIP ( a b -- b )\r
- swap drop\r
-;\r
-: TUCK ( a b -- b a b )\r
- swap over\r
-;\r
-\r
-: <= ( a b -- f , true if A <= b )\r
- > 0=\r
-;\r
-: >= ( a b -- f , true if A >= b )\r
- < 0=\r
-;\r
-\r
-: INVERT ( n -- 1'comp )\r
- -1 xor\r
-;\r
-\r
-: NOT ( n -- !n , logical negation )\r
- 0=\r
-;\r
-\r
-: NEGATE ( n -- -n )\r
- 0 swap -\r
-;\r
-\r
-: DNEGATE ( d -- -d , negate by doing 0-d )\r
- 0 0 2swap d-\r
-;\r
-\r
-\r
-\ --------------------------------------------------------------------\r
-\r
-: ID. ( nfa -- )\r
- count 31 and type\r
-;\r
-\r
-: DECIMAL 10 base ! ;\r
-: OCTAL 8 base ! ;\r
-: HEX 16 base ! ;\r
-: BINARY 2 base ! ;\r
-\r
-: PAD ( -- addr )\r
- here 128 +\r
-;\r
-\r
-: $MOVE ( $src $dst -- )\r
- over c@ 1+ cmove\r
-;\r
-: BETWEEN ( n lo hi -- flag , true if between lo & hi )\r
- >r over r> > >r\r
- < r> or 0=\r
-;\r
-: [ ( -- , enter interpreter mode )\r
- 0 state !\r
-; immediate\r
-: ] ( -- enter compile mode )\r
- 1 state !\r
-;\r
-\r
-: EVEN-UP ( n -- n | n+1 , make even ) dup 1 and + ;\r
-: ALIGNED ( addr -- a-addr )\r
- [ cell 1- ] literal +\r
- [ cell 1- invert ] literal and\r
-;\r
-: ALIGN ( -- , align DP ) dp @ aligned dp ! ;\r
-: ALLOT ( nbytes -- , allot space in dictionary ) dp +! ( align ) ;\r
-\r
-: C, ( c -- ) here c! 1 chars dp +! ;\r
-: W, ( w -- ) dp @ even-up dup dp ! w! 2 chars dp +! ;\r
-: , ( n -- , lay into dictionary ) align here ! cell allot ;\r
-\r
-\ Dictionary conversions ------------------------------------------\r
-\r
-: N>NEXTLINK ( nfa -- nextlink , traverses name field )\r
- dup c@ 31 and 1+ + aligned\r
-;\r
-\r
-: NAMEBASE ( -- base-of-names )\r
- Headers-Base @\r
-;\r
-: CODEBASE ( -- base-of-code dictionary )\r
- Code-Base @\r
-;\r
-\r
-: NAMELIMIT ( -- limit-of-names )\r
- Headers-limit @\r
-;\r
-: CODELIMIT ( -- limit-of-code, last address in dictionary )\r
- Code-limit @\r
-;\r
-\r
-: NAMEBASE+ ( rnfa -- nfa , convert relocatable nfa to actual )\r
- namebase +\r
-;\r
-\r
-: >CODE ( xt -- secondary_code_address, not valid for primitives )\r
- codebase +\r
-;\r
-\r
-: CODE> ( secondary_code_address -- xt , not valid for primitives )\r
- codebase -\r
-;\r
-\r
-: N>LINK ( nfa -- lfa )\r
- 2 CELLS -\r
-;\r
-\r
-: >BODY ( xt -- pfa )\r
- >code body_offset +\r
-;\r
-\r
-: BODY> ( pfa -- xt )\r
- body_offset - code>\r
-;\r
-\r
-\ convert between addresses useable by @, and relocatable addresses.\r
-: USE->REL ( useable_addr -- rel_addr )\r
- codebase -\r
-;\r
-: REL->USE ( rel_addr -- useable_addr )\r
- codebase +\r
-;\r
-\r
-\ for JForth code\r
-\ : >REL ( adr -- adr ) ; immediate\r
-\ : >ABS ( adr -- adr ) ; immediate\r
-\r
-: X@ ( addr -- xt , fetch execution token from relocatable ) @ ;\r
-: X! ( addr -- xt , store execution token as relocatable ) ! ;\r
-\r
-\ Compiler support ------------------------------------------------\r
-: COMPILE, ( xt -- , compile call to xt )\r
- ,\r
-;\r
-\r
-( Compiler support , based on FIG )\r
-: [COMPILE] ( <name> -- , compile now even if immediate )\r
- ' compile,\r
-; IMMEDIATE\r
-\r
-: (COMPILE) ( xt -- , postpone compilation of token )\r
- [compile] literal ( compile a call to literal )\r
- ( store xt of word to be compiled )\r
- \r
- [ ' compile, ] literal \ compile call to compile,\r
- compile,\r
-;\r
- \r
-: COMPILE ( <name> -- , save xt and compile later )\r
- ' (compile)\r
-; IMMEDIATE\r
-\r
-\r
-: :NONAME ( -- xt , begin compilation of headerless secondary )\r
- align\r
- here code> \ convert here to execution token\r
- ]\r
-;\r
-\r
-\ Error codes defined in ANSI Exception word set.\r
-: ERR_ABORT -1 ; \ general abort\r
-: ERR_EXECUTING -14 ; \ compile time word while not compiling\r
-: ERR_PAIRS -22 ; \ mismatch in conditional\r
-: ERR_DEFER -258 ; \ not a deferred word\r
-\r
-: ABORT ( i*x -- )\r
- ERR_ABORT throw\r
-;\r
-\r
-\ Conditionals in '83 form -----------------------------------------\r
-: CONDITIONAL_KEY ( -- , lazy constant ) 29521 ;\r
-: ?CONDITION ( f -- ) conditional_key - err_pairs ?error ;\r
-: >MARK ( -- addr ) here 0 , ;\r
-: >RESOLVE ( addr -- ) here over - swap ! ;\r
-: <MARK ( -- addr ) here ;\r
-: <RESOLVE ( addr -- ) here - , ;\r
-\r
-: ?COMP ( -- , error if not compiling )\r
- state @ 0= err_executing ?error\r
-;\r
-: ?PAIRS ( n m -- )\r
- - err_pairs ?error\r
-;\r
-\ conditional primitives\r
-: IF ( -- f orig ) ?comp compile 0branch conditional_key >mark ; immediate\r
-: THEN ( f orig -- ) swap ?condition >resolve ; immediate\r
-: BEGIN ( -- f dest ) ?comp conditional_key <mark ; immediate\r
-: AGAIN ( f dest -- ) compile branch swap ?condition <resolve ; immediate\r
-: UNTIL ( f dest -- ) compile 0branch swap ?condition <resolve ; immediate\r
-: AHEAD ( -- f orig ) compile branch conditional_key >mark ; immediate\r
-\r
-\ conditionals built from primitives\r
-: ELSE ( f orig1 -- f orig2 )\r
- [compile] AHEAD 2swap [compile] THEN ; immediate\r
-: WHILE ( f dest -- f orig f dest ) [compile] if 2swap ; immediate\r
-: REPEAT ( -- f orig f dest ) [compile] again [compile] then ; immediate\r
-\r
-: ['] ( <name> -- xt , define compile time tick )\r
- ?comp ' [compile] literal\r
-; immediate\r
-\r
-\ for example:\r
-\ compile time: compile create , (does>) then ;\r
-\ execution time: create <name>, ',' data, then patch pi to point to @\r
-\ : con create , does> @ ;\r
-\ 345 con pi\r
-\ pi\r
-\ \r
-: (DOES>) ( xt -- , modify previous definition to execute code at xt )\r
- latest name> >code \ get address of code for new word\r
- cell + \ offset to second cell in create word\r
- ! \ store execution token of DOES> code in new word\r
-;\r
-\r
-: DOES> ( -- , define execution code for CREATE word )\r
- 0 [compile] literal \ dummy literal to hold xt\r
- here cell- \ address of zero in literal\r
- compile (does>) \ call (DOES>) from new creation word\r
- >r \ move addrz to return stack so ; doesn't see stack garbage\r
- [compile] ; \ terminate part of code before does>\r
- r>\r
- :noname ( addrz xt )\r
- swap ! \ save execution token in literal\r
-; immediate\r
-\r
-: VARIABLE ( <name> -- )\r
- CREATE 0 , \ IMMEDIATE\r
-\ DOES> [compile] aliteral \ %Q This could be optimised\r
-;\r
-\r
-: 2VARIABLE ( <name> -c- ) ( -x- addr )\r
- create 0 , 0 ,\r
-;\r
-\r
-: CONSTANT ( n <name> -c- ) ( -x- n )\r
- CREATE , ( n -- )\r
- DOES> @ ( -- n )\r
-;\r
-\r
-\r
-\r
-0 1- constant -1\r
-0 2- constant -2\r
-\r
-: 2! ( x1 x2 addr -- , store x2 followed by x1 )\r
- swap over ! cell+ !\r
-;\r
-: 2@ ( addr -- x1 x2 )\r
- dup cell+ @ swap @\r
-;\r
-\r
-\r
-: ABS ( n -- |n| )\r
- dup 0<\r
- IF negate\r
- THEN\r
-;\r
-: DABS ( d -- |d| )\r
- dup 0<\r
- IF dnegate\r
- THEN\r
-;\r
-\r
-: S>D ( s -- d , extend signed single precision to double )\r
- dup 0<\r
- IF -1\r
- ELSE 0\r
- THEN\r
-;\r
-\r
-: D>S ( d -- s ) drop ;\r
-\r
-: /MOD ( a b -- rem quo , unsigned version, FIXME )\r
- >r s>d r> um/mod\r
-;\r
-\r
-: MOD ( a b -- rem )\r
- /mod drop\r
-;\r
-\r
-: 2* ( n -- n*2 )\r
- 1 lshift\r
-;\r
-: 2/ ( n -- n/2 )\r
- 1 arshift\r
-;\r
-\r
-: D2* ( d -- d*2 )\r
- 2* over
- cell 8 * 1- rshift or swap\r
- 2* swap\r
-;\r
-\r
-\ define some useful constants ------------------------------\r
-1 0= constant FALSE\r
-0 0= constant TRUE\r
-32 constant BL\r
-\r
-\r
-\ Store and Fetch relocatable data addresses. ---------------\r
-: IF.USE->REL ( use -- rel , preserve zero )\r
- dup IF use->rel THEN\r
-;\r
-: IF.REL->USE ( rel -- use , preserve zero )\r
- dup IF rel->use THEN\r
-;\r
-\r
-: A! ( dictionary_address addr -- )\r
- >r if.use->rel r> !\r
-;\r
-: A@ ( addr -- dictionary_address )\r
- @ if.rel->use\r
-;\r
-\r
-: A, ( dictionary_address -- )\r
- if.use->rel ,\r
-;\r
-\r
-\ Stack data structure ----------------------------------------\r
-\ This is a general purpose stack utility used to implement necessary\r
-\ stacks for the compiler or the user. Not real fast.\r
-\ These stacks grow up which is different then normal.\r
-\ cell 0 - stack pointer, offset from pfa of word\r
-\ cell 1 - limit for range checking\r
-\ cell 2 - first data location\r
-\r
-: :STACK ( #cells -- )\r
- CREATE 2 cells , ( offset of first data location )\r
- dup , ( limit for range checking, not currently used )\r
- cells cell+ allot ( allot an extra cell for safety )\r
-;\r
-\r
-: >STACK ( n stack -- , push onto stack, postincrement )\r
- dup @ 2dup cell+ swap ! ( -- n stack offset )\r
- + !\r
-;\r
-\r
-: STACK> ( stack -- n , pop , predecrement )\r
- dup @ cell- 2dup swap !\r
- + @\r
-;\r
-\r
-: STACK@ ( stack -- n , copy )\r
- dup @ cell- + @ \r
-;\r
-\r
-: STACK.PICK ( index stack -- n , grab Nth from top of stack )\r
- dup @ cell- +\r
- swap cells - \ offset for index\r
- @ \r
-;\r
-: STACKP ( stack -- ptr , to next empty location on stack )\r
- dup @ +\r
-;\r
-\r
-: 0STACKP ( stack -- , clear stack)\r
- 8 swap !\r
-;\r
-\r
-32 :stack ustack\r
-ustack 0stackp\r
-\r
-\ Define JForth like words.\r
-: >US ustack >stack ;\r
-: US> ustack stack> ;\r
-: US@ ustack stack@ ;\r
-: 0USP ustack 0stackp ;\r
-\r
-\r
-\ DO LOOP ------------------------------------------------\r
-\r
-3 constant do_flag\r
-4 constant leave_flag\r
-5 constant ?do_flag\r
-\r
-: DO ( -- , loop-back do_flag jump-from ?do_flag )\r
- ?comp\r
- compile (do)\r
- here >us do_flag >us ( for backward branch )\r
-; immediate\r
-\r
-: ?DO ( -- , loop-back do_flag jump-from ?do_flag , on user stack )\r
- ?comp\r
- ( leave address to set for forward branch )\r
- compile (?do)\r
- here 0 ,\r
- here >us do_flag >us ( for backward branch )\r
- >us ( for forward branch ) ?do_flag >us\r
-; immediate\r
-\r
-: LEAVE ( -- addr leave_flag )\r
- compile (leave)\r
- here 0 , >us\r
- leave_flag >us\r
-; immediate\r
-\r
-: LOOP-FORWARD ( -us- jump-from ?do_flag -- )\r
- BEGIN\r
- us@ leave_flag =\r
- us@ ?do_flag =\r
- OR\r
- WHILE\r
- us> leave_flag =\r
- IF\r
- us> here over - cell+ swap !\r
- ELSE\r
- us> dup\r
- here swap -\r
- cell+ swap !\r
- THEN\r
- REPEAT\r
-;\r
-\r
-: LOOP-BACK ( loop-addr do_flag -us- )\r
- us> do_flag ?pairs\r
- us> here - here\r
- !\r
- cell allot\r
-;\r
-\r
-: LOOP ( -- , loop-back do_flag jump-from ?do_flag )\r
- compile (loop)\r
- loop-forward loop-back\r
-; immediate\r
-\r
-\ : DOTEST 5 0 do 333 . loop 888 . ;\r
-\ : ?DOTEST0 0 0 ?do 333 . loop 888 . ;\r
-\ : ?DOTEST1 5 0 ?do 333 . loop 888 . ;\r
-\r
-: +LOOP ( -- , loop-back do_flag jump-from ?do_flag )\r
- compile (+loop)\r
- loop-forward loop-back\r
-; immediate\r
- \r
-: UNLOOP ( loop-sys -r- )\r
- r> \ save return pointer\r
- rdrop rdrop\r
- >r\r
-;\r
-\r
-: RECURSE ( ? -- ? , call the word currently being defined )\r
- latest name> compile,\r
-; immediate\r
-\r
-\r
-\r
-: SPACE bl emit ;\r
-: SPACES 512 min 0 max 0 ?DO space LOOP ;\r
-: 0SP depth 0 ?do drop loop ;\r
-\r
-: >NEWLINE ( -- , CR if needed )\r
- out @ 0>\r
- IF cr\r
- THEN\r
-;\r
-\r
-\r
-\ Support for DEFER --------------------\r
-: CHECK.DEFER ( xt -- , error if not a deferred word by comparing to type )\r
- >code @\r
- ['] emit >code @\r
- - err_defer ?error\r
-;\r
-\r
-: >is ( xt -- address_of_vector )\r
- >code\r
- cell +\r
-;\r
-\r
-: (IS) ( xt_do xt_deferred -- )\r
- >is !\r
-;\r
-\r
-: IS ( xt <name> -- , act like normal IS )\r
- ' \ xt\r
- dup check.defer \r
- state @\r
- IF [compile] literal compile (is)\r
- ELSE (is)\r
- THEN\r
-; immediate\r
-\r
-: (WHAT'S) ( xt -- xt_do )\r
- >is @\r
-;\r
-: WHAT'S ( <name> -- xt , what will deferred word call? )\r
- ' \ xt\r
- dup check.defer\r
- state @\r
- IF [compile] literal compile (what's)\r
- ELSE (what's)\r
- THEN\r
-; immediate\r
-\r
-: /STRING ( addr len n -- addr' len' )\r
- over min rot over + -rot -\r
-;\r
-: PLACE ( addr len to -- , move string )\r
- 3dup 1+ swap cmove c! drop\r
-;\r
-\r
-: PARSE-WORD ( char -- addr len )\r
- >r source tuck >in @ /string r@ skip over swap r> scan\r
- >r over - rot r> dup 0<> + - >in !\r
-;\r
-: PARSE ( char -- addr len )\r
- >r source >in @ /string over swap r> scan\r
- >r over - dup r> 0<> - >in +!\r
-;\r
-\r
-: LWORD ( char -- addr )\r
- parse-word here place here \ 00002 , use PARSE-WORD\r
-;\r
-\r
-: ASCII ( <char> -- char , state smart )\r
- bl parse drop c@\r
- state @\r
- IF [compile] literal\r
- THEN\r
-; immediate\r
-\r
-: CHAR ( <char> -- char , interpret mode )\r
- bl parse drop c@\r
-;\r
-\r
-: [CHAR] ( <char> -- char , for compile mode )\r
- char [compile] literal\r
-; immediate\r
-\r
-: $TYPE ( $string -- )\r
- count type\r
-;\r
-\r
-: 'word ( -- addr ) here ;\r
-\r
-: EVEN ( addr -- addr' ) dup 1 and + ;\r
-\r
-: (C") ( -- $addr , some Forths return addr AND count, OBSOLETE?)\r
- r> dup count + aligned >r\r
-;\r
-: (S") ( -- c-addr cnt )\r
- r> count 2dup + aligned >r\r
-;\r
-\r
-: (.") ( -- , type following string )\r
- r> count 2dup + aligned >r type\r
-;\r
-\r
-: ", ( adr len -- , place string into dictionary )\r
- tuck 'word place 1+ allot align\r
-;\r
-: ," ( -- )\r
- [char] " parse ",\r
-;\r
-\r
-: .( ( <string> -- , type string delimited by parentheses )\r
- [CHAR] ) PARSE TYPE\r
-; IMMEDIATE\r
-\r
-: ." ( <string> -- , type string )\r
- state @\r
- IF compile (.") ,"\r
- ELSE [char] " parse type\r
- THEN\r
-; immediate\r
-\r
-\r
-: .' ( <string> -- , type string delimited by single quote )\r
- state @\r
- IF compile (.") [char] ' parse ",\r
- ELSE [char] ' parse type\r
- THEN\r
-; immediate\r
-\r
-: C" ( <string> -- addr , return string address, ANSI )\r
- state @\r
- IF compile (c") ,"\r
- ELSE [char] " parse pad place pad\r
- THEN\r
-; immediate\r
-\r
-: S" ( <string> -- , -- addr , return string address, ANSI )\r
- state @\r
- IF compile (s") ,"\r
- ELSE [char] " parse pad place pad count\r
- THEN\r
-; immediate\r
-\r
-: " ( <string> -- , -- addr , return string address )\r
- [compile] C"\r
-; immediate\r
-: P" ( <string> -- , -- addr , return string address )\r
- [compile] C"\r
-; immediate\r
-\r
-: "" ( <string> -- addr )\r
- state @\r
- IF \r
- compile (C")\r
- bl parse-word ",\r
- ELSE\r
- bl parse-word pad place pad\r
- THEN\r
-; immediate\r
-\r
-: SLITERAL ( addr cnt -- , compile string )\r
- compile (S")\r
- ",\r
-; IMMEDIATE\r
-\r
-: $APPEND ( addr count $1 -- , append text to $1 )\r
- over >r\r
- dup >r\r
- count + ( -- a2 c2 end1 )\r
- swap cmove\r
- r> dup c@ ( a1 c1 )\r
- r> + ( -- a1 totalcount )\r
- swap c!\r
-;\r
-\r
-\r
-\ ANSI word to replace [COMPILE] and COMPILE ----------------\r
-: POSTPONE ( <name> -- )\r
- bl word find\r
- dup 0=\r
- IF\r
- ." Postpone could not find " count type cr abort\r
- ELSE\r
- 0>\r
- IF compile, \ immediate\r
- ELSE (compile) \ normal\r
- THEN\r
- THEN\r
-; immediate\r
-\r
-\ -----------------------------------------------------------------\r
-\ Auto Initialization\r
-: AUTO.INIT ( -- )\r
-\ Kernel finds AUTO.INIT and executes it after loading dictionary.\r
-\ ." Begin AUTO.INIT ------" cr\r
-;\r
-: AUTO.TERM ( -- )\r
-\ Kernel finds AUTO.TERM and executes it on bye.\r
-\ ." End AUTO.TERM ------" cr\r
-;\r
-\r
-\ -------------- INCLUDE ------------------------------------------\r
-variable TRACE-INCLUDE\r
-\r
-: INCLUDE.MARK.START ( $filename -- , mark start of include for FILE?)\r
- " ::::" pad $MOVE\r
- count pad $APPEND\r
- pad ['] noop (:)\r
-;\r
-\r
-: INCLUDE.MARK.END ( -- , mark end of include )\r
- " ;;;;" ['] noop (:)\r
-;\r
-\r
-: $INCLUDE ( $filename -- )\r
-\ Print messages.\r
- trace-include @\r
- IF\r
- >newline ." Include " dup count type cr\r
- THEN\r
- here >r\r
- dup\r
- count r/o open-file \r
- IF ( -- $filename bad-fid )\r
- drop ." Could not find file " $type cr abort\r
- ELSE ( -- $filename good-fid )\r
- swap include.mark.start\r
- dup >r \ save fid for close-file\r
- depth >r\r
- include-file\r
- depth 1+ r> -\r
- IF\r
- ." Warning: stack depth changed during include!" cr\r
- .s cr\r
- 0sp\r
- THEN\r
- r> close-file drop\r
- include.mark.end\r
- THEN\r
- trace-include @\r
- IF\r
- ." include added " here r@ - . ." bytes,"\r
- codelimit here - . ." left." cr\r
- THEN\r
- rdrop\r
-;\r
-\r
-create INCLUDE-SAVE-NAME 128 allot\r
-: INCLUDE ( <fname> -- )\r
- BL lword\r
- dup include-save-name $move \ save for RI\r
- $include\r
-;\r
-\r
-: RI ( -- , ReInclude previous file as a convenience )\r
- include-save-name $include\r
-;\r
-\r
-: INCLUDE? ( <word> <file> -- , load file if word not defined )\r
- bl word find\r
- IF drop bl word drop ( eat word from source )\r
- ELSE drop include\r
- THEN\r
-;\r
-\r
-\ desired sizes for dictionary loaded after SAVE-FORTH\r
-variable HEADERS-SIZE \r
-variable CODE-SIZE\r
-\r
-: AUTO.INIT\r
- auto.init\r
- codelimit codebase - code-size !\r
- namelimit namebase - headers-size !\r
-;\r
-auto.init\r
-\r
-: SAVE-FORTH ( $name -- )\r
- 0 \ Entry point\r
- headers-ptr @ namebase - 65536 + \ NameSize\r
- headers-size @ MAX\r
- here codebase - 131072 + \ CodeSize\r
- code-size @ MAX\r
- (save-forth)\r
- IF\r
- ." SAVE-FORTH failed!" cr abort\r
- THEN\r
-;\r
-\r
-: TURNKEY ( $name entry-token-- )\r
- 0 \ NameSize = 0, names not saved in turnkey dictionary\r
- here codebase - 131072 + \ CodeSize, remember that base is HEX\r
- (save-forth)\r
- IF\r
- ." TURNKEY failed!" cr abort\r
- THEN\r
-;\r
-\r
-\ Now that we can load from files, load remainder of dictionary.\r
-\r
-trace-include on\r
-trace-stack on\r
-\r
-include loadp4th.fth\r
-\r
-decimal\r
-\r
-: ;;;; ; \ Mark end of this file so FILE? can find things in here.\r
-FREEZE \ prevent forgetting below this point\r
-\r
-.( Dictionary compiled, save in "pforth.dic".) cr\r
-c" pforth.dic" save-forth\r
-\r
-\ Save the dictionary in "pfdicdat.h" file so pForth can be compiled for standalone mode.\r
-SDAD\r
+
+: CHAR+ ( n -- n+size_of_char ) 1+ ;
+: CHARS ( n -- n*size_of_char , don't do anything) ; immediate
+
+\ useful stack manipulation words
+: -ROT ( a b c -- c a b )
+ rot rot
+;
+: 3DUP ( a b c -- a b c a b c )
+ 2 pick 2 pick 2 pick
+;
+: 2DROP ( a b -- )
+ drop drop
+;
+: NIP ( a b -- b )
+ swap drop
+;
+: TUCK ( a b -- b a b )
+ swap over
+;
+
+: <= ( a b -- f , true if A <= b )
+ > 0=
+;
+: >= ( a b -- f , true if A >= b )
+ < 0=
+;
+
+: INVERT ( n -- 1'comp )
+ -1 xor
+;
+
+: NOT ( n -- !n , logical negation )
+ 0=
+;
+
+: NEGATE ( n -- -n )
+ 0 swap -
+;
+
+: DNEGATE ( d -- -d , negate by doing 0-d )
+ 0 0 2swap d-
+;
+
+
+\ --------------------------------------------------------------------
+
+: ID. ( nfa -- )
+ count 31 and type
+;
+
+: DECIMAL 10 base ! ;
+: OCTAL 8 base ! ;
+: HEX 16 base ! ;
+: BINARY 2 base ! ;
+
+: PAD ( -- addr )
+ here 128 +
+;
+
+: $MOVE ( $src $dst -- )
+ over c@ 1+ cmove
+;
+: BETWEEN ( n lo hi -- flag , true if between lo & hi )
+ >r over r> > >r
+ < r> or 0=
+;
+: [ ( -- , enter interpreter mode )
+ 0 state !
+; immediate
+: ] ( -- enter compile mode )
+ 1 state !
+;
+
+: EVEN-UP ( n -- n | n+1 , make even ) dup 1 and + ;
+: ALIGNED ( addr -- a-addr )
+ [ cell 1- ] literal +
+ [ cell 1- invert ] literal and
+;
+: ALIGN ( -- , align DP ) dp @ aligned dp ! ;
+: ALLOT ( nbytes -- , allot space in dictionary ) dp +! ( align ) ;
+
+: C, ( c -- ) here c! 1 chars dp +! ;
+: W, ( w -- ) dp @ even-up dup dp ! w! 2 chars dp +! ;
+: , ( n -- , lay into dictionary ) align here ! cell allot ;
+
+\ Dictionary conversions ------------------------------------------
+
+: N>NEXTLINK ( nfa -- nextlink , traverses name field )
+ dup c@ 31 and 1+ + aligned
+;
+
+: NAMEBASE ( -- base-of-names )
+ Headers-Base @
+;
+: CODEBASE ( -- base-of-code dictionary )
+ Code-Base @
+;
+
+: NAMELIMIT ( -- limit-of-names )
+ Headers-limit @
+;
+: CODELIMIT ( -- limit-of-code, last address in dictionary )
+ Code-limit @
+;
+
+: NAMEBASE+ ( rnfa -- nfa , convert relocatable nfa to actual )
+ namebase +
+;
+
+: >CODE ( xt -- secondary_code_address, not valid for primitives )
+ codebase +
+;
+
+: CODE> ( secondary_code_address -- xt , not valid for primitives )
+ codebase -
+;
+
+: N>LINK ( nfa -- lfa )
+ 2 CELLS -
+;
+
+: >BODY ( xt -- pfa )
+ >code body_offset +
+;
+
+: BODY> ( pfa -- xt )
+ body_offset - code>
+;
+
+\ convert between addresses useable by @, and relocatable addresses.
+: USE->REL ( useable_addr -- rel_addr )
+ codebase -
+;
+: REL->USE ( rel_addr -- useable_addr )
+ codebase +
+;
+
+\ for JForth code
+\ : >REL ( adr -- adr ) ; immediate
+\ : >ABS ( adr -- adr ) ; immediate
+
+: X@ ( addr -- xt , fetch execution token from relocatable ) @ ;
+: X! ( addr -- xt , store execution token as relocatable ) ! ;
+
+\ Compiler support ------------------------------------------------
+: COMPILE, ( xt -- , compile call to xt )
+ ,
+;
+
+( Compiler support , based on FIG )
+: [COMPILE] ( <name> -- , compile now even if immediate )
+ ' compile,
+; IMMEDIATE
+
+: (COMPILE) ( xt -- , postpone compilation of token )
+ [compile] literal ( compile a call to literal )
+ ( store xt of word to be compiled )
+
+ [ ' compile, ] literal \ compile call to compile,
+ compile,
+;
+
+: COMPILE ( <name> -- , save xt and compile later )
+ ' (compile)
+; IMMEDIATE
+
+
+: :NONAME ( -- xt , begin compilation of headerless secondary )
+ align
+ here code> \ convert here to execution token
+ ]
+;
+
+\ Error codes defined in ANSI Exception word set.
+: ERR_ABORT -1 ; \ general abort
+: ERR_ABORTQ -2 ; \ for abort"
+: ERR_EXECUTING -14 ; \ compile time word while not compiling
+: ERR_PAIRS -22 ; \ mismatch in conditional
+: ERR_DEFER -258 ; \ not a deferred word
+
+: ABORT ( i*x -- )
+ ERR_ABORT throw
+;
+
+\ Conditionals in '83 form -----------------------------------------
+: CONDITIONAL_KEY ( -- , lazy constant ) 29521 ;
+: ?CONDITION ( f -- ) conditional_key - err_pairs ?error ;
+: >MARK ( -- addr ) here 0 , ;
+: >RESOLVE ( addr -- ) here over - swap ! ;
+: <MARK ( -- addr ) here ;
+: <RESOLVE ( addr -- ) here - , ;
+
+: ?COMP ( -- , error if not compiling )
+ state @ 0= err_executing ?error
+;
+: ?PAIRS ( n m -- )
+ - err_pairs ?error
+;
+\ conditional primitives
+: IF ( -- f orig ) ?comp compile 0branch conditional_key >mark ; immediate
+: THEN ( f orig -- ) swap ?condition >resolve ; immediate
+: BEGIN ( -- f dest ) ?comp conditional_key <mark ; immediate
+: AGAIN ( f dest -- ) compile branch swap ?condition <resolve ; immediate
+: UNTIL ( f dest -- ) compile 0branch swap ?condition <resolve ; immediate
+: AHEAD ( -- f orig ) compile branch conditional_key >mark ; immediate
+
+\ conditionals built from primitives
+: ELSE ( f orig1 -- f orig2 )
+ [compile] AHEAD 2swap [compile] THEN ; immediate
+: WHILE ( f dest -- f orig f dest ) [compile] if 2swap ; immediate
+: REPEAT ( -- f orig f dest ) [compile] again [compile] then ; immediate
+
+: ['] ( <name> -- xt , define compile time tick )
+ ?comp ' [compile] literal
+; immediate
+
+\ for example:
+\ compile time: compile create , (does>) then ;
+\ execution time: create <name>, ',' data, then patch pi to point to @
+\ : con create , does> @ ;
+\ 345 con pi
+\ pi
+\
+: (DOES>) ( xt -- , modify previous definition to execute code at xt )
+ latest name> >code \ get address of code for new word
+ cell + \ offset to second cell in create word
+ ! \ store execution token of DOES> code in new word
+;
+
+: DOES> ( -- , define execution code for CREATE word )
+ 0 [compile] literal \ dummy literal to hold xt
+ here cell- \ address of zero in literal
+ compile (does>) \ call (DOES>) from new creation word
+ >r \ move addrz to return stack so ; doesn't see stack garbage
+ [compile] ; \ terminate part of code before does>
+ r>
+ :noname ( addrz xt )
+ swap ! \ save execution token in literal
+; immediate
+
+: VARIABLE ( <name> -- )
+ CREATE 0 , \ IMMEDIATE
+\ DOES> [compile] aliteral \ %Q This could be optimised
+;
+
+: 2VARIABLE ( <name> -c- ) ( -x- addr )
+ create 0 , 0 ,
+;
+
+: CONSTANT ( n <name> -c- ) ( -x- n )
+ CREATE , ( n -- )
+ DOES> @ ( -- n )
+;
+
+
+
+0 1- constant -1
+0 2- constant -2
+
+: 2! ( x1 x2 addr -- , store x2 followed by x1 )
+ swap over ! cell+ !
+;
+: 2@ ( addr -- x1 x2 )
+ dup cell+ @ swap @
+;
+
+
+: ABS ( n -- |n| )
+ dup 0<
+ IF negate
+ THEN
+;
+: DABS ( d -- |d| )
+ dup 0<
+ IF dnegate
+ THEN
+;
+
+: S>D ( s -- d , extend signed single precision to double )
+ dup 0<
+ IF -1
+ ELSE 0
+ THEN
+;
+
+: D>S ( d -- s ) drop ;
+
+: /MOD ( a b -- rem quo , unsigned version, FIXME )
+ >r s>d r> um/mod
+;
+
+: MOD ( a b -- rem )
+ /mod drop
+;
+
+: 2* ( n -- n*2 )
+ 1 lshift
+;
+: 2/ ( n -- n/2 )
+ 1 arshift
+;
+
+: D2* ( d -- d*2 )
+ 2* over
+ cell 8 * 1- rshift or swap
+ 2* swap
+;
+
+\ define some useful constants ------------------------------
+1 0= constant FALSE
+0 0= constant TRUE
+32 constant BL
+
+
+\ Store and Fetch relocatable data addresses. ---------------
+: IF.USE->REL ( use -- rel , preserve zero )
+ dup IF use->rel THEN
+;
+: IF.REL->USE ( rel -- use , preserve zero )
+ dup IF rel->use THEN
+;
+
+: A! ( dictionary_address addr -- )
+ >r if.use->rel r> !
+;
+: A@ ( addr -- dictionary_address )
+ @ if.rel->use
+;
+
+: A, ( dictionary_address -- )
+ if.use->rel ,
+;
+
+\ Stack data structure ----------------------------------------
+\ This is a general purpose stack utility used to implement necessary
+\ stacks for the compiler or the user. Not real fast.
+\ These stacks grow up which is different then normal.
+\ cell 0 - stack pointer, offset from pfa of word
+\ cell 1 - limit for range checking
+\ cell 2 - first data location
+
+: :STACK ( #cells -- )
+ CREATE 2 cells , ( offset of first data location )
+ dup , ( limit for range checking, not currently used )
+ cells cell+ allot ( allot an extra cell for safety )
+;
+
+: >STACK ( n stack -- , push onto stack, postincrement )
+ dup @ 2dup cell+ swap ! ( -- n stack offset )
+ + !
+;
+
+: STACK> ( stack -- n , pop , predecrement )
+ dup @ cell- 2dup swap !
+ + @
+;
+
+: STACK@ ( stack -- n , copy )
+ dup @ cell- + @
+;
+
+: STACK.PICK ( index stack -- n , grab Nth from top of stack )
+ dup @ cell- +
+ swap cells - \ offset for index
+ @
+;
+: STACKP ( stack -- ptr , to next empty location on stack )
+ dup @ +
+;
+
+: 0STACKP ( stack -- , clear stack)
+ 8 swap !
+;
+
+32 :stack ustack
+ustack 0stackp
+
+\ Define JForth like words.
+: >US ustack >stack ;
+: US> ustack stack> ;
+: US@ ustack stack@ ;
+: 0USP ustack 0stackp ;
+
+
+\ DO LOOP ------------------------------------------------
+
+3 constant do_flag
+4 constant leave_flag
+5 constant ?do_flag
+
+: DO ( -- , loop-back do_flag jump-from ?do_flag )
+ ?comp
+ compile (do)
+ here >us do_flag >us ( for backward branch )
+; immediate
+
+: ?DO ( -- , loop-back do_flag jump-from ?do_flag , on user stack )
+ ?comp
+ ( leave address to set for forward branch )
+ compile (?do)
+ here 0 ,
+ here >us do_flag >us ( for backward branch )
+ >us ( for forward branch ) ?do_flag >us
+; immediate
+
+: LEAVE ( -- addr leave_flag )
+ compile (leave)
+ here 0 , >us
+ leave_flag >us
+; immediate
+
+: LOOP-FORWARD ( -us- jump-from ?do_flag -- )
+ BEGIN
+ us@ leave_flag =
+ us@ ?do_flag =
+ OR
+ WHILE
+ us> leave_flag =
+ IF
+ us> here over - cell+ swap !
+ ELSE
+ us> dup
+ here swap -
+ cell+ swap !
+ THEN
+ REPEAT
+;
+
+: LOOP-BACK ( loop-addr do_flag -us- )
+ us> do_flag ?pairs
+ us> here - here
+ !
+ cell allot
+;
+
+: LOOP ( -- , loop-back do_flag jump-from ?do_flag )
+ compile (loop)
+ loop-forward loop-back
+; immediate
+
+\ : DOTEST 5 0 do 333 . loop 888 . ;
+\ : ?DOTEST0 0 0 ?do 333 . loop 888 . ;
+\ : ?DOTEST1 5 0 ?do 333 . loop 888 . ;
+
+: +LOOP ( -- , loop-back do_flag jump-from ?do_flag )
+ compile (+loop)
+ loop-forward loop-back
+; immediate
+
+: UNLOOP ( loop-sys -r- )
+ r> \ save return pointer
+ rdrop rdrop
+ >r
+;
+
+: RECURSE ( ? -- ? , call the word currently being defined )
+ latest name> compile,
+; immediate
+
+
+
+: SPACE bl emit ;
+: SPACES 512 min 0 max 0 ?DO space LOOP ;
+: 0SP depth 0 ?do drop loop ;
+
+: >NEWLINE ( -- , CR if needed )
+ out @ 0>
+ IF cr
+ THEN
+;
+
+
+\ Support for DEFER --------------------
+: CHECK.DEFER ( xt -- , error if not a deferred word by comparing to type )
+ >code @
+ ['] emit >code @
+ - err_defer ?error
+;
+
+: >is ( xt -- address_of_vector )
+ >code
+ cell +
+;
+
+: (IS) ( xt_do xt_deferred -- )
+ >is !
+;
+
+: IS ( xt <name> -- , act like normal IS )
+ ' \ xt
+ dup check.defer
+ state @
+ IF [compile] literal compile (is)
+ ELSE (is)
+ THEN
+; immediate
+
+: (WHAT'S) ( xt -- xt_do )
+ >is @
+;
+: WHAT'S ( <name> -- xt , what will deferred word call? )
+ ' \ xt
+ dup check.defer
+ state @
+ IF [compile] literal compile (what's)
+ ELSE (what's)
+ THEN
+; immediate
+
+: /STRING ( addr len n -- addr' len' )
+ over min rot over + -rot -
+;
+: PLACE ( addr len to -- , move string )
+ 3dup 1+ swap cmove c! drop
+;
+
+: PARSE-WORD ( char -- addr len )
+ >r source tuck >in @ /string r@ skip over swap r> scan
+ >r over - rot r> dup 0<> + - >in !
+;
+: PARSE ( char -- addr len )
+ >r source >in @ /string over swap r> scan
+ >r over - dup r> 0<> - >in +!
+;
+
+: LWORD ( char -- addr )
+ parse-word here place here \ 00002 , use PARSE-WORD
+;
+
+: ASCII ( <char> -- char , state smart )
+ bl parse drop c@
+ state @
+ IF [compile] literal
+ THEN
+; immediate
+
+: CHAR ( <char> -- char , interpret mode )
+ bl parse drop c@
+;
+
+: [CHAR] ( <char> -- char , for compile mode )
+ char [compile] literal
+; immediate
+
+: $TYPE ( $string -- )
+ count type
+;
+
+: 'word ( -- addr ) here ;
+
+: EVEN ( addr -- addr' ) dup 1 and + ;
+
+: (C") ( -- $addr , some Forths return addr AND count, OBSOLETE?)
+ r> dup count + aligned >r
+;
+: (S") ( -- c-addr cnt )
+ r> count 2dup + aligned >r
+;
+
+: (.") ( -- , type following string )
+ r> count 2dup + aligned >r type
+;
+
+: ", ( adr len -- , place string into dictionary )
+ tuck 'word place 1+ allot align
+;
+: ," ( -- )
+ [char] " parse ",
+;
+
+: .( ( <string> -- , type string delimited by parentheses )
+ [CHAR] ) PARSE TYPE
+; IMMEDIATE
+
+: ." ( <string> -- , type string )
+ state @
+ IF compile (.") ,"
+ ELSE [char] " parse type
+ THEN
+; immediate
+
+
+: .' ( <string> -- , type string delimited by single quote )
+ state @
+ IF compile (.") [char] ' parse ",
+ ELSE [char] ' parse type
+ THEN
+; immediate
+
+: C" ( <string> -- addr , return string address, ANSI )
+ state @
+ IF compile (c") ,"
+ ELSE [char] " parse pad place pad
+ THEN
+; immediate
+
+: S" ( <string> -- , -- addr , return string address, ANSI )
+ state @
+ IF compile (s") ,"
+ ELSE [char] " parse pad place pad count
+ THEN
+; immediate
+
+: " ( <string> -- , -- addr , return string address )
+ [compile] C"
+; immediate
+: P" ( <string> -- , -- addr , return string address )
+ [compile] C"
+; immediate
+
+: "" ( <string> -- addr )
+ state @
+ IF
+ compile (C")
+ bl parse-word ",
+ ELSE
+ bl parse-word pad place pad
+ THEN
+; immediate
+
+: SLITERAL ( addr cnt -- , compile string )
+ compile (S")
+ ",
+; IMMEDIATE
+
+: $APPEND ( addr count $1 -- , append text to $1 )
+ over >r
+ dup >r
+ count + ( -- a2 c2 end1 )
+ swap cmove
+ r> dup c@ ( a1 c1 )
+ r> + ( -- a1 totalcount )
+ swap c!
+;
+
+
+\ ANSI word to replace [COMPILE] and COMPILE ----------------
+: POSTPONE ( <name> -- )
+ bl word find
+ dup 0=
+ IF
+ ." Postpone could not find " count type cr abort
+ ELSE
+ 0>
+ IF compile, \ immediate
+ ELSE (compile) \ normal
+ THEN
+ THEN
+; immediate
+
+\ -----------------------------------------------------------------
+\ Auto Initialization
+: AUTO.INIT ( -- )
+\ Kernel finds AUTO.INIT and executes it after loading dictionary.
+\ ." Begin AUTO.INIT ------" cr
+;
+: AUTO.TERM ( -- )
+\ Kernel finds AUTO.TERM and executes it on bye.
+\ ." End AUTO.TERM ------" cr
+;
+
+\ -------------- INCLUDE ------------------------------------------
+variable TRACE-INCLUDE
+
+: INCLUDE.MARK.START ( c-addr u -- , mark start of include for FILE?)
+ " ::::" pad $MOVE
+ pad $APPEND
+ pad ['] noop (:)
+;
+
+: INCLUDE.MARK.END ( -- , mark end of include )
+ " ;;;;" ['] noop (:)
+;
+
+: INCLUDED ( c-addr u -- )
+ \ Print messages.
+ trace-include @
+ IF
+ >newline ." Include " 2dup type cr
+ THEN
+ here >r
+ 2dup r/o open-file
+ IF ( -- c-addr u bad-fid )
+ drop ." Could not find file " type cr abort
+ ELSE ( -- c-addr u good-fid )
+ -rot include.mark.start
+ depth >r
+ include-file \ will also close the file
+ depth 1+ r> -
+ IF
+ ." Warning: stack depth changed during include!" cr
+ .s cr
+ 0sp
+ THEN
+ include.mark.end
+ THEN
+ trace-include @
+ IF
+ ." include added " here r@ - . ." bytes,"
+ codelimit here - . ." left." cr
+ THEN
+ rdrop
+;
+
+: $INCLUDE ( $filename -- ) count included ;
+
+create INCLUDE-SAVE-NAME 128 allot
+: INCLUDE ( <fname> -- )
+ BL lword
+ dup include-save-name $move \ save for RI
+ $include
+;
+
+: RI ( -- , ReInclude previous file as a convenience )
+ include-save-name $include
+;
+
+: INCLUDE? ( <word> <file> -- , load file if word not defined )
+ bl word find
+ IF drop bl word drop ( eat word from source )
+ ELSE drop include
+ THEN
+;
+
+\ desired sizes for dictionary loaded after SAVE-FORTH
+variable HEADERS-SIZE
+variable CODE-SIZE
+
+: AUTO.INIT
+ auto.init
+ codelimit codebase - code-size !
+ namelimit namebase - headers-size !
+;
+auto.init
+
+: SAVE-FORTH ( $name -- )
+ 0 \ Entry point
+ headers-ptr @ namebase - 65536 + \ NameSize
+ headers-size @ MAX
+ here codebase - 131072 + \ CodeSize
+ code-size @ MAX
+ (save-forth)
+ IF
+ ." SAVE-FORTH failed!" cr abort
+ THEN
+;
+
+: TURNKEY ( $name entry-token-- )
+ 0 \ NameSize = 0, names not saved in turnkey dictionary
+ here codebase - 131072 + \ CodeSize, remember that base is HEX
+ (save-forth)
+ IF
+ ." TURNKEY failed!" cr abort
+ THEN
+;
+
+\ Now that we can load from files, load remainder of dictionary.
+
+trace-include on
+\ Turn this OFF if you do not want to see the contents of the stack after each entry.
+trace-stack off
+
+include loadp4th.fth
+
+decimal
+
+: ;;;; ; \ Mark end of this file so FILE? can find things in here.
+FREEZE \ prevent forgetting below this point
+
+.( Dictionary compiled, save in "pforth.dic".) cr
+c" pforth.dic" save-forth
projects / pforth / blobdiff