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