Initial import.

[pforth] / fth / system.fth

: FIRST_COLON ;\r
\r
: LATEST context @ ;\r
\r
: FLAG_IMMEDIATE 64 ;\r
\r
: IMMEDIATE\r
        latest dup c@ flag_immediate OR\r
        swap c!\r
;\r
\r
: (   41 word drop ; immediate\r
( That was the definition for the comment word. )\r
( Now we can add comments to what we are doing! )\r
( Note that we are in decimal numeric input mode. )\r
\r
: \ ( <line> -- , comment out rest of line )\r
        EOL word drop\r
; immediate\r
\r
\ *********************************************************************\r
\ This is another style of comment that is common in Forth.\r
\ pFORTH - Portable Forth System\r
\ Based on HMSL Forth\r
\\r
\ Author: Phil Burk\r
\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom\r
\\r
\ The pForth software code is dedicated to the public domain,\r
\ and any third party may reproduce, distribute and modify\r
\ the pForth software code or any derivative works thereof\r
\ without any compensation or license.  The pForth software\r
\ code is provided on an "as is" basis without any warranty\r
\ of any kind, including, without limitation, the implied\r
\ warranties of merchantability and fitness for a particular\r
\ purpose and their equivalents under the laws of any jurisdiction.\r
\ *********************************************************************\r
\r
: COUNT  dup 1+ swap c@ ;\r
\r
\ Miscellaneous support words\r
: ON ( addr -- , set true )\r
        -1 swap !\r
;\r
: OFF ( addr -- , set false )\r
        0 swap !\r
;\r
\r
\ size of data items\r
\ FIXME - move these into 'C' code for portability ????\r
: CELL ( -- size_of_stack_item ) 4 ;\r
\r
: CELL+ ( n -- n+cell )  cell + ;\r
: CELL- ( n -- n+cell )  cell - ;\r
: CELLS ( n -- n*cell )  2 lshift ;\r
\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
        8 -\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 31 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
\ 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
SDAD\r