"Loading SFS Slow Library System" $PRINT CRLF
; Created 5/27/05 Last mod 5/31/05
;
; Note: as written there must be a volume named LIB on drive 0
; make versions of the LIB word to load other libraries if desired
;
; LIB - opens library, creates LIBRARY if doesn't exist
; "Name" R - runs "Name" from buffered library then forgets it
; "Name" L - loads "Name" from buffered library into dictionary
; "Name" D2L - saves definition to buffered library (not to disk)
; "Name" LDEL - deletes "Name", truncating buffered library
; LDIR - lists library names
;
; To save library to disk: 3 CLOSE then LIB to reload library
;
VARIABLE RCTL
;------- scarfed and modded from msscan.ipl
;support for multiple-file streams 11/6/04
;"string" MSSCAN - searches for "string" in MS input stream,
;up until ascii 128 character. If found, pushes a 1 and leaves
;MS positioned to next character after target, otherwise pushes 0.
OCTAL DEFINE MSSCAN
 #0 ;success/fail flag
 #0 ;mode - 0=looking for 1st occ, 1=matching subsequent
 $DUP ;match string, when empty match is made
 $HEAD ;start by looking for first char
 DO ;until done
  MSBIN ;get one byte from MS input
  DUP 200 SUB IFZ ;if ascii 128 then
   DROP ;the ms in char
   DROP ;the char being matched
   DROP ;the mode
   ;leave 0 on stack
   #1 ;we're done
  ELSE ;not an ascii 128, try to match...
   OVER SUB IFNZ ;(drop char) if no match then
    OVER IFZ ;if mode 0
     #0 ;just keep going
    ELSE ;if partial match gone bad
     DROP DROP ;match char and mode
     #0 ;back to mode 0
     $DROP $DUP $HEAD ;start it again
     #0 ;keep going
    ENDIF
   ELSE ;finally a match!
    DROP DROP ;the match char and mode
    $LEN ;of emptying match string
    IFZ ;if successful match
     DROP #1 ;change to success
     #1 ;and exit
    ELSE
     #1 ;mode 1, match successive chars
     $HEAD ;next char to match
     #0 ;keep going
    ENDIF
   ENDIF
  ENDIF
 UNTIL ;done
 $DROP $DROP ;strings
END
;
;RUN&DEL - execute word in string on X stack then delete it
;modified 5/27/05 to use RCTL to save address
DEFINE RUN&DEL
 $DEFADR DUP IFZ
  "Word not found" $PRINT DROP
 ELSE
  DUP RCTL SWAP PUT ;save forget address
  EXECUTE ;run it
  ;word must not change RCTL or else
  RCTL GET 4 SUB #0 PUT ;delete it
  RCTL #0 PUT ;clear RCTL to avoid inadvertent op
  CRLF ;to make it look neat
 ENDIF
END
;
;"file" LIBLOAD searches for the specified file then loads it
;modified 5/28/05 to pop str from Y if not found and RCTL set
DEFINE LIBLOAD
 ";;;FILE:" $SWAP $CAT ":" $CAT
 MSSCAN IFZ
  "Not found" $PRINT
  RCTL GET IFNZ Y>>X $DROP ENDIF
 ELSE LOAD ENDIF
END
;
; LIBEND - used to terminate library chunks. Does CONSOLE
; then if RCTL <> 0 runs and deletes word on Y stack
DEFINE LIBEND
CONSOLE RCTL GET IFNZ RCTL #0 PUT Y>>X RUN&DEL ENDIF END
;
; LIB - opens library, hardcoded as "LIBRARY" in volume "LIB"
; on drive 0. Volume "LIB" must already exist, an empty library
; is created with a single 128 byte if "LIBRARY" doesn't exist.
; All library operations use SFS buffer 3.
DEFINE LIB
3 RELEASE ;whatever is using buffer 3, too bad
"LIB" 000003 #0 DIRECTORY FSS GET IFZ
 "LIBRARY" 000003 OPEN FSS GET IFNZ
  " creating" $PRINT "LIBRARY" 000003 CNF
  "LIBRARY" 000003 OPEN MS_SAVE 000003 >FILE 000200 MSBOUT
  MS_RESTORE 000003 CLOSE "LIBRARY" 000003 OPEN
 ENDIF
