(FILECREATED " 1-AUG-83 15:59:55" {PHYLUM}<LISPCORE>SOURCES>LLCHAR.;18
 28250  

      changes to:  (FNS BKSYSBUF)

      previous date: "28-JUL-83 23:55:37" {PHYLUM}<LISPCORE>SOURCES>LLCHAR.;17)


(* Copyright (c) 1982, 1983 by Xerox Corporation)

(PRETTYCOMPRINT LLCHARCOMS)

(RPAQQ LLCHARCOMS
 ((FNS MKATOM SUBATOM CHARACTER MKNUMATOM \MKINTEGER MKSTRING BKSYSBUF NCHARS 
			NTHCHARCODE RPLCHARCODE \RPLCHARCODE NTHCHAR RPLSTRING SUBSTRING GNC GNCCODE 
			GLC GLCCODE STREQUAL CHCON1 U-CASE L-CASE U-CASEP \SMASHSTRING)
	(EXPORT (GLOBALVARS \OneCharAtomBase)
		(GLOBALRESOURCES (\NUMSTR (ALLOCSTRING 38))
				 (\NUMSTR1 (CONCAT))
				 (\PNAMESTRING (ALLOCSTRING \PNAMELIMIT)))
		(DECLARE: DONTCOPY (PROP DMACRO FCHARACTER)
			  (I.S.OPRS INATOM INSTRING)
			  (CONSTANTS (\CHARMASK 255)
				     (\MAXCHAR 255))
			  (MACROS \NATOMCHARS \NSTRINGCHARS \RPLCHARCODE)))
	(P (MOVD? (QUOTE CHARACTER)
		  (QUOTE FCHARACTER)))
	(LOCALVARS . T)))
