(FILECREATED "29-Jul-84 19:16:21" {ERIS}<LISPCORE>SOURCES>LLCHAR.;4 29288
changes to: (VARS LLCHARCOMS)
previous date: "24-Jul-84 15:26:10" {ERIS}<LISPCORE>SOURCES>LLCHAR.;3)
(* Copyright (c) 1982, 1983, 1984 by Xerox Corporation. All rights reserved.)
(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 \NUMSTR1 \PNAMESTRING)
(DECLARE: DONTCOPY (PROP DMACRO FCHARACTER)
(I.S.OPRS INPNAME 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) (* JonL " 7-May-84 03:31")
(PROG (LEN OFFST)
(RETURN (FCHARACTER (COND
((STRINGP X)
(COND
((EQ 0 (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) (* JonL " 7-May-84 03:31")
(PROG (LEN OFFST)
(RETURN (COND
((STRINGP X)
(COND
((EQ 0 (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) (* JonL " 7-May-84 03:31")
(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
((EQ 0 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)
)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTDEF (QUOTE \NUMSTR)
(QUOTE RESOURCES)
(QUOTE (NEW (ALLOCSTRING 38))))
(PUTDEF (QUOTE \NUMSTR1)
(QUOTE RESOURCES)
(QUOTE (NEW (CONCAT))))
(PUTDEF (QUOTE \PNAMESTRING)
(QUOTE RESOURCES)
(QUOTE (NEW (ALLOCSTRING \PNAMELIMIT))))
)
)
(/SETTOPVAL (QUOTE \\NUMSTR.GLOBALRESOURCE))
(/SETTOPVAL (QUOTE \\NUMSTR1.GLOBALRESOURCE))
(/SETTOPVAL (QUOTE \\PNAMESTRING.GLOBALRESOURCE))
(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 INPNAME)
NIL
(QUOTE (SUBPAIR (QUOTE ($$OFF $$BASE $$END $$BODY))
(LIST (GETDUMMYVAR)
(GETDUMMYVAR)
(GETDUMMYVAR)
(GETDUMMYVAR))
(BQUOTE (bind $$OFF ← 1 $$BODY ← BODY $$BASE $$END first
(PROG NIL $$LP (SELECTC (NTYPX $$BODY)
(\STRINGP
(SETQ $$BASE (ffetch (STRINGP BASE)
of $$BODY))
(SETQ $$OFF (ffetch (STRINGP OFFST)
of $$BODY))
(SETQ $$END
(SUB1 (ffetch (STRINGP LENGTH)
of $$BODY))))
(\LITATOM (SETQ $$BASE
(ffetch (LITATOM
PNAMEBASE)
of $$BODY))
(SETQ $$END
(ffetch (LITATOM
PNAMELENGTH)
of $$BODY)))
(PROGN (SETQ $$BODY (MKSTRING $$BODY))
(GO $$LP))))
eachtime
(if (IGREATERP $$OFF $$END)
then
(GO $$OUT))
(SETQ I.V. (GETBASEBYTE $$BASE (PROG1 $$OFF (SETQ
$$OFF
(ADD1 $$OFF)))))))))
T)
(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 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (914 25385 (MKATOM 924 . 1394) (SUBATOM 1396 . 2659) (CHARACTER 2661 . 2794) (MKNUMATOM
2796 . 6812) (\MKINTEGER 6814 . 7591) (MKSTRING 7593 . 8736) (BKSYSBUF 8738 . 9512) (NCHARS 9514 .
10399) (NTHCHARCODE 10401 . 11604) (RPLCHARCODE 11606 . 12612) (\RPLCHARCODE 12614 . 13298) (NTHCHAR
13300 . 14519) (RPLSTRING 14521 . 15934) (SUBSTRING 15936 . 17757) (GNC 17759 . 18421) (GNCCODE 18423
. 19035) (GLC 19037 . 19545) (GLCCODE 19547 . 20017) (STREQUAL 20019 . 20760) (CHCON1 20762 . 21413)
(U-CASE 21415 . 22676) (L-CASE 22678 . 24386) (U-CASEP 24388 . 24835) (\SMASHSTRING 24837 . 25383))))
)
STOP