diff options
Diffstat (limited to 'qemu/roms/openbios/forth/lib')
| -rw-r--r-- | qemu/roms/openbios/forth/lib/64bit.fs | 128 | ||||
| -rw-r--r-- | qemu/roms/openbios/forth/lib/build.xml | 22 | ||||
| -rw-r--r-- | qemu/roms/openbios/forth/lib/creation.fs | 52 | ||||
| -rw-r--r-- | qemu/roms/openbios/forth/lib/lists.fs | 26 | ||||
| -rw-r--r-- | qemu/roms/openbios/forth/lib/locals.fs | 197 | ||||
| -rw-r--r-- | qemu/roms/openbios/forth/lib/preinclude.fs | 11 | ||||
| -rw-r--r-- | qemu/roms/openbios/forth/lib/preprocessor.fs | 76 | ||||
| -rw-r--r-- | qemu/roms/openbios/forth/lib/split.fs | 49 | ||||
| -rw-r--r-- | qemu/roms/openbios/forth/lib/string.fs | 127 | ||||
| -rw-r--r-- | qemu/roms/openbios/forth/lib/vocabulary.fs | 153 |
10 files changed, 841 insertions, 0 deletions
diff --git a/qemu/roms/openbios/forth/lib/64bit.fs b/qemu/roms/openbios/forth/lib/64bit.fs new file mode 100644 index 000000000..239ddd028 --- /dev/null +++ b/qemu/roms/openbios/forth/lib/64bit.fs @@ -0,0 +1,128 @@ +\ +\ Copyright (C) 2009 Stefan Reinauer +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +\ Implementation of IEEE Draft Std P1275.6/D5 +\ Standard for Boot (Initialization Configuration) Firmware +\ 64 Bit Extensions + + +cell /x = constant 64bit? + +64bit? [IF] + +: 32>64 ( 32bitsigned -- 64bitsigned ) + dup 80000000 and if \ is it negative? + ffffffff00000000 or \ then set all high bits + then +; + +: 64>32 ( 64bitsigned -- 32bitsigned ) + h# ffffffff and +; + +: lxjoin ( quad.lo quad.hi -- o ) + d# 32 lshift or +; + +: wxjoin ( w.lo w.2 w.3 w.hi -- o ) + wljoin >r wljoin r> lxjoin +; + +: bxjoin ( b.lo b.2 b.3 b.4 b.5 b.6 b.7 b.hi -- o ) + bljoin >r bljoin r> lxjoin +; + +: <l@ ( qaddr -- n ) + l@ 32>64 +; + +: unaligned-x@ ( addr - o ) + dup la1+ unaligned-l@ 64>32 swap unaligned-l@ 64>32 lxjoin +; + +: unaligned-x! ( o oaddr -- ) + >r dup d# 32 rshift r@ unaligned-l! + h# ffffffff and r> la1+ unaligned-l! +; + +: x@ ( oaddr -- o ) + unaligned-x@ \ for now +; + +: x! ( o oaddr -- ) + unaligned-x! \ for now +; + +: (rx@) ( oaddr - o ) + x@ +; + +: (rx!) ( o oaddr -- ) + x! +; + +: x, ( o -- ) + here /x allot x! +; + +: /x* ( nu1 -- nu2 ) + /x * +; + +: xa+ ( addr1 index -- addr2 ) + /x* + +; + +: xa1+ ( addr1 -- addr2 ) + /x + +; + +: xlsplit ( o -- quad.lo quad.hi ) + dup h# ffffffff and swap d# 32 rshift +; + +: xwsplit ( o -- w.lo w.2 w.3 w.hi ) + xlsplit >r lwsplit r> lwsplit +; + +: xbsplit ( o -- b.lo b.2 b.3 b.4 b.5 b.6 b.7 b.hi ) + xlsplit >r lbsplit r> lbsplit +; + +: xlflip ( oct1 -- oct2 ) + xlsplit swap lxjoin +; + +: xlflips ( oaddr len -- ) + bounds ?do + i unaligned-x@ xlflip i unaligned-x! + /x +loop +; + +: xwflip ( oct1 -- oct2 ) + xlsplit lwflip swap lwflip lxjoin +; + +: xwflips ( oaddr len -- ) + bounds ?do + i unaligned-x@ xwflip i unaligned-x! /x + +loop +; + +: xbflip ( oct1 -- oct2 ) + xlsplit lbflip swap lbflip lxjoin +; + +: xbflips ( oaddr len -- ) + bounds ?do + i unaligned-x@ xbflip i unaligned-x! + /x +loop +; + +\ : b(lit) b(lit) 32>64 ; + +[THEN] diff --git a/qemu/roms/openbios/forth/lib/build.xml b/qemu/roms/openbios/forth/lib/build.xml new file mode 100644 index 000000000..34eee4072 --- /dev/null +++ b/qemu/roms/openbios/forth/lib/build.xml @@ -0,0 +1,22 @@ +<build> + <!-- + build description for openbios forth library functions + + Copyright (C) 2003-2005 by Stefan Reinauer + See the file "COPYING" for further information about + the copyright and warranty status of this work. + --> + + <dictionary name="openbios" target="forth"> + <object source="vocabulary.fs"/> + <object source="string.fs"/> + <object source="preprocessor.fs"/> + <object source="preinclude.fs" /> <!-- FIXME dependencies --> + <object source="creation.fs"/> + <object source="split.fs"/> + <object source="lists.fs"/> + <object source="64bit.fs"/> + <object source="locals.fs"/> + </dictionary> + +</build> diff --git a/qemu/roms/openbios/forth/lib/creation.fs b/qemu/roms/openbios/forth/lib/creation.fs new file mode 100644 index 000000000..c3d0db84c --- /dev/null +++ b/qemu/roms/openbios/forth/lib/creation.fs @@ -0,0 +1,52 @@ +\ tag: misc useful functions +\ +\ C bindings +\ +\ Copyright (C) 2003, 2004 Samuel Rydh +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +\ return xt of the word just defined +: last-xt ( -- xt ) + latest @ na1+ +; + +\ ------------------------------------------------------------------------- +\ word creation +\ ------------------------------------------------------------------------- + +: $is-ibuf ( size name name-len -- xt ) + instance $buffer: drop + last-xt +; + +: is-ibuf ( size -- xt ) + 0 0 $is-ibuf +; + +: is-ivariable ( size name len -- xt ) + 4 -rot instance $buffer: drop + last-xt +; + +: is-xt-func ( xt|0 wordstr len ) + header 1 , + ?dup if , then + ['] (semis) , reveal +; + +: is-2xt-func ( xt1 xt2 wordstr len ) + header 1 , + swap , , + ['] (semis) , reveal +; + +: is-func-begin ( wordstr len ) + header 1 , +; + +: is-func-end ( wordstr len ) + ['] (semis) , reveal +; diff --git a/qemu/roms/openbios/forth/lib/lists.fs b/qemu/roms/openbios/forth/lib/lists.fs new file mode 100644 index 000000000..91f7867b9 --- /dev/null +++ b/qemu/roms/openbios/forth/lib/lists.fs @@ -0,0 +1,26 @@ +\ tag: misc useful functions +\ +\ Misc useful functions +\ +\ Copyright (C) 2003 Samuel Rydh +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +\ ------------------------------------------------------------------------- +\ statically allocated lists +\ ------------------------------------------------------------------------- +\ list-head should be a variable + +: list-add ( listhead -- ) + here 0 , swap \ next, [data...] + ( here listhead ) + begin dup @ while @ repeat ! +; + +: list-get ( listptr -- nextlistptr dictptr true | false ) + @ dup if + dup na1+ true + then +; diff --git a/qemu/roms/openbios/forth/lib/locals.fs b/qemu/roms/openbios/forth/lib/locals.fs new file mode 100644 index 000000000..e697383b6 --- /dev/null +++ b/qemu/roms/openbios/forth/lib/locals.fs @@ -0,0 +1,197 @@ +\ tag: local variables +\ +\ Copyright (C) 2012 Mark Cave-Ayland +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +[IFDEF] CONFIG_LOCALS + +\ Init local variable stack +variable locals-var-stack +here 200 cells allot locals-var-stack ! + +\ Set initial stack pointer +\ +\ Stack looks like this: +\ ... (sp n-2) local1 ... localm-1 localm (sp n-1) <-- sp + +locals-var-stack @ value locals-var-sp +locals-var-sp locals-var-stack @ ! + +0 value locals-var-count +0 value locals-flags + +here 200 cells allot locals-dict-buf ! + +8 constant #locals + +: (local1) locals-var-sp @ /n + ; +: (local2) locals-var-sp @ 2 cells + ; +: (local3) locals-var-sp @ 3 cells + ; +: (local4) locals-var-sp @ 4 cells + ; +: (local5) locals-var-sp @ 5 cells + ; +: (local6) locals-var-sp @ 6 cells + ; +: (local7) locals-var-sp @ 7 cells + ; +: (local8) locals-var-sp @ 8 cells + ; + +: local1@ (local1) @ ; +: local2@ (local2) @ ; +: local3@ (local3) @ ; +: local4@ (local4) @ ; +: local5@ (local5) @ ; +: local6@ (local6) @ ; +: local7@ (local7) @ ; +: local8@ (local8) @ ; + +: local1! (local1) ! ; +: local2! (local2) ! ; +: local3! (local3) ! ; +: local4! (local4) ! ; +: local5! (local5) ! ; +: local6! (local6) ! ; +: local7! (local7) ! ; +: local8! (local8) ! ; + +create locals-read-table +['] local1@ , +['] local2@ , +['] local3@ , +['] local4@ , +['] local5@ , +['] local6@ , +['] local7@ , +['] local8@ , + +create locals-write-table +['] local1! , +['] local2! , +['] local3! , +['] local4! , +['] local5! , +['] local6! , +['] local7! , +['] local8! , + + +: locals-push ( n -- ) + locals-var-sp /n + to locals-var-sp + locals-var-sp ! +; + +: locals-0-push ( -- ) + 0 locals-push +; + +: (apply-local-flags) ( lfa -- ) + 1 - dup c@ locals-flags or swap c! +; + +: locals-no-pop? ( lfa -- ? ) + 1 - c@ 8 and 0<> +; + +: locals-drop \ Destroy current stack frame + locals-var-sp @ to locals-var-sp +; + +['] locals-drop to locals-end + +: (local-init) ( str len -- ) + header 1 , \ DOCOL + ['] (lit) , ['] noop , \ read-xt + ['] (lit) , ['] noop , \ write-xt + ['] 2drop , \ do nothing + ['] (lit) , + here 5 cells - , + ['] @ , ['] , , \ store read-xt + ['] (semis) , + reveal + immediate + last @ (apply-local-flags) +; + +: (local-noop) ( str len -- ) + 2drop +; + +\ Word called when consuming a local variable +defer (local) + +: } ( C: current latest here -- ) + here! latest ! current ! \ Switch back to normal dict + locals-dict-buf @ to locals-dict \ Make locals-dict visible to $find + 0 to locals-var-count + ['] locals-var-sp , \ save previous sp on rstack + ['] >r , + locals-dict @ \ ( last -- ) + begin + ?dup 0<> + while + >r + locals-var-count /n * + locals-read-table + @ r@ 3 cells + ! \ set read-xt + locals-var-count /n * + locals-write-table + @ r@ 5 cells + ! \ set write-xt + locals-var-count 1+ to locals-var-count + r@ locals-no-pop? if + ['] locals-0-push , \ initialise with 0 + else + ['] locals-push , \ initialise from stack + then + r> @ \ next lfa + repeat + ['] r> , + ['] locals-push , \ write previous sp +; immediate + +: { ( C: -- current latest here ) + current @ latest @ here + ['] (local-init) to (local) + 0 to locals-flags + 0 to locals-var-count + locals-dict-buf @ 200 cells 0 fill \ Zero out temporary dictionary + locals-dict-buf @ current ! \ Switch to locals dictionary + locals-dict-buf @ /n + here! + + begin + parse-word + 2dup s" }" strcmp 0= if + 2drop + ['] } execute -1 + else + 2dup s" ;" strcmp 0= if + 2drop + 8 to locals-flags 0 \ Don't init from stack + else + 2dup s" |" strcmp 0= if + 2drop + 8 to locals-flags 0 \ Don't init from stack + else + 2dup s" --" strcmp 0= if + 2drop + ['] (local-noop) to (local) 0 + else + locals-var-count #locals < if + (local) 0 \ accept local + else + s" maximum locals used ignoring " type type cr 0 + then + locals-var-count 1+ to locals-var-count + then + then + then + then + until +; immediate + +: -> ( n -- ) + parse-word $find if + 4 cells + @ , + else + s" unable to find word " type type + then +; immediate + +[THEN] diff --git a/qemu/roms/openbios/forth/lib/preinclude.fs b/qemu/roms/openbios/forth/lib/preinclude.fs new file mode 100644 index 000000000..6f20ea8f7 --- /dev/null +++ b/qemu/roms/openbios/forth/lib/preinclude.fs @@ -0,0 +1,11 @@ +\ +\ config and build date includes +\ +\ Copyright (C) 2005 Stefan Reinauer +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +include config.fs +include version.fs diff --git a/qemu/roms/openbios/forth/lib/preprocessor.fs b/qemu/roms/openbios/forth/lib/preprocessor.fs new file mode 100644 index 000000000..89d478cff --- /dev/null +++ b/qemu/roms/openbios/forth/lib/preprocessor.fs @@ -0,0 +1,76 @@ +\ tag: Forth preprocessor +\ +\ Forth preprocessor +\ +\ Copyright (C) 2003, 2004 Samuel Rydh +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +0 value prep-wid +0 value prep-dict +0 value prep-here + +: ([IF]) + begin + begin parse-word dup 0= while + 2drop refill + repeat + + 2dup " [IF]" strcmp 0= if 1 throw then + 2dup " [IFDEF]" strcmp 0= if 1 throw then + 2dup " [ELSE]" strcmp 0= if 2 throw then + 2dup " [THEN]" strcmp 0= if 3 throw then + " \\" strcmp 0= if linefeed parse 2drop then + again +; + +: [IF] ( flag -- ) + if exit then + 1 begin + ['] ([IF]) catch case + \ EOF (FIXME: this does not work) + \ -1 of ." Missing [THEN]" abort exit endof + \ [IF] + 1 of 1+ endof + \ [ELSE] + 2 of dup 1 = if 1- then endof + \ [THEN] + 3 of 1- endof + endcase + dup 0 <= + until drop +; immediate + +: [ELSE] 0 [ ['] [IF] , ] ; immediate +: [THEN] ; immediate + +:noname + 0 to prep-wid + 0 to prep-dict +; initializer + +: [IFDEF] ( <word> -- ) + prep-wid if + parse-word prep-wid search-wordlist dup if nip then + else 0 then + [ ['] [IF] , ] +; immediate + +: [DEFINE] ( <word> -- ) + parse-word here get-current >r >r + prep-dict 0= if + 2000 alloc-mem here! + here to prep-dict + wordlist to prep-wid + here to prep-here + then + prep-wid set-current prep-here here! + $create + here to prep-here + r> r> set-current here! +; immediate + +: [0] 0 ; immediate +: [1] 1 ; immediate diff --git a/qemu/roms/openbios/forth/lib/split.fs b/qemu/roms/openbios/forth/lib/split.fs new file mode 100644 index 000000000..1a7ac3a0a --- /dev/null +++ b/qemu/roms/openbios/forth/lib/split.fs @@ -0,0 +1,49 @@ +\ implements split-before, split-after and left-split +\ as described in 4.3 (Path resolution) + +\ delimeter returned in R-string +: split-before ( addr len delim -- addr-R len-R addr-L len-L ) + 0 rot dup >r 0 ?do + ( str char cnt R: len <sys> ) + 2 pick over + c@ 2 pick = if leave then + 1+ + loop + nip + 2dup + r> 2 pick - + 2swap +; + +\ delimeter returned in L-string +: split-after ( addr len delim -- addr-R len-R addr-L len-L ) + over 1- rot dup >r 0 ?do + ( str char cnt R: len <sys> ) + 2 pick over + c@ 2 pick = if leave then + 1- + loop + nip + dup 0 >= if 1+ else drop r@ then + 2dup + r> 2 pick - + 2swap +; + +\ delimiter not returned +: left-split ( addr len delim -- addr-R len-R addr-L len-L ) + 0 rot dup >r 0 ?do + ( str char cnt R: len <sys> ) + 2 pick i + c@ 2 pick = if leave then + 1+ + loop + nip + 2dup + 1+ r> 2 pick - + dup if 1- then + 2swap +; + +\ delimiter not returned [THIS FUNCTION IS NOT NEEDED] +: right-split ( addr len delim -- addr-R len-R addr-L len-L ) + dup >r + split-after + dup if 2dup + 1- + c@ r@ = if 1- then then + r> drop +; diff --git a/qemu/roms/openbios/forth/lib/string.fs b/qemu/roms/openbios/forth/lib/string.fs new file mode 100644 index 000000000..eb6474917 --- /dev/null +++ b/qemu/roms/openbios/forth/lib/string.fs @@ -0,0 +1,127 @@ +\ tag: misc useful functions +\ +\ Misc useful functions +\ +\ Copyright (C) 2003 Samuel Rydh +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +\ compare c-string with (str len) pair +: comp0 ( cstr str len -- 0|-1|1 ) + 3dup + comp ?dup if >r 3drop r> exit then + nip + c@ 0<> if 1 else 0 then +; + +\ returns 0 if the strings match +: strcmp ( str1 len1 str2 len2 -- 0|1 ) + rot over <> if 3drop 1 exit then + comp if 1 else 0 then +; + +: strchr ( str len char -- where|0 ) + >r + begin + 1- dup 0>= + while + ( str len ) + over c@ r@ = if r> 2drop exit then + swap 1+ swap + repeat + r> 3drop 0 +; + +: cstrlen ( cstr -- len ) + dup + begin dup c@ while 1+ repeat + swap - +; + +: strdup ( str len -- newstr len ) + dup if + dup >r + dup alloc-mem dup >r swap move + r> r> + else + 2drop 0 0 + then +; + +: dict-strdup ( str len -- dict-addr len ) + dup here swap allot null-align + swap 2dup >r >r move r> r> +; + +\ ----------------------------------------------------- +\ string copy and cat variants +\ ----------------------------------------------------- + +: tmpstrcat ( addr2 len2 addr1 len1 tmpbuf -- buf len1+len2 tmpbuf+l1+l2 ) + \ save return arguments + dup 2 pick + 4 pick + >r ( R: buf+l1+l2 ) + over 4 pick + >r + dup >r + \ copy... + 2dup + >r + swap move r> swap move + r> r> r> +; + +: tmpstrcpy ( addr1 len1 tmpbuf -- tmpbuf len1 tmpbuf+len1 ) + swap 2dup >r >r move + r> r> 2dup + +; + + + +\ ----------------------------------------------------- +\ number to string conversion +\ ----------------------------------------------------- + +: numtostr ( num buf -- buf len ) + swap rdepth -rot + ( rdepth buf num ) + begin + base @ u/mod swap + \ dup 0< if base @ + then + dup a < if ascii 0 else ascii a a - then + >r + ?dup 0= + until + + rdepth rot - 0 + ( buf len cnt ) + begin + r> over 4 pick + c! + 1+ 2dup <= + until + drop +; + +: tohexstr ( num buf -- buf len ) + base @ hex -rot numtostr rot base ! +; + +: toudecstr ( num buf -- buf len ) + base @ decimal -rot numtostr rot base ! +; + +: todecstr ( num buf -- buf len ) + over 0< if + swap negate over ascii - over c! 1+ + ( buf num buf+1 ) + toudecstr 1+ nip + else + toudecstr + then +; + + +\ ----------------------------------------------------- +\ string to number conversion +\ ----------------------------------------------------- + +: parse-hex ( str len -- value ) + base @ hex -rot $number if 0 then swap base ! +; diff --git a/qemu/roms/openbios/forth/lib/vocabulary.fs b/qemu/roms/openbios/forth/lib/vocabulary.fs new file mode 100644 index 000000000..faa75ea87 --- /dev/null +++ b/qemu/roms/openbios/forth/lib/vocabulary.fs @@ -0,0 +1,153 @@ +\ tag: vocabulary implementation for openbios +\ +\ Copyright (C) 2003 Stefan Reinauer +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +\ +\ this is an implementation of DPANS94 wordlists (SEARCH EXT) +\ + + +16 constant #vocs +create vocabularies #vocs cells allot \ word lists +['] vocabularies to context + +: search-wordlist ( c-addr u wid -- 0 | xt 1 | xt -1 ) + \ Find the definition identified by the string c-addr u in the word + \ list identified by wid. If the definition is not found, return zero. + \ If the definition is found, return its execution token xt and + \ one (1) if the definition is immediate, minus-one (-1) otherwise. + find-wordlist + if + true over immediate? if + negate + then + else + 2drop false + then + ; + +: wordlist ( -- wid ) + \ Creates a new empty word list, returning its word list identifier + \ wid. The new word list may be returned from a pool of preallocated + \ word lists or may be dynamically allocated in data space. A system + \ shall allow the creation of at least 8 new word lists in addition + \ to any provided as part of the system. + here 0 , + ; + +: get-order ( -- wid1 .. widn n ) + #order @ 0 ?do + #order @ i - 1- cells context + @ + loop + #order @ + ; + +: set-order ( wid1 .. widn n -- ) + dup -1 = if + drop forth-last 1 \ push system default word list and number of lists + then + dup #order ! + 0 ?do + i cells context + ! + loop + ; + +: order ( -- ) + \ display word lists in the search order in their search order sequence + \ from the first searched to last searched. Also display word list into + \ which new definitions will be placed. + cr + get-order 0 ?do + ." wordlist " i (.) type 2e emit space u. cr + loop + cr ." definitions: " current @ u. cr + ; + + +: previous ( -- ) + \ Transform the search order consisting of widn, ... wid2, wid1 (where + \ wid1 is searched first) into widn, ... wid2. An ambiguous condition + \ exists if the search order was empty before PREVIOUS was executed. + get-order nip 1- set-order + ; + + +: do-vocabulary ( -- ) \ implementation factor + does> + @ >r ( ) ( R: widnew ) + get-order swap drop ( wid1 ... widn-1 n ) + r> swap set-order + ; + +: discard ( x1 .. xu u - ) \ implementation factor + 0 ?do + drop + loop + ; + +: vocabulary ( >name -- ) + wordlist create , do-vocabulary + ; + +: also ( -- ) + get-order over swap 1+ set-order + ; + +: only ( -- ) + -1 set-order also + ; + +only + +\ create forth forth-wordlist , do-vocabulary +create forth get-order over , discard do-vocabulary + +: findw ( c-addr -- c-addr 0 | w 1 | w -1 ) + 0 ( c-addr 0 ) + #order @ 0 ?do + over count ( c-addr 0 c-addr' u ) + i cells context + @ ( c-addr 0 c-addr' u wid ) + search-wordlist ( c-addr 0; 0 | w 1 | w -1 ) + ?dup if ( c-addr 0; w 1 | w -1 ) + 2swap 2drop leave ( w 1 | w -1 ) + then ( c-addr 0 ) + loop ( c-addr 0 | w 1 | w -1 ) + ; + +: get-current ( -- wid ) + current @ + ; + +: set-current ( wid -- ) + current ! + ; + +: definitions ( -- ) + \ Make the compilation word list the same as the first word list in + \ the search order. Specifies that the names of subsequent definitions + \ will be placed in the compilation word list. + \ Subsequent changes in the search order will not affect the + \ compilation word list. + context @ set-current + ; + +: forth-wordlist ( -- wid ) + forth-last + ; + +: #words ( -- ) + 0 last + begin + @ ?dup + while + swap 1+ swap + repeat + + cr + ; + +true to vocabularies? |