(DEFINEQ

(MKATOM

  [LAMBDA (X)                                               (* rmk: "30-JAN-81 23:56")

    (SELECTC (NTYPX X)
	     [\STRINGP (\MKATOM (fetch
 (STRINGP BASE) of
 X)
				(fetch
 (STRINGP OFFST) of
 X)
				([LAMBDA (LEN)
				    (COND
				      ((IGREATERP LEN \PNAMELIMIT)
					(LISPERROR "ATOM TOO LONG" X))
				      (T LEN]
				  (fetch
 (STRINGP LENGTH) of
 X]
	     ((LIST \LITATOM \SMALLP \FIXP \FLOATP)
	       X)
	     (PACK* X])

(SUBATOM

  [LAMBDA (X N M)                                           (* rmk: "10-NOV-81 20:03")

    (PROG (BASE OFFST LEN (N1 N)
		(M1 M))                                     (* N1 and M1 so don't reset user arg.)

          [COND
	    ((LITATOM X)
	      (SETQ BASE (fetch
 (LITATOM PNAMEBASE) of
 X))
	      (SETQ OFFST 1)
	      (SETQ LEN (fetch
 (LITATOM PNAMELENGTH) of
 X)))
	    (T (SETQ LEN (OR (STRINGP X)
			     (MKSTRING
 X)))                 (* Don't reset user arg)

	       (SETQ BASE (fetch
 (STRINGP BASE) of
 LEN))
	       (SETQ OFFST (fetch
 (STRINGP OFFST) of
 LEN))
	       (SETQ LEN (fetch
 (STRINGP LENGTH) of
 LEN]
          [COND
	    ((IGREATERP 0 N1)                               (* Coerce the first index)

	      (SETQ N1 (IPLUS N1 LEN 1]
          [COND
	    ((NULL M1)                                      (* Coerce the second)

	      (SETQ M1 LEN))
	    ((IGREATERP 0 M1)
	      (SETQ M1 (IPLUS M1 LEN 1]
          (RETURN (AND (IGREATERP N1 0)
		       (ILEQ N1 M1)
		       (ILEQ M1 LEN)
		       (\MKATOM BASE (IPLUS OFFST N1 -1)
				(COND
				  ((IGREATERP (SETQ LEN (ADD1 (IDIFFERENCE M1 N1)))
					      \PNAMELIMIT)
				    (LISPERROR "ATOM TOO LONG" X))
				  (T LEN])

(CHARACTER

  [LAMBDA (N)                      (* lmm "21-DEC-81 23:19")

    (SETQ N (LOGAND N \CHARMASK))
    (FCHARACTER N])

(MKNUMATOM

  [LAMBDA (BASE BN LEN)                                     (* rmk: " 3-MAY-83 06:36")


          (* * Attempt to create a numeric atom out of the chars in BASE from byte BN for LEN bytes. Return NIL if the chars 

	  do not form a legal number)



    (PROG ((I BN)
	   (END (IPLUS BN LEN))
	   (STATE (QUOTE INIT))
	   C SIGN START ENDFRAC DECPT EXPSTART NEGFRAC SIGDIGITS EXP10)
      LP  

          (* * Scan string to see what we have: a decimal integer, octal integer, or floating-point number.

	  Once we know which we have, we can pack up the value quickly)



          [COND
	    ((EQ I END)
	      (RETURN (SELECTQ STATE
			       ((INITDIGIT AFTERQ)
				 (COND
				   [START (\MKINTEGER
 BASE START (OR ENDFRAC I)
						      (EQ SIGN (QUOTE -))
						      (COND
							((EQ STATE (QUOTE AFTERQ))
							  8)
							(T 10]
				   (T 0)))
			       [(INFRACTION INEXPONENT)
				 (COND
				   [SIGDIGITS [COND
						((NOT ENDFRAC)
						  (SETQ ENDFRAC I)
						  (SETQ NEGFRAC (EQ SIGN (QUOTE -]
					      [COND
						((IGREATERP SIGDIGITS MAX.DIGITS.ACCURACY)

          (* Too many digits--we will overflow. Only take as many as we can handle. Don't worry about looking at the n+1'st 

	  digit for rounding, since it won't make any difference (there are many fewer sig bits in a floatp than in a fixp))



						  (SETQ ENDFRAC (IPLUS START MAX.DIGITS.ACCURACY))
						  (COND
						    ((AND (IGREATERP DECPT START)
							  (ILESSP DECPT ENDFRAC))
						      (add
 ENDFRAC 1]
					      (SETQ EXP10 (COND
						  (EXPSTART (\MKINTEGER
 BASE EXPSTART I
									(EQ SIGN (QUOTE -))
									10))
						  (T 0)))   (* the explicit exponent)

					      (\FLOATINGSCALE (\MKINTEGER
 BASE START ENDFRAC NEGFRAC 
									  10)
							      (IPLUS EXP10 (IDIFFERENCE DECPT ENDFRAC)
								     (COND
								       ((ILESSP DECPT ENDFRAC)
                                                            (* don't count the position the dec pt occupies)

									 1)
								       (T 0]
				   (T (FLOAT 0]
			       NIL]
          (SETQ STATE (OR [SELCHARQ (SETQ C (\GETBASEBYTE BASE I))
				    (- (AND (NOT SIGN)
					    (SELECTQ STATE
						     ((INIT AFTERE)
						       (SETQ SIGN (QUOTE -))
						       STATE)
						     NIL)))
				    (+ (AND (NOT SIGN)
					    (SELECTQ STATE
						     ((INIT AFTERE)
						       (SETQ SIGN (QUOTE +))
						       STATE)
						     NIL)))
				    (Q (SELECTQ STATE
						(INITDIGIT (SETQ ENDFRAC I)
							   (QUOTE AFTERQ))
						NIL))
				    (E (SELECTQ STATE
						((INITDIGIT INFRACTION)
                                                            (* We've seen digits and/or a fraction)

						  (OR DECPT (SETQ DECPT I))
						  (SETQ ENDFRAC I)
						  (SETQ NEGFRAC (EQ SIGN (QUOTE -)))
						  (SETQ SIGN NIL)
						  (QUOTE AFTERE))
						NIL))
				    (%. (SETQ DECPT I)
					(SELECTQ STATE
						 (INIT (QUOTE AFTERINITIALDOT))
						 (INITDIGIT (QUOTE INFRACTION))
						 NIL))
				    (COND
				      ([AND (IGEQ C (CHARCODE 0))
					    (ILEQ C (CONSTANT (CHCON1
 "9"]
                                                            (* digit)

					(SELECTQ STATE
						 ((INIT INITDIGIT)
						   (COND
						     (SIGDIGITS (add
 SIGDIGITS 1))
						     ((NEQ C (CHARCODE 0))
                                                            (* record where first significant digit happens)

						       (SETQ START I)
						       (SETQ SIGDIGITS 1)))
						   (QUOTE INITDIGIT))
						 ((INFRACTION AFTERINITIALDOT)
                                                            (* Scanning fractional part)

						   (COND
						     (SIGDIGITS (add
 SIGDIGITS 1))
						     ((NEQ C (CHARCODE 0))
						       (SETQ SIGDIGITS 1)
						       (SETQ START I)))
						   (QUOTE INFRACTION))
						 (AFTERE (SETQ EXPSTART I)
							 (QUOTE INEXPONENT))
						 (INEXPONENT (QUOTE INEXPONENT))
						 NIL]
			  (RETURN NIL)))
          (SETQ I (ADD1 I))
          (GO LP])

(\MKINTEGER

  [LAMBDA (BASE START END NEG RADIX)                        (* rmk: " 3-MAY-83 06:36")


          (* * Return integer whose Ascii characters run from START to END off BASE. If NEG is true, negate it.

	  RADIX is the base (8 or 10). For benefit of floating routines, dec pt is ignored)



    (PROG ((VAL 0)
	   CH)
      LP  (COND
	    ((EQ START END)
	      (RETURN VAL)))
          (SETQ CH (IDIFFERENCE (\GETBASEBYTE BASE START)
				(CHARCODE 0)))
          [COND
	    ([NEQ CH (CONSTANT (IDIFFERENCE (CHCON1
 (QUOTE %.))
					    (CHARCODE 0]    (* ignore dec pt)

	      (SETQ VAL (COND
		  (NEG (IDIFFERENCE (ITIMES VAL RADIX)
				    CH))
		  (T (IPLUS (ITIMES VAL RADIX)
			    CH]
          (SETQ START (ADD1 START))
          (GO LP])

(MKSTRING

  [LAMBDA (X FLG RDTBL)            (* lmm "28-JUL-83 23:53")

    (DECLARE
 (GLOBALVARS PRXFLG \PRINTRADIX \SIGNFLAG))
    (PROG NIL
          (OR FLG (SELECTC (NTYPX X)
			   (\STRINGP (RETURN X))
			   (\LITATOM (RETURN (create
 STRINGP
						     BASE ←(fetch
 (LITATOM PNAMEBASE) of
 X)
						     LENGTH ←(fetch
 (LITATOM PNAMELENGTH)
								of
 X)
						     OFFST ← 1
						     READONLY ← T)))
			   [(LIST \FIXP \SMALLP \FLOATP)
			     (RETURN (GLOBALRESOURCE
				       (\NUMSTR \NUMSTR1)
				       (PROG [(STR (COND
						     ((FLOATP X)
						       (\CONVERT.FLOATING.NUMBER X \NUMSTR \NUMSTR1))
						     (T (\CONVERTNUMBER X (COND
									  (PRXFLG \PRINTRADIX)
									  (T 10))
									(OR (NULL PRXFLG)
									    \SIGNFLAG)
									NIL \NUMSTR \NUMSTR1]
					     (RETURN (RPLSTRING
 (ALLOCSTRING (NCHARS
 STR))
								1 STR]
			   NIL))
          (RETURN (PROG ((S (ALLOCSTRING (NCHARS
 X FLG RDTBL)))
			 (J 1))
		        (\MAPCHARS [FUNCTION (LAMBDA (CODE)
				       (\RPLCHARCODE
 S J CODE)
				       (SETQ J (ADD1 J]
				   X FLG RDTBL)
		        (RETURN S])

(BKSYSBUF

  [LAMBDA (X FLG RDTBL)                                      (* rrb " 1-AUG-83 15:59")

    (PROG (BASE OFFST LEN)
          (COND
	    (FLG (GO SLOWCASE)))
          (SELECTC (NTYPX X)
		   (\LITATOM (SETQ BASE (fetch
 (LITATOM PNAMEBASE) of
 X))
			     (SETQ OFFST 1)
			     (SETQ LEN (fetch
 (LITATOM PNAMELENGTH) of
 X)))
		   (\STRINGP (SETQ BASE (fetch
 (STRINGP BASE) of
 X))
			     (SETQ OFFST (fetch
 (STRINGP OFFST) of
 X))
			     (SETQ LEN (fetch
 (STRINGP LENGTH) of
 X)))
		   (GO SLOWCASE))
          (for
 I from
 OFFST to
 (IPLUS OFFST LEN -1) DO
 (BKSYSCHARCODE (\GETBASEBYTE BASE I)))
          (RETURN)
      SLOWCASE
          (\MAPCHARS (FUNCTION BKSYSCHARCODE)
		     X FLG RDTBL))
    X])

(NCHARS

  [LAMBDA (X FLG RDTBL)                                     (* rmk: "11-MAR-82 23:13")

    (SELECTC (NTYPX X)
	     [\LITATOM (COND
			 [FLG (IPLUS (fetch
 (LITATOM PNAMELENGTH) of
 X)
				     (for
 C (SA ←(fetch
 READSA of
 (\GTREADTABLE RDTBL)))
					inatom
 X count
 (fetch
 (READCODE ESCQUOTE)
							  of
 (\SYNCODE SA C]
			 (T (fetch
 (LITATOM PNAMELENGTH) of
 X]
	     [\STRINGP (COND
			 [FLG                               (* 2 for the enclosing quotes)

			      (IPLUS 2 (fetch
 (STRINGP LENGTH) of
 X)
				     (for
 C instring
 X count
 (OR (EQ C (CHARCODE %"))
								 (EQ C (CHARCODE %%]
			 (T (fetch
 (STRINGP LENGTH) of
 X]
	     (PROG ((N 0))
	           (DECLARE
 (SPECVARS N))
	           (\MAPCHARS (FUNCTION [LAMBDA NIL
				  (ADD1VAR N])
			      X FLG RDTBL)
	           (RETURN N])

(NTHCHARCODE

  [LAMBDA (X N FLG RDTBL)                                   (* rmk: " 3-MAY-83 06:36")

    (PROG (BASE OFFST LEN (M N))
          [COND
	    (FLG (GO SLOWCASE))
	    (T (SELECTC (NTYPX X)
			(\STRINGP (SETQ BASE (fetch
 (STRINGP BASE) of
 X))
				  (SETQ LEN (fetch
 (STRINGP LENGTH) of
 X))
				  (SETQ OFFST (fetch
 (STRINGP OFFST) of
 X)))
			(\LITATOM (SETQ BASE (fetch
 (LITATOM PNAMEBASE) of
 X))
				  (SETQ LEN (fetch
 (LITATOM PNAMELENGTH) of
 X))
				  (SETQ OFFST 1))
			(GO SLOWCASE]
          [COND
	    ((IGREATERP 0 M)
	      (SETQ M (IPLUS M LEN 1]
          (COND
	    ((OR (IGREATERP 1 M)
		 (IGREATERP M LEN))
	      (RETURN NIL)))                                (* The -1 is cause strings have ORIG=1)

          [RETURN (\GETBASEBYTE BASE (SUB1 (IPLUS OFFST M]
      SLOWCASE
          [COND
	    ((EQ M 0)
	      (RETURN))
	    ((IGREATERP 0 M)
	      (AND (IGREATERP 1 (SETQ M (IPLUS M (NCHARS
 X FLG RDTBL)
					       1)))
		   (RETURN]
          (\MAPCHARS [FUNCTION (LAMBDA (CODE)
			 (COND
			   ((EQ (SETQ M (SUB1 M))
				0)
			     (RETFROM (QUOTE NTHCHARCODE)
				      CODE]
		     X FLG RDTBL)
          (RETURN])

(RPLCHARCODE

  [LAMBDA (X N CHAR)                                        (* rmk: " 3-MAY-83 06:35")

    (COND
      ((STRINGP X)
	(PROG ((LEN (fetch
 (STRINGP LENGTH) of
 X)))
	      (COND
		((fetch
 (STRINGP READONLY) of
 X)            (* Really an atom, so quietly copy it to a string)

		  (\MOVEBYTES (fetch
 (STRINGP BASE) of
 X)
			      (fetch
 (STRINGP OFFST) of
 X)
			      (fetch
 (STRINGP BASE) of
 (SETQ X (ALLOCSTRING LEN NIL X)))
			      0 LEN)))
	      [COND
		((ILESSP N 0)                               (* address from end)

		  (SETQ N (IPLUS N LEN 1]
	      (COND
		((OR (ILESSP N 1)
		     (IGREATERP N LEN))
		  (LISPERROR "ILLEGAL ARG" N)))             (* We assume that ORIG is 1 because X is a string)

	      (\PUTBASEBYTE (fetch
 (STRINGP BASE) of
 X)
			    (IPLUS (fetch
 (STRINGP OFFST) of
 X)
				   (SUB1 N))
			    (LOGAND CHAR 255))
	      (RETURN X)))
      (T (RPLCHARCODE
 (MKSTRING
 X)
		      N CHAR])

(\RPLCHARCODE

  [LAMBDA (X N CHAR)                                        (* edited: "11-DEC-82 19:15")


          (* * System version: does error checking interpreted. Compiles open as PUTBASEBYTE. N must be positive, X must be a 

	  real string)



    (COND
      ((OR (NOT (STRINGP X))
	   (fetch
 (STRINGP READONLY) of
 X))
	(LISPERROR "ILLEGAL ARG" X))
      ((OR (ILEQ N 0)
	   (IGREATERP N (fetch
 (STRINGP LENGTH) of
 X)))
	(LISPERROR "ILLEGAL ARG" N))
      ((IGREATERP CHAR 255)
	(LISPERROR "ILLEGAL ARG" CHAR)))
    (\PUTBASEBYTE (fetch
 (STRINGP BASE) of
 X)
		  (IPLUS (fetch
 (STRINGP OFFST) of
 X)
			 (SUB1 N))
		  CHAR)
    X])

(NTHCHAR

  [LAMBDA (X N FLG RDTBL)                                   (* rmk: " 3-MAY-83 06:35")

    (PROG (BASE OFFST LEN (M N))
          [COND
	    (FLG (GO SLOWCASE))
	    (T (SELECTC (NTYPX X)
			(\STRINGP (SETQ BASE (fetch
 (STRINGP BASE) of
 X))
				  (SETQ LEN (fetch
 (STRINGP LENGTH) of
 X))
				  (SETQ OFFST (fetch
 (STRINGP OFFST) of
 X)))
			(\LITATOM (SETQ BASE (fetch
 (LITATOM PNAMEBASE) of
 X))
				  (SETQ LEN (fetch
 (LITATOM PNAMELENGTH) of
 X))
				  (SETQ OFFST 1))
			(GO SLOWCASE]
          [COND
	    ((IGREATERP 0 M)
	      (SETQ M (IPLUS M LEN 1]
          (COND
	    ((OR (IGREATERP 1 M)
		 (IGREATERP M LEN))
	      (RETURN NIL)))                                (* The -1 is cause strings have ORIG=1)

          [RETURN (FCHARACTER (\GETBASEBYTE BASE (SUB1 (IPLUS OFFST M]
      SLOWCASE
          [COND
	    ((EQ M 0)
	      (RETURN))
	    ((IGREATERP 0 M)
	      (AND (IGREATERP 1 (SETQ M (IPLUS M (NCHARS
 X FLG RDTBL)
					       1)))
		   (RETURN]
          (\MAPCHARS [FUNCTION (LAMBDA (CODE)
			 (COND
			   ((EQ (SETQ M (SUB1 M))
				0)
			     (RETFROM (QUOTE NTHCHAR)
				      (FCHARACTER CODE]
		     X FLG RDTBL)
          (RETURN])

(RPLSTRING

  [LAMBDA (X N Y)                                           (* edited: "11-DEC-82 19:16")

    (PROG ((OLD
 (OR (STRINGP X)
		    (MKSTRING
 X)))
	   (REP Y)
	   OBASE OLEN RBASE RLEN ROFFST POS)
          (SETQ OBASE (fetch
 (STRINGP BASE) of
 OLD))
          (SETQ OLEN (fetch
 (STRINGP LENGTH) of
 OLD))
          [COND
	    ((LITATOM REP)
	      (SETQ RBASE (fetch
 (LITATOM PNAMEBASE) of
 REP))
	      (SETQ ROFFST 1)
	      (SETQ RLEN (fetch
 (LITATOM PNAMELENGTH) of
 REP)))
	    (T (OR (STRINGP REP)
		   (SETQ REP (MKSTRING
 REP)))
	       (SETQ RBASE (fetch
 (STRINGP BASE) of
 REP))
	       (SETQ ROFFST (fetch
 (STRINGP OFFST) of
 REP))
	       (SETQ RLEN (fetch
 (STRINGP LENGTH) of
 REP]
          (COND
	    ((IGREATERP [IPLUS RLEN (SETQ POS (COND
				   ((IGREATERP N 0)
				     (SUB1 N))
				   (T (IPLUS OLEN N]
			OLEN)
	      (LISPERROR "ILLEGAL ARG" Y)))
          (COND
	    ((fetch
 (STRINGP READONLY) of
 OLD)
	      (\MOVEBYTES OBASE (fetch
 (STRINGP OFFST) of
 OLD)
			  (fetch
 (STRINGP BASE) of
 (SETQ OLD (ALLOCSTRING OLEN NIL OLD)))
			  0 OLEN)))                         (* Now can put Y into X starting at position POS)

          (\MOVEBYTES RBASE ROFFST (fetch
 (STRINGP BASE) of
 OLD)
		      (IPLUS POS (fetch
 (STRINGP OFFST) of
 OLD))
		      RLEN)
          (RETURN OLD])

(SUBSTRING

  [LAMBDA (X N M OLDPTR)                                    (* edited: "11-DEC-82 19:24")

    (PROG (BASE OFFST LEN (XX X)
		(N1 N)
		(M1 M))                                     (* XX, N1, and M1 so don't reset user args)

          [COND
	    ((LITATOM XX)
	      (SETQ BASE (fetch
 (LITATOM PNAMEBASE) of
 XX))
	      (SETQ LEN (fetch
 (LITATOM PNAMELENGTH) of
 XX))
	      (SETQ OFFST 1))
	    (T (OR (STRINGP XX)
		   (SETQ XX (MKSTRING
 XX)))
	       (SETQ BASE (fetch
 (STRINGP BASE) of
 XX))
	       (SETQ OFFST (fetch
 (STRINGP OFFST) of
 XX))
	       (SETQ LEN (fetch
 (STRINGP LENGTH) of
 XX]
          [COND
	    ((IGREATERP 0 N1)                               (* Coerce the first index)

	      (SETQ N1 (IPLUS N1 LEN 1]
          [COND
	    ((NULL M1)                                      (* Now coerce the second index)

	      (SETQ M1 LEN))
	    ((IGREATERP 0 M1)
	      (SETQ M1 (IPLUS M1 LEN 1]
          (RETURN (COND
		    ((AND (IGREATERP N1 0)
			  (ILEQ N1 M1)
			  (ILEQ M1 LEN))
		      (COND
			((STRINGP OLDPTR)
			  (UNINTERRUPTABLY
                              (PROGN (freplace
 (STRINGP READONLY) of
 OLDPTR
					with
 (OR (LITATOM XX)
						 (fetch
 (STRINGP READONLY) of
 XX)))
				     (freplace
 (STRINGP BASE) of
 OLDPTR with
 BASE)
				     (freplace
 (STRINGP LENGTH) of
 OLDPTR
					with
 (ADD1 (IDIFFERENCE M1 N1)))
				     (freplace
 (STRINGP OFFST) of
 OLDPTR
					with
 (IPLUS N1 OFFST -1))
				     (freplace
 (STRINGP ORIG) of
 OLDPTR with
 1)))
			  OLDPTR)
			(T (create
 STRINGP
				   READONLY ←(OR (LITATOM XX)
						 (fetch
 (STRINGP READONLY) of
 XX))
				   BASE ← BASE
				   LENGTH ←(ADD1 (IDIFFERENCE M1 N1))
				   OFFST ←(IPLUS N1 OFFST -1])

(GNC

  [LAMBDA (X)                                               (* edited: "11-DEC-82 19:29")

    (PROG (LEN OFFST)
          (RETURN (FCHARACTER (COND
				[(STRINGP X)
				  (COND
				    ((ZEROP (SETQ LEN (fetch
 (STRINGP LENGTH) of
 X)))
				      (RETURN))
				    (T (PROG1 (\GETBASEBYTE (fetch
 (STRINGP BASE) of
 X)
							    (SETQ OFFST (fetch
 (STRINGP OFFST)
									   of
 X)))
					      (UNINTERRUPTABLY
                                                  (replace
 (STRINGP OFFST) of
 X with
 (ADD1 OFFST))
						  (replace
 (STRINGP LENGTH) of
 X with
 (SUB1 LEN)))]
				(T (NTHCHARCODE
 X 1])

(GNCCODE

  [LAMBDA (X)                                               (* edited: "11-DEC-82 19:30")

    (PROG (LEN OFFST)
          (RETURN (COND
		    [(STRINGP X)
		      (COND
			((ZEROP (SETQ LEN (fetch
 (STRINGP LENGTH) of
 X)))
			  (RETURN))
			(T (PROG1 (\GETBASEBYTE (fetch
 (STRINGP BASE) of
 X)
						(SETQ OFFST (fetch
 (STRINGP OFFST) of
 X)))
				  (UNINTERRUPTABLY
                                      (replace
 (STRINGP OFFST) of
 X with
 (ADD1 OFFST))
				      (replace
 (STRINGP LENGTH) of
 X with
 (SUB1 LEN)))]
		    (T (NTHCHARCODE
 X 1])

(GLC

  [LAMBDA (X)                                               (* edited: "11-DEC-82 19:31")

    (PROG (LEN)
          (RETURN (FCHARACTER (COND
				[(STRINGP X)
				  (COND
				    ([EQ -1 (SETQ LEN (SUB1 (fetch
 (STRINGP LENGTH) of
 X]
				      (RETURN))
				    (T (PROG1 (\GETBASEBYTE (fetch
 (STRINGP BASE) of
 X)
							    (IPLUS LEN (fetch
 (STRINGP OFFST)
									  of
 X)))
					      (replace
 (STRINGP LENGTH) of
 X with
 LEN]
				(T (NTHCHARCODE
 X -1])

(GLCCODE

  [LAMBDA (X)                                               (* edited: "11-DEC-82 19:32")

    (PROG (LEN)
          (RETURN (COND
		    [(STRINGP X)
		      (COND
			([EQ -1 (SETQ LEN (SUB1 (fetch
 (STRINGP LENGTH) of
 X]
			  (RETURN))
			(T (PROG1 (\GETBASEBYTE (fetch
 (STRINGP BASE) of
 X)
						(IPLUS LEN (fetch
 (STRINGP OFFST) of
 X)))
				  (replace
 (STRINGP LENGTH) of
 X with
 LEN]
		    (T (NTHCHARCODE
 X -1])

(STREQUAL

  [LAMBDA (X Y)                                             (* rmk: " 3-MAY-83 06:53")

    (AND (STRINGP X)
	 (STRINGP Y)
	 (PROG ((LEN (fetch
 (STRINGP LENGTH) of
 X)))
	       (COND
		 ((NEQ LEN (fetch
 (STRINGP LENGTH) of
 Y))
		   (RETURN)))
	       (RETURN (PROG ((BASEX (fetch
 (STRINGP BASE) of
 X))
			      (BNX (fetch
 (STRINGP OFFST) of
 X))
			      (BASEY (fetch
 (STRINGP BASE) of
 Y))
			      (BNY (fetch
 (STRINGP OFFST) of
 Y)))
			 LP  (COND
			       ((ZEROP LEN)
				 (RETURN T))
			       ((NEQ (\GETBASEBYTE BASEX BNX)
				     (\GETBASEBYTE BASEY BNY))
				 (RETURN))
			       (T (add
 BNX 1)
				  (add
 BNY 1)
				  (add
 LEN -1)
				  (GO LP])

(CHCON1

  [LAMBDA (X)                                               (* rmk: " 3-MAY-83 06:35")

                                                            (* This is opencoded NTHCHARCODE for the case where N=1 

							    and FLG=NIL)

    (SELECTC (NTYPX X)
	     [\STRINGP (AND (IGREATERP (fetch
 (STRINGP LENGTH) of
 X)
				       0)
			    (\GETBASEBYTE (fetch
 (STRINGP BASE) of
 X)
					  (fetch
 (STRINGP OFFST) of
 X]
	     (\LITATOM (AND (IGREATERP (fetch
 (LITATOM PNAMELENGTH) of
 X)
				       0)
			    (\GETBASEBYTE (fetch
 (LITATOM PNAMEBASE) of
 X)
					  1)))
	     (NTHCHARCODE
 X 1])

(U-CASE

  [LAMBDA (X)                                                (* rmk: " 9-MAY-83 14:58")

    (SELECTC (NTYPX X)
	     [\LITATOM (GLOBALRESOURCE \PNAMESTRING (for
 C CHANGEFLG (BASE ←(fetch
 (STRINGP BASE)
									       of
 \PNAMESTRING))
						       inatom
 X as
 I from
 0
						       do
 (\PUTBASEBYTE
							    BASE I (COND
							      [(AND (IGEQ C (CHARCODE a))
								    (ILEQ C (CHARCODE z)))
								(SETQ CHANGEFLG
								  (IPLUS (IDIFFERENCE C (CHARCODE
											a))
									 (CHARCODE A]
							      (T C)))
						       finally
 (RETURN (COND
									 (CHANGEFLG (\MKATOM BASE 0 I)
										    )
									 (T X]
	     [\STRINGP (for
 C BASE CHANGEFLG (NEWSTRING ←(ALLOCSTRING (\NSTRINGCHARS X)))
			  instring
 X as
 I from
 0 first
 (SETQ BASE (fetch
 (STRINGP BASE) of
 NEWSTRING))
			  do
 (\PUTBASEBYTE BASE I (COND
					     [(AND (IGEQ C (CHARCODE a))
						   (ILEQ C (CHARCODE z)))
					       (SETQ CHANGEFLG (IPLUS (IDIFFERENCE C (CHARCODE a))
								      (CHARCODE A]
					     (T C)))
			  finally
 (RETURN (COND
					    (CHANGEFLG NEWSTRING)
					    (T X]
	     [\LISTP (CONS (U-CASE
 (CAR X))
			   (AND (CDR X)
				(U-CASE
 (CDR X]
	     X])

(L-CASE

  [LAMBDA (X FLG)                                            (* rmk: " 9-MAY-83 15:07")

    (SELECTC (NTYPX X)
	     [\LITATOM (GLOBALRESOURCE \PNAMESTRING
				       (for
 C CHANGEFLG (BASE ←(fetch
 (STRINGP BASE) of
 \PNAMESTRING))
					  inatom
 X as
 I from
 0
					  do
 [COND
					       [(AND (IGEQ C (CHARCODE A))
						     (ILEQ C (CHARCODE Z)))
						 (COND
						   (FLG (SETQ FLG NIL))
						   (T (SETQ CHANGEFLG (SETQ C
							  (IPLUS (IDIFFERENCE C (CHARCODE A))
								 (CHARCODE a]
					       ([AND FLG (AND (IGEQ C (CHARCODE a))
							      (ILEQ C (CHARCODE z]
						 (SETQ FLG NIL)
						 (SETQ CHANGEFLG (SETQ C (IPLUS (IDIFFERENCE
										  C
										  (CHARCODE a))
										(CHARCODE A]
					     (\PUTBASEBYTE BASE I C)
					  finally
 (RETURN (COND
							    (CHANGEFLG (\MKATOM BASE 0 I))
							    (T X]
	     [\STRINGP (for
 C BASE CHANGEFLG (NEWSTRING ←(ALLOCSTRING (\NSTRINGCHARS X)))
			  instring
 X as
 I from
 0 first
 (SETQ BASE (fetch
 (STRINGP BASE) of
 NEWSTRING))
			  do
 [COND
			       [(AND (IGEQ C (CHARCODE A))
				     (ILEQ C (CHARCODE Z)))
				 (COND
				   (FLG (SETQ FLG NIL))
				   (T (SETQ CHANGEFLG (SETQ C (IPLUS (IDIFFERENCE C (CHARCODE A))
								     (CHARCODE a]
			       ([AND FLG (AND (IGEQ C (CHARCODE a))
					      (ILEQ C (CHARCODE z]
				 (SETQ FLG NIL)
				 (SETQ CHANGEFLG (SETQ C (IPLUS (IDIFFERENCE C (CHARCODE a))
								(CHARCODE A]
			     (\PUTBASEBYTE BASE I C)
			  finally
 (RETURN (COND
					    (CHANGEFLG NEWSTRING)
					    (T X]
	     [\LISTP (CONS (L-CASE
 (CAR X)
				   FLG)
			   (AND (CDR X)
				(L-CASE
 (CDR X)
					FLG]
	     X])

(U-CASEP

  [LAMBDA (X)                                               (* rmk: " 3-MAY-83 07:35")

    (SELECTC (NTYPX X)
	     [\LITATOM (for
 C inatom
 X never
 (AND (IGEQ C (CHARCODE a))
						  (ILEQ C (CHARCODE z]
	     [\STRINGP (for
 C instring
 X never
 (AND (IGEQ C (CHARCODE a))
						    (ILEQ C (CHARCODE z]
	     [\LISTP (AND (U-CASEP
 (CAR X))
			  (OR (NULL (CDR X))
			      (U-CASEP
 (CDR X]
	     T])

(\SMASHSTRING

  [LAMBDA (DEST POS SOURCE NC)                              (* lmm "20-APR-81 22:18")


          (* copy NC characters from the string SOURCE to the string DEST starting at character POS (counting from 0) of DEST.

	  If NC=NIL, length of SOURCE is used)



    (\MOVEBYTES (fetch
 (STRINGP BASE) of
 SOURCE)
		(fetch
 (STRINGP OFFST) of
 SOURCE)
		(fetch
 (STRINGP BASE) of
 DEST)
		(IPLUS POS (fetch
 (STRINGP OFFST) of
 DEST))
		(OR NC (fetch
 (STRINGP LENGTH) of
 SOURCE)))
    DEST])
)
(* FOLLOWING DEFINITIONS EXPORTED)


(DECLARE: DOEVAL@COMPILE DONTCOPY

(ADDTOVAR GLOBALVARS \OneCharAtomBase)
)

(RPAQQ \NUMSTR
 NIL)

(RPAQQ \NUMSTR1
 NIL)

(RPAQQ \PNAMESTRING
 NIL)
(DECLARE: DOEVAL@COMPILE DONTCOPY

(ADDTOVAR GLOBALVARS \NUMSTR \NUMSTR1 \PNAMESTRING)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY 
(PUTDEF (QUOTE \NUMSTR)
	(QUOTE GLOBALRESOURCES)
	(QUOTE (ALLOCSTRING 38)))
(PUTDEF (QUOTE \NUMSTR1)
	(QUOTE GLOBALRESOURCES)
	(QUOTE (CONCAT)))
(PUTDEF (QUOTE \PNAMESTRING)
	(QUOTE GLOBALRESOURCES)
	(QUOTE (ALLOCSTRING \PNAMELIMIT)))
)
(DECLARE: DONTCOPY 

(PUTPROPS FCHARACTER DMACRO
 [OPENLAMBDA (N)
					(COND ((IGREATERP N (CHARCODE 9))
					       (\ADDBASE \OneCharAtomBase (IDIFFERENCE N 10)))
					      ((IGEQ N (CHARCODE 0))
					       (IDIFFERENCE N (CHARCODE 0)))
					      (T (\ADDBASE \OneCharAtomBase N])

(DECLARE: EVAL@COMPILE 
(I.S.OPR (QUOTE INATOM)
	 NIL
	 [QUOTE (SUBPAIR (QUOTE ($$OFF $$BASE $$END $$BODY))
			 (LIST (GETDUMMYVAR)
			       (GETDUMMYVAR)
			       (GETDUMMYVAR)
			       (GETDUMMYVAR))
			 (QUOTE (BIND $$OFF ← 1 $$BODY ← BODY $$BASE $$END FIRST $$BASE ←
				      (fetch (LITATOM PNAMEBASE)
					     of BODY)
				      $$END ← (fetch (LITATOM PNAMELENGTH)
						     of BODY)
				      EACHTIME
				      (COND ((IGREATERP $$OFF $$END)
					     (GO $$OUT)))
				      (SETQ I.V. (GETBASEBYTE $$BASE (PROG1 $$OFF (SETQ $$OFF
											(ADD1 $$OFF]
	 T)
(I.S.OPR (QUOTE INSTRING)
	 NIL
	 [QUOTE (SUBPAIR (QUOTE ($$END $$OFF $$BASE $$BODY))
			 (LIST (GETDUMMYVAR)
			       (GETDUMMYVAR)
			       (GETDUMMYVAR)
			       (GETDUMMYVAR))
			 (QUOTE (BIND $$BODY ← BODY $$END $$OFF $$BASE FIRST (SETQ
					$$OFF
					(fetch (STRINGP OFFST)
					       of $$BODY))
				      (SETQ $$BASE (fetch (STRINGP BASE)
							  of $$BODY))
				      [SETQ $$END (IPLUS $$OFF (SUB1 (fetch (STRINGP LENGTH)
									    of $$BODY]
				      EACHTIME
				      (COND ((IGREATERP $$OFF $$END)
					     (GO $$OUT)))
				      (SETQ I.V. (\GETBASEBYTE $$BASE (PROG1 $$OFF (SETQ
									       $$OFF
									       (ADD1 $$OFF]
	 T)
)

(DECLARE: EVAL@COMPILE 

(RPAQQ \CHARMASK
 255)

(RPAQQ \MAXCHAR
 255)

(CONSTANTS (\CHARMASK 255)
	   (\MAXCHAR 255))
)

(DECLARE: EVAL@COMPILE 

(PUTPROPS \NATOMCHARS DMACRO
 ((AT)
			      (FETCH (LITATOM PNAMELENGTH)
				     OF AT)))

(PUTPROPS \NSTRINGCHARS DMACRO
 ((S)
				(fetch (STRINGP LENGTH)
				       of S)))

(PUTPROPS \RPLCHARCODE DMACRO
 ((X N CHAR)
			       (\PUTBASEBYTE (fetch (STRINGP BASE)
						    of X)
					     (IPLUS (fetch (STRINGP OFFST)
							   of X)
						    (SUB1 N))
					     CHAR)))
)
)


(* END EXPORTED DEFINITIONS)

(MOVD? (QUOTE CHARACTER)
       (QUOTE FCHARACTER))
(DECLARE: DOEVAL@COMPILE DONTCOPY

(LOCALVARS . T)
)
(PUTPROPS LLCHAR COPYRIGHT ("Xerox Corporation" 1982 1983))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (949 25402 (MKATOM 959 . 1429) (SUBATOM 1431 . 2694) (CHARACTER 2696 . 2829) (MKNUMATOM 
2831 . 6847) (\MKINTEGER 6849 . 7626) (MKSTRING 7628 . 8771) (BKSYSBUF 8773 . 9547) (NCHARS 9549 . 
10434) (NTHCHARCODE 10436 . 11639) (RPLCHARCODE 11641 . 12647) (\RPLCHARCODE 12649 . 13333) (NTHCHAR 
13335 . 14554) (RPLSTRING 14556 . 15969) (SUBSTRING 15971 . 17792) (GNC 17794 . 18450) (GNCCODE 18452
 . 19059) (GLC 19061 . 19569) (GLCCODE 19571 . 20041) (STREQUAL 20043 . 20777) (CHCON1 20779 . 21430) 
(U-CASE 21432 . 22693) (L-CASE 22695 . 24403) (U-CASEP 24405 . 24852) (\SMASHSTRING 24854 . 25400))))
)
STOP