1 \ tag: bootstrap of basic forth words
3 \ Copyright (C) 2003-2005 Stefan Reinauer, Patrick Mauritz
5 \ See the file "COPYING" for further information about
6 \ the copyright and warranty status of this work.
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,
17 \ often used constants (reduces dictionary size)
29 \ 7.3.5.1 Numeric-base control
41 variable current forth-last current !
47 variable #order 0 #order !
54 variable locals-dict-buf
57 \ 7.3.7 Flag constants
64 \ 7.3.9.2.2 Immediate words (part 1)
67 : (immediate) ( xt -- )
68 1 - dup c@ 1 or swap c!
72 1 - dup c@ 2 or swap c!
83 : flags? ( xt -- flags )
87 : immediate? ( xt -- true|false )
91 : compile-only? ( xt -- true|false )
95 : [ 0 state ! ; compile-only
101 \ 7.3.9.2.1 Data space allocation
104 : allot here + here! ;
105 : , here /n allot ! ;
106 : c, here /c allot c! ;
109 /n here /n 1 - and - \ how many bytes to next alignment
110 /n 1 - and allot \ mask out everything that is bigger
114 here dup align here swap - 0 fill
118 here 1 and allot \ if here is not even, we have to align.
123 /l here /l 1 - and - \ same as in align, with /l
124 /l 1 - and \ if it's /l we are already aligned.
131 \ 7.3.6 comparison operators (part 1)
138 \ 7.3.9.2.4 Miscellaneous dictionary (part 1)
141 : (to) ( xt-new xt-defer -- )
145 : >body ( xt -- a-addr ) /n 1 lshift + ;
146 : body> ( a-addr -- xt ) /n 1 lshift - ;
148 : reveal latest @ last ! ;
149 : recursive reveal ; immediate
150 : recurse latest @ /n + , ; immediate
159 ['] no-environment? ['] environment? (to)
163 \ 7.3.8.1 Conditional branches
166 \ A control stack entry is implemented using 2 data stack items
167 \ of the form ( addr type ). type can be one of the
173 : resolve-orig here nip over /n + - swap ! ;
174 : (if) ['] do?branch , here 0 0 , ; compile-only
175 : (then) resolve-orig ; compile-only
177 variable tmp-comp-depth -1 tmp-comp-depth !
178 variable tmp-comp-buf 0 tmp-comp-buf !
180 : setup-tmp-comp ( -- )
182 here tmp-comp-buf @ here! , \ save here and switch to tmp directory
184 depth tmp-comp-depth ! \ save control depth
189 : execute-tmp-comp ( -- )
190 depth tmp-comp-depth @ =
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
206 \ 7.3.8.3 Conditional loops
209 \ some dummy words for see
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
221 : resolve-dest ( dest origN ... orig )
224 \ Find topmost control stack entry with a type of 1 (dest)
225 r> dup dup pick 1 = if
271 resolve-dest resolve-orig
277 \ 7.3.8.4 Counted loops
280 variable leaves 0 leaves !
287 dup @ \ leaves -- leaves *leaves )
288 swap \ -- *leaves leaves )
289 here over - \ -- *leaves leaves here-leaves
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 ;
331 : unloop r> r> r> 2drop >r ;
341 : ?leave if leave then ;
344 \ 7.3.8.2 Case statement
376 \ 7.3.8.5 Other control flow commands
383 \ 7.3.4.3 ASCII constants (part 1)
394 \ 7.3.1.1 - stack duplication
397 : 3dup 2 pick 2 pick 2 pick ;
400 \ 7.3.1.2 - stack removal
406 \ 7.3.1.3 - stack rearrangement
409 : 2rot >r >r 2swap r> r> 2swap ;
412 \ 7.3.1.4 - return stack
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 ;
423 \ 7.3.2.1 - single precision integer arithmetic (part 1)
426 : u/mod 0 swap mu/mod drop ;
432 : bounds over + swap ;
435 \ 7.3.2.2 bitwise logical operators
445 \ 7.3.2.3 double number arithmetic
449 : dnegate 0 0 2swap d- ;
450 : dabs dup 0 < if dnegate then ;
451 : um/mod mu/mod drop ;
454 : sm/rem ( d n -- rem quot )
455 over >r >r dabs r@ abs um/mod r> 0 <
460 negate swap negate swap
465 : fm/mod ( d n -- rem quot )
466 dup >r 2dup xor 0 < >r sm/rem over 0 <> r> and if
467 1 - swap r> + swap exit
473 \ 7.3.2.1 - single precision integer arithmetic (part 2)
476 : */mod ( n1 n2 n3 -- quot rem ) >r m* r> fm/mod ;
477 : */ ( n1 n2 n3 -- n1*n2/n3 ) */mod nip ;
478 : /mod >r s>d r> fm/mod ;
484 \ 7.3.2.4 Data type conversion
487 : lwsplit ( quad -- w.lo w.hi )
488 dup ffff and swap 10 rshift ffff and
491 : wbsplit ( word -- b.lo b.hi )
492 dup ff and swap 8 rshift ff and
495 : lbsplit ( quad -- b.lo b2 b3 b.hi )
496 lwsplit swap wbsplit rot wbsplit
499 : bwjoin ( b.lo b.hi -- word )
500 ff and 8 lshift swap ff and or
503 : wljoin ( w.lo w.hi -- quad )
504 ffff and 10 lshift swap ffff and or
507 : bljoin ( b.lo b2 b3 b.hi -- quad )
508 bwjoin -rot bwjoin swap wljoin
511 : wbflip ( word -- word ) \ flips bytes in a word
512 dup 8 rshift ff and swap ff and bwjoin
515 : lwflip ( q1 -- q2 )
516 dup 10 rshift ffff and swap ffff and wljoin
519 : lbflip ( q1 -- q2 )
520 dup 10 rshift ffff and wbflip swap ffff and wbflip wljoin
524 \ 7.3.2.5 address arithmetic
539 : aligned /n 1- + /n negate and ;
547 \ 7.3.6 Comparison operators
560 : within >r over > swap r> >= or not ;
561 : between 1 + within ;
564 \ 7.3.3.1 Memory access
567 : 2@ dup cell+ @ swap @ ;
568 : 2! dup >r ! r> cell+ ! ;
570 : <w@ w@ dup 8000 >= if 10000 - then ;
572 : comp ( str1 str2 len -- 0|1|-1 )
576 < if 1 else -1 then swap leave
585 : $= ( str1 len1 str2 len2 -- true|false )
586 rot ( str1 str2 len2 len1 )
587 over ( str1 str2 len2 len1 len2 )
588 <> if ( str1 str2 len2 )
591 else ( str1 str2 len2 )
597 \ : +! tuck @ + swap ! ;
602 : wbflips ( waddr len -- )
603 bounds do i w@ wbflip i w! /w +loop
606 : lwflips ( qaddr len -- )
607 bounds do i l@ lwflip i l! /l +loop
610 : lbflips ( qaddr len -- )
611 bounds do i l@ lbflip i l! /l +loop
616 \ 7.3.8.6 Error handling (part 1)
643 \ 7.3.3.2 memory allocation
650 \ 7.3.4.4 Console output (part 1)
655 : type bounds ?do i c@ emit loop ;
657 \ this one obviously only works when called
658 \ with a forth string as count fetches addr-1.
659 \ openfirmware has no such req. therefore it has to go:
661 \ : type 0 do count emit loop drop ;
663 : debug-type bounds ?do i c@ (emit) loop ;
674 : source ( -- addr len )
678 : /string ( c-addr1 u1 n -- c-addr2 u2 )
684 \ pockets implementation for 7.3.4.1
686 100 constant pocketsize
687 4 constant numpockets
688 variable pockets 0 pockets !
689 variable whichpocket 0 whichpocket !
691 \ allocate 4 pockets to begin with
692 : init-pockets ( -- )
693 pocketsize numpockets * alloc-mem pockets !
696 : pocket ( ?? -- ?? )
697 pocketsize whichpocket @ *
699 whichpocket @ 1 + numpockets mod
703 \ span variable from 7.3.4.2
704 variable span 0 span !
706 \ if char is bl then any control character is matched
707 : findchar ( str len char -- offs true | false )
710 over dup bl = if <= else = then if
711 2drop i dup dup leave
712 \ i nip nip true exit \ replaces above
719 : parse ( delim text<delim> -- str len )
722 span @ >in @ - \ ib+offs len-offset.
723 dup 0 < if \ if we are already at the end of the string, return an empty string
724 + 0 \ move to end of input string
728 2dup r> \ ib+offs len-offset ib+offs len-offset delim
729 findchar if \ look for the delimiter.
735 \ dup -1 = if drop 0 then \ workaround for negative length
739 ib span @ ( -- ib recvchars )
741 dup >in @ > if ( -- recvchars>offs )
753 : parse-word ( < >text< > -- str len )
757 : word ( delim <delims>text<delim> -- pstr )
758 pocket >r parse dup r@ c! bounds r> dup 2swap
765 : ( 29 parse 2drop ; immediate
766 : \ span @ >in ! ; immediate
771 \ 7.3.4.7 String literals
780 : (") ( -- addr len )
782 2 cells + ( r-addr addr )
783 over cell+ @ ( r-addr addr len )
784 rot over + aligned cell+ >r ( addr len R: r-addr )
787 : handle-text ( temp-addr len -- addr len )
789 ['] (") , dup , ", null-align
794 over i + c@ over i + c!
807 \ 7.3.4.4 Console output (part 2)
833 \ 7.3.4.8 String manipulation
836 : count ( pstr -- str len ) 1+ dup 1- c@ ;
838 : pack ( str len addr -- pstr )
841 over i + c@ over i + c!
845 : lcc ( char1 -- char2 ) dup 41 5a between if 20 + then ;
846 : upc ( char1 -- char2 ) dup 61 7a between if 20 - then ;
848 : -trailing ( str len1 -- str len2 )
850 dup 0<> if \ len != 0 ?
863 \ 7.3.4.5 Output formatting
867 : debug-cr linefeed (emit) ;
870 : spaces 0 ?do space loop ;
871 variable #line 0 #line !
872 variable #out 0 #out !
876 \ 7.3.9.2.3 Dictionary search
881 : lfa2name ( lfa -- name len )
883 begin \ skip 0 padding
886 7f and \ clear high bit in length
888 tuck - swap ( ptr-to-len len - name len )
891 : comp-nocase ( str1 str2 len -- true|false )
893 2dup i + c@ upc ( str1 str2 byteX )
894 swap i + c@ upc ( str1 str2 byte1 byte2 )
899 if -1 else drop 0 then
903 : comp-word ( b-str len lfa -- true | false )
904 lfa2name ( str len str len -- )
905 >r swap r> ( str str len len )
906 over = if ( str str len )
909 drop drop drop false \ if len does not match, string does not match
913 \ $find is an fcode word, but we place it here since we use it for find.
915 : find-wordlist ( name-str name-len last -- xt true | name-str name-len false )
920 2dup r@ dup if comp-word dup false = then
926 -rot 2drop r> cell+ swap
928 r> drop drop drop false
933 : $find ( name-str name-len -- xt true | name-str name-len false )
935 locals-dict-buf @ find-wordlist ?dup if
949 forth-last find-wordlist
953 \ look up a word in the current wordlist
954 : $find1 ( name-str name-len -- xt true | name-str name-len false )
965 parse-word $find 0= if
966 type 3a emit -13 throw
971 parse-word $find 0= if
972 type 3a emit -13 throw
979 : find ( pstr -- xt n | pstr false )
980 dup count $find \ pstr xt true | pstr name-str name-len false
984 negate \ immediate returns 1
993 \ 7.3.9.2.2 Immediate words (part 2)
996 : literal ['] (lit) , , ; immediate
997 : compile, , ; immediate
998 : compile r> cell+ dup @ , >r ;
999 : [compile] ['] ' execute , ; immediate
1003 dup immediate? not if
1008 s" undefined word " type type cr
1014 \ 7.3.9.2.4 Miscellaneous dictionary (part 2)
1024 my-self dup if @ then
1028 my-self dup if na1+ then
1031 \ the following instance words are used internally
1032 \ to implement variable instantiation.
1034 : instance-cfa? ( cfa -- true | false )
1035 b e within \ b,c and d are instance defining words
1038 : behavior ( xt-defer -- xt )
1039 dup @ instance-cfa? if
1040 #instance-base ?dup if
1050 : (ito) ( xt-new xt-defer -- )
1051 #instance-base ?dup if
1061 swap ['] (lit) , , if ['] (ito) else ['] (to) then ,
1063 if (ito) else /n + ! then
1072 : is ( xt "wordname<>" -- )
1076 s" could not find " type type
1081 \ 7.3.4.2 Console Input
1087 : accept ( addr len -- len2 )
1091 space drop drop drop i 0 leave
1093 dup emit over c! 1 +
1098 : expect ( addr len -- )
1104 \ 7.3.4.3 ASCII constants (part 2)
1119 parse-word 0<> if c@ else s" Unexpected EOL." type cr then ;
1122 : ascii char 1 handle-lit ; immediate
1123 : [char] char 1 handle-lit ; immediate
1126 char bl 1- and 1 handle-lit
1132 \ 7.3.8.6 Error handling (part 2)
1141 22 parse handle-text
1150 \ 7.5.3.1 Dictionary search
1153 \ this does not belong here, but its nice for testing
1161 \ Don't print spaces for headerless words
1173 \ 7.3.5.4 Numeric output primitives
1176 false value capital-hex?
1178 : pad ( -- addr ) here 100 + aligned ;
1180 : todigit ( num -- ascii )
1191 : hold pad dup @ 1- tuck swap ! c! ;
1198 : # base @ mu/mod rot todigit hold ;
1199 : #s begin # 2dup or 0= until ;
1200 : #> 2drop pad dup @ tuck - ;
1201 : (.) <# dup >r abs 0 #s r> sign #> ;
1203 : u# base @ u/mod swap todigit hold ;
1204 : u#s begin u# dup 0= until ;
1209 \ 7.3.5.3 Numeric output
1212 : . (.) type space ;
1214 : u. (u.) type space ;
1215 : .r swap (.) rot 2dup < if over - spaces else drop then type ;
1216 : u.r swap (u.) rot 2dup < if over - spaces else drop then type ;
1217 : .d base @ swap decimal . base ! ;
1218 : .h base @ swap hex . base ! ;
1221 3c emit depth dup (.) type 3e emit space
1230 \ 7.3.5.2 Numeric input
1233 : digit ( char base -- n true | char false )
1235 41 5a ( A - Z ) between if
1238 dup 39 > if \ protect from : and ;
1239 -rot 2drop false exit
1243 30 ( number 0 ) - rot over swap 0 swap within if
1254 over c@ base @ digit 0= if
1256 then >r 2swap r> swap base @ um* drop rot base @ um* d+ 2swap
1262 dup 2e = swap 2c = or
1269 then over c@ 2d = dup >r negate /string begin
1272 over c@ numdelim? 0= if
1273 2drop 2drop r> drop 0 exit
1279 2drop r> drop 0 exit
1300 2 of drop false endof
1311 s" illegal number" type cr 0
1324 s" illegal number" type cr 0
1337 s" illegal number" type cr 0
1345 \ 7.3.4.7 String Literals (part 2)
1352 22 parse >r ( pocket pocket str R: len )
1353 over r@ move \ copy string
1354 r> + ( pocket nextdest )
1355 ib >in @ + c@ ( pocket nextdest nexchar )
1357 28 = \ is nextchar a parenthesis?
1358 span @ >in @ > \ more input?
1364 29 parse \ parse everything up to the next ')'
1385 \ 7.3.3.1 Memory Access (part 2)
1388 : dump ( addr len -- )
1394 dup 10 / todigit emit
1402 dup 20 < if drop 2e then \ non-printables as dots?
1412 \ 7.3.9.1 Defining words
1415 : header ( name len -- )
1416 dup if \ might be a noname...
1418 drop 2dup type s" isn't unique." type cr
1424 dup -rot ", 80 or c, \ write name and len
1425 here /n 1- and 0= if 0 c, then \ pad and space for flags
1427 80 here 1- c! \ write flags byte
1428 here last @ , latest ! \ write backlink and set latest
1445 0 ['] locals-dict /n + !
1448 ['] (semis) , reveal ['] [ execute
1453 3 , , \ compile DOCON and value
1457 0 value active-package
1458 : instance, ( size -- )
1459 \ first word of the device node holds the instance size
1460 dup active-package @ dup rot + active-package !
1464 : instance? ( -- flag )
1473 /n b , instance, , \ DOIVAL
1483 /n c , instance, 0 ,
1490 : $buffer: ( size str len -- where )
1493 /n over /n 1- and - /n 1- and + \ align buffer size
1494 dup c , instance, \ DOIVAR
1499 2dup 0 fill \ zerofill
1504 : buffer: ( size -- )
1505 parse-word $buffer: drop
1508 : (undefined-defer) ( -- )
1509 \ XXX: this does not work with behavior ... execute
1510 r@ 2 cells - lfa2name
1511 s" undefined defer word " type type cr ;
1513 : (undefined-idefer) ( -- )
1514 s" undefined idefer word " type cr ;
1516 : defer ( new-name< > -- )
1519 2 /n* d , instance, \ DOIDEFER
1520 ['] (undefined-idefer)
1523 ['] (undefined-defer)
1530 : alias ( new-name< >old-name< > -- )
1533 -rot \ move xt behind.
1535 1 , \ fixme we want our own cfa here.
1536 , \ compile old name xt
1540 s" undefined word " type type space
1556 r> cell+ \ get address of code to execute
1557 latest @ \ backlink of just "create"d word
1558 cell+ cell+ ! \ write code to execute after the
1563 ['] (does>) , \ compile does handling
1583 \ initializer for the temporary compile buffer
1587 here 200 allot tmp-comp-buf !