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 \ *********************************************************************\r
  22 \ This is another style of comment that is common in Forth.\r
  23 \ pFORTH - Portable Forth System\r
  24 \ Based on HMSL Forth\r
  25 \\r
  26 \ Author: Phil Burk\r
  27 \ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom\r
  28 \\r
  29 \ The pForth software code is dedicated to the public domain,\r
  30 \ and any third party may reproduce, distribute and modify\r
  31 \ the pForth software code or any derivative works thereof\r
  32 \ without any compensation or license.  The pForth software\r
  33 \ code is provided on an "as is" basis without any warranty\r
  34 \ of any kind, including, without limitation, the implied\r
  35 \ warranties of merchantability and fitness for a particular\r
  36 \ purpose and their equivalents under the laws of any jurisdiction.\r
  37 \ *********************************************************************\r
  38 \r
  39 : COUNT  dup 1+ swap c@ ;\r
  40 \r
  41 \ Miscellaneous support words\r
  42 : ON ( addr -- , set true )\r
  43         -1 swap !\r
  44 ;\r
  45 : OFF ( addr -- , set false )\r
  46         0 swap !\r
  47 ;\r
  48 \r
  49 \ size of data items\r
  50 \ FIXME - move these into 'C' code for portability ????\r
  51 : CELL ( -- size_of_stack_item ) 4 ;\r
  52 \r
  53 : CELL+ ( n -- n+cell )  cell + ;\r
  54 : CELL- ( n -- n+cell )  cell - ;\r
  55 : CELLS ( n -- n*cell )  2 lshift ;\r
  56 \r
  57 : CHAR+ ( n -- n+size_of_char ) 1+ ;\r
  58 : CHARS ( n -- n*size_of_char , don't do anything)  ; immediate\r
  59 \r
  60 \ useful stack manipulation words\r
  61 : -ROT ( a b c -- c a b )\r
  62         rot rot\r
  63 ;\r
  64 : 3DUP ( a b c -- a b c a b c )\r
  65         2 pick 2 pick 2 pick\r
  66 ;\r
  67 : 2DROP ( a b -- )\r
  68         drop drop\r
  69 ;\r
  70 : NIP ( a b -- b )\r
  71         swap drop\r
  72 ;\r
  73 : TUCK ( a b -- b a b )\r
  74         swap over\r
  75 ;\r
  76 \r
  77 : <= ( a b -- f , true if A <= b )\r
  78         > 0=\r
  79 ;\r
  80 : >= ( a b -- f , true if A >= b )\r
  81         < 0=\r
  82 ;\r
  83 \r
  84 : INVERT ( n -- 1'comp )\r
  85     -1 xor\r
  86 ;\r
  87 \r
  88 : NOT ( n -- !n , logical negation )\r
  89         0=\r
  90 ;\r
  91 \r
  92 : NEGATE ( n -- -n )\r
  93         0 swap -\r
  94 ;\r
  95 \r
  96 : DNEGATE ( d -- -d , negate by doing 0-d )\r
  97         0 0 2swap d-\r
  98 ;\r
  99 \r
 100 \r
 101 \ --------------------------------------------------------------------\r
 102 \r
 103 : ID.   ( nfa -- )\r
 104     count 31 and type\r
 105 ;\r
 106 \r
 107 : DECIMAL   10 base !  ;\r
 108 : OCTAL      8 base !  ;\r
 109 : HEX       16 base !  ;\r
 110 : BINARY     2 base !  ;\r
 111 \r
 112 : PAD ( -- addr )\r
 113         here 128 +\r
 114 ;\r
 115 \r
 116 : $MOVE ( $src $dst -- )\r
 117         over c@ 1+ cmove\r
 118 ;\r
 119 : BETWEEN ( n lo hi -- flag , true if between lo & hi )\r
 120         >r over r> > >r\r
 121         < r> or 0=\r
 122 ;\r
 123 : [ ( -- , enter interpreter mode )\r
 124         0 state !\r
 125 ; immediate\r
 126 : ] ( -- enter compile mode )\r
 127         1 state !\r
 128 ;\r
 129 \r
 130 : EVEN-UP  ( n -- n | n+1 , make even )  dup 1 and +  ;\r
 131 : ALIGNED  ( addr -- a-addr )\r
 132         [ cell 1- ] literal +\r
 133         [ cell 1- invert ] literal and\r
 134 ;\r
 135 : ALIGN ( -- , align DP )  dp @ aligned dp ! ;\r
 136 : ALLOT ( nbytes -- , allot space in dictionary ) dp +! ( align ) ;\r
 137 \r
 138 : C,    ( c -- )  here c! 1 chars dp +! ;\r
 139 : W,    ( w -- )  dp @ even-up dup dp !    w!  2 chars dp +! ;\r
 140 : , ( n -- , lay into dictionary )  align here !  cell allot ;\r
 141 \r
 142 \ Dictionary conversions ------------------------------------------\r
 143 \r
 144 : N>NEXTLINK  ( nfa -- nextlink , traverses name field )\r
 145         dup c@ 31 and 1+ + aligned\r
 146 ;\r
 147 \r
 148 : NAMEBASE  ( -- base-of-names )\r
 149         Headers-Base @\r
 150 ;\r
 151 : CODEBASE  ( -- base-of-code dictionary )\r
 152         Code-Base @\r
 153 ;\r
 154 \r
 155 : NAMELIMIT  ( -- limit-of-names )\r
 156         Headers-limit @\r
 157 ;\r
 158 : CODELIMIT  ( -- limit-of-code, last address in dictionary )\r
 159         Code-limit @\r
 160 ;\r
 161 \r
 162 : NAMEBASE+   ( rnfa -- nfa , convert relocatable nfa to actual )\r
 163         namebase +\r
 164 ;\r
 165 \r
 166 : >CODE ( xt -- secondary_code_address, not valid for primitives )\r
 167         codebase +\r
 168 ;\r
 169 \r
 170 : CODE> ( secondary_code_address -- xt , not valid for primitives )\r
 171         codebase -\r
 172 ;\r
 173 \r
 174 : N>LINK  ( nfa -- lfa )\r
 175         8 -\r
 176 ;\r
 177 \r
 178 : >BODY   ( xt -- pfa )\r
 179     >code body_offset +\r
 180 ;\r
 181 \r
 182 : BODY>   ( pfa -- xt )\r
 183     body_offset - code>\r
 184 ;\r
 185 \r
 186 \ convert between addresses useable by @, and relocatable addresses.\r
 187 : USE->REL  ( useable_addr -- rel_addr )\r
 188         codebase -\r
 189 ;\r
 190 : REL->USE  ( rel_addr -- useable_addr )\r
 191         codebase +\r
 192 ;\r
 193 \r
 194 \ for JForth code\r
 195 \ : >REL  ( adr -- adr )  ; immediate\r
 196 \ : >ABS  ( adr -- adr )  ; immediate\r
 197 \r
 198 : X@ ( addr -- xt , fetch execution token from relocatable )   @ ;\r
 199 : X! ( addr -- xt , store execution token as relocatable )   ! ;\r
 200 \r
 201 \ Compiler support ------------------------------------------------\r
 202 : COMPILE, ( xt -- , compile call to xt )\r
 203         ,\r
 204 ;\r
 205 \r
 206 ( Compiler support , based on FIG )\r
 207 : [COMPILE]  ( <name> -- , compile now even if immediate )\r
 208     ' compile,\r
 209 ;  IMMEDIATE\r
 210 \r
 211 : (COMPILE) ( xt -- , postpone compilation of token )\r
 212         [compile] literal       ( compile a call to literal )\r
 213         ( store xt of word to be compiled )\r
 214         \r
 215         [ ' compile, ] literal   \ compile call to compile,\r
 216         compile,\r
 217 ;\r
 218         \r
 219 : COMPILE  ( <name> -- , save xt and compile later )\r
 220     ' (compile)\r
 221 ; IMMEDIATE\r
 222 \r
 223 \r
 224 : :NONAME ( -- xt , begin compilation of headerless secondary )\r
 225         align\r
 226         here code>   \ convert here to execution token\r
 227         ]\r
 228 ;\r
 229 \r
 230 \ Error codes defined in ANSI Exception word set.\r
 231 : ERR_ABORT         -1 ;   \ general abort\r
 232 : ERR_EXECUTING    -14 ;   \ compile time word while not compiling\r
 233 : ERR_PAIRS        -22 ;   \ mismatch in conditional\r
 234 : ERR_DEFER       -258 ;  \ not a deferred word\r
 235 \r
 236 : ABORT ( i*x -- )\r
 237         ERR_ABORT throw\r
 238 ;\r
 239 \r
 240 \ Conditionals in '83 form -----------------------------------------\r
 241 : CONDITIONAL_KEY ( -- , lazy constant ) 29521 ;\r
 242 : ?CONDITION   ( f -- )  conditional_key - err_pairs ?error ;\r
 243 : >MARK      ( -- addr )   here 0 ,  ;\r
 244 : >RESOLVE   ( addr -- )   here over - swap !  ;\r
 245 : <MARK      ( -- addr )   here  ;\r
 246 : <RESOLVE   ( addr -- )   here - ,  ;\r
 247 \r
 248 : ?COMP  ( -- , error if not compiling )\r
 249         state @ 0= err_executing ?error\r
 250 ;\r
 251 : ?PAIRS ( n m -- )\r
 252         - err_pairs ?error\r
 253 ;\r
 254 \ conditional primitives\r
 255 : IF     ( -- f orig )  ?comp compile 0branch  conditional_key >mark     ; immediate\r
 256 : THEN   ( f orig -- )  swap ?condition  >resolve   ; immediate\r
 257 : BEGIN  ( -- f dest )  ?comp conditional_key <mark   ; immediate\r
 258 : AGAIN  ( f dest -- )  compile branch  swap ?condition  <resolve  ; immediate\r
 259 : UNTIL  ( f dest -- )  compile 0branch swap ?condition  <resolve  ; immediate\r
 260 : AHEAD  ( -- f orig )  compile branch   conditional_key >mark     ; immediate\r
 261 \r
 262 \ conditionals built from primitives\r
 263 : ELSE   ( f orig1 -- f orig2 )\r
 264         [compile] AHEAD  2swap [compile] THEN  ; immediate\r
 265 : WHILE  ( f dest -- f orig f dest )  [compile]  if   2swap ; immediate\r
 266 : REPEAT ( -- f orig f dest ) [compile] again  [compile] then  ; immediate\r
 267 \r
 268 : [']  ( <name> -- xt , define compile time tick )\r
 269         ?comp ' [compile] literal\r
 270 ; immediate\r
 271 \r
 272 \ for example:\r
 273 \ compile time:  compile create , (does>) then ;\r
 274 \ execution time:  create <name>, ',' data, then patch pi to point to @\r
 275 \    : con create , does> @ ;\r
 276 \    345 con pi\r
 277 \    pi\r
 278 \ \r
 279 : (DOES>)  ( xt -- , modify previous definition to execute code at xt )\r
 280         latest name> >code \ get address of code for new word\r
 281         cell + \ offset to second cell in create word\r
 282         !      \ store execution token of DOES> code in new word\r
 283 ;\r
 284 \r
 285 : DOES>   ( -- , define execution code for CREATE word )\r
 286         0 [compile] literal \ dummy literal to hold xt\r
 287         here cell-          \ address of zero in literal\r
 288         compile (does>)     \ call (DOES>) from new creation word\r
 289                 >r                  \ move addrz to return stack so ; doesn't see stack garbage\r
 290         [compile] ;         \ terminate part of code before does>\r
 291                 r>\r
 292         :noname       ( addrz xt )\r
 293         swap !              \ save execution token in literal\r
 294 ; immediate\r
 295 \r
 296 : VARIABLE  ( <name> -- )\r
 297     CREATE 0 , \ IMMEDIATE\r
 298 \       DOES> [compile] aliteral  \ %Q This could be optimised\r
 299 ;\r
 300 \r
 301 : 2VARIABLE  ( <name> -c- ) ( -x- addr )\r
 302         create 0 , 0 ,\r
 303 ;\r
 304 \r
 305 : CONSTANT  ( n <name> -c- ) ( -x- n )\r
 306         CREATE , ( n -- )\r
 307         DOES> @ ( -- n )\r
 308 ;\r
 309 \r
 310 \r
 311 \r
 312 0 1- constant -1\r
 313 0 2- constant -2\r
 314 \r
 315 : 2! ( x1 x2 addr -- , store x2 followed by x1 )\r
 316         swap over ! cell+ !\r
 317 ;\r
 318 : 2@ ( addr -- x1 x2 )\r
 319         dup cell+ @ swap @\r
 320 ;\r
 321 \r
 322 \r
 323 : ABS ( n -- |n| )\r
 324         dup 0<\r
 325         IF negate\r
 326         THEN\r
 327 ;\r
 328 : DABS ( d -- |d| )\r
 329         dup 0<\r
 330         IF dnegate\r
 331         THEN\r
 332 ;\r
 333 \r
 334 : S>D  ( s -- d , extend signed single precision to double )\r
 335         dup 0<\r
 336         IF -1\r
 337         ELSE 0\r
 338         THEN\r
 339 ;\r
 340 \r
 341 : D>S ( d -- s ) drop ;\r
 342 \r
 343 : /MOD ( a b -- rem quo , unsigned version, FIXME )\r
 344         >r s>d r> um/mod\r
 345 ;\r
 346 \r
 347 : MOD ( a b -- rem )\r
 348         /mod drop\r
 349 ;\r
 350 \r
 351 : 2* ( n -- n*2 )\r
 352         1 lshift\r
 353 ;\r
 354 : 2/ ( n -- n/2 )\r
 355         1 arshift\r
 356 ;\r
 357 \r
 358 : D2*  ( d -- d*2 )\r
 359         2* over 31 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                 dup >r   \ save fid for close-file\r
 743                 depth >r\r
 744                 include-file\r
 745                 depth 1+ r> -\r
 746                 IF\r
 747                         ." Warning: stack depth changed during include!" cr\r
 748                         .s cr\r
 749                         0sp\r
 750                 THEN\r
 751                 r> close-file drop\r
 752                 include.mark.end\r
 753         THEN\r
 754         trace-include @\r
 755         IF\r
 756                 ."     include added " here r@ - . ." bytes,"\r
 757                 codelimit here - . ." left." cr\r
 758         THEN\r
 759         rdrop\r
 760 ;\r
 761 \r
 762 create INCLUDE-SAVE-NAME 128 allot\r
 763 : INCLUDE ( <fname> -- )\r
 764         BL lword\r
 765         dup include-save-name $move  \ save for RI\r
 766         $include\r
 767 ;\r
 768 \r
 769 : RI ( -- , ReInclude previous file as a convenience )\r
 770         include-save-name $include\r
 771 ;\r
 772 \r
 773 : INCLUDE? ( <word> <file> -- , load file if word not defined )\r
 774         bl word find\r
 775         IF drop bl word drop  ( eat word from source )\r
 776         ELSE drop include\r
 777         THEN\r
 778 ;\r
 779 \r
 780 \ desired sizes for dictionary loaded after SAVE-FORTH\r
 781 variable HEADERS-SIZE  \r
 782 variable CODE-SIZE\r
 783 \r
 784 : AUTO.INIT\r
 785         auto.init\r
 786         codelimit codebase - code-size !\r
 787         namelimit namebase - headers-size !\r
 788 ;\r
 789 auto.init\r
 790 \r
 791 : SAVE-FORTH ( $name -- )\r
 792     0                                    \ Entry point\r
 793     headers-ptr @ namebase - 65536 +     \ NameSize\r
 794     headers-size @ MAX\r
 795     here codebase - 131072 +              \ CodeSize\r
 796     code-size @ MAX\r
 797     (save-forth)\r
 798     IF\r
 799                 ." SAVE-FORTH failed!" cr abort\r
 800     THEN\r
 801 ;\r
 802 \r
 803 : TURNKEY ( $name entry-token-- )\r
 804     0     \ NameSize = 0, names not saved in turnkey dictionary\r
 805     here codebase - 131072 +             \ CodeSize, remember that base is HEX\r
 806     (save-forth)\r
 807     IF\r
 808                 ." TURNKEY failed!" cr abort\r
 809     THEN\r
 810 ;\r
 811 \r
 812 \ load remainder of dictionary\r
 813 \r
 814 trace-include on\r
 815 trace-stack on\r
 816 \r
 817 include loadp4th.fth\r
 818 \r
 819 decimal\r
 820 \r
 821 : ;;;; ;  \ Mark end of this file so FILE? can find things in here.\r
 822 FREEZE    \ prevent forgetting below this point\r
 823 \r
 824 .( Dictionary compiled, save in "pforth.dic".) cr\r
 825 c" pforth.dic" save-forth\r
 826 \r
 827 SDAD\r