PDP-10.its/src/nilcom/string.186

;;;  STRING    				-*-Mode:Lisp;Package:SI;Lowercase:T-*-
;;;  *************************************************************************
;;;  *** NIL ***** Functions for STRINGs and CHARACTERs **********************
;;;  *************************************************************************
;;;  ** (c) Copyright 1981 Massachusetts Institute of Technology *************
;;;  *************************************************************************

;;; Provides support for NIL string operations under maclisp, with
;;;   most LISPM STRING functions added for compatibility.
;;; To read this file in on LISPM, do (PACKAGE-DECLARE * SYSTEM 100)

(herald STRING /186)

(eval-when (eval compile)
  (or (get 'SUBLOAD 'VERSION)
      (load '((lisp) subload)))
  (subload SHARPCONDITIONALS)
  )


;;; CHARACTER support:
;;; m	CHARACTERP, *:CHARACTER-TO-FIXNUM, *:FIXNUM-TO-CHARACTER
;;; m 	TO-CHARACTER, TO-CHARACTER-N, 
;;;     DIGITP, DIGIT-WEIGHT 
;;; +m	CHARACTER, 
;;; +*  CHAR-EQUAL, CHAR-LESSP,
;;; &	|+internal-tilde-macro/||  (can be set onto ~ as readmacro)
;;; &   USERATOMS-HOOK->CHARACTER-CLASS  FLATSIZE->CHARACTER-CLASS 
;;; STRING support:
;;; m   STRINGP, CHAR, RPLACHAR
;;; m   STRING-LENGTH, STRING-SEARCHQ, STRING-BSEARCHQ
;;; 	SET-STRING-LENGTH, STRING-REMQ 
;;; 	MAKE-STRING, STRING-SUBSEQ, STRING-MISMATCHQ, STRING-HASH
;;; *	CHAR-N, RPLACHAR-N, STRING-FILL, STRING-FILL-N, STRING-REPLACE
;;; * 	STRING-POSQ, STRING-BPOSQ, STRING-POSQ-N, STRING-BPOSQ-N
;;; * 	STRING-SKIPQ, STRING-BSKIPQ, STRING-SKIPQ-N, STRING-BSKIPQ-N
;;; +m 	STRING-EQUAL, STRING-LESSP, STRING-SEARCH, STRING-REVERSE-SEARCH
;;; +m 	STRING-DOWNCASE, STRING-UPCASE
;;; +	GET-PNAME, SUBSTRING, STRING-APPEND, STRING-REVERSE, STRING-NREVERSE
;;; +   STRING-TRIM, STRING-LEFT-TRIM, STRING-RIGHT-TRIM
;;; +*  CHAR-DOWNCASE, CHAR-UPCASE,
;;; +*  STRING-SEARCH-CHAR, STRING-SEARCH-NOT-CHAR, 
;;; +*  STRING-SEARCH-SET, STRING-SEARCH-NOT-SET
;;; +*  STRING-REVERSE-SEARCH-CHAR, STRING-REVERSE-SEARCH-NOT-CHAR, 
;;; +*  STRING-REVERSE-SEARCH-SET, STRING-REVERSE-SEARCH-NOT-SET
;;; &	STRING-PNGET,  STRING-PNPUT,  |+internal-doublequote-macro/||  
;;; & 	USERATOMS-HOOK->STRING-CLASS 	EQUAL->STRING-CLASS  
;;; &   FLATSIZE->STRING-CLASS 		PURCOPY->STRING-CLASS  
;;; & 	NAMESTRING->STRING-CLASS 	SXHASH->STRING-CLASS 
;;; &   EXPLODE->STRING-CLASS 		SAMEPNAMEP->STRING-CLASS
;;; &   ALPHALESSP->STRING-CLASS	LESSP->STRING-CLASS
;;; &   GREATERP->STRING-CLASS
;;; &*  +INTERNAL-CHAR-N,  +INTERNAL-RPLACHAR-N,  +INTERNAL-STRING-WORD-N 
;;; &* 	STR/:CLEAR-WORDS,  STR/:COMPARE-WORDS,  STR/:GRAB-PURSEG, 

;;;   (a "m" is for lines whose routines are implemnted as both macros and
;;; 	subrs - macro definition is active only in the compiler)

;;;   (a + is for lines whose routines are directly LISPM compatible - 
;;; 	many other such routines can be written using the NIL primitives)

;;;   (an * is for lines whose routines have been written in MIDAS - 
;;; 	primarily for speed - and are in the file STRAUX >)

;;;   (a & is for lines whose routines are PDP10-specific, and are 
;;; 	 primarily for internal support)

;;;   (the functions named "...-N" use ascii numerical values for their 
;;; 	arguments which are interpreted as "CHARACTER"s, instead of the
;;; 	new datatype "CHARACTER"  - thus while STRING-POSQ scans for a 
;;; 	particular character in a string, STRING-POSQ-N wants its character
;;; 	as a fixnum.)

;				  ---------
;A  "STRING" is a 4-hunk, with    | 1 | 0 | 
;  indices as indicated in the	  ---------
;  diagram.			  | 3 | 2 |
;				  ---------
;  (cxr 0 s) 	;ptr to class object for STRINGs
;  (cxr 1 s) 	;"**SELF-EVAL**" 
;  (cxr 2 s) 	;word-index in STR:ARRAY of first word of packed ascii
;  (cxr 3 s) 	;length of string, in characters



;;;; Out-of-core loading, and DECLAREs

#+(or LISPM (and NIL (not MacLISP)))
(progn (globalize "STRINGP")
	;; well, hundreds more! (globalize )
       )


#+(local MacLISP)
(declare (own-symbol MAKE-STRING  STRINGP  *:FIXNUM-TO-CHARACTER 
		     |+internal-doublequote-macro/||  STRING-PNPUT))

#-NIL 
(eval-when (eval compile)
    ;; SUBSEQ also downloads EXTEND
   (subload SUBSEQ)
   (subload EXTMAC)
   (subload EXTBAS)
   (subload SETF)
   (subload DEFSETF)
   (subload EVONCE)
   (subload LOOP)
   #M (cond ((status feature COMPLR)
	     (*lexpr NIL-INTERN SYMBOLCONC TO-STRING)
	     (*expr STRINGP *:FIXNUM-TO-CHARACTER )
     #+PDP10 (*expr STRING-PNGET STRING-PNPUT)
	     (setq STRT7 'T)))
   (setq-if-unbound *:bits-per-character #Q 8 #-Lispm 7)
   (setq-if-unbound *:bytes-per-word #+Multics 4 #M 5 #Q 4)
)

#M
(defmacro (/" defmacro-for-compiling () defmacro-displace-call () )
	  (x) 
   (if (not (symbolp x)) (error '|Uluz - /" pseudo-string maker|))
#+PDP10 
   (progn (setq x (copysymbol x () ))
	  (set x x)
	  (putprop x `(SPECIAL ,x) 'SPECIAL)
	  (putprop x 'T '+INTERNAL-STRING-MARKER))
   x)




#-NIL 
(eval-when (eval load compile)
    (let ((x (get 'ERRCK 'VERSION)))
      (cond ((null x))
	    ((alphalessp x (/" /30))
	      (remprop 'ERRCK 'VERSION)
	      (let (FASLOAD) #%(subload ERRCK))))
       ;; Need CLASS-OF, SEND etc, for things to work
      (subload EXTEND)
      (cond ((and (setq x (get 'SUBSEQ 'VERSION)) 
		  (alphalessp x (/" /39)))
	      (remprop 'SUBSEQ 'VERSION)
	      (let (FASLOAD) #%(subload SUBSEQ)))
	      ;; Following is basically a bunch of DEF-OR-AUTOLOADABLE's
	    ((null x)
	      (mapc #'(lambda (x) 
		       (or (getl x '(SUBR LSUBR AUTOLOAD))
			   (putprop x #%(autoload-filename SUBSEQ) 'AUTOLOAD)))
		   '(TO-CHARACTER  TO-CHARACTER-N?  TO-STRING  TO-UPCASE 
		     TO-SYMBOL  SUBSEQ  REPLACE  SI/:REPLACER)))))
    (cond (#M (status feature COMPLR) #Q 'T 
	    (special CHARACTER-CLASS 
		     |+internal-CHARACTER-table/||
		     STRING-CLASS 
		     STR/:NULL-STRING)
	 #M (progn (fixnum (STRING-LENGTH)
			   (CHAR-N () fixnum) 
			   (CHAR-DOWNCASE fixnum) 
			   (CHAR-UPCASE fixnum))
		   (notype (RPLACHAR-N () fixnum fixnum))
	   #+PDP10 (progn (fixnum (+INTERNAL-CHAR-N () fixnum)
				  (+INTERNAL-STRING-WORD-N () fixnum))
			  (notype (+INTERNAL-RPLACHAR-N () fixnum fixnum)
				  (+INTERNAL-SET-STRING-WORD-N () fixnum fixnum)
				  (SET-STRING-LENGTH () fixnum))
			  (fixnum STR/:GRAB-PURSEG))
		   (*lexpr MAKE-STRING 
			   STRING-SKIPQ STRING-BSKIPQ STRING-SKIPQ-N 
			   STRING-BSKIPQ-N  STRING-POSQ STRING-BPOSQ 
			   STRING-POSQ-N STRING-BPOSQ-N  STRING-FILL 
			   STRING-FILL-N  STRING-SEARCH-SET 
			   STRING-REVERSE-SEARCH-SET STRING-SEARCH-NOT-SET 
			   STRING-REVERSE-SEARCH-NOT-SET  STRING-SEARCH-CHAR 
			   STRING-REVERSE-SEARCH-CHAR STRING-SEARCH-NOT-CHAR 
			   STRING-REVERSE-SEARCH-NOT-CHAR   STRING-REPLACE 
			   STRING-SUBSEQ STRING-MISMATCHQ  STRING-REMQ 
			   SUBSTRING STRING-APPEND )
		   (array* (FIXNUM (STR/:ARRAY ()))))
	 ))
    )

#-LISPM 
(eval-when (eval load compile)
    (cond ((status feature COMPLR)
 	    (special |STR/:STRING-SEARCHer| 
		     |STR/:STRING-POSQ-Ner| 
		     |STR/:STRING-POSQer| 
		     STR/:STRING-EQUAL-LESSP 
		     STR/:STRING-UP-DOWN-CASE)
      #M    (*lexpr |STR/:STRING-SEARCHer| 
		    STR/:STRING-EQUAL-LESSP 
		    STR/:STRING-UP-DOWN-CASE)
  #-Multics (*expr GET-PNAME) ))
    )




#M
(declare 
    (ARRAY* (NOTYPE (STR/:GCMARRAY)))
    (*EXPR STR/:GC-DAEMON)
    (SPECIAL STRINGS-GCSIZE STRINGS-GCMAX STRINGS-GCMIN)
    (SPECIAL 
      STR/:ARRAY 	;fixnum array, holding packed ascii for strings
      STR/:ARYSIZE 	;current size of above array, in words
      STR/:FREESLOT 	;slot in array above which no strings stored 
      STR/:GCMARRAY 	;non-GC-marked s-exp array - holds all strings
      STR/:GCMSIZE 	;current size of above array, in "entries"
      STR/:NO/.STRS 	;number of strings currently entered in arrays
      STR/:DUMMY 	;dummy header used during string relocations
      ) 
    (SPECIAL STR/:PURE-ADDR 
	     STR/:NO/.PWDSF 
	     STR/:STRING-HUNK-PATTERN 
	     STR/:CHARACTER-HUNK-PATTERN 
	     STR/:CHARACTER-EXTEND-PATTERN )
  )


#-NIL (eval-when (eval compile load) 
	(DEFCLASS* STRING STRING-CLASS SEQUENCE-CLASS)
	(DEFCLASS* CHARACTER CHARACTER-CLASS OBJECT-CLASS)
	)

(define-loop-path (characters character)
		  si:loop-sequence-elements-path
		  (of from to below above downto in by)
		  char string-length string character)



;;;; Temporary macros

(eval-when (compile)
   (setq defmacro-for-compiling () defmacro-displace-call () )
)

(defmacro EXCH (x y) `(PSETQ ,x ,y ,y ,x))

;; For getting and setting stack args
(defmacro S-ARG (w i) 
   #N 	 	`(VREF ,w ,i)
   #M 	 	`(ARG (1+ ,i))
   #Q 		`(NTH ,i ,w)
   )
(defmacro S-SETARG (w i val)
   #N 		`(VSET ,w ,i ,val)
   #M 		`(SETARG (1+ ,i) ,val)
   #Q 		`(RPLACA (NTHCDR ,i ,w) ,val)
   )

#M (progn 'compile 

(defmacro AR-1 (&rest w) `(ARRAYCALL T ,. w)) 

#+PDP10 (progn 'compile 
(defmacro NEW-CHARACTER (i &optional purep)
   `(LET ((I ,i)
	  (C ,(cond (purep `(PURCOPY STR/:CHARACTER-HUNK-PATTERN))
		    ('T    `(SUBST () () STR/:CHARACTER-HUNK-PATTERN)))))
      (SETF (SI:EXTEND-CLASS-OF C) 
	    (SI:EXTEND-CLASS-OF STR/:CHARACTER-EXTEND-PATTERN))
      (SETF (SI:EXTEND-MARKER-OF C) 
	    (SI:EXTEND-MARKER-OF STR/:CHARACTER-EXTEND-PATTERN))
      (SI:XSET C 0 (MUNKAM I))))
(defmacro NEW-STRING (wordno len) 
   `(SI:EXTEND STRING-CLASS ,wordno ,len))
  )

#-PDP10 (progn 'compile 
  (defmacro NEW-CHARACTER (i &optional purep) `(SI:EXTEND CHARACTER-CLASS ,i))
  (defmacro +INTERNAL-CHAR-N (&rest w) `(CHAR-N ,.w))
  (defmacro +INTERNAL-RPLACHAR-N (&rest w) `(RPLACHAR-N ,.w))
  )

)	;end of #M


(defmacro SUBSTRINGIFY (str i cnt)
   #+Multics  `(SUBSTR ,str ,i ,cnt)
   #-Multics  `(STRING-REPLACE (MAKE-STRING ,cnt) ,str 0 ,i ,cnt)
   )


#M (progn 'compile 

(defmacro DEFLEXPRMACRO (name fun first-arg args-prop &aux (g (gensym)))
   `(PROGN 'COMPILE 
	   (AND (STATUS FEATURE COMPLR) 
		(EVAL '(DEFMACRO ,name (&REST W)
			  `(,',fun ,',first-arg ,. W)))) 
	   (DEFUN ,name ,g 
		  ,g 
		  (|*lexpr-funcall-1| ',name ,fun ,first-arg ,args-prop))))
)	;end of #M 

#-MacLISP 
(defmacro DEFLEXPRMACRO (name fun first-arg args-prop &aux g)
     (si:gen-local-var g)
    `(DEFUN ,name (&REST ,g)
	    (LEXPR-FUNCALL ,fun ,first-arg ,g)))

#-NIL 
(defmacro DEFMUMBLE (&rest w) `(DEFLEXPRMACRO ,.w))

;;; In real NIL, defmumble generates a DEFUN which "passes along" a call
;;;  to a specific sequence function, as a mini-subr call either with or
;;;  without the optional "CNT" argument, depending on whether it was 
;;;  provided by the source code caller.  This strategy allows defaulting
;;;  any other optional argument to 0, but permits the mini-subr to 
;;;  calculate the default for the "count" argument.
#+NIL 
  (defmacro (DEFMUMBLE defmacro-for-compiling () )  
	    (name () () args 
		&aux (cntp (si:gen-local-var () "Cntp")) 
		     (opt-args (list (si:gen-local-var () "&opt")))
		     (req-args (mapcar #'(lambda (x) (si:gen-local-var () "Req-Var"))
				       (make-list (car args)))) )
    (do ((i (1- (cdr args)) (1- i))
	 (opt-argsl `(,(car opt-args) 0 ,cntp)))
	((<= i (car args))
	 `(DEFUN ,name (,@req-args &OPTIONAL ,@opt-argsl)
		 (COND (,cntp (,name ,@req-args ,opt-args))
		       (#T (,name ,@req-args 
				  ,(nreverse (cdr (reverse opt-args))))))))
      (push (si:gen-local-var () "&opt") opt-args)
      (push `(,(car opt-args) 0) opt-argsl)))





(eval-when (compile)
   (setq defmacro-for-compiling 'T defmacro-displace-call MACROEXPANDED )
)


;;;; Initial setups

#+PDP10
  (cond ((and (get 'STRAUX 'VERSION)
	      (eq (array-type 'STR/:ARRAY) 'FIXNUM)
	      (fixp (array-/#-dims 'STR/:GCMARRAY))))
	('T (mapc '(lambda (x y) (and (not (boundp x)) (set x y)))
		  '(STRINGS-GCSIZE STRINGS-GCMAX STRINGS-GCMIN)
		  '(2048.         20480.        .2))
	    (setq STR/:ARYSIZE STRINGS-GCSIZE 
		  STR/:GCMSIZE  256. 
		  STR/:FREESLOT   0 
		  STR/:NO/.STRS   0  
		  STR/:NO/.PWDSF  0
		  STR/:PURE-ADDR  -1 )
	    (setq STR/:STRING-HUNK-PATTERN (new-string -1 0))
	    (setf (SI:extend-marker-of STR/:STRING-HUNK-PATTERN) () )
	    (setf (SI:extend-class-of STR/:STRING-HUNK-PATTERN) () )
	    (setq STR/:CHARACTER-EXTEND-PATTERN 
		  (SI:EXTEND CHARACTER-CLASS (MUNKAM #O777777))
		  STR/:CHARACTER-HUNK-PATTERN 
		  (SI:EXTEND CHARACTER-CLASS (MUNKAM #O777777)))
	    (setf (si:extend-marker-of STR/:CHARACTER-HUNK-PATTERN) () )
	    (setf (si:extend-class-of STR/:CHARACTER-HUNK-PATTERN) () )
	    (array STR/:ARRAY FIXNUM STR/:ARYSIZE)
	    (array STR/:GCMARRAY () STR/:GCMSIZE)
	    (mapc '(lambda (x) (set x (get x 'ARRAY))) 
		  '(STR/:ARRAY STR/:GCMARRAY))
	    ;; (setq STR/:NULL-STRING (make-string 0))
	    ((lambda (x y)
		     (store (STR/:GCMARRAY 0) y)
		     (setq STR/:FREESLOT 1 
			   STR/:NO/.STRS  1 
			   STR/:NULL-STRING y)
		     (setq STR/:DUMMY (new-string 0 0))
		     (nointerrupt x))
	     (nointerrupt 'T) 
	     (new-string 0 0))
	    (cond ((getddtsym 'GRBPSG))
		  ((status feature ITS)
		   (cond ((eq (status lispv) '/1914) 
			  (defprop GRBPSG 19042. SYM))
			 ((valret '|:symlod/î:vp |))))
		  ;; On non-ITS systems, make the PURE_STRING loader bomb
		  ;;   out by doing a THROW
		  ('T (putprop 'GRBPSG (1- (getddtsym 'ERUNDO)) 'SYM)))
	    (subload STRAUX)))


;;;; Bothmacros and lexprmacros

#-NIL (progn 'COMPILE 

(defbothmacro CHARACTERP (x) `(EQ (PTR-TYPEP ,x) 'CHARACTER))
#M 
(defbothmacro STRINGP (x) `(EQ (PTR-TYPEP ,x) 'STRING))
#+Multics 
(defbothmacro STRING-LENGTH (x) `(STRINGLENGTH ,x))
(defcomplrmac CHAR (str i) 
   `(*:FIXNUM-TO-CHARACTER (+INTERNAL-CHAR-N  ,str ,i)))
(defun CHAR (str i)
   (if *RSET 
       (let ((cnt 1))
	 (check-subsequence (str i cnt) 'STRING 'CHAR)))
   (char str i))
(defcomplrmac RPLACHAR (str i c) 
   `(+INTERNAL-RPLACHAR-N ,str ,i (*:CHARACTER-TO-FIXNUM ,c)))
(defun RPLACHAR (str i c)
   (cond ((or *RSET 
	      (not (stringp str)) 
	      (not (fixnump i))
	      (< i 0)
	      (>= i (string-length str))) 
	   (let ((cnt 1))
	     (check-subsequence (str i cnt) 'STRING 'RPLACHAR))
	   (check-type c #'CHARACTERP 'RPLACHAR)))
   (rplachar str i c))

)

(defbothmacro CHARACTER (c) `(TO-CHARACTER-N? ,c () ))

#M
  (progn 'compile 
    (defbothmacro *:CHARACTER-TO-FIXNUM (c) `(MAKNUM (SI:XREF ,c 0)))
    (defbothmacro STRING-LENGTH (x) `(SI:XREF ,x 1))
;;  (defbothmacro SET-STRING-LENGTH  (x n) `(SI:XSET ,x 1 ,n))
;;   SET-STRING-LENGTH has been re-written as a subr -- see near MAKE-STRING
    (defsetf STRING-LENGTH ((() str) len) () 
	     `(SI:XSET ,str 1 ,len))
    )	;end of #M 

#+(or LISPM MULTICS) 
  (progn 'compile 
      (defbothmacro *:CHARACTER-TO-FIXNUM (VAL) `(AR-1 ,val 1))
      (defbothmacro CHAR-N (H N) `(AR-1 ,h ,n))
      (defbothmacro RPLACHAR-N (H N VAL)
	 (cond ((or (|side-effectsp/|| h) 
		    (|side-effectsp/|| n) 
		    (|side-effectsp/|| val))
		(let (htem tmp)
		     (si:gen-local-var htem (/" |Char|))
		     (si:gen-local-var tmp (/" I))
		     `((LAMBDA (,htem ,tmp) (AS-1 ,val ,htem ,tmp))
		          ,h ,n)))
	       (`(AS-1 ,val ,h ,n))))
      (defbothmacro SET-STRING-LENGTH  (x n) `(ADJUST-ARRAY-SIZE ,x ,n))
      (defsetf STRING-LENGTH ((() str) len) () 
	       `(SET-STRING-LENGTH ,str ,len))
      )	;end of #+(or LISPM MULTICS) 


;; STRING-SEARCHQ AND STRING-EQUAL are already mini-subr'd in real NIL

#-NIL 
(defmumble STRING-SEARCHQ  |STR/:STRING-SEARCHer| 
	  '(() T STRING-SEARCHQ)   '(2 . 4))

(defmumble STRING-BSEARCHQ |STR/:STRING-SEARCHer| 
	  '(() () STRING-BSEARCHQ) '(2 . 4))


#-LISPM (progn 'compile 
     ;;; STRING-EQUAL and STRING-LESSP should be rewritten in machine lang?
(deflexprmacro STRING-LESSP STR/:STRING-EQUAL-LESSP '(() . () ) '(2 . 6))
 #-NIL
(deflexprmacro STRING-EQUAL STR/:STRING-EQUAL-LESSP '(() . T) '(2 . 6))
(deflexprmacro STRING-SEARCH |STR/:STRING-SEARCHer| 
	      '(T T STRING-SEARCH) '(2 . 4))
(deflexprmacro STRING-REVERSE-SEARCH |STR/:STRING-SEARCHer| 
	       '(T () STRING-REVERSE-SEARCH) '(2 . 4))
(deflexprmacro STRING-DOWNCASE STR/:STRING-UP-DOWN-CASE () '(1 . 3))
(deflexprmacro STRING-UPCASE STR/:STRING-UP-DOWN-CASE #T '(1 . 3))
)	;end of #-LISPM 


#-PDP10 		;These come in from the STRAUX file for maclisp
  (progn 'compile 
     #-NIL
     (defmumble STRING-POSQ |STR/:STRING-POSQer| '(POSQ . T) '(2 . 4))
     (defmumble STRING-BPOSQ |STR/:STRING-POSQer| '(POSQ . () ) '(2 . 4))
     #-NIL
     (defmumble STRING-SKIPQ |STR/:STRING-POSQer| '(SKIPQ . T) '(2 . 4))
     (defmumble STRING-BSKIPQ |STR/:STRING-POSQer| '(SKIPQ . () ) '(2 . 4))
     #-NIL
     (defmumble STRING-POSQ-N |STR/:STRING-POSQ-Ner| '(POSQ . T) '(2 . 4))
     (defmumble STRING-BPOSQ-N |STR/:STRING-POSQ-Ner| '(POSQ . () ) '(2 . 4))
     #-NIL
     (defmumble STRING-SKIPQ-N |STR/:STRING-POSQ-Ner| '(SKIPQ . T) '(2 . 4))
     (defmumble STRING-BSKIPQ-N |STR/:STRING-POSQ-Ner| '(SKIPQ . () ) '(2 . 4))
     #-NIL
     (defmumble STRING-FILL |STR/:STRING-POSQer| '(FILL . () ) '(2 . 4))
     #-NIL
     (defmumble STRING-FILL-N |STR/:STRING-POSQ-Ner| '(FILL . () ) '(2 . 4))
	)	;end of #-PDP10



(defsetf CHAR ((() frob index) value) () 
   `(RPLACHAR ,frob ,index ,value))

(defsetf CHAR-N ((() frob index) value) () 
   `(RPLACHAR-N ,frob ,index ,value))


;;;; Maclisp MAKE-STRING and gc support, and buck-passing |*lexpr-funcall-1|

#+PDP10
(progn 'compile 

(eval-when (eval compile)
(defmacro WORD-NO  (str)  `(SI:XREF ,str 0))
    ;; Warning!  Discontinuity at 0:  (// -1 5) => -1, instead of 0
(defsimplemac NO-WORDS-USED (x) 
   `(IF (<= ,x 0)  1  (1+ (// (1- ,x) #.*:bytes-per-word))))
(defsimplemac WORDNO-OF-NEXT-FREESLOT (str)
   `(+ (WORD-NO (STR/:GCMARRAY ,str))
       (NO-WORDS-USED (FIXNUM-IDENTITY (STRING-LENGTH ,str)))))
(defmacro TRIMWORD (word no-odd-chrs)
   `(DEPOSIT-BYTE ,word 
		  0 
		  (1+ (* (- #.*:bytes-per-word ,no-odd-chrs) 
			 #.*:bits-per-character)) 
		  0))
  )



(defconst STR/:GC-DAEMON () 
  "Flag used to communicate the fact that the gc-daemon has been run.")

(defun MAKE-STRING (x &optional (filler 0 fillerp))
   (if (or (not (fixnump x)) (< x 0))
       (check-type x #'SI:NON-NEG-FIXNUMP 'MAKE-STRING))
   (prog (wds-required maxslot n no-strings str oni cfl gfl *RSET)
	 (declare (fixnum n wds-required no-strings maxslot))
	 (setq oni (nointerrupt 'T) 
	       n x 
	       wds-required (no-words-used n))
      A  (setq maxslot (+ wds-required STR/:FREESLOT))
	 (cond 
	   ((>= maxslot STR/:ARYSIZE)
	      ;;Do we need GC or COMPRESSION attention?
	     (cond ((< maxslot STRINGS-GCSIZE)
		      ;;Maybe we could just grow the array without GC'ing?
		     (str/:grow-array maxslot))
		   ((null cfl)
		      ;;Try compressing without GC at least once.
		     (STR/:COMPRESS-SPACE () )
		     (setq cfl 'T)
		     (go A))
		   ((null gfl)
		      ;;Well, try Gc'ing once, and (maybe) permit interrupts
		     (nointerrupt oni)
		     (setq STR/:GC-DAEMON () )
		     (gc)		
		      ;;Must have GC-DAEMON run, to mark STR/:GCMARRAY 
		     (if (null STR/:GC-DAEMON) (str/:gc-daemon () ))
		     (nointerrupt 'T)
		     (STR/:COMPRESS-SPACE () )
		     (str/:grow-array maxslot)
		     (setq gfl 'T cfl 'T)
		     (go A))
		   ('T (error (/" |Can't get enough STRING space|)
			      wds-required 
			      'FAIL-ACT)
		       (setq gfl () cfl () )
		       (go A)))))
          ;; Here is the basic consification of strings!
	 (setq no-strings (setq STR/:NO/.STRS (1+ STR/:NO/.STRS)))
	 (cond ((> no-strings STR/:GCMSIZE )
		(nointerrupt oni)
		(let ((newsize (+ STR/:GCMSIZE 512.)))
		  (*rearray 'STR/:GCMARRAY () newsize)
		  (setq STR/:GCMSIZE newsize)) 
		(nointerrupt 'T)))
	 (setq str (new-string STR/:FREESLOT n)
	       STR/:FREESLOT (+ STR/:FREESLOT wds-required))
	 (store (STR/:GCMARRAY (1- no-strings)) str)
	 (nointerrupt oni)
	 (if (or (null fillerp) (= filler 0))
	     (str/:clear-words str wds-required)
	     (string-fill-n str (character filler)))
	 (return str)))


(defun STR/:GROW-ARRAY (maxslot)
    ;; Calculate a size to which the array ought to be grown.
  (setq maxslot 
	(+ maxslot
	   (cond ((fixnump STRINGS-GCMIN) STRINGS-GCMIN)
		 ((flonump STRINGS-GCMIN) 
		   (ifix (*$ STRINGS-GCMIN (float STR/:ARYSIZE))))
		 ('T 1024.))))
  (*rearray 'STR/:ARRAY 'FIXNUM maxslot)
  (setq STR/:ARYSIZE (array-dimension-n 1 'STR/:ARRAY))
  (if (< STRINGS-GCSIZE STR/:ARYSIZE)
      (setq STRINGS-GCSIZE STR/:ARYSIZE))
  (if ^D 
      (let ((OUTFILES (if (memq 'T msgfiles) 
			  (cons tyo msgfiles) 
			  msgfiles)) 
	    (^R 'T) (^W 'T) 
	    (BASE 10.) (*NOPOINT))
	(terpri)
	(princ '|;Adding a new STRING chunk -- space is now |)
	(prin1 STR/:ARYSIZE)
	(princ '| words.|)))
  'T)


(eval-when (eval compile)
  (defsimplemac GCDAEMON-LOST? (str)
    `(OR (NOT (EQ (TYPEP ,str) ',(typep (new-string -1 0))))
	 (AND (CXR 1 ,str)			    ;GC nullifies LH of hunk
	      (NOT (EQ (SI:EXTEND-CLASS-OF ,str) STRING-CLASS))
	      (NOT (EQ (TYPE-OF ,str) 'STRING)))))
)

(defvar STR/:GC-CHECK? () )
;;; If non-null, causes the weird condition of non-string-found-in-string-array
;;;  to breakpoint.  Whether breaking or not, the conditions is proceedable
;;;  merely by nullifying the offending slot.


(defun STR/:GC-CHECK? (msg fun i flushp errorp)
  (cond ((or STR/:GC-CHECK? errorp) 
	  (format msgfiles 
		  (/" |;Possible STRING bug: ~A~%;  Discovered in ~A ~:[-- Returning will merely flush (STR/:GCMARRAY ~d)~]|)
		  (or msg (/" |Non-string in GCMARRAY|))
		  fun 
		  (not flushp)
		  i)
	  (let ((BREAK i))
	    (declare (special BREAK))
	    (break STR/:GC-CHECK?))))
  (if (not (fixnump i)) (+internal-lossage 'FIXNUM 'STR/:GC-CHECK? i))
  (and flushp (store (STR/:GCMARRAY i) () )))


(defun STR/:COMPRESS-SPACE (recursivep) 
    ;; *RSET is () when MAKE-STRING  calls this function, but most 
    ;;  importantly, (NOINTERRUPT 'T) has been done, so there can't be
    ;;  any re-entrant calls!!!
  (do ((i 1 (1+ i))
       (lui 0) 					;last used index
       (free-loc 1) (str-ln 0) 
       (current-loc 0) (old-loc 0) 
       (byte-parity 0) (lowest-i-certified-safe 0)
       (str) 
       (str-free STR/:DUMMY))
      ((> i STR/:NO/.STRS)	 		;Loop thru the GCMARRAY
        (if ^D 
	    (let ((OUTFILES (if (memq 'T msgfiles) 
				(cons tyo msgfiles) 
				msgfiles)) 
		  (n (1+ lui))
		  (^R 'T) (^W 'T) 
		  (BASE 10.) (*NOPOINT))
	      (declare (fixnum n))
	      (terpri) 
	      (princ '|;Compression of STRING space: |)
	      (prin1 n)
	      (princ '| live Strings, using |)
	      (prin1 free-loc)
	      (princ '| words.|)
	      (terpri)
	      (cond ((not (= 0 (setq n (- STR/:NO/.STRS n))))
		     (princ '|;   (Reclaimed |)
		     (prin1 n)
		     (princ '| strings using |)
		     (prin1 (- STR/:FREESLOT free-loc))
		     (princ '| words.)|))
		    ('T (print '|; (Nothing reclaimed).|)))))
        (setq STR/:NO/.STRS (1+ lui) 		; # strs still alive
	      STR/:FREESLOT free-loc)		;lowest free in STR:ARRAY
	() )
    (declare (fixnum i lui free-loc str-ln current-loc old-loc 
		     byte-parity lowest-i-certified-safe))
    (setq str (STR/:GCMARRAY i))
    (cond ((null str) () )			;String already proven dead
	  ((gcdaemon-lost? str) 
	    (str/:gc-check? () 'STR/:COMPRESS-SPACE i 'T () ))
	  ((or (< (setq str-ln (string-length str)) 0) 
	       (> str-ln 1_14.)
	       (< (setq current-loc (word-no str)) 0)
	       (> current-loc 12._14.))
	    (str/:gc-check? (/" |STRING length or location bad!|) 
			    'STR/:COMPRESS-SPACE 
			    i 
			    'T 
			    'T))
	  ((>= current-loc old-loc)
	     ;;Aha! STRING is alive!
	    (if (= current-loc old-loc)
		(str/:gc-check? '|Failure to increment STR/:FREESLOT| 
				'STR/:COMPRESS-SPACE 
				i 
				() 
				'T))
	    (setf (string-length str-free) str-ln) ;Close gap, if any,
	    (setf (word-no str-free) free-loc)	   ; moving string to 
	    (cond ((not (= str-ln 0)) 		   ; the lower slot
		    (string-replace str-free str) 
		      ;;After string movement, we have have to insure
		      ;; that final word is padded with 0's
		    (if (not (= (setq byte-parity (\ str-ln 5)) 0))
			 ;;Byte-parity is 0,1,2,3,4 counting from left
			(let ((ha (1- (no-words-used str-ln))))
			  (+internal-set-string-word-n 
			    str-free 
			    ha  
			    (trimword (+internal-string-word-n 
				        str-free 
					ha)
				      byte-parity))))))
	    (setf (word-no str) free-loc)
	     ;; Update running counters for FREE-SLOTLOC and NO.STRS
	    (setq old-loc current-loc  
		  free-loc (+ free-loc (no-words-used str-ln)))
	    (cond ((not (= (setq lui (1+ lui)) i))
		    (store (STR/:GCMARRAY lui) str)
		    (store (STR/:GCMARRAY i) () ))))
	  ('T ;; means that (< current-loc old-loc)
	      ;;Looks like some loser "sneaked" in here.
	   (if recursivep (+internal-lossage 'STR/:COMPRESS-SPACE 'STR/:COMPRESS-SPACE recursivep))
	   (comment  ;For the time being, just ignore any extra 
		     ;processing on these losers
	    (let ((loser (str/:gcmarray lui)))
	      (str/:gc-check? (/" |Re-cons'd String found|) 
			      'STR/:COMPRESS-SPACE 
			      lui 
			      'T 
			      () )
	       ;;Ok, just try to certify that all strings in the array
	       ;; from 0 up to here are "unique"
	      (do ((k (1+ lowest-i-certified-safe) (1+ k))
		   (sk))
		  ((>= k lui))
		(declare (fixnum k j))
		(setq sk (str/:gcmarray k))
		(do ((j (1+ k) (1+ j)))
		    ((> j STR/:NO/.STRS))
		  (if (eq sk (str/:gcmarray j))
		      (str/:gc-check? (/" |Re-cons'd String out of order?|) 
				      'STR/:COMPRESS-SPACE k () 'T))))
	       ;;And check out this loser -- it had better be a twice-
	       ;; cons'd hunk used as a string again.
	      (do ((j i (1+ j)))
		  ((> j STR/:NO/.STRS)
		   (str/:gc-check? (/" |Re-cons'd String has no 2nd instance.|)
				   'STR/:COMPRESS-SPACE lui () 'T)) 
		(declare (fixnum j))
		(if (eq loser (str/:gcmarray j)) (return () )))
	      (setq lowest-i-certified-safe lui)
	      (setq lui (1- lui)))
	      )
	   (do ((k 1 (1+ k))
		(sk))
	       ((>= k STR/:NO/.STRS))
	      ;;Try to kill out any low-index entries whose hunk is being
	      ;; used later in the GCMARRAY
	     (declare (fixnum k j))
	     (setq sk (str/:gcmarray k))
	     (do ((j (1+ k) (1+ j)))
		 ((>= j STR/:NO/.STRS))
	       (cond ((eq sk (str/:gcmarray j))
		      (store (str:gcmarray k) () )
		      (return () )))))
	    ;Then try again!
	   (str/:compress-space i)
	   (return () )))))




(defun STR/:GC-DAEMON  (() ) 
   ;; *RSET is () when MAKE-STRING  calls the GC
  (cond ((not (eq STR/:NULL-STRING (STR/:GCMARRAY 0)))
	  (str/:gc-check? (/" |(STR/:GCMARRAY 0) clobbered|) 
			  'STR/:GC-DAEMON 
			  0 
			  () 
			  'T)
	  (store (STR/:GCMARRAY 0) STR/:NULL-STRING)))
  (do ((i 1 (1+ i))		;index which cycles thru gcmarray
       (ns 0)			;number of non-"nullified" slots
       (nn 0)			; amount of space consumed
       (str) )
      ((> i STR/:NO/.STRS)
        (if ^D 
	    (let ((OUTFILES (if (memq 'T msgfiles) 
				(cons tyo msgfiles) 
				msgfiles)) 
		  (^R 'T) (^W 'T) 
		  (BASE 10.) (*NOPOINT))
	      (princ '|;STRING space:  |)
	      (prin1 ns)
	      (princ '| live strings, using |)
	      (prin1 nn)
	      (princ '| words.|)
	      (terpri) )))
    (declare (fixnum i ns nn))
    (cond ((null (setq str (STR/:GCMARRAY i))) () )  ;Already flushed this one?
	  ((null (car str))
	     ;;GC nullifies LH of hunk, so if string is dead, then nullify 
	     ;;  gcmarray slot, for it is garbage!
	    (store (STR/:GCMARRAY i) () ))
	  ((gcdaemon-lost? str) 
	    (str/:gc-check? () 'STR/:GC-DAEMON i 'T () ))
	  (^D (setq ns (1+ ns) 
		    nn (+ nn (no-words-used (string-length str)))))))
  (setq STR/:GC-DAEMON 'T))	    


(eval-when (compile)
  (notype (SET-STRING-LENGTH () () )))

(defun SET-STRING-LENGTH (str n &aux (lstr 0) (no-odd-chrs 0))
    (declare (fixnum lstr no-odd-chrs))
    (if (not (stringp str)) (check-type str #'STRINGP 'SET-STRING-LENGTH))
    (setq lstr (string-length str))
    (do () 
	((and (fixnump n) (<= 0 n lstr)))
      (setq n (error (/" |Can't set length of string to this|)
		     `(STRING str n)
		     'FAIL-ACT)))
    (setq no-odd-chrs (\ n #.*:bytes-per-word))
    (or (= no-odd-chrs 0)
	(let* ((lstwd-i (1- (no-words-used n)))
	       (lastword (+internal-string-word-n str lstwd-i)))
	  (declare (fixnum lstwd-i))
	  (+internal-set-string-word-n 
	     str 
	     lstwd-i 
	     (trimword lastword no-odd-chrs))))
      (setf (string-length str) n)
      str)



(eval-when (eval compile)
(defmacro LEXPR-FCL-HELPER (n) 
   (or (fixnump n) (error 'lexpr-fcl-helper n))
   (do ((i 1 (1+ i)) (w () ))
       ((> i n) `(LSUBRCALL T FUN FIRST-ARG ,. (nreverse w)))
     (push `(ARG ,i) w)))
)

(defun |*lexpr-funcall-1| (name fun first-arg args-prop) 
    ;; Function for passing the buck
   (let ((n (arg () )))
	(and (or (< n (car args-prop)) (> n (cdr args-prop)))
		  (error (/" |Wrong number args to function|) name))
	(caseq n 
	       (1  (lexpr-fcl-helper 1))
	       (2  (lexpr-fcl-helper 2))
	       (3  (lexpr-fcl-helper 3))
	       (4  (lexpr-fcl-helper 4))
	       (5  (lexpr-fcl-helper 5))
	       (6  (lexpr-fcl-helper 6)))))


)		;end of moby #+PDP10


;;;; Some funs primitive in real NIL:   *:FIXNUM-TO-CHARACTER, DIGITP, DIGITP-N
;;;; STRING-SUBSEQ,  STRING-MISMATCHQ

#-NIL (progn 'compile 

(defun STR/:CHARACTER-VALUEP (x) (and (fixnump x) (<= 0 x #O7777)))

(defun *:FIXNUM-TO-CHARACTER (x &aux (n 0))
   (declare (fixnum n))
   (and *RSET (check-type x #'STR/:CHARACTER-VALUEP '*:FIXNUM-TO-CHARACTER))
   (cond ((cond ((< (setq n x) #.(^ 2 *:bits-per-character)))
		('T (and (bit-test n #O4000) 		;IOR the %TXTOP bit to 
			 (setq n (bit-set #O1000 n)))	; %TXSFT position, and
		    (setq n (logand #O1777 n)) 		; fold down to 10. bits
		    (< (setq n x) #.(^ 2 *:bits-per-character))))
	  (ar-1 |+internal-CHARACTER-table/|| n))
	 ('T (setq x (munkam n))
	     (cdr (cond ((assq x (ar-1 |+internal-CHARACTER-table/|| 
				       #.(^ 2 *:bits-per-character))))
			('T (setq x (cons x (new-character n)))
			    (push x (ar-1 |+internal-CHARACTER-table/|| 
					  #.(^ 2 *:bits-per-character)))
			    x))))))


(defun STRING-SUBSEQ (str i &optional (cnt () cntp))
   (cond (*RSET (check-subsequence (str i cnt) 'STRING 'STRING-SUBSEQ #T cntp))
	 ((not cntp) (setq cnt (- (string-length str) i))))
   (substringify str i cnt))

;;; Someday, STRING-MISMATCHQ should be rewritten in MIDAS.
(defun STRING-MISMATCHQ (s1 s2  &optional (i1 0) (i2 0) (cnt () ocntp))
  (let	((n 0) (cntp ocntp))
   (declare (fixnum n))
   (cond (*RSET 
	   (let ((foo1 cnt) (foo2 cnt))
	     (check-subsequence (s1 i1 foo1) 'STRING 'STRING-MISMATCHQ #T cntp)
	     (check-subsequence (s1 i2 foo2) 'STRING 'STRING-MISMATCHQ #T cntp)
	     (setq n (if (< foo1 foo2) foo1 foo2) 
		   cntp #T)))
	 (cntp (setq n cnt)))
   (let ((ls1 (- (string-length s1) i1)) 
	 (ls2 (- (string-length s2) i2)))
     (declare (fixnum ls1 ls2))
     (if (not cntp) (setq n (if (< ls1 ls2) ls1 ls2)))
     (cond  #+PDP10 
	   ((and (= i1 0)
		 (= i2 0)
		 (= ls1 ls2)
		 (= n ls1)
		 (str/:compare-words s1 s2))
	      () )
	   (#T (do ((i 0 (1+ i)))
		   ((>= i n) 
		    (if (or ocntp (and (= n ls1) (= n ls2))) 
			() 
			n))
		 (declare (fixnum i))
		 (if (not (= (+internal-char-n s1 (+ i1 i))
			     (+internal-char-n s2 (+ i2 i))))
		     (return (+ i1 i)))))))))

)	;end of #-NIL 


;;;; STRING-PNGET and STRING-PNPUT

#+PDP10 (progn 'COMPILE 

(defun STRING-PNGET (string seven)
   (cond (*RSET
	  (if (not (and (fixnump seven) (= seven 7)))
	      (error (/" |Uluz - need 7|) seven))
	  (check-type string #'STRINGP 'STRING-PNGET)))
   (let* ((str-ln (string-length string))
	  (lstwd-i (1- (no-words-used str-ln)))
	  (no-odd-chrs (\ str-ln #.*:bytes-per-word))
	  (lastword (+internal-string-word-n string lstwd-i))
	  (wdsl `(,(if (= no-odd-chrs 0) 
		       lastword 
		       (trimword lastword no-odd-chrs)))))
     (declare (fixnum str-ln lstwd-i no-odd-chrs lastword))
     (do ((i 0 (1+ i)))
	 ((>= i lstwd-i))
       (declare (fixnum i))
	(push (+internal-string-word-n string (- lstwd-i i 1)) wdsl))
     wdsl))

(defun STRING-PNPUT (l () )
  (do () 
      ((or (null l) (pairp l)))
    (setq l (error (/" |Bad arg - STRING-PNPUT|) l 'WRNG-TYPE-ARG)))
   (if (and l (null (cdr l)) (= (car l) 0)) (setq l () )) ;Let || ==> ""
   (let* ((no/.wds (length l))
	  (str-ln (* no/.wds #.*:bytes-per-word))
	  (str (make-string str-ln)))
     (declare (fixnum no/.wds str-ln))
     (if l (progn 
	     (do ((ll l (cdr ll))
		  (i 0 (1+ i)))
		 ((null ll))
	       (declare (fixnum i))
	       (+internal-set-string-word-n str i (car ll)))
	     (let ((*RSET)
		   (where (string-bskipq-n 0 str (1- str-ln) #.*:bytes-per-word)))
	       (if where (setf (string-length str) (1+ where))))))
     str))


;;;;  STRING-HASH and  |*lexpr-funcall-1|

(defun STRING-HASH (str &optional (start-i 0) (cnt () cntp))
   (cond ((and (stringp str) 		;Don't bother with complicated
	       (fixnump start-i)	; general error checking, if
	       (= start-i 0)		; the simple case obtains
	       (null cntp)))
	 (*RSET 
	   (check-subsequence (str start-i cnt) 'STRING 'STRING-HASH #T cntp)
	   (setq cntp #T)))
   (let ((str-ln (string-length str)))
     (declare (fixnum str-ln))
     (if (not cntp) (setq cnt (- str-ln start-i)))
     (cond 
       ((= cnt 0) 12345.)
       (#T (if (not (= (\ start-i #.*:bytes-per-word) 0))
	       (setq str (string-subseq str start-i cnt) start-i 0))
	   (let* ((1stwd-i (// start-i #.*:bytes-per-word))
		  (lstwd-i (1- (no-words-used cnt)))
		  (no-odd-chars (\ cnt #.*:bytes-per-word))
		  (hash (+internal-string-word-n str (+ 1stwd-i lstwd-i))))
	     (declare (fixnum 1stwd-i lstwd-i no-odd-chars hash))
	     (or (= no-odd-chars 0)
		 (setq hash (trimword hash no-odd-chars)))
	     (do ((i (- lstwd-i 1stwd-i 1) (1- i)))
		 ((< i 1stwd-i))
	       (declare (fixnum i))
	       (setq hash (logxor (+internal-string-word-n str i) hash)))
	     (lsh hash -1))))))

)	;end of #+PDP10 


;;;; DIGITP, DIGIT-WEIGHT, and  |STR/:STRING-SEARCHer| 


(defun DIGITP (c)  
   (and (setq c (to-character-n? c #T))
	(<= #/0 c #/9)))

(defun DIGIT-WEIGHT (c)
   (setq c (to-character-n? c () ))
   (cond ((<= #/0 c #/9) (- c #/0))
	 ((<= #/A c #/Z)  (- c #.(- #/A 10.)))
	 ((<= #/a c #/z)  (- c #.(- #/a 10.)))))




(defun |STR/:STRING-SEARCHer| (foo s1 s2 &optional (i2 () i2p) (cnt () cntp) 
					 &aux (lispmp (car foo))
					      (fwp (cadr foo)) 
					      (fun (caddr foo)))
  (cond (*RSET 
	  (check-type s1 #'STRINGP 'STRING-SEARCH)
	  (check-subsequence (s2 i2 cnt) 'STRING fun i2p cntp fwp lispmp)
	  (setq i2p #T cntp #T)))
   (prog (ls1 ls2 mpsi ss-i)
     (declare (fixnum ls1 ls2 mpsi ss-i))
     (setq ls1 (string-length s1) 
	   ls2 (string-length s2) 
	   mpsi (- ls2 ls1))
     (cond ((or (not i2p) (null i2)) 
	    (setq i2 (if fwp 0 (if lispmp ls2 (1- ls2))))
	    (setq i2p () )))
     (setq ss-i i2)			;search start index
     (cond ((not fwp) 
	     (setq ss-i (- ss-i ls1))
	     (if (not lispmp) (setq ss-i (1+ ss-i)))))
     (return 
      (cond 
       ((< mpsi 0) () )
       ((= ls1 0)  
	(if (not fwp) (setq ss-i (1- ss-i)))
	ss-i)
       ((let ((haumany 0)
	      (1st-p-c (+internal-char-n s1 0)) ;First pattern char
	      (mnpsi 0))
	  (declare (fixnum haumany 1st-p-c mnpsi))
	  (setq haumany (1+ (if fwp (- mpsi ss-i) ss-i)))
	  (cond ((and cntp (< cnt haumany)) 
		 (setq haumany cnt)
		 (if fwp (setq mpsi (+ ss-i haumany -1))))) 
	  (setq mnpsi (- ss-i haumany))  ;Minimum possible start index
	  (do ((j ss-i)
	       #-NIL (*RSET)
	       #-NIL (nxt-i) )
	      ((cond ((null j))			;Iterate while "next" search-
		     (fwp (> j mpsi))		; start index will be within 
		     (#T  (< j mnpsi)))		; bounds.
	       () )
	    (if lispmp 
		(cond 
		 ((setq j
		    (if fwp 
			(string-search-char 1st-p-c s2 j)
			(string-reverse-search-char 1st-p-c s2 (1+ j))))
		   (and (<= mnpsi j mpsi)
			(string-equal s1 s2 0 j ls1 (+ j ls1))
			(return j))))
		#-NIL 
	         (cond 
		   ((setq nxt-i 
		      (cond (fwp (string-posq-n 1st-p-c s2 j haumany))
			    (#T  (string-bposq-n 1st-p-c s2 j haumany))))
		     (and (<= mnpsi nxt-i mpsi)
			  (not (string-mismatchq s1 s2 0 nxt-i ls1)) 
			  (return nxt-i))
		     (setq haumany (- haumany (if fwp 
						  (1+ (- nxt-i j))
						  (- j nxt-i)))))
		   ('T (setq j () )))))
	  ))))))





;;;;  SUBSTRING,  STRING-APPEND,  STRING-REVERSE,  STRING-NREVERSE,

;; LISPM compatibility stuff

#-LISPM
(progn 'compile 

(defun SUBSTRING (str i &optional (lmi () lmip))
   (cond (*RSET 
	    ;; Check as if "end-index" were a start for backwards searching
	   (check-subsequence (str lmi () ) 'STRING 'SUBSTRING lmip () () #T)
	   (check-type i #'SI:NON-NEG-FIXNUMP 'SUBSTRING))
	 ((null lmip) (string-length str)))
   (substringify str i (- lmi i)))


(defun STRING-APPEND #-NIL n #+NIL (&rest w &aux (n (vector-length w)))
   (let ((new-len 0) str)
     (declare (fixnum new-len))
     (do ((i 0 (1+ i)))
	 ((>= i n))
       (declare (fixnum i))
       (setq str (s-arg w i))	;Calculate total length of resultant string
       (cond  ((not (stringp str)) 
	       (cond ((not (symbolp str))
		       (check-type str #'STRINGP 'STRING-APPEND))
		     (#T (setq str (get-pname str))))
	       (s-setarg w i str)))
       (setq new-len (+ new-len (string-length str))))
    #+Multics
     (apply 'CATENATE (listify n))
    #-Multics
     (let ((newstr (make-string new-len))
	   (ii 0)				;"ii" is a running start index
	   *RSET)
       (do ((i 0 (1+ i)))
	   ((>= i n))
	 (declare (fixnum i))
	 (setq str (s-arg w i))
	 (cond ((not (= (string-length str) 0))  ;Fill in parts of new string
		 (string-replace newstr str ii)
		 (setq ii (+ ii (string-length str))))))
       newstr)))


(defun STRING-REVERSE  (str &optional start (cnt () cntp))
       (str/:string-reverser str #T start cnt cntp))
(defun STRING-NREVERSE (str &optional start (cnt () cntp))
       (str/:string-reverser str () start cnt cntp))


;;;;  STR/:STRING-REVERSER  STR/:STRING-EQUAL-LESSP
;;; Remember, still within a #-LISPM conditional

(defun STR/:STRING-REVERSER 
	    (str newp start cnt cntp &aux (newstr str) (lstr 0))
   (declare (fixnum lstr))
   (if (null start) (setq start 0))
   (cond ((or *RSET (not newp))
	   (check-subsequence (str start cnt)
			      'STRING
			      (if newp 'STRING-REVERSE 'STRING-NREVERSE) 
			      #T 
			      cntp)
	   (setq cntp #T lstr (string-length str))
	   (if newp (let (*RSET) (setq newstr (string-subseq str start cnt)))))
	 (#T (setq lstr (string-length str))
	     (cond ((not cntp) (setq cnt (- lstr start)))
		   ((not (<= (+ start cnt) lstr))
		    (setq cnt (- lstr start))))
	     (if newp (setq newstr (string-subseq str start cnt)))))
   (if newp (setq start 0))
   (do ((i start (1+ i))
	(ii (+ start cnt -1) (1- ii))
	chii)
       ((> i ii) )
     (declare (fixnum i ii chii))
     (setq chii (+internal-char-n newstr ii))	    ;Save an interchange char,
     (+internal-rplachar-n newstr ii (+internal-char-n newstr i))
     (+internal-rplachar-n newstr i chii))	    ; and pairwise-interchange
   newstr)

(defun STR/:STRING-EQUAL-LESSP 
       (foo s1 s2 
	&optional (i1 0 i1p) (i2 0 i2p) (lm1 () lm1p) (lm2 () lm2p))
  (let (((nocasep . equalp) foo) 
	 (ls1 0) (ls2 0) (c1 0) (c2 0))
    (declare (fixnum ls1 ls2 c1 c2))
    (cond 
      (*RSET 
         ;; Check as if "end-index" were a start for backwards searching
        (check-subsequence 
	   (s1 lm1 () )  'STRING  'STR/:STRING-EQUAL-LESSP  lm1p  ()  () #T)
	(check-subsequence 
	   (s2 lm2 () )  'STRING  'STR/:STRING-EQUAL-LESSP  lm2p  ()  () #T)
	(setq lm1p #T lm2p #T)
	(if i1p (check-type i1 #'SI:NON-NEG-FIXNUMP 'STR/:STRING-EQUAL-LESSP))
	(if i2p (check-type i2 #'SI:NON-NEG-FIXNUMP 'STR/:STRING-EQUAL-LESSP))
	(setq c1 (- lm1 i1) c2 (- lm2 i2))
	(check-subsequence (s1 i1 c1) 'STRING 'STR/:STRING-EQUAL-LESSP)
	(check-subsequence (s2 i2 c2) 'STRING 'STR/:STRING-EQUAL-LESSP)
	(setq ls1 (string-length s1) ls2 (string-length s2)) )
      (#T (setq ls1 (string-length s1) ls2 (string-length s2)
		c1 (- (if lm1p lm1 ls1) i1) 
		c2 (- (if lm2p lm2 ls2) i2))))
    (cond 
      ((and equalp (not (= c1 c2)))  () )
      ((and (not equalp) (= c1 0))  (not (= c2 0)))
      ((do ((i1* i1 (1+ i1*))				;Iterate over the two
	    (i2* i2 (1+ i2*))				; strings, looking for
	    (i (if (< c1 c2) c1 c2) (1- i)))		; a place of discord
	   ((<= i 0)
	    (if (or equalp (> (- lm2 i2*) (- lm1 i1*))) 
		#T))
	 (declare (fixnum i i1* i2*))
	 (setq c1 (+internal-char-n s1 i1*)
	       c2 (+internal-char-n s2 i2*))
	 (if (not (if nocasep (= c1 c2) (char-equal c1 c2)))
	       ;;No decision possible when chars are "equal"
	     (return (cond (equalp () )
			   (nocasep (< c1 c2))
			   (#T (char-lessp c1 c2)))))) )) ))



;;; Remember, still within a #-LISPM conditional
(comment  GET-PNAME  STR/:STRING-UP-DOWN-CASE  TRIMers)
;LISPM compatibility stuff

#+PDP10 
(defun GET-PNAME (x) 
   (setq x (pnget x 7))
   (and (null (cdr x))	;Foo! || has (0) as pname list.
	(= (car x) 0)
	(setq x () ))
   (string-pnput x 7))

(defun STR/:STRING-UP-DOWN-CASE (up s1 &optional i1 (cnt () cntp))
   (if (null i1) (setq i1 0))
   (if (symbolp s1) (setq s1 (get-pname s1)))
   (cond (*RSET   
	   (check-subsequence (s1 i1 cnt) 
			      'STRING 
			      (if up 'STRING-UPCASE 'STRING-DOWNCASE)
			      #T 
			      cntp)
	   (setq cntp #T)))
   (let ((ls1 (string-length s1))
	 (ch 0)
	 newstr)
     (declare (fixnum ls1 ch))
     (if (not cntp) (setq cnt (- ls1 i1)))
     (setq newstr (make-string cnt))
     (do ((i 0 (1+ i)))
	 ((>= i cnt))
       (declare (fixnum i))
	(setq ch (+internal-char-n s1 (+ i i1)) 		;get this char
	      ch (if up (char-upcase ch) (char-downcase ch))) 	;case-ify it
	(+internal-rplachar-n newstr i ch))
     newstr))


(defun STRING-LEFT-TRIM (cl str)
  (str:trim-check cl str 'T () 'STRING-LEFT-TRIM))
(defun STRING-RIGHT-TRIM (cl str)
  (str:trim-check cl str () 'T 'STRING-RIGHT-TRIM))
(defun STRING-TRIM (cl str)
  (str:trim-check cl str 'T 'T 'STRING-TRIM))
    
(defun STR:TRIM-CHECK (cl str leftp rightp fun)
  (prog (i1*) 
    (declare (fixnum i1* i2* len))
    (setq i1* 0)
    (if (symbolp str) (setq str (get-pname str)))
    (cond (*RSET (check-type str #'STRINGP fun)
		 (check-type cl #'LISTP fun)))
    (if leftp
	(if (setq leftp (string-search-not-set cl str))
	    (setq i1* leftp)
	    (return STR/:NULL-STRING)))
    (return 
      (cond ((null rightp) (string-subseq str i1*))
	    ((null (setq rightp (string-reverse-search-not-set cl str)))
	      STR/:NULL-STRING)
	    ((let ((len (string-length str))
		   (i2* rightp))
	       (if (>= i2* len) (setq i2* (1- len)))
	       (string-subseq str i1* (- i2* i1* -1))))))))

)	;end of moby #-LISPM conditional


;;;; STRING-REMQ 

(setq si:STRING-REMQ-buffer () )

#+(or NIL MacLISP)
(push 'si:STRING-REMQ-buffer #N SI:BREAK-BOUND-VARIABLES
			     #M +INTERNAL-INTERRUPT-BOUND-VARIABLES )

(defun STRING-REMQ (c str &optional (starti 0 ip) (cnt () cntp) 
			  &aux (n 0) (cn 0))
  (declare (fixnum ln i j cn cc maxln)
	   (special si:STRING-REMQ-buffer))
  (or si:STRING-REMQ-buffer (setq si:STRING-REMQ-buffer (make-string 100.)))
  (if *RSET 
      (check-subsequence (str starti cnt) 'STRING 'STRING-SUBSEQ ip cntp))
  (setq n (or cnt (- (string-length str) starti))
	cn (to-character-n c))
  (do ((i starti (1+ i)) 
       (j 0)
       (cc 0)
       (maxln (string-length si:STRING-REMQ-buffer)))
      ((< (setq n (1- n)) 0) (substringify si:STRING-REMQ-buffer 0 j))
    (cond ((not (= cn (setq cc (+internal-char-n str i))))
	    (if (> j maxln)
		(setq si:STRING-REMQ-buffer 
		      (string-replace 
		        (make-string (setq maxln (+ maxln 100.))) 
			si:STRING-REMQ-buffer)))
	    (+internal-rplachar-n si:STRING-REMQ-buffer j cc)
	    (setq j (1+ j))))))
  


;;;; Fill-in primitives


#+Multics
(defun MAKE-STRING (n) 
   (do ((s "" (catenate s ""))
	(i n (- n 4))) 
       ((< i 4) 
	(cond ((= i 0) s)
	      ((catenate (cond ((= i 1) "")
			       ((= i 2) "")
			       ((= i 3) ""))
			 s))))))

#Q 
(defun MAKE-STRING (n) 
       (let ((s (make-array () 'ART-16B n)))
	    (as-1 s STRING-CLASS 0)
	    s))
     

#-PDP10 (progn 'compile 

(defun |STR/:STRING-POSQer| (foo char str &OPTIONAL  (i* 0) (cnt 0 cntp))
       (setq char (*:character-to-fixnum char))
       (cond (cntp (|STR/:STRING-POSQ-Ner| foo char str i* cnt))
	     (#T (|STR/:STRING-POSQ-Ner| foo char str i*))))

(defun |STR/:STRING-POSQ-Ner| (foo char str &OPTIONAL (i* () i*p) (cnt () cntp)
					    &AUX      (op (car foo))
						      (fwp (cdr foo)) )
   (if (eq op 'FILL) (exch char str))
   (cond (*RSET 
	   (check-type char #'STR/:CHARACTER-VALUEP op)
	   (check-subsequence (str i* cnt) 'STRING op i*p cntp fwp)
	   (setq cntp #T i*p #T))
	 (#T (if (not i*p) (setq i* 0)) ))
   (do ((n (cond (cntp cnt) 
		 (fwp (- (string-length str) i*))
		 ((1+ i*)))
	   (1- n))
	(i i* (cond (fwp (1+ i)) ((1- i)))))
       ((= n 0) () )
     (declare (fixnum n i))
     (if (eq op 'FILL) (+internal-rplachar-n str i char)
	 (if (eq op (if (= char (+internal-char-n str i)) 'POSQ 'SKIPQ))
	     (return i)))))
     
)	;end of  #-PDP10


;;;; PDP10 hooks -  Methods for PRINT, EXPLODE, SXHASH, NAMESTRING, SAMEPNAMEP,
;;;;  ALPHALESSP, LESSP, GREATERP, EQUAL, FLATSIZE, PURCOPY, USERATOMS

	     
#+PDP10 (progn 'compile 

(defmethod* (:PRINT-SELF STRING-CLASS) (str ofile () slashifyp)
   (if *RSET (check-type str #'STRINGP ':PRINT-SELF->STRING-CLASS))
   (setq ofile (si:normalize-stream ofile))
   (if slashifyp (tyo #/" ofile))
   (do ((len (string-length str))
	(i 0 (1+ i)) 
	(c 0))
       ((>= i len) )
     (declare (fixnum len i c))
     (setq c (+internal-char-n str i))
     (and slashifyp (or (= c #/") (= c #//)) (tyo #// ofile))
     (tyo c ofile))
   (and slashifyp (tyo #/" ofile)))

(defmethod* (:PRINT-SELF CHARACTER-CLASS) (chr ofile () slashifyp)
   (if *RSET (check-type chr #'CHARACTERP ':PRINT-SELF->CHARACTER-CLASS))
   (setq ofile (si:normalize-stream ofile))
   (cond (slashifyp (princ '|~//| ofile)))
   (tyo (*:character-to-fixnum chr) ofile))

(defmethod* (EXPLODE STRING-CLASS) (str slashifyp number-p)
   (if *RSET (check-type str #'STRINGP 'EXPLODE->STRING-CLASS))
   (do ((strlist (and slashifyp
		      (if number-p (ncons #/") (ncons '/")))
		 (cons c strlist))
	(len (string-length str))
	(i 0 (1+ i))
	(c 0))
       ((>= i len)
	(if slashifyp (push (if number-p #/" '/") strlist))
	(nreverse strlist))
     (declare (fixnum len i))
     (setq c (+internal-char-n str i))
     (if (not number-p) (setq c (ascii c)))
     (and slashifyp 
	  (or (= c #/") (= c #//))
	  (push (if number-p #// '//) strlist))))

 (defmethod* (EXPLODE CHARACTER-CLASS) (object slashify-p number-p)
    (let ((result (cons #/~
			(if slashify-p
			    (cons #//
				  (ncons (*:character-to-fixnum object)))
			    (ncons (*:character-to-fixnum object))))))
	 (if (not number-p) (mapcar 'ascii result) result)))

(defmethod* (SXHASH STRING-CLASS) (string) (string-hash string))

(defmethod* (NAMESTRING STRING-CLASS) (string) 
   (pnput (string-pnget string 7) () ))


(defmethod* (SAMEPNAMEP STRING-CLASS) (x y) 
  (si:alpha-test x y '(T . T) () )) 
(defmethod* (ALPHALESSP STRING-CLASS) (x y) 
  (si:alpha-test x y '(T . () ) #T))
(defmethod* (LESSP STRING-CLASS) (x y) 
  (si:alpha-test x y '(T . () ) () ))
(defmethod* (GREATERP STRING-CLASS) (x y) 
  (si:alpha-test y x '(T . () ) () ))


(defun SI:ALPHA-TEST (x y foo alphalesspp)
  (and (cond ((stringp x) (if (not (stringp y)) (setq y (get-pname y))))
	     ((stringp y) (setq x (get-pname x)) #T)
	     (#T (+internal-lossage 'STRINGP 'ALPHALESSP->STRING-CLASS (list x y))))
       alphalesspp 
       (error (/" |Mixed mode tests in an old lisp -  ALPHALESSP|) (list x y)))
   (str/:string-equal-lessp foo x y)) 


(defmethod* (EQUAL STRING-CLASS) (obj other-obj)
   (and (stringp other-obj) (str/:compare-words obj other-obj)))

(DEFMETHOD* (FLATSIZE STRING-CLASS) (OBJ () () SLASHIFYP)
   (DECLARE (FIXNUM MAX CNT))
   (COND (SLASHIFYP
	  (DO ((MAX (1- (STRING-LENGTH OBJ)))
	       (I -1 (STRING-SEARCH-SET '(#/" #//) OBJ (1+ I)))
	       (CNT 2 (1+ CNT)))
	      ((OR (NULL I) (= I MAX))
	       (+ CNT (COND (I (1+ MAX)) (MAX))))	;Fix fencepost
	      ))
	 (#T (STRING-LENGTH OBJ))))


(defmethod* (FLATSIZE CHARACTER-CLASS) (() () () slashifyp)
   (if slashifyp 3 1))

(defmethod* (PURCOPY STRING-CLASS) (x) 
   (let ((nx (purcopy STR/:STRING-HUNK-PATTERN))
	 (nwds 1)
	 (str-len 0))
      (declare (fixnum nwds str-len))
      (and (cond ((not (stringp x)))
		 ((< (setq str-len (string-length x)) 0))
		 ((> (setq nwds (no-words-used str-len)) 512.))) 
		  (error (/" |Can't PURCOPY a string this long|) x))
      (let ((oni (nointerrupt #T)))
	(if (< STR/:NO/.PWDSF nwds) 
	    (setq STR/:PURE-ADDR (STR/:GRAB-PURSEG) 
		  STR/:NO/.PWDSF 512.))
	(setf (word-no nx) (purcopy (logior 1_35. (- (+ STR/:PURE-ADDR 512.)
						     STR/:NO/.PWDSF))))
	(setq STR/:NO/.PWDSF (- STR/:NO/.PWDSF nwds))
	(nointerrupt oni))
      (setf (si:extend-class-of nx) (si:extend-class-of x))
      (setf (si:extend-marker-of nx) (si:extend-marker-of x))
      (setf (string-length nx) (purcopy str-len))
      (if (> str-len 0) (string-replace nx x 0 0 str-len))
      nx))

(defmethod* (DESCRIBE STRING-CLASS) (ob stream level)
  (declare (special SI:DESCRIBE-MAX-LEVEL))
  (if (and (not (> level SI:DESCRIBE-MAX-LEVEL)) 
	   (stringp ob))
      (format stream 
	      (/" |~%~vTThe string ~S has ~D characters.|)
	      level ob (string-length ob))))


(defmethod* (USERATOMS-HOOK STRING-CLASS) (x)
   (list `(STRING-PNPUT ',(string-pnget x 7) #T)))

(defmethod* (USERATOMS-HOOK CHARACTER-CLASS) (x)    ;; Don't macroexpand this - need the use of autoload properties
   (list `(*:FIXNUM-TO-CHARACTER ,(*:character-to-fixnum x))))

)	;end of #+PDP10


;;;; Set up tables and constants


#M 
(mapc #'(lambda (x) (set x (get x 'LSUBR)))
      '(|STR/:STRING-SEARCHer| STR/:STRING-EQUAL-LESSP STR/:STRING-UP-DOWN-CASE 
	#-PDP10 |STR/:STRING-POSQ-Ner| #-PDP10 |STR/:STRING-POSQer| ))
#Q 
(mapc '(lambda (x) (set x (fsymeval x)))
      '(|STR/:STRING-POSQ-Ner| |STR/:STRING-POSQer|))

#+PDP10 
(setq *FORMAT-STRING-GENERATOR 'TO-STRING)

#-NIL (progn 'compile 

(setq |+internal-CHARACTER-table/|| 
      (*array () 'T #.(1+ (^ 2 *:bits-per-character))))
	  ;;Fill in this table with the full 128. character objects,
	  ;; for the ASCII alphabet, leaving a 129.th slot for a list 
	  ;; of folded-down 12-bit characters seen.
(do ((i #.(1- (^ 2 *:bits-per-character)) (1- i)) 
     (*RSET)
     (z (and (status feature PDP10) (status nofeature ONESEGMENT))))
    ((< i 0))
  (store (arraycall T |+internal-CHARACTER-table/|| i)
	 (if z 
	     (new-character i T)
	     (new-character i))))

(defun |+internal-tilde-macro/|| #-LISPM () #Q (ignore ignore) 
   (let ((c (tyi)))
      (declare (fixnum c))
      (cond ((= c #//) (setq c (tyi)))		;Check for slash
	    ((= c #/\) (setq c (/#-/\-parse))))
      (*:fixnum-to-character c)))


#-LISPM  (setsyntax '/~ 'MACRO '|+internal-tilde-macro/||)
#Q 	 (set-syntax-macro-char #/~ '|+internal-tilde-macro/||)

#+PDP10  (progn 'compile

(def-or-autoloadable /#-/\-parse SHARPM) 

(defun |+internal-doublequote-macro/|| ()
     (declare (fixnum ln i c))
     (do ((c (tyi) (tyi))
	  (charsl))
	 ((= c #/")
	  (let* ((ln (length charsl))
		 (str (make-string ln))) 
	    (declare (fixnum ln))
	    (do ((i 0 (1+ i)))
		((>= i ln))
	      (declare (fixnum i))
	      (+internal-rplachar-n str (- ln i 1) (pop charsl)))
	    str))
       (push (if (= c #//) (tyi) c) charsl)))
(setsyntax '/" 'MACRO '|+internal-doublequote-macro/||)
  )	  ;end of #+PDP10
)	;end of #-NIL



(mapc '(lambda (x) (putprop x '|mmcdrside/|| '|side-effectsp/||))
      '(CHAR CHAR-N +INTERNAL-CHAR-N CHARACTERP 
	*:CHARACTER-TO-FIXNUM  *:FIXNUM-TO-CHARACTER
	TO-CHARACTER TO-CHARACTER-N TO-CHARACTER-N? 
	TO-STRING DIGITP DIGIT-WEIGHT 
	CHARACTER CHAR-EQUAL CHAR-LESSP GET-PNAME  STRING-REMQ 
	MAKE-STRING  STRING-SEARCHQ  STRING-BSEARCHQ  STRING-MISMATCHQ 
 	STRING-POSQ  STRING-BPOSQ  STRING-POSQ-N  STRING-BPOSQ-N
 	STRING-SKIPQ STRING-BSKIPQ STRING-SKIPQ-N STRING-BSKIPQ-N
 	STRING-EQUAL STRING-LESSP STRING-SEARCH STRING-REVERSE-SEARCH
 	STRING-DOWNCASE  STRING-UPCASE CHAR-DOWNCASE CHAR-UPCASE
	STRING-REVERSE  SUBSTRING STRING-APPEND  STRING-SUBSEQ 
	STRING-SEARCH-CHAR 		STRING-SEARCH-NOT-CHAR 
	STRING-SEARCH-SET 		STRING-SEARCH-NOT-SET
	STRING-REVERSE-SEARCH-CHAR 	STRING-REVERSE-SEARCH-NOT-CHAR 
	STRING-REVERSE-SEARCH-SET 	STRING-REVERSE-SEARCH-NOT-SET
	STRING-PNGET  STRING-PNPUT  STRING-HASH
	) )



#+PDP10
  (setq GC-DAEMON 
	(cond ((null GC-DAEMON)  'STR/:GC-DAEMON)
	      ((let ((g (gensym)) 
		     (h (cond ((or (symbolp gc-daemon)
				   (and (not (atom gc-daemon))
					(eq (car gc-daemon) 'LAMBDA)))
			       `(,gc-daemon))
			      (`(FUNCALL ',gc-daemon)))))
		    `(LAMBDA (,g) 
			     (STR/:GC-DAEMON ,g)
			     (,.H ,g))))))


(sstatus feature STRING)