List missing query strings in comment

[pforth] / fth / misc2.fth

\ @(#) 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  ( <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

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