ENDIF
END
;
; "name" R - runs word from open library then forgets it
; name is stored on Y stack for LIBEND to run/forget
DEFINE R
CWA 000003 ADD GET #1 AND IFZ "No library" $PRINT $DROP ELSE
 000003 <FILE 000003 #0 SEEK RCTL #1 PUT $DUP X>>Y LIBLOAD
ENDIF
END
;
; "name" L - loads word from open library
DEFINE L
CWA 000003 ADD GET #1 AND IFZ "No library" $PRINT $DROP ELSE
 000003 <FILE 000003 #0 SEEK RCTL #0 PUT LIBLOAD
ENDIF END
;
; "name" D2L - writes definition to library, must be open
; note - writes to buffer only, does not save to disk.
; run 3 CLOSE then LIB (or otherwise reopen lib) after
; using D2L to write changes. DEFINE LIBSAVE to 3 CLOSE LIB END
DEFINE D2L
$DUP $DEFADR IFZ $PRINT " not found" $PRINT ELSE
 CWA 000003 ADD GET #1 AND IFZ $DROP "No library" $PRINT ELSE
  MS_SAVE 000003 >FILE >MS 000003 FSA 000003 ADD GET DEC SEEK
  ";;;FILE:" $PRINT $DUP $PRINT ":" $PRINT CRLF $DEFADR PDEF
  "LIBEND" $PRINT CRLF 000200 MSBOUT <>CON MS_RESTORE
 ENDIF
ENDIF
END
;
; "Name" LDEL - deletes "Name", truncating buffered library
DEFINE LDEL
3 #0 SEEK FSS GET IFNZ $DROP ELSE
 ";;;FILE:" $SWAP $CAT ;form search string
 $LEN ;push length of search string
 MS_SAVE 3 <FILE ;redirect input from library
 MSSCAN IFNZ ;scan for string, if found...
  FPA 3 ADD GET ;push current pointer
  OVER SUB ;subtract string length
  FPA 3 ADD OVER PUT ;set pointer
  FSA 3 ADD SWAP PUT ;set size popping ptr
  3 >FILE ;redirect output to library
  200 MSBOUT ;write terminator byte
 ENDIF
 DROP ;length
 MS_RESTORE
ENDIF
END
;
; LDIR - lists words in library
DEFINE LDIR
3 #0 SEEK FSS GET IFZ ;if library open
 MS_SAVE ;save existing MS vectors
 "Library size: " $PRINT FSA 3 ADD GET PNUM CRLF
 #0 ;char counter
 3 <FILE DO
  ";;;FILE:" MSSCAN DUP IFNZ ;scan to file tag
   MS$IN ;get rest of line
   $ADR GET 177400 AND 21000 SUB IFZ $DROP ELSE ;if 1st char not quote
    $TAIL DROP 40 $APPEND ;drop ":" from string and add a space
    SWAP $LEN ADD SWAP ;add string length to counter
    OVER 106 SWAP SUB IF<0 ;if counter > 70
     CRLF ;print return
     SWAP DROP #0 SWAP ;zero counter
    ENDIF $PRINT
   ENDIF
  ENDIF
 WHILE
 DROP ;counter
 MS_RESTORE ;restore prev MS vectors
ENDIF
END
;------------
CONSOLE
; changes...
; 5/31/05 modified LDIR to avoid false hits, rearranged
; 5/30/05 added LDEL, made LDIR neater
; 5/28/05 cleaned up Y when R word not found
; 5/28/05 added LDIR
; 5/27/05 initial version