-\ @(#) misc2.fth 98/01/26 1.2\r
-\ Utilities for PForth extracted from HMSL\r
-\\r
-\ Author: Phil Burk\r
-\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom\r
-\\r
-\ The pForth software code is dedicated to the public domain,\r
-\ and any third party may reproduce, distribute and modify\r
-\ the pForth software code or any derivative works thereof\r
-\ without any compensation or license. The pForth software\r
-\ code is provided on an "as is" basis without any warranty\r
-\ of any kind, including, without limitation, the implied\r
-\ warranties of merchantability and fitness for a particular\r
-\ purpose and their equivalents under the laws of any jurisdiction.\r
-\\r
-\ 00001 9/14/92 Added call, 'c w->s\r
-\ 00002 11/23/92 Moved redef of : to loadcom.fth\r
-\r
-anew task-misc2.fth\r
-\r
-: 'N ( <name> -- , make 'n state smart )\r
- bl word find\r
- IF\r
- state @\r
- IF namebase - ( make nfa relocatable )\r
- [compile] literal ( store nfa of word to be compiled )\r
- compile namebase+\r
- THEN\r
- THEN\r
-; IMMEDIATE\r
-\r
-: ?LITERAL ( n -- , do literal if compiling )\r
- state @\r
- IF [compile] literal\r
- THEN\r
-;\r
-\r
-: 'c ( <name> -- xt , state sensitive ' )\r
- ' ?literal\r
-; immediate\r
-\r
-variable if-debug\r
-\r
-decimal\r
-create msec-delay 10000 , ( default for SUN )\r
-: (MSEC) ( #msecs -- )\r
- 0\r
- do msec-delay @ 0\r
- do loop\r
- loop\r
-;\r
-\r
-defer msec\r
-' (msec) is msec\r
-\r
-: SHIFT ( val n -- val<<n )\r
- dup 0<\r
- IF negate arshift\r
- ELSE lshift\r
- THEN\r
-;\r
-\r
-\r
-variable rand-seed here rand-seed !\r
-: random ( -- random_number )\r
- rand-seed @\r
- 31421 * 6927 + \r
- 65535 and dup rand-seed !\r
-;\r
-: choose ( range -- random_number , in range )\r
- random * -16 shift\r
-;\r
-\r
-: wchoose ( hi lo -- random_number )\r
- tuck - choose +\r
-;\r
-\r
-\r
-\ sort top two items on stack.\r
-: 2sort ( a b -- a<b | b<a , largest on top of stack)\r
- 2dup >\r
- if swap\r
- then\r
-;\r
-\r
-\ sort top two items on stack.\r
-: -2sort ( a b -- a>b | b>a , smallest on top of stack)\r
- 2dup <\r
- if swap\r
- then\r
-;\r
-\r
-: barray ( #bytes -- ) ( index -- addr )\r
- create allot\r
- does> +\r
-;\r
-\r
-: warray ( #words -- ) ( index -- addr )\r
- create 2* allot\r
- does> swap 2* +\r
-;\r
-\r
-: array ( #cells -- ) ( index -- addr )\r
- create cell* allot\r
- does> swap cell* +\r
-;\r
-\r
-: .bin ( n -- , print in binary )\r
- base @ binary swap . base !\r
-;\r
-: .dec ( n -- )\r
- base @ decimal swap . base !\r
-;\r
-: .hex ( n -- )\r
- base @ hex swap . base !\r
-;\r
-\r
-: B->S ( c -- c' , sign extend byte )\r
- dup $ 80 and \r
- IF\r
- $ FFFFFF00 or\r
- ELSE\r
- $ 000000FF and\r
- THEN\r
-;\r
-: W->S ( 16bit-signed -- 32bit-signed )\r
- dup $ 8000 and\r
- if\r
- $ FFFF0000 or\r
- ELSE\r
- $ 0000FFFF and\r
- then\r
-;\r
-\r
-: WITHIN { n1 n2 n3 -- flag }\r
- n2 n3 <=\r
- IF\r
- n2 n1 <=\r
- n1 n3 < AND\r
- ELSE\r
- n2 n1 <=\r
- n1 n3 < OR\r
- THEN\r
-;\r
-\r
-: MOVE ( src dst num -- )\r
- >r 2dup - 0<\r
- IF\r
- r> CMOVE>\r
- ELSE\r
- r> CMOVE\r
- THEN\r
-;\r
-\r
-: ERASE ( caddr num -- )\r
- dup 0>\r
- IF\r
- 0 fill\r
- ELSE\r
- 2drop\r
- THEN\r
-;\r
-\r
-: BLANK ( addr u -- , set memory to blank )\r
- DUP 0>\r
- IF\r
- BL FILL \r
- ELSE \r
- 2DROP \r
- THEN \r
-;\r
-\r
-\ Obsolete but included for CORE EXT word set.\r
-: QUERY REFILL DROP ;\r
-VARIABLE SPAN\r
-: EXPECT accept span ! ;\r
-: TIB source drop ;\r
-\r
-\r
-: UNUSED ( -- unused , dictionary space )\r
- CODELIMIT HERE -\r
-;\r
-\r
-: MAP ( -- , dump interesting dictionary info )\r
- ." Code Segment" cr\r
- ." CODEBASE = " codebase .hex cr\r
- ." HERE = " here .hex cr\r
- ." CODELIMIT = " codelimit .hex cr\r
- ." Compiled Code Size = " here codebase - . cr\r
- ." CODE-SIZE = " code-size @ . cr\r
- ." Code Room UNUSED = " UNUSED . cr\r
- ." Name Segment" cr\r
- ." NAMEBASE = " namebase .hex cr\r
- ." HEADERS-PTR @ = " headers-ptr @ .hex cr\r
- ." NAMELIMIT = " namelimit .hex cr\r
- ." CONTEXT @ = " context @ .hex cr\r
- ." LATEST = " latest .hex ." = " latest id. cr\r
- ." Compiled Name size = " headers-ptr @ namebase - . cr\r
- ." HEADERS-SIZE = " headers-size @ . cr\r
- ." Name Room Left = " namelimit headers-ptr @ - . cr\r
-;\r
-\r
-\r
-\ Search for substring S2 in S1\r
-: SEARCH { addr1 cnt1 addr2 cnt2 | addr3 cnt3 flag -- addr3 cnt3 flag }\r
-\ ." Search for " addr2 cnt2 type ." in " addr1 cnt1 type cr\r
-\ if true, s1 contains s2 at addr3 with cnt3 chars remaining\r
-\ if false, s3 = s1 \r
- addr1 -> addr3\r
- cnt1 -> cnt3\r
- cnt1 cnt2 < not\r
- IF\r
- cnt1 cnt2 - 1+ 0\r
- DO\r
- true -> flag\r
- cnt2 0\r
- ?DO\r
- addr2 i chars + c@\r
- addr1 i j + chars + c@ <> \ mismatch?\r
- IF\r
- false -> flag\r
- LEAVE\r
- THEN\r
- LOOP\r
- flag\r
- IF\r
- addr1 i chars + -> addr3\r
- cnt1 i - -> cnt3\r
- LEAVE\r
- THEN\r
- LOOP\r
- THEN\r
- addr3 cnt3 flag\r
-;\r
-\r
+\ @(#) misc2.fth 98/01/26 1.2
+\ Utilities for PForth extracted from HMSL
+\
+\ Author: Phil Burk
+\ Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
+\
+\ The pForth software code is dedicated to the public domain,
+\ and any third party may reproduce, distribute and modify
+\ the pForth software code or any derivative works thereof
+\ without any compensation or license. The pForth software
+\ code is provided on an "as is" basis without any warranty
+\ of any kind, including, without limitation, the implied
+\ warranties of merchantability and fitness for a particular
+\ purpose and their equivalents under the laws of any jurisdiction.
+\
+\ 00001 9/14/92 Added call, 'c w->s
+\ 00002 11/23/92 Moved redef of : to loadcom.fth
+
+anew task-misc2.fth
+
+: 'N ( <name> -- , make 'n state smart )
+ bl word find
+ IF
+ state @
+ IF namebase - ( make nfa relocatable )
+ [compile] literal ( store nfa of word to be compiled )
+ compile namebase+
+ THEN
+ THEN
+; IMMEDIATE
+
+: ?LITERAL ( n -- , do literal if compiling )
+ state @
+ IF [compile] literal
+ THEN
+;
+
+: 'c ( <name> -- xt , state sensitive ' )
+ ' ?literal
+; immediate
+
+variable if-debug
+
+: ? ( address -- , fatch from address and print value )
+ @ .
+;
+
+decimal
+create msec-delay 10000 , ( default for SUN )
+: (MSEC) ( #msecs -- )
+ 0
+ do msec-delay @ 0
+ do loop
+ loop
+;
+
+defer msec
+' (msec) is msec
+
+: SHIFT ( val n -- val<<n )
+ dup 0<
+ IF negate arshift
+ ELSE lshift
+ THEN
+;
+
+
+variable rand-seed here rand-seed !
+: random ( -- random_number )
+ rand-seed @
+ 31421 * 6927 +
+ 65535 and dup rand-seed !
+;
+: choose ( range -- random_number , in range )
+ random * -16 shift
+;
+
+: wchoose ( hi lo -- random_number )
+ tuck - choose +
+;
+
+
+\ sort top two items on stack.
+: 2sort ( a b -- a<b | b<a , largest on top of stack)
+ 2dup >
+ if swap
+ then
+;
+
+\ sort top two items on stack.
+: -2sort ( a b -- a>b | b>a , smallest on top of stack)
+ 2dup <
+ if swap
+ then
+;
+
+: barray ( #bytes -- ) ( index -- addr )
+ create allot
+ does> +
+;
+
+: warray ( #words -- ) ( index -- addr )
+ create 2* allot
+ does> swap 2* +
+;
+
+: array ( #cells -- ) ( index -- addr )
+ create cell* allot
+ does> swap cell* +
+;
+
+: .bin ( n -- , print in binary )
+ base @ binary swap . base !
+;
+: .dec ( n -- )
+ base @ decimal swap . base !
+;
+: .hex ( n -- )
+ base @ hex swap . base !
+;
+
+: B->S ( c -- c' , sign extend byte )
+ dup $ 80 and
+ IF
+ $ FFFFFF00 or
+ ELSE
+ $ 000000FF and
+ THEN
+;
+: W->S ( 16bit-signed -- 32bit-signed )
+ dup $ 8000 and
+ if
+ $ FFFF0000 or
+ ELSE
+ $ 0000FFFF and
+ then
+;
+
+: WITHIN { n1 n2 n3 -- flag }
+ n2 n3 <=
+ IF
+ n2 n1 <=
+ n1 n3 < AND
+ ELSE
+ n2 n1 <=
+ n1 n3 < OR
+ THEN
+;
+
+: MOVE ( src dst num -- )
+ >r 2dup - 0<
+ IF
+ r> CMOVE>
+ ELSE
+ r> CMOVE
+ THEN
+;
+
+: ERASE ( caddr num -- )
+ dup 0>
+ IF
+ 0 fill
+ ELSE
+ 2drop
+ THEN
+;
+
+: BLANK ( addr u -- , set memory to blank )
+ DUP 0>
+ IF
+ BL FILL
+ ELSE
+ 2DROP
+ THEN
+;
+
+\ Obsolete but included for CORE EXT word set.
+: QUERY REFILL DROP ;
+VARIABLE SPAN
+: EXPECT accept span ! ;
+: TIB source drop ;
+
+
+: UNUSED ( -- unused , dictionary space )
+ CODELIMIT HERE -
+;
+
+: MAP ( -- , dump interesting dictionary info )
+ ." Code Segment" cr
+ ." CODEBASE = " codebase .hex cr
+ ." HERE = " here .hex cr
+ ." CODELIMIT = " codelimit .hex cr
+ ." Compiled Code Size = " here codebase - . cr
+ ." CODE-SIZE = " code-size @ . cr
+ ." Code Room UNUSED = " UNUSED . cr
+ ." Name Segment" cr
+ ." NAMEBASE = " namebase .hex cr
+ ." HEADERS-PTR @ = " headers-ptr @ .hex cr
+ ." NAMELIMIT = " namelimit .hex cr
+ ." CONTEXT @ = " context @ .hex cr
+ ." LATEST = " latest .hex ." = " latest id. cr
+ ." Compiled Name size = " headers-ptr @ namebase - . cr
+ ." HEADERS-SIZE = " headers-size @ . cr
+ ." Name Room Left = " namelimit headers-ptr @ - . cr
+;
+
+
+\ Search for substring S2 in S1
+: SEARCH { addr1 cnt1 addr2 cnt2 | addr3 cnt3 flag -- addr3 cnt3 flag }
+\ ." Search for " addr2 cnt2 type ." in " addr1 cnt1 type cr
+\ if true, s1 contains s2 at addr3 with cnt3 chars remaining
+\ if false, s3 = s1
+ addr1 -> addr3
+ cnt1 -> cnt3
+ cnt1 cnt2 < not
+ IF
+ cnt1 cnt2 - 1+ 0
+ DO
+ true -> flag
+ cnt2 0
+ ?DO
+ addr2 i chars + c@
+ addr1 i j + chars + c@ <> \ mismatch?
+ IF
+ false -> flag
+ LEAVE
+ THEN
+ LOOP
+ flag
+ IF
+ addr1 i chars + -> addr3
+ cnt1 i - -> cnt3
+ LEAVE
+ THEN
+ LOOP
+ THEN
+ addr3 cnt3 flag
+;
+
+private{
+
+: env= ( c-addr u c-addr1 u1 x -- x true true | c-addr u false )
+ { x } 2over compare 0= if 2drop x true true else false then
+;
+
+: 2env= ( c-addr u c-addr1 u1 x y -- x y true true | c-addr u false )
+ { x y } 2over compare 0= if 2drop x y true true else false then
+;
+
+0 invert constant max-u
+0 invert 1 rshift constant max-n
+
+}private
+
+: ENVIRONMENT? ( c-addr u -- false | i*x true )
+ s" /COUNTED-STRING" 255 env= if exit then
+ s" /HOLD" 128 env= if exit then \ same as PAD
+ s" /PAD" 128 env= if exit then
+ s" ADDRESS-UNITS-BITS" 8 env= if exit then
+ s" FLOORED" false env= if exit then
+ s" MAX-CHAR" 255 env= if exit then
+ s" MAX-D" max-n max-u 2env= if exit then
+ s" MAX-N" max-n env= if exit then
+ s" MAX-U" max-u env= if exit then
+ s" MAX-UD" max-u max-u 2env= if exit then
+ s" RETURN-STACK-CELLS" 512 env= if exit then \ DEFAULT_RETURN_DEPTH
+ s" STACK-CELLS" 512 env= if exit then \ DEFAULT_USER_DEPTH
+ \ FIXME: maybe define those:
+ \ s" FLOATING-STACK"
+ \ s" MAX-FLOAT"
+ \ s" #LOCALS"
+ \ s" WORDLISTS"
+ 2drop false
+;
+
+privatize
projects / pforth / blobdiff