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_ABORTQ        -2 ;   \ for abort"\r
 231 : ERR_EXECUTING    -14 ;   \ compile time word while not compiling\r
 232 : ERR_PAIRS        -22 ;   \ mismatch in conditional\r
 233 : ERR_DEFER       -258 ;  \ not a deferred word\r
 234 \r
 235 : ABORT ( i*x -- )\r
 236         ERR_ABORT throw\r
 237 ;\r
 238 \r
 239 \ Conditionals in '83 form -----------------------------------------\r
 240 : CONDITIONAL_KEY ( -- , lazy constant ) 29521 ;\r
 241 : ?CONDITION   ( f -- )  conditional_key - err_pairs ?error ;\r
 242 : >MARK      ( -- addr )   here 0 ,  ;\r
 243 : >RESOLVE   ( addr -- )   here over - swap !  ;\r
 244 : <MARK      ( -- addr )   here  ;\r
 245 : <RESOLVE   ( addr -- )   here - ,  ;\r
 246 \r
 247 : ?COMP  ( -- , error if not compiling )\r
 248         state @ 0= err_executing ?error\r
 249 ;\r
 250 : ?PAIRS ( n m -- )\r
 251         - err_pairs ?error\r
 252 ;\r
 253 \ conditional primitives\r
 254 : IF     ( -- f orig )  ?comp compile 0branch  conditional_key >mark     ; immediate\r
 255 : THEN   ( f orig -- )  swap ?condition  >resolve   ; immediate\r
 256 : BEGIN  ( -- f dest )  ?comp conditional_key <mark   ; immediate\r
 257 : AGAIN  ( f dest -- )  compile branch  swap ?condition  <resolve  ; immediate\r
 258 : UNTIL  ( f dest -- )  compile 0branch swap ?condition  <resolve  ; immediate\r
 259 : AHEAD  ( -- f orig )  compile branch   conditional_key >mark     ; immediate\r
 260 \r
 261 \ conditionals built from primitives\r
 262 : ELSE   ( f orig1 -- f orig2 )\r
 263         [compile] AHEAD  2swap [compile] THEN  ; immediate\r
 264 : WHILE  ( f dest -- f orig f dest )  [compile]  if   2swap ; immediate\r
 265 : REPEAT ( -- f orig f dest ) [compile] again  [compile] then  ; immediate\r
 266 \r
 267 : [']  ( <name> -- xt , define compile time tick )\r
 268         ?comp ' [compile] literal\r
 269 ; immediate\r
 270 \r
 271 \ for example:\r
 272 \ compile time:  compile create , (does>) then ;\r
 273 \ execution time:  create <name>, ',' data, then patch pi to point to @\r
 274 \    : con create , does> @ ;\r
 275 \    345 con pi\r
 276 \    pi\r
 277 \ \r
 278 : (DOES>)  ( xt -- , modify previous definition to execute code at xt )\r
 279         latest name> >code \ get address of code for new word\r
 280         cell + \ offset to second cell in create word\r
 281         !      \ store execution token of DOES> code in new word\r
 282 ;\r
 283 \r
 284 : DOES>   ( -- , define execution code for CREATE word )\r
 285         0 [compile] literal \ dummy literal to hold xt\r
 286         here cell-          \ address of zero in literal\r
 287         compile (does>)     \ call (DOES>) from new creation word\r
 288                 >r                  \ move addrz to return stack so ; doesn't see stack garbage\r
 289         [compile] ;         \ terminate part of code before does>\r
 290                 r>\r
 291         :noname       ( addrz xt )\r
 292         swap !              \ save execution token in literal\r
 293 ; immediate\r
 294 \r
 295 : VARIABLE  ( <name> -- )\r
 296     CREATE 0 , \ IMMEDIATE\r
 297 \       DOES> [compile] aliteral  \ %Q This could be optimised\r
 298 ;\r
 299 \r
 300 : 2VARIABLE  ( <name> -c- ) ( -x- addr )\r
 301         create 0 , 0 ,\r
 302 ;\r
 303 \r
 304 : CONSTANT  ( n <name> -c- ) ( -x- n )\r
 305         CREATE , ( n -- )\r
 306         DOES> @ ( -- n )\r
 307 ;\r
 308 \r
 309 \r
 310 \r
 311 0 1- constant -1\r
 312 0 2- constant -2\r
 313 \r
 314 : 2! ( x1 x2 addr -- , store x2 followed by x1 )\r
 315         swap over ! cell+ !\r
 316 ;\r
 317 : 2@ ( addr -- x1 x2 )\r
 318         dup cell+ @ swap @\r
 319 ;\r
 320 \r
 321 \r
 322 : ABS ( n -- |n| )\r
 323         dup 0<\r
 324         IF negate\r
 325         THEN\r
 326 ;\r
 327 : DABS ( d -- |d| )\r
 328         dup 0<\r
 329         IF dnegate\r
 330         THEN\r
 331 ;\r
 332 \r
 333 : S>D  ( s -- d , extend signed single precision to double )\r
 334         dup 0<\r
 335         IF -1\r
 336         ELSE 0\r
 337         THEN\r
 338 ;\r
 339 \r
 340 : D>S ( d -- s ) drop ;\r
 341 \r
 342 : /MOD ( a b -- rem quo , unsigned version, FIXME )\r
 343         >r s>d r> um/mod\r
 344 ;\r
 345 \r
 346 : MOD ( a b -- rem )\r
 347         /mod drop\r
 348 ;\r
 349 \r
 350 : 2* ( n -- n*2 )\r
 351         1 lshift\r
 352 ;\r
 353 : 2/ ( n -- n/2 )\r
 354         1 arshift\r
 355 ;\r
 356 \r
 357 : D2*  ( d -- d*2 )\r
 358         2* over
 359         cell 8 * 1- rshift or  swap\r
 360         2* swap\r
 361 ;\r
 362 \r
 363 \ define some useful constants ------------------------------\r
 364 1 0= constant FALSE\r
 365 0 0= constant TRUE\r
 366 32 constant BL\r
 367 \r
 368 \r
 369 \ Store and Fetch relocatable data addresses. ---------------\r
 370 : IF.USE->REL  ( use -- rel , preserve zero )\r
 371         dup IF use->rel THEN\r
 372 ;\r
 373 : IF.REL->USE  ( rel -- use , preserve zero )\r
 374         dup IF rel->use THEN\r
 375 ;\r
 376 \r
 377 : A!  ( dictionary_address addr -- )\r
 378     >r if.use->rel r> !\r
 379 ;\r
 380 : A@  ( addr -- dictionary_address )\r
 381     @ if.rel->use\r
 382 ;\r
 383 \r
 384 : A, ( dictionary_address -- )\r
 385     if.use->rel ,\r
 386 ;\r
 387 \r
 388 \ Stack data structure ----------------------------------------\r
 389 \ This is a general purpose stack utility used to implement necessary\r
 390 \ stacks for the compiler or the user.  Not real fast.\r
 391 \ These stacks grow up which is different then normal.\r
 392 \   cell 0 - stack pointer, offset from pfa of word\r
 393 \   cell 1 - limit for range checking\r
 394 \   cell 2 - first data location\r
 395 \r
 396 : :STACK   ( #cells -- )\r
 397         CREATE  2 cells ,          ( offset of first data location )\r
 398                 dup ,              ( limit for range checking, not currently used )\r
 399                 cells cell+ allot  ( allot an extra cell for safety )\r
 400 ;\r
 401 \r
 402 : >STACK  ( n stack -- , push onto stack, postincrement )\r
 403         dup @ 2dup cell+ swap ! ( -- n stack offset )\r
 404         + !\r
 405 ;\r
 406 \r
 407 : STACK>  ( stack -- n , pop , predecrement )\r
 408         dup @ cell- 2dup swap !\r
 409         + @\r
 410 ;\r
 411 \r
 412 : STACK@ ( stack -- n , copy )\r
 413         dup @ cell- + @ \r
 414 ;\r
 415 \r
 416 : STACK.PICK ( index stack -- n , grab Nth from top of stack )\r
 417         dup @ cell- +\r
 418         swap cells -   \ offset for index\r
 419         @ \r
 420 ;\r
 421 : STACKP ( stack -- ptr , to next empty location on stack )\r
 422         dup @ +\r
 423 ;\r
 424 \r
 425 : 0STACKP  ( stack -- , clear stack)\r
 426     8 swap !\r
 427 ;\r
 428 \r
 429 32 :stack ustack\r
 430 ustack 0stackp\r
 431 \r
 432 \ Define JForth like words.\r
 433 : >US ustack >stack ;\r
 434 : US> ustack stack> ;\r
 435 : US@ ustack stack@ ;\r
 436 : 0USP ustack 0stackp ;\r
 437 \r
 438 \r
 439 \ DO LOOP ------------------------------------------------\r
 440 \r
 441 3 constant do_flag\r
 442 4 constant leave_flag\r
 443 5 constant ?do_flag\r
 444 \r
 445 : DO    ( -- , loop-back do_flag jump-from ?do_flag )\r
 446         ?comp\r
 447         compile  (do)\r
 448         here >us do_flag  >us  ( for backward branch )\r
 449 ; immediate\r
 450 \r
 451 : ?DO    ( -- , loop-back do_flag jump-from ?do_flag  , on user stack )\r
 452         ?comp\r
 453         ( leave address to set for forward branch )\r
 454         compile  (?do)\r
 455         here 0 ,\r
 456         here >us do_flag  >us  ( for backward branch )\r
 457         >us ( for forward branch ) ?do_flag >us\r
 458 ; immediate\r
 459 \r
 460 : LEAVE  ( -- addr leave_flag )\r
 461         compile (leave)\r
 462         here 0 , >us\r
 463         leave_flag >us\r
 464 ; immediate\r
 465 \r
 466 : LOOP-FORWARD  ( -us- jump-from ?do_flag -- )\r
 467         BEGIN\r
 468                 us@ leave_flag =\r
 469                 us@ ?do_flag =\r
 470                 OR\r
 471         WHILE\r
 472                 us> leave_flag =\r
 473                 IF\r
 474                         us> here over - cell+ swap !\r
 475                 ELSE\r
 476                         us> dup\r
 477                         here swap -\r
 478                         cell+ swap !\r
 479                 THEN\r
 480         REPEAT\r
 481 ;\r
 482 \r
 483 : LOOP-BACK  (  loop-addr do_flag -us- )\r
 484         us> do_flag ?pairs\r
 485         us> here -  here\r
 486         !\r
 487         cell allot\r
 488 ;\r
 489 \r
 490 : LOOP    ( -- , loop-back do_flag jump-from ?do_flag )\r
 491    compile  (loop)\r
 492    loop-forward loop-back\r
 493 ; immediate\r
 494 \r
 495 \ : DOTEST 5 0 do 333 . loop 888 . ;\r
 496 \ : ?DOTEST0 0 0 ?do 333 . loop 888 . ;\r
 497 \ : ?DOTEST1 5 0 ?do 333 . loop 888 . ;\r
 498 \r
 499 : +LOOP    ( -- , loop-back do_flag jump-from ?do_flag )\r
 500    compile  (+loop)\r
 501    loop-forward loop-back\r
 502 ; immediate\r
 503         \r
 504 : UNLOOP ( loop-sys -r- )\r
 505         r> \ save return pointer\r
 506         rdrop rdrop\r
 507         >r\r
 508 ;\r
 509 \r
 510 : RECURSE ( ? -- ? , call the word currently being defined )\r
 511         latest  name> compile,\r
 512 ; immediate\r
 513 \r
 514 \r
 515 \r
 516 : SPACE  bl emit ;\r
 517 : SPACES  512 min 0 max 0 ?DO space LOOP ;\r
 518 : 0SP depth 0 ?do drop loop ;\r
 519 \r
 520 : >NEWLINE ( -- , CR if needed )\r
 521         out @ 0>\r
 522         IF cr\r
 523         THEN\r
 524 ;\r
 525 \r
 526 \r
 527 \ Support for DEFER --------------------\r
 528 : CHECK.DEFER  ( xt -- , error if not a deferred word by comparing to type )\r
 529     >code @\r
 530         ['] emit >code @\r
 531         - err_defer ?error\r
 532 ;\r
 533 \r
 534 : >is ( xt -- address_of_vector )\r
 535         >code\r
 536         cell +\r
 537 ;\r
 538 \r
 539 : (IS)  ( xt_do xt_deferred -- )\r
 540         >is !\r
 541 ;\r
 542 \r
 543 : IS  ( xt <name> -- , act like normal IS )\r
 544         '  \ xt\r
 545         dup check.defer \r
 546         state @\r
 547         IF [compile] literal compile (is)\r
 548         ELSE (is)\r
 549         THEN\r
 550 ; immediate\r
 551 \r
 552 : (WHAT'S)  ( xt -- xt_do )\r
 553         >is @\r
 554 ;\r
 555 : WHAT'S  ( <name> -- xt , what will deferred word call? )\r
 556         '  \ xt\r
 557         dup check.defer\r
 558         state @\r
 559         IF [compile] literal compile (what's)\r
 560         ELSE (what's)\r
 561         THEN\r
 562 ; immediate\r
 563 \r
 564 : /STRING   ( addr len n -- addr' len' )\r
 565    over min  rot over   +  -rot  -\r
 566 ;\r
 567 : PLACE   ( addr len to -- , move string )\r
 568    3dup  1+  swap cmove  c! drop\r
 569 ;\r
 570 \r
 571 : PARSE-WORD   ( char -- addr len )\r
 572    >r  source tuck >in @ /string  r@ skip over swap r> scan\r
 573    >r  over -  rot r>  dup 0<> + - >in !\r
 574 ;\r
 575 : PARSE   ( char -- addr len )\r
 576    >r  source >in @  /string  over swap  r> scan\r
 577    >r  over -  dup r> 0<>  -  >in +!\r
 578 ;\r
 579 \r
 580 : LWORD  ( char -- addr )\r
 581         parse-word here place here \ 00002 , use PARSE-WORD\r
 582 ;\r
 583 \r
 584 : ASCII ( <char> -- char , state smart )\r
 585         bl parse drop c@\r
 586         state @\r
 587         IF [compile] literal\r
 588         THEN\r
 589 ; immediate\r
 590 \r
 591 : CHAR ( <char> -- char , interpret mode )\r
 592         bl parse drop c@\r
 593 ;\r
 594 \r
 595 : [CHAR] ( <char> -- char , for compile mode )\r
 596         char [compile] literal\r
 597 ; immediate\r
 598 \r
 599 : $TYPE  ( $string -- )\r
 600         count type\r
 601 ;\r
 602 \r
 603 : 'word   ( -- addr )   here ;\r
 604 \r
 605 : EVEN    ( addr -- addr' )   dup 1 and +  ;\r
 606 \r
 607 : (C")   ( -- $addr , some Forths return addr AND count, OBSOLETE?)\r
 608         r> dup count + aligned >r\r
 609 ;\r
 610 : (S")   ( -- c-addr cnt )\r
 611         r> count 2dup + aligned >r\r
 612 ;\r
 613 \r
 614 : (.")  ( -- , type following string )\r
 615         r> count 2dup + aligned >r type\r
 616 ;\r
 617 \r
 618 : ",  ( adr len -- , place string into dictionary )\r
 619          tuck 'word place 1+ allot align\r
 620 ;\r
 621 : ,"   ( -- )\r
 622    [char] " parse ",\r
 623 ;\r
 624 \r
 625 : .(  ( <string> -- , type string delimited by parentheses )\r
 626         [CHAR] ) PARSE TYPE\r
 627 ; IMMEDIATE\r
 628 \r
 629 : ."   ( <string> -- , type string )\r
 630         state @\r
 631         IF      compile (.")  ,"\r
 632         ELSE [char] " parse type\r
 633         THEN\r
 634 ; immediate\r
 635 \r
 636 \r
 637 : .'   ( <string> -- , type string delimited by single quote )\r
 638         state @\r
 639         IF    compile (.")  [char] ' parse ",\r
 640         ELSE [char] ' parse type\r
 641         THEN\r
 642 ; immediate\r
 643 \r
 644 : C"    ( <string> -- addr , return string address, ANSI )\r
 645         state @\r
 646         IF compile (c")   ,"\r
 647         ELSE [char] " parse pad place pad\r
 648         THEN\r
 649 ; immediate\r
 650 \r
 651 : S"    ( <string> -- , -- addr , return string address, ANSI )\r
 652         state @\r
 653         IF compile (s")   ,"\r
 654         ELSE [char] " parse pad place pad count\r
 655         THEN\r
 656 ; immediate\r
 657 \r
 658 : "    ( <string> -- , -- addr , return string address )\r
 659         [compile] C"\r
 660 ; immediate\r
 661 : P"    ( <string> -- , -- addr , return string address )\r
 662         [compile] C"\r
 663 ; immediate\r
 664 \r
 665 : ""  ( <string> -- addr )\r
 666         state @\r
 667         IF \r
 668                 compile (C")\r
 669                 bl parse-word  ",\r
 670         ELSE\r
 671                 bl parse-word pad place pad\r
 672         THEN\r
 673 ; immediate\r
 674 \r
 675 : SLITERAL ( addr cnt -- , compile string )\r
 676         compile (S")\r
 677         ",\r
 678 ; IMMEDIATE\r
 679 \r
 680 : $APPEND ( addr count $1 -- , append text to $1 )\r
 681     over >r\r
 682         dup >r\r
 683     count +  ( -- a2 c2 end1 )\r
 684     swap cmove\r
 685     r> dup c@  ( a1 c1 )\r
 686     r> + ( -- a1 totalcount )\r
 687     swap c!\r
 688 ;\r
 689 \r
 690 \r
 691 \ ANSI word to replace [COMPILE] and COMPILE ----------------\r
 692 : POSTPONE  ( <name> -- )\r
 693         bl word find\r
 694         dup 0=\r
 695         IF\r
 696                 ." Postpone could not find " count type cr abort\r
 697         ELSE\r
 698                 0>\r
 699                 IF compile,  \ immediate\r
 700                 ELSE (compile)  \ normal\r
 701                 THEN\r
 702         THEN\r
 703 ; immediate\r
 704 \r
 705 \ -----------------------------------------------------------------\r
 706 \ Auto Initialization\r
 707 : AUTO.INIT  ( -- )\r
 708 \ Kernel finds AUTO.INIT and executes it after loading dictionary.\r
 709 \       ." Begin AUTO.INIT ------" cr\r
 710 ;\r
 711 : AUTO.TERM  ( -- )\r
 712 \ Kernel finds AUTO.TERM and executes it on bye.\r
 713 \       ." End AUTO.TERM ------" cr\r
 714 ;\r
 715 \r
 716 \ -------------- INCLUDE ------------------------------------------\r
 717 variable TRACE-INCLUDE\r
 718 \r
 719 : INCLUDE.MARK.START  ( $filename -- , mark start of include for FILE?)\r
 720         " ::::"  pad $MOVE\r
 721         count pad $APPEND\r
 722         pad ['] noop (:)\r
 723 ;\r
 724 \r
 725 : INCLUDE.MARK.END  ( -- , mark end of include )\r
 726         " ;;;;" ['] noop (:)\r
 727 ;\r
 728 \r
 729 : $INCLUDE ( $filename -- )\r
 730 \ Print messages.\r
 731         trace-include @\r
 732         IF\r
 733                 >newline ." Include " dup count type cr\r
 734         THEN\r
 735         here >r\r
 736         dup\r
 737         count r/o open-file \r
 738         IF  ( -- $filename bad-fid )\r
 739                 drop ." Could not find file " $type cr abort\r
 740         ELSE ( -- $filename good-fid )\r
 741                 swap include.mark.start\r
 742                 depth >r\r
 743                 include-file    \ will also close the file\r
 744                 depth 1+ r> -\r
 745                 IF\r
 746                         ." Warning: stack depth changed during include!" cr\r
 747                         .s cr\r
 748                         0sp\r
 749                 THEN\r
 750                 include.mark.end\r
 751         THEN\r
 752         trace-include @\r
 753         IF\r
 754                 ."     include added " here r@ - . ." bytes,"\r
 755                 codelimit here - . ." left." cr\r
 756         THEN\r
 757         rdrop\r
 758 ;\r
 759 \r
 760 create INCLUDE-SAVE-NAME 128 allot\r
 761 : INCLUDE ( <fname> -- )\r
 762         BL lword\r
 763         dup include-save-name $move  \ save for RI\r
 764         $include\r
 765 ;\r
 766 \r
 767 : RI ( -- , ReInclude previous file as a convenience )\r
 768         include-save-name $include\r
 769 ;\r
 770 \r
 771 : INCLUDE? ( <word> <file> -- , load file if word not defined )\r
 772         bl word find\r
 773         IF drop bl word drop  ( eat word from source )\r
 774         ELSE drop include\r
 775         THEN\r
 776 ;\r
 777 \r
 778 \ desired sizes for dictionary loaded after SAVE-FORTH\r
 779 variable HEADERS-SIZE  \r
 780 variable CODE-SIZE\r
 781 \r
 782 : AUTO.INIT\r
 783         auto.init\r
 784         codelimit codebase - code-size !\r
 785         namelimit namebase - headers-size !\r
 786 ;\r
 787 auto.init\r
 788 \r
 789 : SAVE-FORTH ( $name -- )\r
 790     0                                    \ Entry point\r
 791     headers-ptr @ namebase - 65536 +     \ NameSize\r
 792     headers-size @ MAX\r
 793     here codebase - 131072 +              \ CodeSize\r
 794     code-size @ MAX\r
 795     (save-forth)\r
 796     IF\r
 797                 ." SAVE-FORTH failed!" cr abort\r
 798     THEN\r
 799 ;\r
 800 \r
 801 : TURNKEY ( $name entry-token-- )\r
 802     0     \ NameSize = 0, names not saved in turnkey dictionary\r
 803     here codebase - 131072 +             \ CodeSize, remember that base is HEX\r
 804     (save-forth)\r
 805     IF\r
 806                 ." TURNKEY failed!" cr abort\r
 807     THEN\r
 808 ;\r
 809 \r
 810 \ Now that we can load from files, load remainder of dictionary.\r
 811 \r
 812 trace-include on\r
 813 \ Turn this OFF if you do not want to see the contents of the stack after each entry.\r
 814 trace-stack off\r
 815 \r
 816 include loadp4th.fth\r
 817 \r
 818 decimal\r
 819 \r
 820 : ;;;; ;  \ Mark end of this file so FILE? can find things in here.\r
 821 FREEZE    \ prevent forgetting below this point\r
 822 \r
 823 .( Dictionary compiled, save in "pforth.dic".) cr\r
 824 c" pforth.dic" save-forth\r