X-Git-Url: http://git.subgeniuskitty.com/pforth/.git/blobdiff_plain/bb6b2dcdd9acffabfd373c4c3f6b64a9cc43f335..19ed2c32212485415f6e910ce9b93b589f8835cb:/fth/misc2.fth diff --git a/fth/misc2.fth b/fth/misc2.fth index 7d1dafa..c943e82 100644 --- a/fth/misc2.fth +++ b/fth/misc2.fth @@ -1,235 +1,276 @@ -\ @(#) misc2.fth 98/01/26 1.2 -\ Utilities for PForth extracted from HMSL -\ -\ Author: Phil Burk -\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid 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 ( -- , 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 ( -- xt , state sensitive ' ) - ' ?literal -; immediate - -variable if-debug - -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< - 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 -; - +\ @(#) 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 ( -- , 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 ( -- 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< + 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