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