git.gag.com Git - debian/pforth/blob - fth/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 \ 1 echo !  \ Uncomment this line to echo Forth code while compiling.
  22
  23 \ *********************************************************************
  24 \ This is another style of comment that is common in Forth.
  25 \ pFORTH - Portable Forth System
  26 \ Based on HMSL Forth
  27 \
  28 \ Author: Phil Burk
  29 \ Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
  30 \
  31 \ Permission to use, copy, modify, and/or distribute this
  32 \ software for any purpose with or without fee is hereby granted.
  33 \
  34 \ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
  35 \ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
  36 \ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL
  37 \ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
  38 \ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING
  39 \ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF
  40 \ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
  41 \ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  42 \ *********************************************************************
  43
  44 : COUNT  dup 1+ swap c@ ;
  45
  46 \ Miscellaneous support words
  47 : ON ( addr -- , set true )
  48         -1 swap !
  49 ;
  50 : OFF ( addr -- , set false )
  51         0 swap !
  52 ;
  53
  54 : CELL+ ( n -- n+cell )  cell + ;
  55 : CELL- ( n -- n+cell )  cell - ;
  56 : CELL* ( n -- n*cell )  cells ;
  57
  58 : CHAR+ ( n -- n+size_of_char ) 1+ ;
  59 : CHARS ( n -- n*size_of_char , don't do anything)  ; immediate
  60
  61 \ useful stack manipulation words
  62 : -ROT ( a b c -- c a b )
  63         rot rot
  64 ;
  65 : 3DUP ( a b c -- a b c a b c )
  66         2 pick 2 pick 2 pick
  67 ;
  68 : 2DROP ( a b -- )
  69         drop drop
  70 ;
  71 : NIP ( a b -- b )
  72         swap drop
  73 ;
  74 : TUCK ( a b -- b a b )
  75         swap over
  76 ;
  77
  78 : <= ( a b -- f , true if A <= b )
  79         > 0=
  80 ;
  81 : >= ( a b -- f , true if A >= b )
  82         < 0=
  83 ;
  84
  85 : INVERT ( n -- 1'comp )
  86     -1 xor
  87 ;
  88
  89 : NOT ( n -- !n , logical negation )
  90         0=
  91 ;
  92
  93 : NEGATE ( n -- -n )
  94         0 swap -
  95 ;
  96
  97 : DNEGATE ( d -- -d , negate by doing 0-d )
  98         0 0 2swap d-
  99 ;
 100
 101
 102 \ --------------------------------------------------------------------
 103
 104 : ID.   ( nfa -- )
 105     count 31 and type
 106 ;
 107
 108 : DECIMAL   10 base !  ;
 109 : OCTAL      8 base !  ;
 110 : HEX       16 base !  ;
 111 : BINARY     2 base !  ;
 112
 113 : PAD ( -- addr )
 114         here 128 +
 115 ;
 116
 117 : $MOVE ( $src $dst -- )
 118         over c@ 1+ cmove
 119 ;
 120 : BETWEEN ( n lo hi -- flag , true if between lo & hi )
 121         >r over r> > >r
 122         < r> or 0=
 123 ;
 124 : [ ( -- , enter interpreter mode )
 125         0 state !
 126 ; immediate
 127 : ] ( -- enter compile mode )
 128         1 state !
 129 ;
 130
 131 : EVEN-UP  ( n -- n | n+1 , make even )  dup 1 and +  ;
 132 : ALIGNED  ( addr -- a-addr )
 133         [ cell 1- ] literal +
 134         [ cell 1- invert ] literal and
 135 ;
 136 : ALIGN ( -- , align DP )  dp @ aligned dp ! ;
 137 : ALLOT ( nbytes -- , allot space in dictionary ) dp +! ( align ) ;
 138
 139 : C,    ( c -- )  here c! 1 chars dp +! ;
 140 : W,    ( w -- )  dp @ even-up dup dp !    w!  2 chars dp +! ;
 141 : , ( n -- , lay into dictionary )  align here !  cell allot ;
 142
 143 \ Dictionary conversions ------------------------------------------
 144
 145 : N>NEXTLINK  ( nfa -- nextlink , traverses name field )
 146         dup c@ 31 and 1+ + aligned
 147 ;
 148
 149 : NAMEBASE  ( -- base-of-names )
 150         Headers-Base @
 151 ;
 152 : CODEBASE  ( -- base-of-code dictionary )
 153         Code-Base @
 154 ;
 155
 156 : NAMELIMIT  ( -- limit-of-names )
 157         Headers-limit @
 158 ;
 159 : CODELIMIT  ( -- limit-of-code, last address in dictionary )
 160         Code-limit @
 161 ;
 162
 163 : NAMEBASE+   ( rnfa -- nfa , convert relocatable nfa to actual )
 164         namebase +
 165 ;
 166
 167 : >CODE ( xt -- secondary_code_address, not valid for primitives )
 168         codebase +
 169 ;
 170
 171 : CODE> ( secondary_code_address -- xt , not valid for primitives )
 172         codebase -
 173 ;
 174
 175 : N>LINK  ( nfa -- lfa )
 176         2 CELLS -
 177 ;
 178
 179 : >BODY   ( xt -- pfa )
 180     >code body_offset +
 181 ;
 182
 183 : BODY>   ( pfa -- xt )
 184     body_offset - code>
 185 ;
 186
 187 \ convert between addresses useable by @, and relocatable addresses.
 188 : USE->REL  ( useable_addr -- rel_addr )
 189         codebase -
 190 ;
 191 : REL->USE  ( rel_addr -- useable_addr )
 192         codebase +
 193 ;
 194
 195 \ for JForth code
 196 \ : >REL  ( adr -- adr )  ; immediate
 197 \ : >ABS  ( adr -- adr )  ; immediate
 198
 199 : X@ ( addr -- xt , fetch execution token from relocatable )   @ ;
 200 : X! ( addr -- xt , store execution token as relocatable )   ! ;
 201
 202 \ Compiler support ------------------------------------------------
 203 : COMPILE, ( xt -- , compile call to xt )
 204         ,
 205 ;
 206
 207 ( Compiler support , based on FIG )
 208 : [COMPILE]  ( <name> -- , compile now even if immediate )
 209     ' compile,
 210 ;  IMMEDIATE
 211
 212 : (COMPILE) ( xt -- , postpone compilation of token )
 213         [compile] literal       ( compile a call to literal )
 214         ( store xt of word to be compiled )
 215
 216         [ ' compile, ] literal   \ compile call to compile,
 217         compile,
 218 ;
 219
 220 : COMPILE  ( <name> -- , save xt and compile later )
 221     ' (compile)
 222 ; IMMEDIATE
 223
 224
 225 : :NONAME ( -- xt , begin compilation of headerless secondary )
 226         align
 227         here code>   \ convert here to execution token
 228         ]
 229 ;
 230
 231 \ Error codes defined in ANSI Exception word set.
 232 : ERR_ABORT         -1 ;   \ general abort
 233 : ERR_ABORTQ        -2 ;   \ for abort"
 234 : ERR_EXECUTING    -14 ;   \ compile time word while not compiling
 235 : ERR_PAIRS        -22 ;   \ mismatch in conditional
 236 : ERR_DEFER       -258 ;  \ not a deferred word
 237
 238 : ABORT ( i*x -- )
 239     ERR_ABORT throw
 240 ;
 241
 242 \ Conditionals in '83 form -----------------------------------------
 243 : CONDITIONAL_KEY ( -- , lazy constant ) 29521 ;
 244 : ?CONDITION   ( f -- )  conditional_key - err_pairs ?error ;
 245 : >MARK      ( -- addr )   here 0 ,  ;
 246 : >RESOLVE   ( addr -- )   here over - swap !  ;
 247 : <MARK      ( -- addr )   here  ;
 248 : <RESOLVE   ( addr -- )   here - ,  ;
 249
 250 : ?COMP  ( -- , error if not compiling )
 251         state @ 0= err_executing ?error
 252 ;
 253 : ?PAIRS ( n m -- )
 254         - err_pairs ?error
 255 ;
 256 \ conditional primitives
 257 : IF     ( -- f orig )  ?comp compile 0branch  conditional_key >mark     ; immediate
 258 : THEN   ( f orig -- )  swap ?condition  >resolve   ; immediate
 259 : BEGIN  ( -- f dest )  ?comp conditional_key <mark   ; immediate
 260 : AGAIN  ( f dest -- )  compile branch  swap ?condition  <resolve  ; immediate
 261 : UNTIL  ( f dest -- )  compile 0branch swap ?condition  <resolve  ; immediate
 262 : AHEAD  ( -- f orig )  compile branch   conditional_key >mark     ; immediate
 263
 264 \ conditionals built from primitives
 265 : ELSE   ( f orig1 -- f orig2 )
 266     [compile] AHEAD  2swap [compile] THEN  ; immediate
 267 : WHILE  ( f dest -- f orig f dest )  [compile]  if   2swap ; immediate
 268 : REPEAT ( -- f orig f dest ) [compile] again  [compile] then  ; immediate
 269
 270 : [']  ( <name> -- xt , define compile time tick )
 271         ?comp ' [compile] literal
 272 ; immediate
 273
 274 \ for example:
 275 \ compile time:  compile create , (does>) then ;
 276 \ execution time:  create <name>, ',' data, then patch pi to point to @
 277 \    : con create , does> @ ;
 278 \    345 con pi
 279 \    pi
 280 \
 281 : (DOES>)  ( xt -- , modify previous definition to execute code at xt )
 282         latest name> >code \ get address of code for new word
 283         cell + \ offset to second cell in create word
 284         !      \ store execution token of DOES> code in new word
 285 ;
 286
 287 : DOES>   ( -- , define execution code for CREATE word )
 288         0 [compile] literal \ dummy literal to hold xt
 289         here cell-          \ address of zero in literal
 290         compile (does>)     \ call (DOES>) from new creation word
 291         >r                  \ move addrz to return stack so ; doesn't see stack garbage
 292         [compile] ;         \ terminate part of code before does>
 293         r>
 294         :noname       ( addrz xt )
 295         swap !              \ save execution token in literal
 296 ; immediate
 297
 298 : VARIABLE  ( <name> -- )
 299     CREATE 0 , \ IMMEDIATE
 300 \       DOES> [compile] aliteral  \ %Q This could be optimised
 301 ;
 302
 303 : 2VARIABLE  ( <name> -c- ) ( -x- addr )
 304         create 0 , 0 ,
 305 ;
 306
 307 : CONSTANT  ( n <name> -c- ) ( -x- n )
 308         CREATE , ( n -- )
 309         DOES> @ ( -- n )
 310 ;
 311
 312
 313
 314 0 1- constant -1
 315 0 2- constant -2
 316
 317 : 2! ( x1 x2 addr -- , store x2 followed by x1 )
 318         swap over ! cell+ !
 319 ;
 320 : 2@ ( addr -- x1 x2 )
 321         dup cell+ @ swap @
 322 ;
 323
 324 : 2CONSTANT ( n1 n2 <name> -c- ) ( -x- n1 n2 )
 325         CREATE , , ( n1 n2 -- )
 326         DOES> 2@   ( -- n1 n2 )
 327 ;
 328
 329 : ABS ( n -- |n| )
 330         dup 0<
 331         IF negate
 332         THEN
 333 ;
 334 : DABS ( d -- |d| )
 335         dup 0<
 336         IF dnegate
 337         THEN
 338 ;
 339
 340 : S>D  ( s -- d , extend signed single precision to double )
 341         dup 0<
 342         IF -1
 343         ELSE 0
 344         THEN
 345 ;
 346
 347 : D>S ( d -- s ) drop ;
 348
 349 : /MOD ( a b -- rem quo , unsigned version, FIXME )
 350         >r s>d r> um/mod
 351 ;
 352
 353 : MOD ( a b -- rem )
 354         /mod drop
 355 ;
 356
 357 : 2* ( n -- n*2 )
 358         1 lshift
 359 ;
 360 : 2/ ( n -- n/2 )
 361         1 arshift
 362 ;
 363
 364 : D2*  ( d -- d*2 )
 365         2* over
 366         cell 8 * 1- rshift or  swap
 367         2* swap
 368 ;
 369
 370 : D= ( xd1 xd2 -- flag )
 371         rot = -rot = and
 372 ;
 373
 374 : D< ( d1 d2 -- flag )
 375     d- nip 0<
 376 ;
 377
 378 : D> ( d1 d2 -- flag )
 379     2swap d<
 380 ;
 381
 382 \ define some useful constants ------------------------------
 383 1 0= constant FALSE
 384 0 0= constant TRUE
 385 32 constant BL
 386
 387
 388 \ Store and Fetch relocatable data addresses. ---------------
 389 : IF.USE->REL  ( use -- rel , preserve zero )
 390         dup IF use->rel THEN
 391 ;
 392 : IF.REL->USE  ( rel -- use , preserve zero )
 393         dup IF rel->use THEN
 394 ;
 395
 396 : A!  ( dictionary_address addr -- )
 397     >r if.use->rel r> !
 398 ;
 399 : A@  ( addr -- dictionary_address )
 400     @ if.rel->use
 401 ;
 402
 403 : A, ( dictionary_address -- )
 404     if.use->rel ,
 405 ;
 406
 407 \ Stack data structure ----------------------------------------
 408 \ This is a general purpose stack utility used to implement necessary
 409 \ stacks for the compiler or the user.  Not real fast.
 410 \ These stacks grow up which is different then normal.
 411 \   cell 0 - stack pointer, offset from pfa of word
 412 \   cell 1 - limit for range checking
 413 \   cell 2 - first data location
 414
 415 : :STACK   ( #cells -- )
 416         CREATE  2 cells ,          ( offset of first data location )
 417                 dup ,              ( limit for range checking, not currently used )
 418                 cells cell+ allot  ( allot an extra cell for safety )
 419 ;
 420
 421 : >STACK  ( n stack -- , push onto stack, postincrement )
 422         dup @ 2dup cell+ swap ! ( -- n stack offset )
 423         + !
 424 ;
 425
 426 : STACK>  ( stack -- n , pop , predecrement )
 427         dup @ cell- 2dup swap !
 428         + @
 429 ;
 430
 431 : STACK@ ( stack -- n , copy )
 432         dup @ cell- + @
 433 ;
 434
 435 : STACK.PICK ( index stack -- n , grab Nth from top of stack )
 436         dup @ cell- +
 437         swap cells -   \ offset for index
 438         @
 439 ;
 440 : STACKP ( stack -- ptr , to next empty location on stack )
 441     dup @ +
 442 ;
 443
 444 : 0STACKP  ( stack -- , clear stack)
 445     8 swap !
 446 ;
 447
 448 32 :stack ustack
 449 ustack 0stackp
 450
 451 \ Define JForth like words.
 452 : >US ustack >stack ;
 453 : US> ustack stack> ;
 454 : US@ ustack stack@ ;
 455 : 0USP ustack 0stackp ;
 456
 457
 458 \ DO LOOP ------------------------------------------------
 459
 460 3 constant do_flag
 461 4 constant leave_flag
 462 5 constant ?do_flag
 463
 464 : DO    ( -- , loop-back do_flag jump-from ?do_flag )
 465         ?comp
 466         compile  (do)
 467         here >us do_flag  >us  ( for backward branch )
 468 ; immediate
 469
 470 : ?DO    ( -- , loop-back do_flag jump-from ?do_flag  , on user stack )
 471         ?comp
 472         ( leave address to set for forward branch )
 473         compile  (?do)
 474         here 0 ,
 475         here >us do_flag  >us  ( for backward branch )
 476         >us ( for forward branch ) ?do_flag >us
 477 ; immediate
 478
 479 : LEAVE  ( -- addr leave_flag )
 480         compile (leave)
 481         here 0 , >us
 482         leave_flag >us
 483 ; immediate
 484
 485 : LOOP-FORWARD  ( -us- jump-from ?do_flag -- )
 486         BEGIN
 487                 us@ leave_flag =
 488                 us@ ?do_flag =
 489                 OR
 490         WHILE
 491                 us> leave_flag =
 492                 IF
 493                         us> here over - cell+ swap !
 494                 ELSE
 495                         us> dup
 496                         here swap -
 497                         cell+ swap !
 498                 THEN
 499         REPEAT
 500 ;
 501
 502 : LOOP-BACK  (  loop-addr do_flag -us- )
 503         us> do_flag ?pairs
 504         us> here -  here
 505         !
 506         cell allot
 507 ;
 508
 509 : LOOP    ( -- , loop-back do_flag jump-from ?do_flag )
 510    compile  (loop)
 511    loop-forward loop-back
 512 ; immediate
 513
 514 \ : DOTEST 5 0 do 333 . loop 888 . ;
 515 \ : ?DOTEST0 0 0 ?do 333 . loop 888 . ;
 516 \ : ?DOTEST1 5 0 ?do 333 . loop 888 . ;
 517
 518 : +LOOP    ( -- , loop-back do_flag jump-from ?do_flag )
 519    compile  (+loop)
 520    loop-forward loop-back
 521 ; immediate
 522
 523 : UNLOOP ( loop-sys -r- )
 524         r> \ save return pointer
 525         rdrop rdrop
 526         >r
 527 ;
 528
 529 : RECURSE ( ? -- ? , call the word currently being defined )
 530         latest  name> compile,
 531 ; immediate
 532
 533
 534
 535 : SPACE  bl emit ;
 536 : SPACES  512 min 0 max 0 ?DO space LOOP ;
 537 : 0SP depth 0 ?do drop loop ;
 538
 539 : >NEWLINE ( -- , CR if needed )
 540         out @ 0>
 541         IF cr
 542         THEN
 543 ;
 544
 545
 546 \ Support for DEFER --------------------
 547 : CHECK.DEFER  ( xt -- , error if not a deferred word by comparing to type )
 548     >code @
 549         ['] emit >code @
 550         - err_defer ?error
 551 ;
 552
 553 : >is ( xt -- address_of_vector )
 554         >code
 555         cell +
 556 ;
 557
 558 : (IS)  ( xt_do xt_deferred -- )
 559         >is !
 560 ;
 561
 562 : IS  ( xt <name> -- , act like normal IS )
 563         '  \ xt
 564         dup check.defer
 565         state @
 566         IF [compile] literal compile (is)
 567         ELSE (is)
 568         THEN
 569 ; immediate
 570
 571 : (WHAT'S)  ( xt -- xt_do )
 572         >is @
 573 ;
 574 : WHAT'S  ( <name> -- xt , what will deferred word call? )
 575         '  \ xt
 576         dup check.defer
 577         state @
 578         IF [compile] literal compile (what's)
 579         ELSE (what's)
 580         THEN
 581 ; immediate
 582
 583 : /STRING   ( addr len n -- addr' len' )
 584    over min  rot over   +  -rot  -
 585 ;
 586 : PLACE   ( addr len to -- , move string )
 587    3dup  1+  swap cmove  c! drop
 588 ;
 589
 590 : PARSE-WORD   ( char -- addr len )
 591    >r  source tuck >in @ /string  r@ skip over swap r> scan
 592    >r  over -  rot r>  dup 0<> + - >in !
 593 ;
 594 : PARSE   ( char -- addr len )
 595    >r  source >in @  /string  over swap  r> scan
 596    >r  over -  dup r> 0<>  -  >in +!
 597 ;
 598
 599 : LWORD  ( char -- addr )
 600         parse-word here place here \ 00002 , use PARSE-WORD
 601 ;
 602
 603 : ASCII ( <char> -- char , state smart )
 604         bl parse drop c@
 605         state @
 606         IF [compile] literal
 607         THEN
 608 ; immediate
 609
 610 : CHAR ( <char> -- char , interpret mode )
 611         bl parse drop c@
 612 ;
 613
 614 : [CHAR] ( <char> -- char , for compile mode )
 615         char [compile] literal
 616 ; immediate
 617
 618 : $TYPE  ( $string -- )
 619         count type
 620 ;
 621
 622 : 'word   ( -- addr )   here ;
 623
 624 : EVEN    ( addr -- addr' )   dup 1 and +  ;
 625
 626 : (C")   ( -- $addr , some Forths return addr AND count, OBSOLETE?)
 627         r> dup count + aligned >r
 628 ;
 629 : (S")   ( -- c-addr cnt )
 630         r> count 2dup + aligned >r
 631 ;
 632
 633 : (.")  ( -- , type following string )
 634         r> count 2dup + aligned >r type
 635 ;
 636
 637 : ",  ( adr len -- , place string into dictionary )
 638          tuck 'word place 1+ allot align
 639 ;
 640 : ,"   ( -- )
 641    [char] " parse ",
 642 ;
 643
 644 : .(  ( <string> -- , type string delimited by parentheses )
 645     [CHAR] ) PARSE TYPE
 646 ; IMMEDIATE
 647
 648 : ."   ( <string> -- , type string )
 649         state @
 650         IF      compile (.")  ,"
 651         ELSE [char] " parse type
 652         THEN
 653 ; immediate
 654
 655
 656 : .'   ( <string> -- , type string delimited by single quote )
 657         state @
 658         IF    compile (.")  [char] ' parse ",
 659         ELSE [char] ' parse type
 660         THEN
 661 ; immediate
 662
 663 : C"    ( <string> -- addr , return string address, ANSI )
 664         state @
 665         IF compile (c")   ,"
 666         ELSE [char] " parse pad place pad
 667         THEN
 668 ; immediate
 669
 670 : S"    ( <string> -- , -- addr , return string address, ANSI )
 671         state @
 672         IF compile (s")   ,"
 673         ELSE [char] " parse pad place pad count
 674         THEN
 675 ; immediate
 676
 677 : "    ( <string> -- , -- addr , return string address )
 678         [compile] C"
 679 ; immediate
 680 : P"    ( <string> -- , -- addr , return string address )
 681         [compile] C"
 682 ; immediate
 683
 684 : ""  ( <string> -- addr )
 685         state @
 686         IF
 687                 compile (C")
 688                 bl parse-word  ",
 689         ELSE
 690                 bl parse-word pad place pad
 691         THEN
 692 ; immediate
 693
 694 : SLITERAL ( addr cnt -- , compile string )
 695     compile (S")
 696     ",
 697 ; IMMEDIATE
 698
 699 : $APPEND ( addr count $1 -- , append text to $1 )
 700     over >r
 701         dup >r
 702     count +  ( -- a2 c2 end1 )
 703     swap cmove
 704     r> dup c@  ( a1 c1 )
 705     r> + ( -- a1 totalcount )
 706     swap c!
 707 ;
 708
 709
 710 \ ANSI word to replace [COMPILE] and COMPILE ----------------
 711 : POSTPONE  ( <name> -- )
 712     bl word find
 713     dup 0=
 714     IF
 715         ." Postpone could not find " count type cr abort
 716     ELSE
 717         0>
 718         IF compile,  \ immediate
 719         ELSE (compile)  \ normal
 720         THEN
 721     THEN
 722 ; immediate
 723
 724 \ -----------------------------------------------------------------
 725 \ Auto Initialization
 726 : AUTO.INIT  ( -- )
 727 \ Kernel finds AUTO.INIT and executes it after loading dictionary.
 728 \   ." Begin AUTO.INIT ------" cr
 729 ;
 730 : AUTO.TERM  ( -- )
 731 \ Kernel finds AUTO.TERM and executes it on bye.
 732 \   ." End AUTO.TERM ------" cr
 733 ;
 734
 735 \ -------------- INCLUDE ------------------------------------------
 736 variable TRACE-INCLUDE
 737
 738 : INCLUDE.MARK.START  ( c-addr u -- , mark start of include for FILE?)
 739     dup 5 + allocate throw >r
 740     " ::::" r@ $move
 741     r@ $append
 742     r@ ['] noop (:)
 743     r> free throw
 744 ;
 745
 746 : INCLUDE.MARK.END  ( -- , mark end of include )
 747     " ;;;;" ['] noop (:)
 748 ;
 749
 750 : INCLUDED ( c-addr u -- )
 751         \ Print messages.
 752         trace-include @
 753         IF
 754                 >newline ." Include " 2dup type cr
 755         THEN
 756         here >r
 757         2dup r/o open-file
 758         IF  ( -- c-addr u bad-fid )
 759                 drop ." Could not find file " type cr abort
 760         ELSE ( -- c-addr u good-fid )
 761                 -rot include.mark.start
 762                 depth >r
 763                 include-file    \ will also close the file
 764                 depth 1+ r> -
 765                 IF
 766                         ." Warning: stack depth changed during include!" cr
 767                         .s cr
 768                         0sp
 769                 THEN
 770                 include.mark.end
 771         THEN
 772         trace-include @
 773         IF
 774                 ."     include added " here r@ - . ." bytes,"
 775                 codelimit here - . ." left." cr
 776         THEN
 777         rdrop
 778 ;
 779
 780 defer MAP.FILENAME ( $filename1 -- $filename2 , modify name )
 781 ' noop is map.filename
 782
 783 : $INCLUDE ( $filename -- )
 784     map.filename
 785     count included
 786 ;
 787
 788 create INCLUDE-SAVE-NAME 128 allot
 789 : INCLUDE ( <fname> -- )
 790         BL lword
 791         dup include-save-name $move  \ save for RI
 792         $include
 793 ;
 794
 795 : RI ( -- , ReInclude previous file as a convenience )
 796         include-save-name $include
 797 ;
 798
 799 : INCLUDE? ( <word> <file> -- , load file if word not defined )
 800         bl word find
 801         IF drop bl word drop  ( eat word from source )
 802         ELSE drop include
 803         THEN
 804 ;
 805
 806 \ desired sizes for dictionary loaded after SAVE-FORTH
 807 variable HEADERS-SIZE
 808 variable CODE-SIZE
 809
 810 : AUTO.INIT
 811     auto.init
 812     codelimit codebase - code-size !
 813     namelimit namebase - headers-size !
 814 ;
 815 auto.init
 816
 817 : SAVE-FORTH ( $name -- )
 818     0                                    \ Entry point
 819     headers-ptr @ namebase - 65536 +     \ NameSize
 820     headers-size @ MAX
 821     here codebase - 131072 +              \ CodeSize
 822     code-size @ MAX
 823     (save-forth)
 824     IF
 825         ." SAVE-FORTH failed!" cr abort
 826     THEN
 827 ;
 828
 829 : TURNKEY ( $name entry-token-- )
 830     0     \ NameSize = 0, names not saved in turnkey dictionary
 831     here codebase - 131072 +             \ CodeSize, remember that base is HEX
 832     (save-forth)
 833     IF
 834         ." TURNKEY failed!" cr abort
 835     THEN
 836 ;
 837
 838 \ Now that we can load from files, load remainder of dictionary.
 839
 840 trace-include on
 841 \ Turn this OFF if you do not want to see the contents of the stack after each entry.
 842 trace-stack off
 843
 844 include loadp4th.fth
 845
 846 decimal
 847
 848 : ;;;; ;  \ Mark end of this file so FILE? can find things in here.
 849 FREEZE    \ prevent forgetting below this point
 850
 851 .( Dictionary compiled, save in "pforth.dic".) cr
 852 \ 300000 headers-size !
 853 \ 700000 code-size !
 854 c" pforth.dic" save-forth