(FILECREATED "16-Dec-84 20:18:15" {ERIS}<LISPCORE>SOURCES>LLCHAR.;11 114650Q
changes to: (VARS LLCHARCOMS)
previous date: " 5-Dec-84 13:14:22" {ERIS}<LISPCORE>SOURCES>LLCHAR.;10)
(* Copyright (c) 1982, 1983, 1984 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT LLCHARCOMS)
(RPAQQ LLCHARCOMS ((FNS ALLOCSTRING 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)
(FNS \GETBASESTRING \PUTBASESTRING)
(DECLARE: DONTCOPY (EXPORT (RECORDS STRINGP)
(GLOBALVARS \OneCharAtomBase)
(RESOURCES \NUMSTR \NUMSTR1 \PNAMESTRING)
(PROP DMACRO FCHARACTER)
(I.S.OPRS inpname inatom instring)
(* For use when the inner-loop test in the generic operators is
too expensive)
(I.S.OPRS infatatom inthinatom infatstring inthinstring)
(MACROS \CHARCODEP \FATCHARCODEP \THINCHARCODEP)
(* For benefit of Masterscope)
(MACROS \GETBASEFAT \GETBASETHIN \PUTBASEFAT \PUTBASETHIN)
(MACROS \PUTBASECHAR \GETBASECHAR)
(* These are to flag things that we are still uncertain about)
(MACROS \CHARSET \CHAR8CODE)
(CONSTANTS (\CHARMASK 377Q)
(\MAXCHAR 377Q)
(\MAXTHINCHAR 377Q)
(\MAXFATCHAR 177777Q)
(NSCHARSETSHIFT 377Q))
(MACROS \NATOMCHARS \NSTRINGCHARS \RPLCHARCODE)))
(INITRESOURCES \NUMSTR \NUMSTR1 \PNAMESTRING)
(P (MOVD? (QUOTE CHARACTER)
(QUOTE FCHARACTER)))
[COMS (FNS COPYSTRING)
(* For MAKEINIT)
(DECLARE: DONTCOPY (ADDVARS (INEWCOMS (FNS ALLOCSTRING COPYSTRING)
(ADDVARS (EXPANDMACROFNS \PUTBASETHIN \PUTBASEFAT
\CHARCODEP)))
(DONTCOMPILEFNS COPYSTRING]
(LOCALVARS . T)))
(DEFINEQ
(ALLOCSTRING
[LAMBDA (N INITCHAR OLD FATFLG) (* rmk: "24-Nov-84 17:16")
(SETQ N (FIX N)) (* Coerce floats at the outset)
(COND
((OR (ILESSP N 0)
(IGREATERP N \MaxArrayLen))
(LISPERROR "ILLEGAL ARG" N)))
[COND
((NULL INITCHAR)
(SETQ INITCHAR 0))
((\CHARCODEP INITCHAR))
(T (SETQ INITCHAR (CHCON1 INITCHAR]
[PROG [B (FATP (OR FATFLG (IGREATERP INITCHAR \MAXTHINCHAR]
(* Allocate the block before going uninterruptable in
the smashing case.)
[SETQ B (\ALLOCBLOCK (COND
(FATP (FOLDHI N WORDSPERCELL))
(T (FOLDHI N BYTESPERCELL]
[COND
[(STRINGP OLD)
(UNINTERRUPTABLY
(create STRINGP smashing OLD LENGTH ← N BASE ← B TYP ←(COND
(FATP \ST.POS16)
(T \ST.BYTE))))]
(T (SETQ OLD (create STRINGP
LENGTH ← N
BASE ← B
TYP ←(COND
(FATP \ST.POS16)
(T \ST.BYTE]
(COND
((NEQ 0 INITCHAR)
(if FATP
then (for I (OBASE ←(ffetch (STRINGP BASE) of OLD)) from 0 to (SUB1 N)
do (\PUTBASEFAT OBASE I INITCHAR))
else (for I (OBASE ←(ffetch (STRINGP BASE) of OLD)) from 0 to (SUB1 N)
do (\PUTBASETHIN OBASE I INITCHAR] (* \ALLOCBLOCK always zeros the block, so don't need to
initialize then)
OLD])
(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: " 4-Dec-84 10:54")
(SELECTC (NTYPX X)
[\LITATOM (GLOBALRESOURCE \PNAMESTRING (for C CHANGEFLG (BASE ←(fetch (STRINGP BASE)
of \PNAMESTRING))
inatom X as I from 0
do (\PUTBASECHAR
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 (\PUTBASECHAR 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: " 4-Dec-84 10:59")
(SELECTC (NTYPX X)
[\LITATOM (WITH-RESOURCE \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]
(\PUTBASECHAR BASE I C)
finally (RETURN (COND
(CHANGEFLG (\MKATOM BASE 0 I))
(T X]
[\STRINGP (for C BASE CHANGEFLG (NEWSTRING ←(ALLOCSTRING (\NSTRINGCHARS X)
NIL NIL (ffetch (STRINGP
FATSTRINGP)
of X)))
instring X as I from 0 first (SETQ BASE (ffetch (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]
(\PUTBASECHAR 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: " 4-Dec-84 10:59")
(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])
)
(DEFINEQ
(\GETBASESTRING
[LAMBDA (BASE BYTEOFFSET NCHARS) (* JonL "11-JUN-82 22:05")
([LAMBDA (NEW)
(\MOVEBYTES BASE BYTEOFFSET (fetch (STRINGP BASE) of NEW)
(fetch (STRINGP OFFST) of NEW)
NCHARS)
NEW]
(ALLOCSTRING NCHARS])
(\PUTBASESTRING
[LAMBDA (BASE BYTEOFFSET SOURCE) (* JonL "11-JUN-82 21:59")
(* In addition to putting the bytes into memory, this guy returns the number of characters "written", since the
source may not be a STRINGP, bu will be coerced to one.)
(SELECTC (NTYPX SOURCE)
(\STRINGP (\MOVEBYTES (fetch (STRINGP BASE) of SOURCE)
(fetch (STRINGP OFFST) of SOURCE)
BASE BYTEOFFSET (SETQ SOURCE (fetch (STRINGP LENGTH) of SOURCE)))
SOURCE)
(\LITATOM (\MOVEBYTES (fetch (LITATOM PNAMEBASE) of SOURCE)
1 BASE BYTEOFFSET (SETQ SOURCE (fetch (LITATOM PNAMELENGTH)
of SOURCE)))
SOURCE)
(\PUTBASESTRING BASE BYTEOFFSET (MKSTRING SOURCE])
)
(DECLARE: DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
[DECLARE: EVAL@COMPILE
(DATATYPE STRINGP ((ORIG BITS 1) (* ORIG is always 1)
(NIL BITS 1)
(READONLY FLAG)
(NIL BITS 1)
(TYP BITS 4) (* TYP is \ST.BYTE for thin strings, \ST.POS16 for fat
ones)
(BASE POINTER)
(LENGTH WORD)
(OFFST WORD))
(ACCESSFNS STRINGP (FATSTRINGP (NEQ (ffetch (STRINGP TYP) of DATUM)
\ST.BYTE)))
TYP ← \ST.BYTE ORIG ← 1 (* while STRINGP is declared as a declaration, the
initialization really happens at MAKEINIT time under
INITDATATYPES using the DTDECLS list))
]
(/DECLAREDATATYPE (QUOTE STRINGP)
(QUOTE ((BITS 1)
(BITS 1)
FLAG
(BITS 1)
(BITS 4)
POINTER WORD WORD)))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \OneCharAtomBase)
)
(DECLARE: EVAL@COMPILE
[PUTDEF (QUOTE \NUMSTR)
(QUOTE RESOURCES)
(QUOTE (NEW (ALLOCSTRING 46Q]
[PUTDEF (QUOTE \NUMSTR1)
(QUOTE RESOURCES)
(QUOTE (NEW (CONCAT]
[PUTDEF (QUOTE \PNAMESTRING)
(QUOTE RESOURCES)
(QUOTE (NEW (ALLOCSTRING \PNAMELIMIT]
)
(PUTPROPS FCHARACTER DMACRO [OPENLAMBDA (N)
(COND ((IGREATERP N (CHARCODE 11Q))
(\ADDBASE \OneCharAtomBase (IDIFFERENCE N 12Q)))
((IGEQ N (CHARCODE 0))
(IDIFFERENCE N (CHARCODE 0)))
(T (\ADDBASE \OneCharAtomBase N])
(DECLARE: EVAL@COMPILE
(I.S.OPR (QUOTE inpname)
NIL
[QUOTE (SUBPAIR (QUOTE ($$END $$BODY))
(LIST (GETDUMMYVAR)
(GETDUMMYVAR))
(BQUOTE (bind $$OFFSET ← 0 $$BODY ← BODY $$BASE $$END $$FATP declare
(LOCALVARS $$OFFSET $$BASE $$FATP)
first
[PROG NIL $$LP (SELECTC (NTYPX $$BODY)
(\STRINGP
(SETQ $$BASE (ffetch (STRINGP BASE)
of $$BODY))
(SETQ $$OFFSET
(SUB1 (ffetch (STRINGP OFFST)
of $$BODY)))
(SETQ $$END
(IPLUS $$OFFSET
(ffetch (STRINGP LENGTH)
of $$BODY)))
(SETQ $$FATP (ffetch (STRINGP
FATSTRINGP)
of $$BODY)))
(\LITATOM (SETQ $$BASE
(ffetch (LITATOM
PNAMEBASE)
of $$BODY))
(SETQ $$FATP
(ffetch (LITATOM
FATPNAMEP)
of $$BODY)))
(PROGN (SETQ $$BODY (MKSTRING $$BODY))
(GO $$LP]
eachtime
(SETQ $$OFFSET (ADD1 $$OFFSET))
(AND (IGREATERP $$OFFSET $$END)
(GO $$OUT))
(SETQ I.V. (COND ($$FATP (\GETBASEFAT $$BASE $$OFFSET))
(T (\GETBASETHIN $$BASE $$OFFSET]
T)
(I.S.OPR (QUOTE inatom)
NIL
[QUOTE (SUBPAIR (QUOTE ($$END $$BODY))
(LIST (GETDUMMYVAR)
(GETDUMMYVAR))
(QUOTE (bind $$OFFSET ← 0 $$BODY ← BODY $$BASE $$END $$FATP declare
(LOCALVARS $$OFFSET $$BASE $$FATP)
first
(SETQ $$BASE (ffetch (LITATOM PNAMEBASE)
of $$BODY))
(SETQ $$END (ffetch (LITATOM PNAMELENGTH)
of $$BODY))
(SETQ $$FATP (ffetch (LITATOM FATPNAMEP)
of $$BODY))
eachtime
(SETQ $$OFFSET (ADD1 $$OFFSET))
(AND (IGREATERP $$OFFSET $$END)
(GO $$OUT))
(SETQ I.V. (COND ($$FATP (\GETBASEFAT $$BASE $$OFFSET))
(T (\GETBASETHIN $$BASE $$OFFSET]
T)
(I.S.OPR (QUOTE instring)
NIL
[QUOTE (SUBPAIR (QUOTE ($$END $$BODY))
(LIST (GETDUMMYVAR)
(GETDUMMYVAR))
(QUOTE (bind $$BODY ← BODY $$END $$OFFSET $$BASE $$FATP declare
(LOCALVARS $$OFFSET $$BASE $$FATP)
first
(SETQ $$OFFSET (SUB1 (ffetch (STRINGP OFFST)
of $$BODY)))
(SETQ $$BASE (ffetch (STRINGP BASE)
of $$BODY))
(SETQ $$END (IPLUS $$OFFSET (ffetch (STRINGP LENGTH)
of $$BODY)))
(SETQ $$FATP (ffetch (STRINGP FATSTRINGP)
of $$BODY))
eachtime
(SETQ $$OFFSET (ADD1 $$OFFSET))
(AND (IGREATERP $$OFFSET $$END)
(GO $$OUT))
(SETQ I.V. (COND ($$FATP (\GETBASEFAT $$BASE $$OFFSET))
(T (\GETBASETHIN $$BASE $$OFFSET]
T)
)
(DECLARE: EVAL@COMPILE
(I.S.OPR (QUOTE infatatom)
NIL
[QUOTE (SUBPAIR (QUOTE ($$END $$BODY))
(LIST (GETDUMMYVAR)
(GETDUMMYVAR))
(QUOTE (bind $$OFFSET ← 0 $$BODY ← BODY $$BASE $$END declare
(LOCALVARS $$OFFSET $$BASE)
first
(SETQ $$BASE (ffetch (LITATOM PNAMEBASE)
of $$BODY))
(SETQ $$END (ffetch (LITATOM PNAMELENGTH)
of $$BODY))
eachtime
(SETQ $$OFFSET (ADD1 $$OFFSET))
(AND (IGREATERP $$OFFSET $$END)
(GO $$OUT))
(SETQ I.V. (\GETBASEFAT $$BASE $$OFFSET]
T)
(I.S.OPR (QUOTE inthinatom)
NIL
[QUOTE (SUBPAIR (QUOTE ($$END $$BODY))
(LIST (GETDUMMYVAR)
(GETDUMMYVAR))
(QUOTE (bind $$OFFSET ← 0 $$BODY ← BODY $$BASE $$END declare
(LOCALVARS $$OFFSET $$BASE)
first
(SETQ $$BASE (ffetch (LITATOM PNAMEBASE)
of $$BODY))
(SETQ $$END (ffetch (LITATOM PNAMELENGTH)
of $$BODY))
eachtime
(SETQ $$OFFSET (ADD1 $$OFFSET))
(AND (IGREATERP $$OFFSET $$END)
(GO $$OUT))
(SETQ I.V. (\GETBASETHIN $$BASE $$OFFSET]
T)
(I.S.OPR (QUOTE infatstring)
NIL
[QUOTE (SUBPAIR (QUOTE ($$END $$BODY))
(LIST (GETDUMMYVAR)
(GETDUMMYVAR))
(QUOTE (bind $$BODY ← BODY $$END $$OFFSET $$BASE declare (LOCALVARS $$OFFSET
$$BASE)
first
(SETQ $$OFFSET (SUB1 (ffetch (STRINGP OFFST)
of $$BODY)))
(SETQ $$BASE (ffetch (STRINGP BASE)
of $$BODY))
(SETQ $$END (IPLUS $$OFFSET (ffetch (STRINGP LENGTH)
of $$BODY)))
eachtime
(SETQ $$OFFSET (ADD1 $$OFFSET))
(AND (IGREATERP $$OFFSET $$END)
(GO $$OUT))
(SETQ I.V. (\GETBASEFAT $$BASE $$OFFSET]
T)
(I.S.OPR (QUOTE inthinstring)
NIL
[QUOTE (SUBPAIR (QUOTE ($$END $$BODY))
(LIST (GETDUMMYVAR)
(GETDUMMYVAR))
(QUOTE (bind $$BODY ← BODY $$END $$OFFSET $$BASE declare (LOCALVARS $$OFFSET
$$BASE)
first
(SETQ $$OFFSET (SUB1 (ffetch (STRINGP OFFST)
of $$BODY)))
(SETQ $$BASE (ffetch (STRINGP BASE)
of $$BODY))
(SETQ $$END (IPLUS $$OFFSET (ffetch (STRINGP LENGTH)
of $$BODY)))
eachtime
(SETQ $$OFFSET (ADD1 $$OFFSET))
(AND (IGREATERP $$OFFSET $$END)
(GO $$OUT))
(SETQ I.V. (\GETBASETHIN $$BASE $$OFFSET]
T)
)
(DECLARE: EVAL@COMPILE
(PUTPROPS \CHARCODEP DMACRO (OPENLAMBDA (X)
(AND (SMALLP X)
(IGEQ X 0)
(ILEQ X \MAXFATCHAR))))
(PUTPROPS \FATCHARCODEP DMACRO (OPENLAMBDA (X)
(AND (SMALLP X)
(IGREATERP X \MAXTHINCHAR)
(ILEQ X \MAXFATCHAR))))
(PUTPROPS \THINCHARCODEP DMACRO (OPENLAMBDA (X)
(AND (SMALLP X)
(IGEQ X 0)
(ILEQ X \MAXTHINCHAR))))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS \GETBASEFAT MACRO (= . \GETBASE))
(PUTPROPS \GETBASETHIN MACRO (= . \GETBASEBYTE))
(PUTPROPS \PUTBASEFAT MACRO (= . \PUTBASE))
(PUTPROPS \PUTBASETHIN MACRO (= . \PUTBASEBYTE))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS \PUTBASECHAR MACRO (= . \PUTBASEBYTE))
(PUTPROPS \GETBASECHAR MACRO (= . \GETBASEBYTE))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS \CHARSET MACRO ((CHARCODE)
(LRSH CHARCODE 10Q)))
(PUTPROPS \CHAR8CODE MACRO ((CHARCODE)
(LOGAND CHARCODE 377Q)))
)
(DECLARE: EVAL@COMPILE
(RPAQQ \CHARMASK 377Q)
(RPAQQ \MAXCHAR 377Q)
(RPAQQ \MAXTHINCHAR 377Q)
(RPAQQ \MAXFATCHAR 177777Q)
(RPAQQ NSCHARSETSHIFT 377Q)
(CONSTANTS (\CHARMASK 377Q)
(\MAXCHAR 377Q)
(\MAXTHINCHAR 377Q)
(\MAXFATCHAR 177777Q)
(NSCHARSETSHIFT 377Q))
)
(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)
)
(/SETTOPVAL (QUOTE \\NUMSTR.GLOBALRESOURCE))
(/SETTOPVAL (QUOTE \\NUMSTR1.GLOBALRESOURCE))
(/SETTOPVAL (QUOTE \\PNAMESTRING.GLOBALRESOURCE))
(MOVD? (QUOTE CHARACTER)
(QUOTE FCHARACTER))
(DEFINEQ
(COPYSTRING
[LAMBDA (X) (* rrb "13-DEC-82 11:19")
(PROG ((N (LOCAL (NCHARS X)))
STR BASE OFFST)
(SETQ STR (ALLOCSTRING N))
(SETQ BASE (ffetch (STRINGP BASE) of STR))
(SETQ OFFST (ffetch (STRINGP OFFST) of STR))
[for I from 1 to N do (\PUTBASEBYTE BASE (LOCAL (IPLUS OFFST I -1))
(IPLUS (NTHCHARCODE X I]
(RETURN STR])
)
(* For MAKEINIT)
(DECLARE: DONTCOPY
(ADDTOVAR INEWCOMS (FNS ALLOCSTRING COPYSTRING)
(ADDVARS (EXPANDMACROFNS \PUTBASETHIN \PUTBASEFAT \CHARCODEP)))
(ADDTOVAR DONTCOMPILEFNS COPYSTRING)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS)
)
(PUTPROPS LLCHAR COPYRIGHT ("Xerox Corporation" 3676Q 3677Q 3700Q))
(DECLARE: DONTCOPY
(FILEMAP (NIL (3511Q 67646Q (ALLOCSTRING 3523Q . 6675Q) (MKATOM 6677Q . 7625Q) (SUBATOM 7627Q . 12206Q
) (CHARACTER 12210Q . 12415Q) (MKNUMATOM 12417Q . 22277Q) (\MKINTEGER 22301Q . 23712Q) (MKSTRING
23714Q . 26103Q) (BKSYSBUF 26105Q . 27513Q) (NCHARS 27515Q . 31302Q) (NTHCHARCODE 31304Q . 33567Q) (
RPLCHARCODE 33571Q . 35547Q) (\RPLCHARCODE 35551Q . 37025Q) (NTHCHAR 37027Q . 41332Q) (RPLSTRING
41334Q . 44141Q) (SUBSTRING 44143Q . 47600Q) (GNC 47602Q . 51030Q) (GNCCODE 51032Q . 52176Q) (GLC
52200Q . 53174Q) (GLCCODE 53176Q . 54124Q) (STREQUAL 54126Q . 55473Q) (CHCON1 55475Q . 56710Q) (U-CASE
56712Q . 61517Q) (L-CASE 61521Q . 65566Q) (U-CASEP 65570Q . 66600Q) (\SMASHSTRING 66602Q . 67644Q)) (
67647Q 72071Q (\GETBASESTRING 67661Q . 70343Q) (\PUTBASESTRING 70345Q . 72067Q)) (113057Q 114112Q (
COPYSTRING 113071Q . 114110Q)))))
STOP