Added lots of new LSPLIB packages (and their sources).

src/libdoc/string.psz1

@@ -0,0 +1,164 @@
+ 
+
+;;*(SLASHIFY /")
+
+
+;;; This file contains definitions of (most of) the MACLISP
+;;;string functions which exist on MULTICS -- simulated by much
+;;;less efficient schemes here -- and several of the more common
+;;;INTERLISP string functions. 
+
+;;; For this package, a string is an (uninterned) atom whose
+;;;first and last characters are /" -- that character is defined
+;;;as a macro character which creates such strings.
+
+(DECLARE (*EXPR STRINGP MKSTRING MAKE-ATOM STRINGLENGTH
+	        NTHCHAR)
+	 (*LEXPR CATENATE SUBSTR CONCAT SUBSTRING)) 
+
+(DEFUN /"-STRING-MACRO NIL 
+       (DO
+	((COLLECT (NCONS '/") (CONS (READCH) COLLECT)))
+	((AND (EQ '/" (CAR COLLECT)) (CDR COLLECT))
+	 (MAKNAM (NREVERSE COLLECT))))) 
+
+;;; Turn on the garbage collection of truly worthless
+;;;atoms since this package will be creating a lot of them. 
+
+(GCTWA T) 
+
+(DEFUN STRINGP (STRING?) 
+       (AND (EQ 'SYMBOL (TYPEP  STRING?))
+	    (EQ '/" (GETCHAR STRING? 1.))
+	    (EQ '/" (GETCHAR STRING? (FLATC STRING?)))
+	    STRING?)) 
+
+(DEFUN MKSTRING (STRING?) 
+       (COMMENT THE ATOM ^@ (ASCII NULL) MAKES THE NULL STRING)
+       (OR
+	(STRINGP STRING?)
+	((LAMBDA (L BASE *NOPOINT) 
+		 (COND ((SETQ L (EXPLODEN STRING?))
+			(RPLACD (LAST L) (NCONS '/"))
+			  (MAKNAM (CONS '/" L)))
+		       (T (MAKNAM '(/" /")))))
+	 NIL 10. T))) 
+
+(DEFUN MAKE-ATOM (STRING) 
+       (COMMENT THIS IS THE OPPOSITE OF MKSTRING -- NOTE THAT
+		THE NULL STRING IS MADE INTO ^@ (ASCII NULL))
+       (PROG (ANSWER WORK) 
+	     (SETQ ANSWER (CDR (EXPLODEN STRING)) WORK ANSWER)
+	     (OR (CDR WORK) (RETURN (MAKNAM NIL)))
+	LOOP (COND
+	      ((CDDR WORK) (SETQ WORK (CDR WORK)) (GO LOOP)))
+	     (RPLACD WORK NIL)
+	     (RETURN (MAKNAM ANSWER)))) 
+
+(DEFUN STRINGLENGTH (STRING) (- (FLATC STRING) 2.)) 
+
+;;; The MACLISP functions require that their string arguments
+;;;always be strings;  therefore, they do not check. 
+
+(DEFUN CATENATE EXPR NARGS 
+       (COMMENT CATENATE CONCATENATES ONE OR MORE STRING
+		ARGUMENTS)
+       (PROG (ANSWER WORK ARGNO) 
+	     (AND (EQUAL NARGS 1.) (RETURN (ARG 1.)))
+	     (SETQ ARGNO 1. 
+		   ANSWER (EXPLODEN (ARG 1.)) 
+		   WORK ANSWER)
+	LOOP (COND
+	      ((CDDR WORK) (SETQ WORK (CDR WORK)) (GO LOOP)))
+	     (RPLACD
+	      WORK
+	      (CDR (EXPLODEN (ARG (SETQ ARGNO (1+ ARGNO))))))
+	     (AND (< ARGNO NARGS) (GO LOOP))
+	     (RETURN (MAKNAM ANSWER)))) 
+
+(DEFUN SUBSTR EXPR NARGS 
+       (COMMENT (SUBSTR STRING START LENGTH) SELECTS A
+		SUBSTRING OF <STRING> STARTING AT POSITION
+		<START> FOR <LENGTH> CHARACTERS -- IF
+		<LENGTH> IS OMITTED THEN IT DEFAULTS TO THE
+		REST OF THE STRING -- AN INVALID SELECTION
+		RETURNS NIL (NOT THE NULL STRING) -- A
+		<LENGTH> OF 0. YIELDS THE NULL STRING AND AN
+		EXCESSIVE <LENGTH> IS IGNORED)
+       (PROG (STRING STRINGLENGTH START LENGTH ANSWER LEN)
+	     (DECLARE (FIXNUM START))
+	     (SETQ STRING (EXPLODEN (ARG 1.)) 
+		   ANSWER STRING 
+		   STRINGLENGTH (STRINGLENGTH (ARG 1.)) 
+		   START (ARG 2.) 
+		   LEN (AND (> NARGS 2.) (ARG 3.))
+		   LENGTH (COND
+			   ((NUMBERP LEN)
+			    (MIN (FIX LEN)
+				 (- STRINGLENGTH START -1.)))
+			   (T (- STRINGLENGTH START -1.))))
+	     (OR (AND (PLUSP START)
+		      (NOT (> START STRINGLENGTH))
+		      (PLUSP LENGTH))
+		 (RETURN NIL))
+	     (AND (NOT (= START 1.))
+		  (PROG NIL 
+		   L1	(RPLACD STRING (CDDR STRING))
+			(AND (> (SETQ START (1- START)) 1.)
+			     (GO L1))))
+	L2   (COND ((PLUSP (SETQ LENGTH (1- LENGTH)))
+		    (SETQ STRING (CDR STRING))
+		    (GO L2)))
+	     (RPLACD (CDR STRING) (LAST STRING))
+	     (RETURN (MAKNAM ANSWER)))) 
+
+;;; CONCAT and SUBSTRING are INTERLISP versions of CATENATE and
+;;;SUBSTR but with somewhat different conventions. 
+
+(DEFUN CONCAT EXPR NARGS 
+       (COMMENT CONCAT IS JUST LIKE CATENATE EXCEPT THAT ITS
+		ARGUMENT NEED NOT BE STRINGS TO BEGIN WITH)
+       (DO ((I 1. (1+ I))
+	    (ARGLIST NIL (CONS (MKSTRING (ARG I)) ARGLIST)))
+	   ((> I NARGS)
+	    (APPLY (FUNCTION CATENATE) (NREVERSE ARGLIST))))) 
+
+(DEFUN SUBSTRING EXPR NARGS 
+       (COMMENT SUBSTRING IS A GENERALIZED VERSION OF SUBSTR
+		-- (SUBSTRING STRING START END) SELECTS THAT
+		STRING IN <STRING> WHICH STARTS AT POSITION
+		<START> AND RUNS TO POSITION <END> -- IF
+		<START> OR <END> ARE NEGATIVE THEY INDICATE
+		CHARACTER POSITIONS FROM THE RIGHT END OF THE
+		STRING -- OUT OF BOUNDS PARAMETERS OR A
+		NEGATIVE-LENGTH RESULT CAUSE NIL TO BE
+		RETURNED)
+       (PROG (STRING START END STRINGLENGTH)
+	     (DECLARE (FIXNUM STRINGLENGTH START))
+	     (SETQ STRING (MKSTRING (ARG 1.)) 
+		   START (ARG 2.) 
+		   END (AND (> NARGS 2.) (ARG 3.)) 
+		   STRINGLENGTH (STRINGLENGTH STRING))
+	     (AND (OR (ZEROP START) (AND END (ZEROP END)))
+		  (RETURN NIL))
+	     (OR (PLUSP START)
+		 (SETQ START (+ STRINGLENGTH START 1.)))
+	     (OR (NULL END)
+		 (PLUSP END)
+		 (SETQ END (+ STRINGLENGTH END 1.)))
+	     (OR (NULL END) (NOT (< END START)) (RETURN NIL))
+	     (RETURN (SUBSTR STRING
+			     START
+			     (COND (END (- END START -1.)))))))
+ 
+
+(DEFUN NTHCHAR (STRING N) 
+       (COND
+	((STRINGP STRING)
+	 (COND ((> N (STRINGLENGTH STRING)) NIL)
+	       (T  (GETCHAR STRING (1+ N)))))
+	((EQ (TYPEP STRING) 'SYMBOL) (GETCHAR STRING N))
+	(T (NTHCHAR (MKSTRING STRING) N)))) 
+
+(SETSYNTAX '/" 'MACRO '/"-STRING-MACRO)
+