git.gag.com Git - debian/pforth/blob - system.fth

   1 : FIRST_COLON ;
   2
   3 : LATEST context @ ;
   4
   5 : FLAG_IMMEDIATE 64 ;
   6
   7 : IMMEDIATE
   8         latest dup c@ flag_immediate OR
   9         swap c!
  10 ;
  11
  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. )
  16
  17 : \ ( <line> -- , comment out rest of line )
  18         EOL word drop
  19 ; immediate
  20
  21 \ This is another style of comment that is common in Forth.
  22
  23 \ @(#) system.fth 98/01/26 1.4
  24 \ *********************************************************************
  25 \ pFORTH - Portable Forth System
  26 \ Based on HMSL Forth
  27 \
  28 \ Author: Phil Burk
  29 \ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom
  30 \
  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 \ *********************************************************************
  40
  41 : COUNT  dup 1+ swap c@ ;
  42
  43 \ Miscellaneous support words
  44 : ON ( addr -- , set true )
  45         -1 swap !
  46 ;
  47 : OFF ( addr -- , set false )
  48         0 swap !
  49 ;
  50
  51 \ size of data items
  52 \ FIXME - move these into 'C' code for portability ????
  53 : CELL ( -- size_of_stack_item ) 4 ;
  54
  55 : CELL+ ( n -- n+cell )  cell + ;
  56 : CELL- ( n -- n+cell )  cell - ;
  57 : CELLS ( n -- n*cell )  2 lshift ;
  58
  59 : CHAR+ ( n -- n+size_of_char ) 1+ ;
  60 : CHARS ( n -- n*size_of_char , don't do anything)  ; immediate
  61
  62 \ useful stack manipulation words
  63 : -ROT ( a b c -- c a b )
  64         rot rot
  65 ;
  66 : 3DUP ( a b c -- a b c a b c )
  67         2 pick 2 pick 2 pick
  68 ;
  69 : 2DROP ( a b -- )
  70         drop drop
  71 ;
  72 : NIP ( a b -- b )
  73         swap drop
  74 ;
  75 : TUCK ( a b -- b a b )
  76         swap over
  77 ;
  78
  79 : <= ( a b -- f , true if A <= b )
  80         > 0=
  81 ;
  82 : >= ( a b -- f , true if A >= b )
  83         < 0=
  84 ;
  85
  86 : INVERT ( n -- 1'comp )
  87     -1 xor
  88 ;
  89
  90 : NOT ( n -- !n , logical negation )
  91         0=
  92 ;
  93
  94 : NEGATE ( n -- -n )
  95         0 swap -
  96 ;
  97
  98 : DNEGATE ( d -- -d , negate by doing 0-d )
  99         0 0 2swap d-
 100 ;
 101
 102
 103 \ --------------------------------------------------------------------
 104
 105 : ID.   ( nfa -- )
 106     count 31 and type
 107 ;
 108
 109 : DECIMAL   10 base !  ;
 110 : OCTAL      8 base !  ;
 111 : HEX       16 base !  ;
 112 : BINARY     2 base !  ;
 113
 114 : PAD ( -- addr )
 115         here 128 +
 116 ;
 117
 118 : $MOVE ( $src $dst -- )
 119         over c@ 1+ cmove
 120 ;
 121 : BETWEEN ( n lo hi -- flag , true if between lo & hi )
 122         >r over r> > >r
 123         < r> or 0=
 124 ;
 125 : [ ( -- , enter interpreter mode )
 126         0 state !
 127 ; immediate
 128 : ] ( -- enter compile mode )
 129         1 state !
 130 ;
 131
 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
 136 ;
 137 : ALIGN ( -- , align DP )  dp @ aligned dp ! ;
 138 : ALLOT ( nbytes -- , allot space in dictionary ) dp +! ( align ) ;
 139
 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 ;
 143
 144 \ Dictionary conversions ------------------------------------------
 145
 146 : N>NEXTLINK  ( nfa -- nextlink , traverses name field )
 147         dup c@ 31 and 1+ + aligned
 148 ;
 149
 150 : NAMEBASE  ( -- base-of-names )
 151         Headers-Base @
 152 ;
 153 : CODEBASE  ( -- base-of-code dictionary )
 154         Code-Base @
 155 ;
 156
 157 : NAMELIMIT  ( -- limit-of-names )
 158         Headers-limit @
 159 ;
 160 : CODELIMIT  ( -- limit-of-code, last address in dictionary )
 161         Code-limit @
 162 ;
 163
 164 : NAMEBASE+   ( rnfa -- nfa , convert relocatable nfa to actual )
 165         namebase +
 166 ;
 167
 168 : >CODE ( xt -- secondary_code_address, not valid for primitives )
 169         codebase +
 170 ;
 171
 172 : CODE> ( secondary_code_address -- xt , not valid for primitives )
 173         codebase -
 174 ;
 175
 176 : N>LINK  ( nfa -- lfa )
 177         8 -
 178 ;
 179
 180 : >BODY   ( xt -- pfa )
 181     >code body_offset +
 182 ;
 183
 184 : BODY>   ( pfa -- xt )
 185     body_offset - code>
 186 ;
 187
 188 \ convert between addresses useable by @, and relocatable addresses.
 189 : USE->REL  ( useable_addr -- rel_addr )
 190         codebase -
 191 ;
 192 : REL->USE  ( rel_addr -- useable_addr )
 193         codebase +
 194 ;
 195
 196 \ for JForth code
 197 \ : >REL  ( adr -- adr )  ; immediate
 198 \ : >ABS  ( adr -- adr )  ; immediate
 199
 200 : X@ ( addr -- xt , fetch execution token from relocatable )   @ ;
 201 : X! ( addr -- xt , store execution token as relocatable )   ! ;
 202
 203 \ Compiler support ------------------------------------------------
 204 : COMPILE, ( xt -- , compile call to xt )
 205         ,
 206 ;
 207
 208 ( Compiler support , based on FIG )
 209 : [COMPILE]  ( <name> -- , compile now even if immediate )
 210     ' compile,
 211 ;  IMMEDIATE
 212
 213 : (COMPILE) ( xt -- , postpone compilation of token )
 214         [compile] literal       ( compile a call to literal )
 215         ( store xt of word to be compiled )
 216
 217         [ ' compile, ] literal   \ compile call to compile,
 218         compile,
 219 ;
 220
 221 : COMPILE  ( <name> -- , save xt and compile later )
 222     ' (compile)
 223 ; IMMEDIATE
 224
 225
 226 : :NONAME ( -- xt , begin compilation of headerless secondary )
 227         align
 228         here code>   \ convert here to execution token
 229         ]
 230 ;
 231
 232 \ Error codes
 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
 238 : ERR_UNDERFLOW   -6 ;
 239
 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 - ,  ;
 247
 248 : ?COMP  ( -- , error if not compiling )
 249         state @ 0= err_executing ?error
 250 ;
 251 : ?PAIRS ( n m -- )
 252         - err_pairs ?error
 253 ;
 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
 261
 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
 267
 268 : [']  ( <name> -- xt , define compile time tick )
 269         ?comp ' [compile] literal
 270 ; immediate
 271
 272 \ for example:
 273 \ compile time:  compile create , (does>) then ;
 274 \ execution time:  create <name>, ',' data, then patch pi to point to @
 275 \    : con create , does> @ ;
 276 \    345 con pi
 277 \    pi
 278 \
 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
 283 ;
 284
 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>
 290         :noname       ( addrz xt )
 291         swap !              \ save execution token in literal
 292 ; immediate
 293
 294 : VARIABLE  ( <name> -- )
 295     CREATE 0 , \ IMMEDIATE
 296 \       DOES> [compile] aliteral  \ %Q This could be optimised
 297 ;
 298
 299 : 2VARIABLE  ( <name> -c- ) ( -x- addr )
 300         create 0 , 0 ,
 301 ;
 302
 303 : CONSTANT  ( n <name> -c- ) ( -x- n )
 304         CREATE , ( n -- )
 305         DOES> @ ( -- n )
 306 ;\r
 307
 308 0 1- constant -1
 309 0 2- constant -2
 310
 311 : 2! ( x1 x2 addr -- , store x2 followed by x1 )
 312         swap over ! cell+ !
 313 ;
 314 : 2@ ( addr -- x1 x2 )
 315         dup cell+ @ swap @
 316 ;
 317
 318
 319 : ABS ( n -- |n| )
 320         dup 0<
 321         IF negate
 322         THEN
 323 ;
 324 : DABS ( d -- |d| )
 325         dup 0<
 326         IF dnegate
 327         THEN
 328 ;
 329
 330 : S>D  ( s -- d , extend signed single precision to double )
 331         dup 0<
 332         IF -1
 333         ELSE 0
 334         THEN
 335 ;
 336
 337 : D>S ( d -- s ) drop ;
 338
 339 : /MOD ( a b -- rem quo , unsigned version, FIXME )
 340         >r s>d r> um/mod
 341 ;
 342
 343 : MOD ( a b -- rem )
 344         /mod drop
 345 ;
 346
 347 : 2* ( n -- n*2 )
 348         1 lshift
 349 ;
 350 : 2/ ( n -- n/2 )
 351         1 arshift
 352 ;
 353
 354 : D2*  ( d -- d*2 )
 355         2* over 31 rshift or  swap
 356         2* swap
 357 ;
 358
 359 \ define some useful constants ------------------------------
 360 1 0= constant FALSE
 361 0 0= constant TRUE
 362 32 constant BL
 363
 364 \ Store and Fetch relocatable data addresses. ---------------
 365 : IF.USE->REL  ( use -- rel , preserve zero )
 366         dup IF use->rel THEN
 367 ;
 368 : IF.REL->USE  ( rel -- use , preserve zero )
 369         dup IF rel->use THEN
 370 ;
 371
 372 : A!  ( dictionary_address addr -- )
 373     >r if.use->rel r> !
 374 ;
 375 : A@  ( addr -- dictionary_address )
 376     @ if.rel->use
 377 ;
 378
 379 : A, ( dictionary_address -- )
 380     if.use->rel ,
 381 ;
 382
 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
 390
 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 )
 395 ;
 396
 397 : >STACK  ( n stack -- , push onto stack, postincrement )
 398         dup @ 2dup cell+ swap ! ( -- n stack offset )
 399         + !
 400 ;
 401
 402 : STACK>  ( stack -- n , pop , predecrement )
 403         dup @ cell- 2dup swap !
 404         + @
 405 ;
 406
 407 : STACK@ ( stack -- n , copy )
 408         dup @ cell- + @
 409 ;
 410
 411 : STACK.PICK ( index stack -- n , grab Nth from top of stack )
 412         dup @ cell- +
 413         swap cells -   \ offset for index
 414         @
 415 ;
 416 : STACKP ( stack -- ptr , to next empty location on stack )
 417         dup @ +
 418 ;
 419
 420 : 0STACKP  ( stack -- , clear stack)
 421     8 swap !
 422 ;
 423
 424 32 :stack ustack
 425 ustack 0stackp
 426
 427 \ Define JForth like words.
 428 : >US ustack >stack ;
 429 : US> ustack stack> ;
 430 : US@ ustack stack@ ;
 431 : 0USP ustack 0stackp ;
 432
 433
 434 \ DO LOOP ------------------------------------------------
 435
 436 3 constant do_flag
 437 4 constant leave_flag
 438 5 constant ?do_flag
 439
 440 : DO    ( -- , loop-back do_flag jump-from ?do_flag )
 441         ?comp
 442         compile  (do)
 443         here >us do_flag  >us  ( for backward branch )
 444 ; immediate
 445
 446 : ?DO    ( -- , loop-back do_flag jump-from ?do_flag  , on user stack )
 447         ?comp
 448         ( leave address to set for forward branch )
 449         compile  (?do)
 450         here 0 ,
 451         here >us do_flag  >us  ( for backward branch )
 452         >us ( for forward branch ) ?do_flag >us
 453 ; immediate
 454
 455 : LEAVE  ( -- addr leave_flag )
 456         compile (leave)
 457         here 0 , >us
 458         leave_flag >us
 459 ; immediate
 460
 461 : LOOP-FORWARD  ( -us- jump-from ?do_flag -- )
 462         BEGIN
 463                 us@ leave_flag =
 464                 us@ ?do_flag =
 465                 OR
 466         WHILE
 467                 us> leave_flag =
 468                 IF
 469                         us> here over - cell+ swap !
 470                 ELSE
 471                         us> dup
 472                         here swap -
 473                         cell+ swap !
 474                 THEN
 475         REPEAT
 476 ;
 477
 478 : LOOP-BACK  (  loop-addr do_flag -us- )
 479         us> do_flag ?pairs
 480         us> here -  here
 481         !
 482         cell allot
 483 ;
 484
 485 : LOOP    ( -- , loop-back do_flag jump-from ?do_flag )
 486    compile  (loop)
 487    loop-forward loop-back
 488 ; immediate
 489
 490 \ : DOTEST 5 0 do 333 . loop 888 . ;
 491 \ : ?DOTEST0 0 0 ?do 333 . loop 888 . ;
 492 \ : ?DOTEST1 5 0 ?do 333 . loop 888 . ;
 493
 494 : +LOOP    ( -- , loop-back do_flag jump-from ?do_flag )
 495    compile  (+loop)
 496    loop-forward loop-back
 497 ; immediate
 498
 499 : UNLOOP ( loop-sys -r- )
 500         r> \ save return pointer
 501         rdrop rdrop
 502         >r
 503 ;
 504
 505 : RECURSE ( ? -- ? , call the word currently being defined )
 506         latest  name> compile,
 507 ; immediate\r
 508
 509 : SPACE  bl emit ;
 510 : SPACES  512 min 0 max 0 ?DO space LOOP ;
 511 : 0SP depth 0 ?do drop loop ;
 512
 513 : >NEWLINE ( -- , CR if needed )
 514         out @ 0>
 515         IF cr
 516         THEN
 517 ;
 518
 519
 520 \ Support for DEFER --------------------
 521 : CHECK.DEFER  ( xt -- , error if not a deferred word by comparing to type )
 522     >code @
 523         ['] emit >code @
 524         - err_defer ?error
 525 ;
 526
 527 : >is ( xt -- address_of_vector )
 528         >code
 529         cell +
 530 ;
 531
 532 : (IS)  ( xt_do xt_deferred -- )
 533         >is !
 534 ;
 535
 536 : IS  ( xt <name> -- , act like normal IS )
 537         '  \ xt
 538         dup check.defer
 539         state @
 540         IF [compile] literal compile (is)
 541         ELSE (is)
 542         THEN
 543 ; immediate
 544
 545 : (WHAT'S)  ( xt -- xt_do )
 546         >is @
 547 ;
 548 : WHAT'S  ( <name> -- xt , what will deferred word call? )
 549         '  \ xt
 550         dup check.defer
 551         state @
 552         IF [compile] literal compile (what's)
 553         ELSE (what's)
 554         THEN
 555 ; immediate
 556
 557 defer ABORT  \ will default to QUIT
 558
 559 : /STRING   ( addr len n -- addr' len' )
 560    over min  rot over   +  -rot  -
 561 ;
 562 : PLACE   ( addr len to -- , move string )
 563    3dup  1+  swap cmove  c! drop
 564 ;
 565
 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 !
 569 ;
 570 : PARSE   ( char -- addr len )
 571    >r  source >in @  /string  over swap  r> scan
 572    >r  over -  dup r> 0<>  -  >in +!
 573 ;
 574
 575 : LWORD  ( char -- addr )
 576         parse-word here place here \ 00002 , use PARSE-WORD
 577 ;
 578
 579 : ASCII ( <char> -- char , state smart )
 580         bl parse drop c@
 581         state @
 582         IF [compile] literal
 583         THEN
 584 ; immediate
 585
 586 : CHAR ( <char> -- char , interpret mode )
 587         bl parse drop c@
 588 ;
 589
 590 : [CHAR] ( <char> -- char , for compile mode )
 591         char [compile] literal
 592 ; immediate
 593
 594 : $TYPE  ( $string -- )
 595         count type
 596 ;
 597
 598 : 'word   ( -- addr )   here ;
 599
 600 : EVEN    ( addr -- addr' )   dup 1 and +  ;
 601
 602 : (C")   ( -- $addr , some Forths return addr AND count, OBSOLETE?)
 603         r> dup count + aligned >r
 604 ;
 605 : (S")   ( -- c-addr cnt )
 606         r> count 2dup + aligned >r
 607 ;
 608
 609 : (.")  ( -- , type following string )
 610         r> count 2dup + aligned >r type
 611 ;
 612
 613 : ",  ( adr len -- , place string into dictionary )
 614          tuck 'word place 1+ allot align
 615 ;
 616 : ,"   ( -- )
 617    [char] " parse ",
 618 ;
 619
 620 : .(  ( <string> -- , type string delimited by parentheses )
 621         [CHAR] ) PARSE TYPE
 622 ; IMMEDIATE
 623
 624 : ."   ( <string> -- , type string )
 625         state @
 626         IF      compile (.")  ,"
 627         ELSE [char] " parse type
 628         THEN
 629 ; immediate
 630
 631
 632 : .'   ( <string> -- , type string delimited by single quote )
 633         state @
 634         IF    compile (.")  [char] ' parse ",
 635         ELSE [char] ' parse type
 636         THEN
 637 ; immediate
 638
 639 : C"    ( <string> -- addr , return string address, ANSI )
 640         state @
 641         IF compile (c")   ,"
 642         ELSE [char] " parse pad place pad
 643         THEN
 644 ; immediate
 645
 646 : S"    ( <string> -- , -- addr , return string address, ANSI )
 647         state @
 648         IF compile (s")   ,"
 649         ELSE [char] " parse pad place pad count
 650         THEN
 651 ; immediate
 652
 653 : "    ( <string> -- , -- addr , return string address )
 654         [compile] C"
 655 ; immediate
 656 : P"    ( <string> -- , -- addr , return string address )
 657         [compile] C"
 658 ; immediate
 659
 660 : ""  ( <string> -- addr )
 661         state @
 662         IF
 663                 compile (C")
 664                 bl parse-word  ",
 665         ELSE
 666                 bl parse-word pad place pad
 667         THEN
 668 ; immediate
 669
 670 : SLITERAL ( addr cnt -- , compile string )
 671         compile (S")
 672         ",
 673 ; IMMEDIATE
 674
 675 : $APPEND ( addr count $1 -- , append text to $1 )
 676     over >r
 677         dup >r
 678     count +  ( -- a2 c2 end1 )
 679     swap cmove
 680     r> dup c@  ( a1 c1 )
 681     r> + ( -- a1 totalcount )
 682     swap c!
 683 ;
 684
 685 \ -----------------------------------------------------------------
 686 \ Auto Initialization
 687 : AUTO.INIT  ( -- )
 688 \ Kernel finds AUTO.INIT and executes it after loading dictionary.
 689         ." Begin AUTO.INIT ------" cr
 690 ;
 691 : AUTO.TERM  ( -- )
 692 \ Kernel finds AUTO.TERM and executes it on bye.
 693         ." End AUTO.TERM ------" cr
 694 ;
 695
 696 \ -------------- INCLUDE ------------------------------------------
 697 variable TRACE-INCLUDE
 698
 699 : INCLUDE.MARK.START  ( $filename -- , mark start of include for FILE?)
 700         " ::::"  pad $MOVE
 701         count pad $APPEND
 702         pad ['] noop (:)
 703 ;
 704
 705 : INCLUDE.MARK.END  ( -- , mark end of include )
 706         " ;;;;" ['] noop (:)
 707 ;
 708
 709 : $INCLUDE ( $filename -- )
 710 \ Print messages.
 711         trace-include @
 712         IF
 713                 >newline ." Include " dup count type cr
 714         THEN
 715         here >r
 716         dup
 717         count r/o open-file
 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
 723                 depth >r
 724                 include-file
 725                 depth 1+ r> -
 726                 IF
 727                         ." Warning: stack depth changed during include!" cr
 728                         .s cr
 729                         0sp
 730                 THEN
 731                 r> close-file drop
 732                 include.mark.end
 733         THEN
 734         trace-include @
 735         IF
 736                 ."     include added " here r@ - . ." bytes,"
 737                 codelimit here - . ." left." cr
 738         THEN
 739         rdrop
 740 ;
 741
 742 create INCLUDE-SAVE-NAME 128 allot
 743 : INCLUDE ( <fname> -- )
 744         BL lword
 745         dup include-save-name $move  \ save for RI
 746         $include
 747 ;
 748
 749 : RI ( -- , ReInclude previous file as a convenience )
 750         include-save-name $include
 751 ;
 752
 753 : INCLUDE? ( <word> <file> -- , load file if word not defined )
 754         bl word find
 755         IF drop bl word drop  ( eat word from source )
 756         ELSE drop include
 757         THEN
 758 ;
 759
 760 \ desired sizes for dictionary loaded after SAVE-FORTH
 761 variable HEADERS-SIZE
 762 variable CODE-SIZE
 763
 764 : AUTO.INIT
 765         auto.init
 766         codelimit codebase - code-size !
 767         namelimit namebase - headers-size !
 768 ;
 769 auto.init
 770
 771 : SAVE-FORTH ( $name -- )
 772         0                                    \ Entry point
 773         headers-ptr @ namebase - 65536 +     \ NameSize
 774         headers-size @ MAX
 775         here codebase - 131072 +              \ CodeSize
 776         code-size @ MAX
 777         (save-forth)
 778         IF
 779                 ." SAVE-FORTH failed!" cr abort
 780         THEN
 781 ;
 782
 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
 786         (save-forth)
 787         IF
 788                 ." TURNKEY failed!" cr abort
 789         THEN
 790 ;
 791
 792 \ load remainder of dictionary
 793
 794 trace-include on
 795 trace-stack on
 796
 797 include loadp4th.fth
 798
 799 decimal
 800
 801 : ;;;; ;  \ Mark end of this file so FILE? can find things in here.
 802 FREEZE    \ prevent forgetting below this point
 803
 804 .( Dictionary compiled, save in "pforth.dic".) cr
 805 c" pforth.dic" save-forth