;;*(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)