forth/bootstrap/bootstrap.fs

   1 \ tag: bootstrap of basic forth words
   2 \
   3 \ Copyright (C) 2003-2005 Stefan Reinauer, Patrick Mauritz
   4 \
   5 \ See the file "COPYING" for further information about
   6 \ the copyright and warranty status of this work.
   7 \
   8
   9 \
  10 \ this file contains almost all forth words described
  11 \ by the open firmware user interface. Some more complex
  12 \ parts are found in seperate files (memory management,
  13 \ vocabulary support)
  14 \
  15
  16 \
  17 \ often used constants (reduces dictionary size)
  18 \
  19
  20 1 constant 1
  21 2 constant 2
  22 3 constant 3
  23 -1 constant -1
  24 0 constant 0
  25
  26 0 value my-self
  27
  28 \
  29 \ 7.3.5.1 Numeric-base control
  30 \
  31
  32 : decimal 10 base ! ;
  33 : hex 16 base ! ;
  34 : octal 8 base ! ;
  35 hex
  36
  37 \
  38 \ vocabulary words
  39 \
  40
  41 variable current forth-last current !
  42
  43 : last
  44   current @
  45   ;
  46
  47 variable #order 0 #order !
  48
  49 defer context
  50 0 value vocabularies?
  51
  52 \
  53 \ 7.3.7 Flag constants
  54 \
  55
  56 1 1 = constant true
  57 0 1 = constant false
  58
  59 \
  60 \ 7.3.9.2.2 Immediate words (part 1)
  61 \
  62
  63 : (immediate) ( xt -- )
  64   1 - dup c@ 1 or swap c!
  65   ;
  66
  67 : (compile-only)
  68   1 - dup c@ 2 or swap c!
  69   ;
  70
  71 : immediate
  72   last @ (immediate)
  73   ;
  74
  75 : compile-only
  76   last @ (compile-only)
  77   ;
  78
  79 : flags? ( xt -- flags )
  80   /n /c + - c@ 7f and
  81   ;
  82
  83 : immediate? ( xt -- true|false )
  84   flags? 1 and 1 =
  85   ;
  86
  87 : compile-only? ( xt -- true|false )
  88   flags? 2 and 2 =
  89   ;
  90
  91 : [  0 state ! ; compile-only
  92 : ] -1 state ! ;
  93
  94
  95
  96 \
  97 \ 7.3.9.2.1 Data space allocation
  98 \
  99
 100 : allot here + here! ;
 101 : ,  here /n allot ! ;
 102 : c, here /c allot c! ;
 103
 104 : align
 105   /n here /n 1 - and -   \ how many bytes to next alignment
 106   /n 1 - and allot       \ mask out everything that is bigger
 107   ;                      \ than cellsize-1
 108
 109 : null-align
 110   here dup align here swap - 0 fill
 111   ;
 112
 113 : w,
 114   here 1 and allot       \ if here is not even, we have to align.
 115   here /w allot w!
 116   ;
 117
 118 : l,
 119   /l here /l 1 - and -   \ same as in align, with /l
 120   /l 1 - and             \ if it's /l we are already aligned.
 121   allot
 122   here /l allot l!
 123   ;
 124
 125
 126 \
 127 \ 7.3.6 comparison operators (part 1)
 128 \
 129
 130 : <> = invert ;
 131
 132
 133 \
 134 \ 7.3.9.2.4 Miscellaneous dictionary (part 1)
 135 \
 136
 137 : (to) ( xt-new xt-defer -- )
 138   /n + !
 139   ;
 140
 141 : >body ( xt -- a-addr )  /n 1 lshift + ;
 142 : body> ( a-addr -- xt )  /n 1 lshift - ;
 143
 144 : reveal latest @ last ! ;
 145 : recursive reveal ; immediate
 146 : recurse latest @ /n +  , ; immediate
 147
 148 : noop ;
 149
 150 defer environment?
 151 : no-environment?
 152   2drop false
 153   ;
 154
 155 ['] no-environment? ['] environment? (to)
 156
 157
 158 \
 159 \ 7.3.8.1 Conditional branches
 160 \
 161
 162 \ A control stack entry is implemented using 2 data stack items
 163 \ of the form ( addr type ). type can be one of the
 164 \ following:
 165 \   0 - orig
 166 \   1 - dest
 167 \   2 - do-sys
 168
 169 : resolve-orig here nip over /n + - swap ! ;
 170 : (if) ['] do?branch , here 0 0 , ; compile-only
 171 : (then) resolve-orig ; compile-only
 172
 173 variable tmp-comp-depth -1 tmp-comp-depth !
 174 variable tmp-comp-buf 0 tmp-comp-buf !
 175
 176 : setup-tmp-comp ( -- )
 177   state @ 0 = (if)
 178     here tmp-comp-buf @ here! ,     \ save here and switch to tmp directory
 179     1 ,                              \ DOCOL
 180     depth tmp-comp-depth !          \ save control depth
 181     ]
 182   (then)
 183 ;
 184
 185 : execute-tmp-comp ( -- )
 186   depth tmp-comp-depth @ =
 187   (if)
 188     -1 tmp-comp-depth !
 189     ['] (semis) ,
 190     tmp-comp-buf @
 191     dup @ here!
 192     0 state !
 193     /n + execute
 194   (then)
 195 ;
 196
 197 : if setup-tmp-comp ['] do?branch , here 0 0 , ; immediate
 198 : then resolve-orig execute-tmp-comp ; compile-only
 199 : else ['] dobranch , here 0 0 , 2swap resolve-orig ; compile-only
 200
 201 \
 202 \ 7.3.8.3 Conditional loops
 203 \
 204
 205 \ some dummy words for see
 206 : (begin) ;
 207 : (again) ;
 208 : (until) ;
 209 : (while) ;
 210 : (repeat) ;
 211
 212 \ resolve-dest requires a loop...
 213 : (resolve-dest) here /n + nip - , ;
 214 : (resolve-begin) setup-tmp-comp ['] (begin) , here 1 ; immediate
 215 : (resolve-until) ['] (until) , ['] do?branch , (resolve-dest) execute-tmp-comp ; compile-only
 216
 217 : resolve-dest ( dest origN ... orig )
 218   2 >r
 219   (resolve-begin)
 220     \ Find topmost control stack entry with a type of 1 (dest)
 221     r> dup dup pick 1 = if
 222       \ Move it to the top
 223       roll
 224       swap 1 - roll
 225       \ Resolve it
 226       (resolve-dest)
 227       1         \ force exit
 228     else
 229       drop
 230       2 + >r
 231       0
 232     then
 233   (resolve-until)
 234 ;
 235
 236 : begin
 237   setup-tmp-comp
 238   ['] (begin) ,
 239   here
 240   1
 241   ; immediate
 242
 243 : again
 244   ['] (again) ,
 245   ['] dobranch ,
 246   resolve-dest
 247   execute-tmp-comp
 248   ; compile-only
 249
 250 : until
 251   ['] (until) ,
 252   ['] do?branch ,
 253   resolve-dest
 254   execute-tmp-comp
 255   ; compile-only
 256
 257 : while
 258   setup-tmp-comp
 259   ['] (while) ,
 260   ['] do?branch ,
 261   here 0 0 , 2swap
 262   ; immediate
 263
 264 : repeat
 265   ['] (repeat) ,
 266   ['] dobranch ,
 267   resolve-dest resolve-orig
 268   execute-tmp-comp
 269   ; compile-only
 270
 271
 272 \
 273 \ 7.3.8.4 Counted loops
 274 \
 275
 276 variable leaves 0 leaves !
 277
 278 : resolve-loop
 279   leaves @
 280   begin
 281     ?dup
 282   while
 283     dup @               \ leaves -- leaves *leaves )
 284     swap                \ -- *leaves leaves )
 285     here over -         \ -- *leaves leaves here-leaves
 286     swap !              \ -- *leaves
 287   repeat
 288   here nip - ,
 289   leaves !
 290   ;
 291
 292 : do
 293   setup-tmp-comp
 294   leaves @
 295   here 2
 296   ['] (do) ,
 297   0 leaves !
 298   ; immediate
 299
 300 : ?do
 301   setup-tmp-comp
 302   leaves @
 303   ['] (?do) ,
 304   here 2
 305   here leaves !
 306   0 ,
 307   ; immediate
 308
 309 : loop
 310   ['] (loop) ,
 311   resolve-loop
 312   execute-tmp-comp
 313   ; immediate
 314
 315 : +loop
 316   ['] (+loop) ,
 317   resolve-loop
 318   execute-tmp-comp
 319   ; immediate
 320
 321
 322 \ Using primitive versions of i and j
 323 \ speeds up loops by 300%
 324 \ : i r> r@ swap >r ;
 325 \ : j r> r> r> r@ -rot >r >r swap >r ;
 326
 327 : unloop r> r> r> 2drop >r ;
 328
 329 : leave
 330   ['] unloop ,
 331   ['] dobranch ,
 332   leaves @
 333   here leaves !
 334   ,
 335   ; immediate
 336
 337 : ?leave if leave then ;
 338
 339 \
 340 \ 7.3.8.2  Case statement
 341 \
 342
 343 : case
 344   setup-tmp-comp
 345   0
 346 ; immediate
 347
 348 : endcase
 349   ['] drop ,
 350   0 ?do
 351     ['] then execute
 352   loop
 353   execute-tmp-comp
 354 ; immediate
 355
 356 : of
 357   1 + >r
 358   ['] over ,
 359   ['] = ,
 360   ['] if execute
 361   ['] drop ,
 362   r>
 363   ; immediate
 364
 365 : endof
 366   >r
 367   ['] else execute
 368   r>
 369   ; immediate
 370
 371 \
 372 \ 7.3.8.5    Other control flow commands
 373 \
 374
 375 : exit r> drop ;
 376
 377
 378 \
 379 \ 7.3.4.3 ASCII constants (part 1)
 380 \
 381
 382 20 constant bl
 383 07 constant bell
 384 08 constant bs
 385 0d constant carret
 386 0a constant linefeed
 387
 388
 389 \
 390 \ 7.3.1.1 - stack duplication
 391 \
 392 : tuck swap over ;
 393 : 3dup 2 pick 2 pick 2 pick ;
 394
 395 \
 396 \ 7.3.1.2 - stack removal
 397 \
 398 : clear 0 depth! ;
 399 : 3drop 2drop drop ;
 400
 401 \
 402 \ 7.3.1.3 - stack rearrangement
 403 \
 404
 405 : 2rot >r >r 2swap r> r> 2swap ;
 406
 407 \
 408 \ 7.3.1.4 - return stack
 409 \
 410
 411 \ Note: these words are not part of the official OF specification, however
 412 \ they are part of the ANSI DPANS94 core extensions (see section 6.2) and
 413 \ so this seems an appropriate place for them.
 414 : 2>r r> -rot swap >r >r >r ;
 415 : 2r> r> r> r> rot >r swap ;
 416 : 2r@ r> r> r> 2dup >r >r rot >r swap ;
 417
 418 \
 419 \ 7.3.2.1 - single precision integer arithmetic (part 1)
 420 \
 421
 422 : u/mod 0 swap mu/mod drop ;
 423 : 1+ 1 + ;
 424 : 1- 1 - ;
 425 : 2+ 2 + ;
 426 : 2- 2 - ;
 427 : even 1+ -2 and ;
 428 : bounds over + swap ;
 429
 430 \
 431 \ 7.3.2.2 bitwise logical operators
 432 \
 433 : << lshift ;
 434 : >> rshift ;
 435 : 2* 1 lshift ;
 436 : u2/ 1 rshift ;
 437 : 2/ 1 >>a ;
 438 : not invert ;
 439
 440 \
 441 \ 7.3.2.3 double number arithmetic
 442 \
 443
 444 : s>d      dup 0 < ;
 445 : dnegate  0 0 2swap d- ;
 446 : dabs     dup 0 < if dnegate then ;
 447 : um/mod   mu/mod drop ;
 448
 449 \ symmetric division
 450 : sm/rem  ( d n -- rem quot )
 451   over >r >r dabs r@ abs um/mod r> 0 <
 452   if
 453     negate
 454   then
 455   r> 0 < if
 456     negate swap negate swap
 457   then
 458   ;
 459
 460 \ floored division
 461 : fm/mod ( d n -- rem quot )
 462   dup >r 2dup xor 0 < >r sm/rem over 0 <> r> and if
 463     1 - swap r> + swap exit
 464   then
 465   r> drop
 466   ;
 467
 468 \
 469 \ 7.3.2.1 - single precision integer arithmetic (part 2)
 470 \
 471
 472 : */mod ( n1 n2 n3 -- quot rem ) >r m* r> fm/mod  ;
 473 : */ ( n1 n2 n3 -- n1*n2/n3 ) */mod nip ;
 474 : /mod >r s>d r> fm/mod ;
 475 : mod /mod drop ;
 476 : / /mod nip ;
 477
 478
 479 \
 480 \ 7.3.2.4 Data type conversion
 481 \
 482
 483 : lwsplit ( quad -- w.lo w.hi )
 484   dup ffff and swap 10 rshift ffff and
 485 ;
 486
 487 : wbsplit ( word -- b.lo b.hi )
 488   dup ff and swap 8 rshift ff and
 489 ;
 490
 491 : lbsplit ( quad -- b.lo b2 b3 b.hi )
 492   lwsplit swap wbsplit rot wbsplit
 493 ;
 494
 495 : bwjoin ( b.lo b.hi -- word )
 496   ff and 8 lshift swap ff and or
 497 ;
 498
 499 : wljoin ( w.lo w.hi -- quad )
 500   ffff and 10 lshift swap ffff and or
 501 ;
 502
 503 : bljoin ( b.lo b2 b3 b.hi -- quad )
 504   bwjoin -rot bwjoin swap wljoin
 505 ;
 506
 507 : wbflip ( word -- word ) \ flips bytes in a word
 508   dup 8 rshift ff and swap ff and bwjoin
 509 ;
 510
 511 : lwflip ( q1 -- q2 )
 512   dup 10 rshift ffff and swap ffff and wljoin
 513 ;
 514
 515 : lbflip ( q1 -- q2 )
 516   dup 10 rshift ffff and wbflip swap ffff and wbflip wljoin
 517 ;
 518
 519 \
 520 \ 7.3.2.5 address arithmetic
 521 \
 522
 523 : /c* /c * ;
 524 : /w* /w * ;
 525 : /l* /l * ;
 526 : /n* /n * ;
 527 : ca+ /c* + ;
 528 : wa+ /w* + ;
 529 : la+ /l* + ;
 530 : na+ /n* + ;
 531 : ca1+ /c + ;
 532 : wa1+ /w + ;
 533 : la1+ /l + ;
 534 : na1+ /n + ;
 535 : aligned /n 1- + /n negate and ;
 536 : char+ ca1+ ;
 537 : cell+ na1+ ;
 538 : chars /c* ;
 539 : cells /n* ;
 540 /n constant cell
 541
 542 \
 543 \ 7.3.6 Comparison operators
 544 \
 545
 546 : <= > not ;
 547 : >= < not ;
 548 : 0= 0 = ;
 549 : 0<= 0 <= ;
 550 : 0< 0 < ;
 551 : 0<> 0 <> ;
 552 : 0> 0 > ;
 553 : 0>=  0 >= ;
 554 : u<= u> not ;
 555 : u>= u< not ;
 556 : within  >r over > swap r> >= or not ;
 557 : between 1 + within ;
 558
 559 \
 560 \ 7.3.3.1 Memory access
 561 \
 562
 563 : 2@ dup cell+ @ swap @  ;
 564 : 2! dup >r ! r> cell+ ! ;
 565
 566 : <w@ w@ dup 8000 >= if 10000 - then ;
 567
 568 : comp ( str1 str2 len -- 0|1|-1 )
 569   >r 0 -rot r>
 570   bounds ?do
 571     dup c@ i c@ - dup if
 572       < if 1 else -1 then swap leave
 573     then
 574     drop ca1+
 575   loop
 576   drop
 577 ;
 578
 579 \ compare two string
 580
 581 : $= ( str1 len1 str2 len2 -- true|false )
 582     rot ( str1 str2 len2 len1 )
 583     over ( str1 str2 len2 len1 len2 )
 584     <> if ( str1 str2 len2 )
 585         3drop
 586         false
 587     else ( str1 str2 len2 )
 588         comp
 589         0=
 590     then
 591 ;
 592
 593 \ : +! tuck @ + swap ! ;
 594 : off false swap ! ;
 595 : on true swap ! ;
 596 : blank bl fill ;
 597 : erase 0 fill ;
 598 : wbflips ( waddr len -- )
 599   bounds do i w@ wbflip i w! /w +loop
 600 ;
 601
 602 : lwflips ( qaddr len -- )
 603   bounds do i l@ lwflip i l! /l +loop
 604 ;
 605
 606 : lbflips ( qaddr len -- )
 607   bounds do i l@ lbflip i l! /l +loop
 608 ;
 609
 610
 611 \
 612 \ 7.3.8.6    Error handling (part 1)
 613 \
 614
 615 variable catchframe
 616 0 catchframe !
 617
 618 : catch
 619   my-self >r
 620   depth >r
 621   catchframe @ >r
 622   rdepth catchframe !
 623   execute
 624   r> catchframe !
 625   r> r> 2drop 0
 626   ;
 627
 628 : throw
 629   ?dup if
 630     catchframe @ rdepth!
 631     r> catchframe !
 632     r> swap >r depth!
 633     drop r>
 634     r> ['] my-self (to)
 635   then
 636   ;
 637
 638 \
 639 \ 7.3.3.2 memory allocation
 640 \
 641
 642 include memory.fs
 643
 644
 645 \
 646 \ 7.3.4.4 Console output (part 1)
 647 \
 648
 649 defer emit
 650
 651 : type bounds ?do i c@ emit loop ;
 652
 653 \ this one obviously only works when called
 654 \ with a forth string as count fetches addr-1.
 655 \ openfirmware has no such req. therefore it has to go:
 656
 657 \ : type 0 do count emit loop drop ;
 658
 659
 660 \
 661 \ 7.3.4.1 Text Input
 662 \
 663
 664 0 value source-id
 665 0 value ib
 666 variable #ib 0 #ib !
 667 variable >in 0 >in !
 668
 669 : source ( -- addr len )
 670   ib #ib @
 671   ;
 672
 673 : /string  ( c-addr1 u1 n -- c-addr2 u2 )
 674    tuck - -rot + swap
 675 ;
 676
 677
 678 \
 679 \ pockets implementation for 7.3.4.1
 680
 681 100 constant pocketsize
 682 4   constant numpockets
 683 variable pockets 0 pockets !
 684 variable whichpocket 0 whichpocket !
 685
 686 \ allocate 4 pockets to begin with
 687 : init-pockets     ( -- )
 688   pocketsize numpockets * alloc-mem pockets !
 689   ;
 690
 691 : pocket ( ?? -- ?? )
 692   pocketsize whichpocket @ *
 693   pockets @ +
 694   whichpocket @ 1 + numpockets mod
 695   whichpocket !
 696   ;
 697
 698 \ span variable from 7.3.4.2
 699 variable span 0 span !
 700
 701 \ if char is bl then any control character is matched
 702 : findchar ( str len char -- offs true | false )
 703   swap 0 do
 704     over i + c@
 705     over dup bl = if <= else = then if
 706       2drop i dup dup leave
 707       \ i nip nip true exit \ replaces above
 708     then
 709   loop
 710   =
 711   \ drop drop false
 712   ;
 713
 714 : parse ( delim  text<delim>  -- str len )
 715   >r              \ save delimiter
 716   ib >in @ +
 717   span @ >in @ -  \ ib+offs len-offset.
 718   dup 0 < if      \ if we are already at the end of the string, return an empty string
 719     + 0           \ move to end of input string
 720     r> drop
 721     exit
 722   then
 723   2dup r>         \ ib+offs len-offset ib+offs len-offset delim
 724   findchar if     \ look for the delimiter.
 725     nip dup 1+
 726   else
 727      dup
 728   then
 729   >in +!
 730   \ dup -1 = if drop 0 then \ workaround for negative length
 731   ;
 732
 733 : skipws ( -- )
 734   ib span @        ( -- ib recvchars )
 735   begin
 736     dup >in @ > if    ( -- recvchars>offs )
 737       over >in @ +
 738       c@ bl <=
 739     else
 740       false
 741     then
 742   while
 743       1 >in +!
 744   repeat
 745   2drop
 746   ;
 747
 748 : parse-word (  < >text< >  -- str len )
 749   skipws bl parse
 750   ;
 751
 752 : word ( delim  <delims>text<delim>  -- pstr )
 753   pocket >r parse dup r@ c! bounds r> dup 2swap
 754   do
 755     char+ i c@ over c!
 756   loop
 757   drop
 758   ;
 759
 760 : ( 29 parse 2drop ; immediate
 761 : \ span @ >in !   ; immediate
 762
 763
 764
 765 \
 766 \ 7.3.4.7 String literals
 767 \
 768
 769 : ",
 770   bounds ?do
 771     i c@ c,
 772   loop
 773   ;
 774
 775 : (")  ( -- addr len )
 776   r> dup
 777   2 cells +                   ( r-addr addr )
 778   over cell+ @                ( r-addr addr len )
 779   rot over + aligned cell+ >r ( addr len R: r-addr )
 780   ;
 781
 782 : handle-text ( temp-addr len -- addr len )
 783   state @ if
 784     ['] (") , dup , ", null-align
 785   else
 786     pocket swap
 787     dup >r
 788     0 ?do
 789       over i + c@ over i + c!
 790     loop
 791     nip r>
 792   then
 793   ;
 794
 795 : s"
 796   22 parse handle-text
 797   ; immediate
 798
 799
 800
 801 \
 802 \ 7.3.4.4 Console output (part 2)
 803 \
 804
 805 : ."
 806   22 parse handle-text
 807   ['] type
 808   state @ if
 809     ,
 810   else
 811     execute
 812   then
 813   ; immediate
 814
 815 : .(
 816   29 parse handle-text
 817   ['] type
 818   state @ if
 819     ,
 820   else
 821     execute
 822   then
 823   ; immediate
 824
 825
 826
 827 \
 828 \ 7.3.4.8 String manipulation
 829 \
 830
 831 : count ( pstr -- str len ) 1+ dup 1- c@ ;
 832
 833 : pack  ( str len addr -- pstr )
 834   2dup c!     \ store len
 835   1+ swap 0 ?do
 836     over i + c@ over i + c!
 837   loop nip 1-
 838   ;
 839
 840 : lcc   ( char1 -- char2 ) dup 41 5a between if 20 + then ;
 841 : upc   ( char1 -- char2 ) dup 61 7a between if 20 - then ;
 842
 843 : -trailing ( str len1 -- str len2 )
 844   begin
 845     dup 0<> if  \ len != 0 ?
 846       2dup 1- +
 847       c@ bl =
 848     else
 849       false
 850     then
 851   while
 852     1-
 853   repeat
 854   ;
 855
 856
 857 \
 858 \ 7.3.4.5   Output formatting
 859 \
 860
 861 : cr linefeed emit ;
 862 : (cr carret emit ;
 863 : space bl emit ;
 864 : spaces 0 ?do space loop ;
 865 variable #line 0 #line !
 866 variable #out  0 #out  !
 867
 868
 869 \
 870 \ 7.3.9.2.3 Dictionary search
 871 \
 872
 873 \ helper functions
 874
 875 : lfa2name ( lfa -- name len )
 876   1-                   \ skip flag byte
 877   begin                \ skip 0 padding
 878     1- dup c@ ?dup
 879   until
 880   7f and               \ clear high bit in length
 881
 882   tuck - swap          ( ptr-to-len len - name len )
 883   ;
 884
 885 : comp-nocase ( str1 str2 len -- true|false )
 886   0 do
 887     2dup i + c@ upc    ( str1 str2 byteX )
 888     swap i + c@ upc ( str1 str2 byte1 byte2 )
 889     <> if
 890       0 leave
 891     then
 892   loop
 893   if -1 else drop 0 then
 894   swap drop
 895   ;
 896
 897 : comp-word ( b-str len lfa -- true | false )
 898   lfa2name        ( str len str len -- )
 899   >r swap r>      ( str str len len )
 900   over = if       ( str str len )
 901     comp-nocase
 902   else
 903     drop drop drop false   \ if len does not match, string does not match
 904   then
 905 ;
 906
 907 \ $find is an fcode word, but we place it here since we use it for find.
 908
 909 : find-wordlist ( name-str name-len last -- xt true | name-str name-len false )
 910
 911   @ >r
 912
 913   begin
 914     2dup r@ dup if comp-word dup false = then
 915   while
 916     r> @ >r drop
 917   repeat
 918
 919   r@ if \ successful?
 920     -rot 2drop r> cell+ swap
 921   else
 922     r> drop drop drop false
 923   then
 924
 925   ;
 926
 927 : $find ( name-str name-len -- xt true | name-str name-len false )
 928   vocabularies? if
 929     #order @ 0 ?do
 930       i cells context + @
 931       find-wordlist
 932       ?dup if
 933         unloop exit
 934       then
 935     loop
 936     false
 937   else
 938     forth-last find-wordlist
 939   then
 940   ;
 941
 942 \ look up a word in the current wordlist
 943 : $find1 ( name-str name-len -- xt true | name-str name-len false )
 944   vocabularies? if
 945     current @
 946   else
 947     forth-last
 948   then
 949   find-wordlist
 950   ;
 951
 952
 953 : '
 954   parse-word $find 0= if
 955     type 3a emit -13 throw
 956   then
 957   ;
 958
 959 : [']
 960   parse-word $find 0= if
 961     type 3a emit -13 throw
 962   then
 963   state @ if
 964     ['] (lit) , ,
 965   then
 966   ; immediate
 967
 968 : find ( pstr -- xt n | pstr false )
 969   dup count $find           \  pstr xt true | pstr name-str name-len false
 970   if
 971     nip true
 972     over immediate? if
 973       negate                \ immediate returns 1
 974     then
 975   else
 976     2drop false
 977   then
 978   ;
 979
 980
 981 \
 982 \ 7.3.9.2.2 Immediate words (part 2)
 983 \
 984
 985 : literal ['] (lit) , , ; immediate
 986 : compile, , ; immediate
 987 : compile r> cell+ dup @ , >r ;
 988 : [compile] ['] ' execute , ; immediate
 989
 990 : postpone
 991   parse-word $find if
 992     dup immediate? not if
 993       ['] (lit) , , ['] ,
 994     then
 995     ,
 996   else
 997     s" undefined word " type type cr
 998   then
 999   ; immediate
1000
1001
1002 \
1003 \ 7.3.9.2.4 Miscellaneous dictionary (part 2)
1004 \
1005
1006 variable #instance
1007
1008 : instance ( -- )
1009   true #instance !
1010 ;
1011
1012 : #instance-base
1013   my-self dup if @ then
1014 ;
1015
1016 : #instance-offs
1017   my-self dup if na1+ then
1018 ;
1019
1020 \ the following instance words are used internally
1021 \ to implement variable instantiation.
1022
1023 : instance-cfa? ( cfa -- true | false )
1024   b e within                              \ b,c and d are instance defining words
1025 ;
1026
1027 : behavior ( xt-defer -- xt )
1028   dup @ instance-cfa? if
1029     #instance-base ?dup if
1030       swap na1+ @ + @
1031     else
1032       3 /n* + @
1033     then
1034   else
1035     na1+ @
1036   then
1037 ;
1038
1039 : (ito) ( xt-new xt-defer -- )
1040   #instance-base ?dup if
1041     swap na1+ @ + !
1042   else
1043     3 /n* + !
1044   then
1045 ;
1046
1047 : to
1048   ['] ' execute
1049   dup @ instance-cfa?
1050   state @ if
1051     swap ['] (lit) , , if ['] (ito) else ['] (to) then ,
1052   else
1053     if (ito) else /n + ! then
1054   then
1055   ; immediate
1056
1057 : is ( xt "wordname<>" -- )
1058   parse-word $find if
1059     (to)
1060   else
1061     s" could not find " type type
1062   then
1063   ;
1064
1065 \
1066 \ 7.3.4.2 Console Input
1067 \
1068
1069 defer key?
1070 defer key
1071
1072 : accept ( addr len -- len2 )
1073   tuck 0 do
1074     key
1075     dup linefeed = if
1076       space drop drop drop i 0 leave
1077     then
1078     dup emit over c! 1 +
1079   loop
1080   drop ( cr )
1081   ;
1082
1083 : expect ( addr len -- )
1084   accept span !
1085   ;
1086
1087
1088 \
1089 \ 7.3.4.3 ASCII constants (part 2)
1090 \
1091
1092 : handle-lit
1093   state @ if
1094     2 = if
1095       ['] (lit) ,  ,
1096     then
1097     ['] (lit) ,  ,
1098   else
1099     drop
1100   then
1101   ;
1102
1103 : char
1104   parse-word 0<> if c@ else s" Unexpected EOL." type cr then ;
1105   ;
1106
1107 : ascii  char 1 handle-lit ; immediate
1108 : [char] char 1 handle-lit ; immediate
1109
1110 : control
1111   char bl 1- and 1 handle-lit
1112 ; immediate
1113
1114
1115
1116 \
1117 \ 7.3.8.6    Error handling (part 2)
1118 \
1119
1120 : abort
1121   -1 throw
1122   ;
1123
1124 : abort"
1125   ['] if execute
1126   22 parse handle-text
1127   ['] type ,
1128   ['] (lit) ,
1129   -2 ,
1130   ['] throw ,
1131   ['] then execute
1132   ; compile-only
1133
1134 \
1135 \ 7.5.3.1 Dictionary search
1136 \
1137
1138 \ this does not belong here, but its nice for testing
1139
1140 : words ( -- )
1141   last
1142   begin @
1143     ?dup while
1144     dup lfa2name
1145
1146     \ Don't print spaces for headerless words
1147     dup if
1148       type space
1149     else
1150       type
1151     then
1152
1153   repeat
1154   cr
1155   ;
1156
1157 \
1158 \ 7.3.5.4 Numeric output primitives
1159 \
1160
1161 false value capital-hex?
1162
1163 : pad       ( -- addr )      here 100 + aligned ;
1164
1165 : todigit   ( num -- ascii )
1166   dup 9 > if
1167     capital-hex? not if
1168       20 +
1169     then
1170     7 +
1171   then
1172   30 +
1173   ;
1174
1175 : <#   pad dup ! ;
1176 : hold pad dup @ 1- tuck swap ! c! ;
1177 : sign
1178   0< if
1179     2d hold
1180   then
1181   ;
1182
1183 : #    base @ mu/mod rot todigit hold ;
1184 : #s   begin # 2dup or 0= until ;
1185 : #>   2drop pad dup @ tuck - ;
1186 : (.)  <# dup >r abs 0 #s r> sign #> ;
1187
1188 : u#   base @ u/mod swap todigit hold ;
1189 : u#s  begin u# dup 0= until ;
1190 : u#> 0 #> ;
1191 : (u.) <# u#s u#> ;
1192
1193 \
1194 \ 7.3.5.3 Numeric output
1195 \
1196
1197 : .    (.) type space ;
1198 : s.   . ;
1199 : u.   (u.) type space ;
1200 : .r   swap (.) rot 2dup < if over - spaces else drop then type ;
1201 : u.r  swap (u.) rot 2dup < if over - spaces else drop then type ;
1202 : .d   base @ swap decimal . base ! ;
1203 : .h   base @ swap hex . base ! ;
1204
1205 : .s
1206   3c emit depth dup (.) type 3e emit space
1207   0
1208   ?do
1209     depth i - 1- pick .
1210   loop
1211   cr
1212   ;
1213
1214 \
1215 \ 7.3.5.2 Numeric input
1216 \
1217
1218 : digit ( char base -- n true | char false )
1219   swap dup upc dup
1220   41 5a ( A - Z ) between if
1221     7 -
1222   else
1223     dup 39 > if \ protect from : and ;
1224       -rot 2drop false exit
1225     then
1226   then
1227
1228   30 ( number 0 ) - rot over swap 0 swap within  if
1229     nip true
1230   else
1231     drop false
1232   then
1233   ;
1234
1235 : >number
1236    begin
1237       dup
1238    while
1239       over c@ base @ digit 0= if
1240          drop exit
1241       then  >r 2swap r> swap base @ um* drop rot base @ um* d+ 2swap
1242       1 /string
1243    repeat
1244    ;
1245
1246 : numdelim?
1247    dup 2e = swap 2c = or
1248 ;
1249
1250
1251 : $dnumber?
1252    0 0 2swap dup 0= if
1253       2drop 2drop 0 exit
1254    then  over c@ 2d = dup >r negate /string begin
1255       >number dup 1 >
1256    while
1257       over c@ numdelim? 0= if
1258          2drop 2drop r> drop 0 exit
1259       then  1 /string
1260    repeat if
1261       c@ 2e = if
1262          true
1263       else
1264          2drop r> drop 0 exit
1265       then
1266    else
1267       drop false
1268    then  over or if
1269       r> if
1270          dnegate
1271       then  2
1272    else
1273      drop r> if
1274          negate
1275       then  1
1276    then
1277 ;
1278
1279
1280 : $number (  )
1281    $dnumber?
1282    case
1283    0 of   true endof
1284    1 of   false endof
1285    2 of   drop false endof
1286    endcase
1287 ;
1288
1289 : d#
1290   parse-word
1291   base @ >r
1292
1293   decimal
1294
1295   $number if
1296     s" illegal number" type cr 0
1297   then
1298   r> base !
1299   1 handle-lit
1300   ; immediate
1301
1302 : h#
1303   parse-word
1304   base @ >r
1305
1306   hex
1307
1308   $number if
1309     s" illegal number" type cr 0
1310   then
1311   r> base !
1312   1 handle-lit
1313   ; immediate
1314
1315 : o#
1316   parse-word
1317   base @ >r
1318
1319   octal
1320
1321   $number if
1322     s" illegal number" type cr 0
1323   then
1324   r> base !
1325   1 handle-lit
1326   ; immediate
1327
1328
1329 \
1330 \ 7.3.4.7 String Literals (part 2)
1331 \
1332
1333 : "
1334   pocket dup
1335   begin
1336     span @ >in @ > if
1337       22 parse >r         ( pocket pocket str  R: len )
1338       over r@ move        \ copy string
1339       r> +                ( pocket nextdest )
1340       ib >in @ + c@       ( pocket nextdest nexchar )
1341       1 >in +!
1342       28 =                \ is nextchar a parenthesis?
1343       span @ >in @ >      \ more input?
1344       and
1345     else
1346       false
1347     then
1348   while
1349     29 parse              \ parse everything up to the next ')'
1350     bounds ?do
1351       i c@ 10 digit if
1352         i 1+ c@ 10 digit if
1353           swap 4 lshift or
1354         else
1355           drop
1356         then
1357         over c! 1+
1358         2
1359       else
1360         drop 1
1361       then
1362     +loop
1363   repeat
1364   over -
1365   handle-text
1366 ; immediate
1367
1368
1369 \
1370 \ 7.3.3.1 Memory Access (part 2)
1371 \
1372
1373 : dump ( addr len -- )
1374   over + swap
1375   cr
1376   do i u. space
1377     10 0 do
1378       j i + c@
1379       dup 10 / todigit emit
1380       10 mod todigit emit
1381       space
1382       i 7 = if space then
1383     loop
1384     3 spaces
1385     10 0 do
1386       j i + c@
1387       dup 20 < if drop 2e then \ non-printables as dots?
1388       emit
1389     loop
1390     cr
1391   10 +loop
1392 ;
1393
1394
1395
1396 \
1397 \ 7.3.9.1 Defining words
1398 \
1399
1400 : header ( name len -- )
1401   dup if                            \ might be a noname...
1402     2dup $find1 if
1403       drop 2dup type s"  isn't unique." type cr
1404     else
1405       2drop
1406     then
1407   then
1408   null-align
1409   dup -rot ", 80 or c,              \ write name and len
1410   here /n 1- and 0= if 0 c, then    \ pad and space for flags
1411   null-align
1412   80 here 1- c!                     \ write flags byte
1413   here last @ , latest !            \ write backlink and set latest
1414  ;
1415
1416
1417 : :
1418   parse-word header
1419   1 , ]
1420   ;
1421
1422 : :noname
1423   0 0 header
1424   here
1425   1 , ]
1426   ;
1427
1428 : ;
1429   ['] (semis) , reveal ['] [ execute
1430   ; immediate
1431
1432 : constant
1433   parse-word header
1434   3 , ,                             \ compile DOCON and value
1435   reveal
1436   ;
1437
1438 0 value active-package
1439 : instance, ( size -- )
1440   \ first word of the device node holds the instance size
1441   dup active-package @ dup rot + active-package !
1442   , ,      \ offset size
1443 ;
1444
1445 : instance? ( -- flag )
1446   #instance @ dup if
1447     false #instance !
1448   then
1449 ;
1450
1451 : value
1452   parse-word header
1453   instance? if
1454     /n b , instance, ,              \ DOIVAL
1455   else
1456     3 , ,
1457   then
1458   reveal
1459   ;
1460
1461 : variable
1462   parse-word header
1463   instance? if
1464     /n c , instance, 0 ,
1465   else
1466     4 , 0 ,
1467   then
1468   reveal
1469   ;
1470
1471 : $buffer: ( size str len -- where )
1472   header
1473   instance? if
1474     /n over /n 1- and - /n 1- and +     \ align buffer size
1475     dup c , instance,                   \ DOIVAR
1476   else
1477     4 ,
1478   then
1479   here swap
1480   2dup 0 fill                            \ zerofill
1481   allot
1482   reveal
1483 ;
1484
1485 : buffer: ( size -- )
1486   parse-word $buffer: drop
1487 ;
1488
1489 : (undefined-defer)  ( -- )
1490   \ XXX: this does not work with behavior ... execute
1491   r@ 2 cells - lfa2name
1492   s" undefined defer word " type type cr ;
1493
1494 : (undefined-idefer)  ( -- )
1495   s" undefined idefer word " type cr ;
1496
1497 : defer  (  new-name< >  -- )
1498   parse-word header
1499   instance? if
1500     2 /n* d , instance,                 \ DOIDEFER
1501     ['] (undefined-idefer)
1502   else
1503     5 ,
1504     ['] (undefined-defer)
1505   then
1506   ,
1507   ['] (semis) ,
1508   reveal
1509   ;
1510
1511 : alias  (  new-name< >old-name< >  -- )
1512   parse-word
1513   parse-word $find if
1514     -rot                     \ move xt behind.
1515     header
1516     1 ,                      \ fixme we want our own cfa here.
1517     ,                        \ compile old name xt
1518     ['] (semis) ,
1519     reveal
1520   else
1521     s" undefined word " type type space
1522     2drop
1523   then
1524   ;
1525
1526 : $create
1527   header 6 ,
1528   ['] noop ,
1529   reveal
1530   ;
1531
1532 : create
1533   parse-word $create
1534   ;
1535
1536 : (does>)
1537   r> cell+              \ get address of code to execute
1538   latest @              \ backlink of just "create"d word
1539   cell+ cell+ !         \ write code to execute after the
1540                         \ new word's CFA
1541   ;
1542
1543 : does>
1544   ['] (does>) ,         \ compile does handling
1545   1 ,                   \ compile docol
1546   ; immediate
1547
1548 0 constant struct
1549
1550 : field
1551   create
1552     over ,
1553     +
1554   does>
1555     @ +
1556   ;
1557
1558 : 2constant
1559   create , ,
1560   does> 2@ reveal
1561   ;
1562
1563 \
1564 \ initializer for the temporary compile buffer
1565 \
1566
1567 : init-tmp-comp
1568   here 200 allot tmp-comp-buf !
1569 ;
1570
1571 \ the end