\                                                                    vandys
\ tools.f
\       Less often used tools, under the "extensions" vocabulary
only extensions definitions

\ ******************************************************************
\ The following block-oriented operations are deprecated now that we
\  have the Forth block filesystem instead.
\ ******************************************************************

\ This is defined as
\  a block with an initial '\', and with all other lines containing
\  only spaces.
\ : (empty) ( a -- bool )
\  dup c@ [char] \ <> if drop false exit then
\  BLKCOLS +
\  SCRSIZ BLKCOLS - 0 do
\   dup c@ ( space ) 32 <> if
\    unloop drop false exit then
\   1+ loop
\  drop true
\ ;



\                                                                    vandys
\ Find first free block
\  Scans forward until an empty one is found.  "block" is expected
\  to throw an error if no free blocks are available.
\ : (1stfree) ( u -- u' )
\  begin   dup block (empty) not   while 1+ repeat ;

\ Insert a block
\  Scans forward to find first unused block, then copies screens
\  to shift them forward.
\ : insblock ( u -- )
\    \ Copy from highest screen down to lowest
\    dup 1+ (1stfree) begin   2dup <>   while
\       dup .   dup dup 1- swap copy
\    1- repeat drop
\    block BLKSIZ blank update   cr sync ;









\ String functions, supports max 256 char length                     vandys
: $null ( a -- )   0 swap c! ;
: $count ( a -- a+1 n )   count ;
: $strlen ( a -- n )   c@ ;
: $eos ( a -- a' )   count + ;
: +c! ( n a -- )   tuck   c@ +   swap c! ;
: $strcat ( a1 a2 -- )
   over $eos over $count >r swap r> move   c@ swap +c! ;
: $ccat ( a c -- )   over $eos c!   1 swap +c! ;
: $strcmp ( s1 s2 -- n )   2dup c@ swap c@ 2dup >r >r   min 1+ 1 do
   2dup i + c@ swap i + c@ - ?dup if
      -rot 2drop r> r> 2drop   unloop exit   then
   loop 2drop   r> r> - ;












\                                                                    vandys
: allEnts ( 'fn -- )   >r current   begin cell+ @ ?dup while
  dup begin @ ?dup while   cell- cell- dup r@ execute cell+   repeat
 repeat   r> drop ;





















\                                                                    vandys
\ Show stack backtrace
\  There's no formal stack framing, so we just interpret the values we
\ find on the return stack as best we can.
\ Note: not reentrant

\ The best entry, and the closest we got to its exact address
variable (bestEnt)
variable (bestDelta)
\ The value we're searching for
variable (val)

\ If the indicated entry is closer to the sought value, record it
: (checkEnt) ( ent -- )
 dup @ (val) @ 2dup u<= if
  swap - dup (bestDelta) @ u< if
   (bestDelta) ! (bestEnt) !
  else 2drop then
 else 2drop drop then ;






\                                                                    vandys
\ Return most closely matching entry
: (bestent) ( a -- 0 | u a )
 (val) ! 0 (bestEnt) ! $10000 (bestDelta) !
 ['] (checkEnt) allEnts
 (bestEnt) @ dup if (bestDelta) @ swap then ;

\ Print an entry in name[+offset] format
: (prval2) ( u a -- )
  cell+ cell+ .id ?dup if ." +" 1 u.r then ;

\ Dump a value as a raw integer, also  name+<offset> if possible
: (showval) ( u -- )
 dup 1 u.r
 (bestent) ?dup if ." : " (prval2) then ;

\ Print a value, in hex if no conversion was possible
: (prval) ( u -- )
 dup (bestent) ?dup if (prval2) drop
 else 1 u.r then ;





\                                                                    vandys
\ Walk back cells of calling stack, displaying each
\  Note: the debugger uses its own routine, which knows about local
\  variable frames
: where ( -- )   cr   rp@ begin   dup rp0 @ <   while
      dup @ (showval)   cr
   cell+ repeat   drop ;

\       Random number generator
create randstate 0 ,

: random ( -- u )
        randstate dup @ 1103515245 * 12345 + $7FFFFFFF and dup rot ! ;












\                                                                    vandys
\ Intern a counted string to a unique counted string pointer which is
\ always the same for that particular string.  Implemented by a tree
\ indexed by successive bytes, with the 257th pointer being a pointer
\ to the unique version of the counted string.
\ create (syms)   0 ,
\ 256 constant (#chars)
: zallot ( u -- )   here over erase   allot ;
: $strdup ( ptr -- ptr' )   here swap   2dup c@ 1+ dup allot
   move   align ;
: $strdup+ ( ptr u -- ptr' )   here -rot   over c@ 1+ + allot
   ( ptr' ptr ) 2dup c@ 1+ move ;
\ : (allocSym) ( ptr a -- )   swap $strdup   tuck swap !   ;
\ : >symbol ( a -- ptr )   (syms) over   count over + swap do
\       dup @ 0= if   here over !   257 cells zallot   then
\       @   i c@ cells +   loop
\       dup @ 0= if   (allocSym)   else   nip @   then ;

only

: $null Init to empty string
: $count Convert to counted buffer, alias for "count"
: $strlen Return string length
: $eos Return pointer to first char position beyond end of string
: +c! Like +!, but affect byte counter instead of cell
: $strcat Concat string a2 onto a1
   Add bytes onto string                   Update count
: $ccat Concat a char onto a string
: $strcmp Like C's strcmp(), return positive or negative based on
 lexical ordering, 0 if strings are equal.















: allEnts Invoke function on all dictionary entries







































































































Root of tree for looking up symbols by successive chars
Number of char values supported (i.e., a byte is a char)
: zallot Allocate zeroed space
: $strdup Duplicate counted string to newly allocated storage

: $strdup+ Duplicate string into memory which has room for extra bytes

: (allocSym) Insert new level in symbol lookup tree


: >symbol Convert string to interned symbol