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

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