(FILECREATED "31-Jul-86 18:52:45" {ERIS}<LISPCORE>SOURCES>LLCHAR.;33 89925
changes to: (FNS STRING.EQUAL)
(VARS LLCHARCOMS)
previous date: "13-May-86 15:44:12" {ERIS}<LISPCORE>SOURCES>LLCHAR.;32)
(* Copyright (c) 1982, 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT LLCHARCOMS)
(RPAQQ LLCHARCOMS
((FNS ALLOCSTRING MKATOM SUBATOM CHARACTER MKNUMATOM \MKINTEGER MKSTRING \PRINDATUM.TO.STRING
BKSYSBUF NCHARS NTHCHARCODE RPLCHARCODE \RPLCHARCODE NTHCHAR RPLSTRING SUBSTRING GNC
GNCCODE GLC GLCCODE STREQUAL STRING.EQUAL CHCON1 U-CASE L-CASE U-CASEP \SMASHABLESTRING
\MAKEWRITABLESTRING \SMASHSTRING \FATTENSTRING \UPDATE.SUBSTRINGS)
(COMS (* Temporary until low level system is changed to call STRING.EQUAL again)
(P (MOVD? (QUOTE STRING.EQUAL)
(QUOTE STRING-EQUAL)
NIL T)))
(FNS \GETBASESTRING \PUTBASESTRING \PUTBASESTRINGFAT GetBcplString SetBcplString)
(DECLARE: DONTCOPY [COMS (* Kludge not currently in effect)
(DECLARE: EVAL@COMPILE (ADDVARS (DONTCOMPILEFNS \UPDATE.SUBSTRINGS]
(EXPORT (RECORDS STRINGP)
(GLOBALVARS \OneCharAtomBase)
(RESOURCES \NUMSTR \NUMSTR1 \PNAMESTRING)
(CONSTANTS (\FATPNAMESTRINGP T))
(MACROS \PNAMESTRINGPUTCHAR)
(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)
(MACROS \CHARSET \CHAR8CODE)
(CONSTANTS (\ST.INDIRECT 3)
(\CHARMASK 255)
(\MAXCHAR 255)
(\MAXTHINCHAR 255)
(\MAXFATCHAR 65535)
(\MAXCHARSET 255)
(NSCHARSETSHIFT 255)
(#STRINGPWORDS 4))
(MACROS \NATOMCHARS \NSTRINGCHARS)))
(INITRESOURCES \NUMSTR \NUMSTR1 \PNAMESTRING)
(P (MOVD? (QUOTE CHARACTER)
(QUOTE FCHARACTER)
NIL T))
[COMS (FNS COPYSTRING)
(* For MAKEINIT)
(DECLARE: DONTCOPY (ADDVARS (INEWCOMS (FNS ALLOCSTRING COPYSTRING))
(EXPANDMACROFNS \PUTBASETHIN \PUTBASEFAT \CHARCODEP
\GETBASECHAR \GETBASETHIN \GETBASEFAT \PUTBASECHAR)
(DONTCOMPILEFNS COPYSTRING]
(LOCALVARS . T)))
(DEFINEQ
(ALLOCSTRING
[LAMBDA (N INITCHAR OLD FATFLG) (* bvm: "28-Jun-85 12:30")
(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]
[LET ((FATP (OR FATFLG (IGREATERP INITCHAR \MAXTHINCHAR)))
STRINGBASE) (* Allocate the block before going
uninterruptable in the smashing case.)
[SETQ STRINGBASE (\ALLOCBLOCK (COND
(FATP (FOLDHI N WORDSPERCELL))
(T (FOLDHI N BYTESPERCELL]
[COND
[(STRINGP OLD)
(UNINTERRUPTABLY
(create STRINGP smashing OLD LENGTH ← N BASE ← STRINGBASE TYP ← (COND
(FATP \ST.POS16)
(T \ST.BYTE))))]
(T (SETQ OLD (create STRINGP
LENGTH ← N
BASE ← STRINGBASE
TYP ← (COND
(FATP \ST.POS16)
(T \ST.BYTE]
(COND
((NEQ 0 INITCHAR) (* \ALLOCBLOCK always zeros the block,
so don't need to initialize then)
(COND
(FATP (for I from 0 to (SUB1 N) do (\PUTBASEFAT STRINGBASE I INITCHAR)))
(T (for I from 0 to (SUB1 N) do (\PUTBASETHIN STRINGBASE I INITCHAR]
OLD])
(MKATOM
[LAMBDA (X) (* bvm: "28-Jun-85 12:33")
(COND
((STRINGP X)
(\MKATOM (ffetch (STRINGP BASE) of X)
(ffetch (STRINGP OFFST) of X)
(LET ((LEN (ffetch (STRINGP LENGTH) of X)))
(COND
((IGREATERP LEN \PNAMELIMIT)
(LISPERROR "ATOM TOO LONG" X))
(T LEN)))
(ffetch (STRINGP FATSTRINGP) of X)))
((OR (LITATOM X)
(NUMBERP X))
X)
(T (PACK* X])
(SUBATOM
[LAMBDA (X N M) (* rmk: "25-Mar-85 15:27")
(PROG (BASE OFFST LEN FATP (N1 N)
(M1 M)) (* N1 and M1 so don't reset user arg.)
[COND
((LITATOM X)
(SETQ BASE (ffetch (LITATOM PNAMEBASE) of X))
(SETQ OFFST 1)
(SETQ FATP (ffetch (LITATOM FATPNAMEP) of X))
(SETQ LEN (ffetch (LITATOM PNAMELENGTH) of X)))
(T (SETQ LEN (OR (STRINGP X)
(MKSTRING X))) (* Don't reset user arg)
(SETQ BASE (ffetch (STRINGP BASE) of LEN))
(SETQ FATP (ffetch (STRINGP FATSTRINGP) of LEN))
(SETQ OFFST (ffetch (STRINGP OFFST) of LEN))
(SETQ LEN (ffetch (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))
FATP])
(CHARACTER
[LAMBDA (N) (* bvm: "27-Jun-85 12:39")
(OR (\CHARCODEP N)
(SETQ N (\ILLEGAL.ARG N)))
(COND
((IGREATERP N \MAXTHINCHAR) (* The character we're getting is NOT
a thin character -- do it the hard way)
(WITH-RESOURCE (\PNAMESTRING)
(\PNAMESTRINGPUTCHAR (ffetch (STRINGP XBASE) of \PNAMESTRING)
0 N)
(\MKATOM (ffetch (STRINGP XBASE) of \PNAMESTRING)
0 1 \FATPNAMESTRINGP)))
((IGREATERP N (CHARCODE 9))
(\ADDBASE \OneCharAtomBase (IDIFFERENCE N 10)))
((IGEQ N (CHARCODE 0))
(IDIFFERENCE N (CHARCODE 0)))
(T (* The common case --
just add on the one-atom base.)
(\ADDBASE \OneCharAtomBase N])
(MKNUMATOM
[LAMBDA (BASE BN LEN FATP) (* lmm " 7-Jul-85 13:07")
(* * Attempt to create a numeric atom out of the chars in BASE from BN for LEN
characters (fat or thin, depending on FATP) 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 VALUE)
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
(DONE VALUE)
((INITDIGIT AFTERQ)
(COND
(START (\MKINTEGER BASE START (OR ENDFRAC I)
(EQ SIGN (QUOTE -))
(COND
((EQ STATE (QUOTE AFTERQ))
8)
(T 10))
FATP))
(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 FATP))
(T 0)))
(* the explicit exponent)
(\FLOATINGSCALE (\MKINTEGER BASE START ENDFRAC NEGFRAC 10
FATP)
(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 (\GETBASECHAR FATP 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)))
(INFINITY (SELECTQ STATE
(INIT (SETQ VALUE (SELECTQ SIGN
((+ NIL)
MAX.INTEGER)
MIN.INTEGER))
(QUOTE DONE))
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 FATP) (* rmk: "25-Mar-85 17:16")
(* * 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 (\GETBASECHAR FATP 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) (* bvm: "13-May-86 15:15")
(* Coerce X to be a string.
The string will be FAT if X is)
(DECLARE (GLOBALVARS PRXFLG))
(OR (COND
((NOT FLG) (* The simple case --
just gather up the characters in the
item)
(SELECTC (NTYPX X)
(\STRINGP (* Strings coerce to themselves)
X)
(\LITATOM (* LITATOMs have a new descriptor
created, pointing to the same
characters.)
(create STRINGP
XBASE ← (ffetch (LITATOM PNAMEBASE) of X)
LENGTH ← (ffetch (LITATOM PNAMELENGTH) of X)
OFFST ← 1
XREADONLY ← T
TYP ← (COND
((ffetch (LITATOM FATPNAMEP) of X)
\ST.POS16)
(T \ST.BYTE))))
NIL)))
(LET [(BASE (COND
(PRXFLG (\CHECKRADIX *PRINT-BASE*))
(T 10]
(LET ((*PRINT-ESCAPE* FLG)
(*READTABLE* (COND
(FLG (\GTREADTABLE RDTBL))
(T *READTABLE*)))
(*PRINT-RADIX* (AND FLG (NEQ BASE 10)))
(*PRINT-BASE* BASE)
(*PRINT-LENGTH*)
(*PRINT-LEVEL*))
(* * General case: internally print the name, gather up the characters)
(\PRINDATUM.TO.STRING X])
(\PRINDATUM.TO.STRING
[LAMBDA (X) (* bvm: "13-May-86 15:35")
(* * Produces a string that is the result of printing X according the current
settings of *PRINT-ESCAPE* etc.)
(SELECTC (NTYPX X)
((LIST \FIXP \SMALLP \FLOATP)
(* We know how to print numbers
without extra steps)
(GLOBALRESOURCE (\NUMSTR \NUMSTR1)
(LET [(STR (COND
((FLOATP X)
(\CONVERT.FLOATING.NUMBER X \NUMSTR \NUMSTR1))
(T (\CONVERTNUMBER X *PRINT-BASE* NIL (AND *PRINT-RADIX*
*READTABLE*)
\NUMSTR \NUMSTR1]
(RPLSTRING (ALLOCSTRING (NCHARS STR))
1 STR))))
(LET ((FATSTRINGP)
(STRINGLEN 0)
(STRINDEX 0)
S)
(* * First count up the characters and their fatness)
[\MAPPNAME.INTERNAL (FUNCTION (LAMBDA (DUMMY CODE)
(COND
((GREATERP CODE \MAXTHINCHAR)
(SETQ FATSTRINGP T)))
(add STRINGLEN 1]
(* * Then print X again actually storing the characters into the string)
(SETQ S (ALLOCSTRING STRINGLEN NIL NIL FATSTRINGP))
(\MAPPNAME.INTERNAL [FUNCTION (LAMBDA (DUMMY CODE)
[COND
((EQ STRINDEX (ffetch (STRINGP LENGTH) of S))
(* Help! NCHARS and \MAPPNAME
disagree.)
(SETQ S (CONCAT S " "]
(add STRINDEX 1)
(COND
((ffetch (STRINGP FATSTRINGP) of S)
(* Fat string; just smash the
character in.)
(\PUTBASEFAT (fetch (STRINGP BASE) of S)
(IPLUS (fetch (STRINGP OFFST) of S)
STRINDEX -1)
CODE))
((ILEQ CODE \MAXTHINCHAR)
(* Thin char and String;
just smash the char in)
(\PUTBASETHIN (fetch (STRINGP BASE) of S)
(IPLUS (fetch (STRINGP OFFST) of S)
STRINDEX -1)
CODE))
(T (* Need to fatten the string, then
smash in the char. This shouldn't
happen unless X gets printed different
the two times!)
(\FATTENSTRING S)
(\PUTBASEFAT (fetch (STRINGP BASE) of S)
(IPLUS (fetch (STRINGP OFFST) of S)
STRINDEX -1)
CODE]
X)
S])
(BKSYSBUF
[LAMBDA (X FLG RDTBL) (* bvm: "27-Mar-86 15:49")
(PROG NIL
(COND
((NOT FLG)
(SELECTC (NTYPX X)
(\LITATOM (RETURN (for C inatom X do (BKSYSCHARCODE C))))
(\STRINGP (RETURN (for C instring X do (BKSYSCHARCODE C))))
NIL)))
(\MAPPNAME [FUNCTION (LAMBDA (DUMMY CODE)
(BKSYSCHARCODE CODE]
X FLG RDTBL))
X])
(NCHARS
[LAMBDA (X FLG RDTBL) (* bvm: "27-Mar-86 17:55")
(* * Return the number of characters in (the print name of) X.
If FLG, then return the number of characters in the PRIN2 version, according to
RDTBL.)
(SELECTC (NTYPX X)
(\LITATOM (IPLUS (fetch (LITATOM PNAMELENGTH) of X)
(COND
(FLG (\SYMBOL.ESCAPE.COUNT X (\GTREADTABLE RDTBL)))
(T 0))))
(\STRINGP (IPLUS (fetch (STRINGP LENGTH) of X)
(COND
[FLG (* 2 for the enclosing quotes and an
escape to quote every double quote
char or escape in the string body)
(IPLUS 2 (for C instring X bind (ESC ← (fetch (READTABLEP ESCAPECHAR
)
of (\GTREADTABLE RDTBL)))
count (OR (EQ C (CHARCODE %"))
(EQ C (CHARCODE LF))
(EQ C ESC]
(T 0))))
(PROG ((N 0))
(DECLARE (SPECVARS N))
(\MAPPNAME [FUNCTION (LAMBDA NIL
(add N 1]
X FLG RDTBL)
(RETURN N])
(NTHCHARCODE
[LAMBDA (X N FLG RDTBL) (* bvm: "24-Mar-86 16:28")
(PROG (BASE OFFST FATP 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))
(SETQ FATP (ffetch (STRINGP FATSTRINGP) of X)))
(\LITATOM (SETQ BASE (fetch (LITATOM PNAMEBASE) of X))
(SETQ LEN (fetch (LITATOM PNAMELENGTH) of X))
(SETQ OFFST 1)
(SETQ FATP (ffetch (LITATOM FATPNAMEP) of X)))
(GO SLOWCASE]
[COND
((ILESSP M 0) (* Negative index counts from end)
(SETQ M (IPLUS M LEN 1]
[RETURN (COND
((OR (ILESSP M 1)
(IGREATERP M LEN)) (* out of range)
NIL)
(T (* The -1 is cause strings have ORIG=1)
(\GETBASECHAR FATP BASE (SUB1 (IPLUS OFFST M]
SLOWCASE
[COND
((EQ M 0)
(RETURN))
((ILESSP M 0)
(AND (ILESSP (SETQ M (IPLUS M (NCHARS X FLG RDTBL)
1))
1)
(RETURN]
(\MAPPNAME [FUNCTION (LAMBDA (DUMMY CODE)
(COND
((EQ (SETQ M (SUB1 M))
0)
(RETFROM (QUOTE NTHCHARCODE)
CODE]
X FLG RDTBL)
(RETURN])
(RPLCHARCODE
[LAMBDA (X N CHAR) (* jds "17-Apr-85 11:48")
(COND
((STRINGP X)
(PROG ((LEN (ffetch (STRINGP LENGTH) of X)))
(\SMASHABLESTRING X (\FATCHARCODEP CHAR))
[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)
(\PUTBASECHAR (FETCH (STRINGP FATSTRINGP) OF X)
(ffetch (STRINGP BASE) of X)
(IPLUS (ffetch (STRINGP OFFST) of X)
(SUB1 N))
CHAR)
(RETURN X)))
(T (RPLCHARCODE (MKSTRING X)
N CHAR])
(\RPLCHARCODE
[LAMBDA (X N CHAR) (* rmk: " 2-Apr-85 19:35")
(* * System version: does error checking interpreted.
Compiles open as \PUTBASEFAT or \PUTBASETHIN.
N must be positive, X must be a real not READONLY string)
(COND
((OR (NOT (STRINGP X))
(ffetch (STRINGP READONLY) of X)) (* X has to be a string, and can't be
READONLY (e.g. a litatom's pname))
(LISPERROR "ILLEGAL ARG" X))
((OR (ILEQ N 0)
(IGREATERP N (fetch (STRINGP LENGTH) of X))) (* The position arg has to be inside
the string's length)
(LISPERROR "ILLEGAL ARG" N))
((NOT (\CHARCODEP CHAR)) (* CHAR has to be a charcode)
(LISPERROR "ILLEGAL ARG" CHAR))
((AND (IGREATERP CHAR \MAXTHINCHAR)
(NOT (ffetch (STRINGP FATSTRINGP) of X))) (* If the char's fat, and the string
isn't, coerce it to fatness.)
(\SMASHABLESTRING X T)))
(\PUTBASECHAR (ffetch (STRINGP FATSTRINGP) of X)
(fetch (STRINGP BASE) of X)
(IPLUS (fetch (STRINGP OFFST) of X)
(SUB1 N))
CHAR)
X])
(NTHCHAR
[LAMBDA (X N FLG RDTBL) (* bvm: "26-Jun-85 17:03")
(PROG (BASE OFFST LEN FATP (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))
(SETQ FATP (ffetch (STRINGP FATSTRINGP) of X)))
(\LITATOM (SETQ BASE (fetch (LITATOM PNAMEBASE) of X))
(SETQ LEN (fetch (LITATOM PNAMELENGTH) of X))
(SETQ OFFST 1)
(SETQ FATP (ffetch (LITATOM FATPNAMEP) of X)))
(GO SLOWCASE]
[COND
((ILESSP M 0)
(SETQ M (IPLUS M LEN 1]
[RETURN (COND
((OR (ILESSP M 1)
(IGREATERP M LEN))
NIL)
(T (* The -1 is cause strings have ORIG=1)
(FCHARACTER (\GETBASECHAR FATP BASE (SUB1 (IPLUS OFFST M]
SLOWCASE
(RETURN (AND (SETQ M (NTHCHARCODE X N FLG RDTBL))
(FCHARACTER M])
(RPLSTRING
[LAMBDA (X N Y) (* bvm: "28-Jun-85 12:51")
(PROG ((OLDSTRING (OR (STRINGP X)
(MKSTRING X)))
(REP Y)
OBASE OLEN RBASE RLEN ROFFST POS FIRSTNEW RFAT)
(SETQ OLEN (ffetch (STRINGP LENGTH) of OLDSTRING))
[COND
((LITATOM REP)
(SETQ RBASE (ffetch (LITATOM PNAMEBASE) of REP))
(SETQ ROFFST 1)
(SETQ RLEN (ffetch (LITATOM PNAMELENGTH) of REP))
(SETQ RFAT (ffetch (LITATOM FATPNAMEP) of REP)))
(T (OR (STRINGP REP)
(SETQ REP (MKSTRING REP)))
(SETQ RBASE (ffetch (STRINGP BASE) of REP))
(SETQ ROFFST (ffetch (STRINGP OFFST) of REP))
(SETQ RLEN (ffetch (STRINGP LENGTH) of REP))
(SETQ RFAT (ffetch (STRINGP FATSTRINGP) of REP]
(COND
((IGREATERP [IPLUS RLEN (SETQ POS (COND
((IGREATERP N 0)
(SUB1 N))
(T (IPLUS OLEN N]
OLEN)
(LISPERROR "ILLEGAL ARG" Y)))
(\SMASHABLESTRING OLDSTRING RFAT) (* Make sure the string is writeable
and of the appropriate width)
(SETQ OBASE (ffetch (STRINGP BASE) of OLDSTRING)) (* Note: OBASE might have changed, so
not fetched until now)
(SETQ FIRSTNEW (IPLUS POS (fetch (STRINGP OFFST) of OLDSTRING)))
(* Now can smash chars from RBASE into
OBASE starting at position FIRSTNEW)
(COND
(RFAT (* Fat into fat. \SMASHABLESTRING
above ensured that OLDSTRING is now
fat)
(\BLT (\ADDBASE OBASE FIRSTNEW)
(\ADDBASE RBASE ROFFST)
RLEN))
[(ffetch (STRINGP FATSTRINGP) of OLDSTRING) (* Smashing thin string into a fat one)
(for I from ROFFST to (SUB1 (IPLUS ROFFST RLEN)) as J from FIRSTNEW
do (\PUTBASEFAT OBASE J (\GETBASETHIN RBASE I]
(T (* Thin into thin is just byte blt)
(\MOVEBYTES RBASE ROFFST OBASE FIRSTNEW RLEN)))
(RETURN OLDSTRING])
(SUBSTRING
[LAMBDA (X N M OLDPTR) (* bvm: "28-Jun-85 12:54")
(PROG ((OLDSTRING X)
(START N)
(END M)
FATP BASE OFFST LEN) (* OLDSTRING START and END so don't
reset user args)
[COND
((LITATOM OLDSTRING)
(SETQ BASE (ffetch (LITATOM PNAMEBASE) of OLDSTRING))
(SETQ LEN (ffetch (LITATOM PNAMELENGTH) of OLDSTRING))
(SETQ FATP (ffetch (LITATOM FATPNAMEP) of OLDSTRING))
(SETQ OFFST 1))
(T (OR (STRINGP OLDSTRING)
(SETQ OLDSTRING (MKSTRING OLDSTRING))) (* Note: if we do the MKSTRING here,
there is no user-accessible base
string, and we could avoid the
indirect)
(SETQ BASE (ffetch (STRINGP BASE) of OLDSTRING))
(SETQ FATP (ffetch (STRINGP FATSTRINGP) of OLDSTRING))
(SETQ OFFST (ffetch (STRINGP OFFST) of OLDSTRING))
(SETQ LEN (ffetch (STRINGP LENGTH) of OLDSTRING]
[COND
((ILESSP START 0) (* Coerce the first index)
(SETQ START (IPLUS START LEN 1]
[COND
((NULL END) (* Now coerce the second index)
(SETQ END LEN))
((ILESSP END 0)
(SETQ END (IPLUS END LEN 1]
(RETURN (COND
((AND (IGREATERP START 0)
(ILEQ START END)
(ILEQ END LEN))
(OR (STRINGP OLDPTR)
(SETQ OLDPTR (create STRINGP)))
(UNINTERRUPTABLY
[COND
[(LITATOM OLDSTRING) (* We are creating a base stringptr)
(freplace (STRINGP READONLY) of OLDPTR with T)
(freplace (STRINGP BASE) of OLDPTR with BASE)
(freplace (STRINGP TYP) of OLDPTR with (COND
(FATP \ST.POS16)
(T \ST.BYTE]
((NEQ OLDPTR OLDSTRING) (* Shortcut -- Don't have to do this
if we're smashing the original string
descriptor.)
(freplace (STRINGP READONLY) of OLDPTR with NIL)
(* The READONLY bit is fetch through
the indirect)
(freplace (STRINGP BASE) of OLDPTR with (ffetch (STRINGP BASE)
of OLDSTRING))
(* substrings point at the block, just
like the original string did)
(freplace (STRINGP TYP) of OLDPTR with (COND
(FATP \ST.POS16)
(T \ST.BYTE)))
(freplace (STRINGP SUBSTRINGED) of OLDSTRING with T)
(* note that someone has taken a substring of OLDSTRING so that we will update
all substrings if the base get changed (e.g.
during fattening))
]
(freplace (STRINGP LENGTH) of OLDPTR with (ADD1 (IDIFFERENCE END START)))
(freplace (STRINGP OFFST) of OLDPTR with (IPLUS START OFFST -1))
(freplace (STRINGP ORIG) of OLDPTR with 1)
(* why is this necessary? ORIG is only
useful for ELT)
)
OLDPTR])
(GNC
[LAMBDA (X) (* rmk: "25-Mar-85 16:46")
(PROG (LEN OFFST)
(RETURN (FCHARACTER (COND
[(STRINGP X)
(COND
((EQ 0 (SETQ LEN (ffetch (STRINGP LENGTH) of X)))
(RETURN))
(T (PROG1 (\GETBASECHAR (ffetch (STRINGP FATSTRINGP)
of X)
(ffetch (STRINGP BASE) of X)
(SETQ OFFST (ffetch (STRINGP OFFST)
of X)))
(UNINTERRUPTABLY
(freplace (STRINGP OFFST) of X with (ADD1 OFFST))
(freplace (STRINGP LENGTH) of X
with (SUB1 LEN)))]
(T (NTHCHARCODE X 1])
(GNCCODE
[LAMBDA (X) (* rmk: "25-Mar-85 16:27")
(PROG (LEN OFFST)
(RETURN (COND
[(STRINGP X)
(COND
((EQ 0 (SETQ LEN (ffetch (STRINGP LENGTH) of X)))
(RETURN))
(T (PROG1 (\GETBASECHAR (ffetch (STRINGP FATSTRINGP) of X)
(ffetch (STRINGP BASE) of X)
(SETQ OFFST (ffetch (STRINGP OFFST) of X)))
(UNINTERRUPTABLY
(freplace (STRINGP OFFST) of X with (ADD1 OFFST))
(freplace (STRINGP LENGTH) of X with (SUB1 LEN)))]
(T (NTHCHARCODE X 1])
(GLC
[LAMBDA (X) (* rmk: "25-Mar-85 16:46")
(PROG (LEN)
(RETURN (FCHARACTER (COND
[(STRINGP X)
(COND
([EQ -1 (SETQ LEN (SUB1 (ffetch (STRINGP LENGTH) of X]
(RETURN))
(T (PROG1 (\GETBASECHAR (ffetch (STRINGP FATSTRINGP)
of X)
(ffetch (STRINGP BASE) of X)
(IPLUS LEN (ffetch (STRINGP OFFST) of X)))
(freplace (STRINGP LENGTH) of X with LEN]
(T (NTHCHARCODE X -1])
(GLCCODE
[LAMBDA (X) (* rmk: "25-Mar-85 16:28")
(PROG (LEN)
(RETURN (COND
[(STRINGP X)
(COND
([EQ -1 (SETQ LEN (SUB1 (ffetch (STRINGP LENGTH) of X]
(RETURN))
(T (PROG1 (\GETBASECHAR (ffetch (STRINGP FATSTRINGP) of X)
(ffetch (STRINGP BASE) of X)
(IPLUS LEN (ffetch (STRINGP OFFST) of X)))
(freplace (STRINGP LENGTH) of X with LEN]
(T (NTHCHARCODE X -1])
(STREQUAL
[LAMBDA (X Y) (* rmk: "25-Mar-85 16:29")
(AND (STRINGP X)
(STRINGP Y)
(PROG ((LEN (ffetch (STRINGP LENGTH) of X)))
(COND
((NEQ LEN (ffetch (STRINGP LENGTH) of Y))
(RETURN)))
(RETURN (PROG ((BASEX (ffetch (STRINGP BASE) of X))
(BNX (ffetch (STRINGP OFFST) of X))
(FATPX (ffetch (STRINGP FATSTRINGP) of X))
(BASEY (ffetch (STRINGP BASE) of Y))
(BNY (ffetch (STRINGP OFFST) of Y))
(FATPY (ffetch (STRINGP FATSTRINGP) of Y)))
LP (COND
((EQ 0 LEN)
(RETURN T))
((NEQ (\GETBASECHAR FATPX BASEX BNX)
(\GETBASECHAR FATPY BASEY BNY))
(RETURN))
(T (add BNX 1)
(add BNY 1)
(add LEN -1)
(GO LP])
(STRING.EQUAL
[LAMBDA (X Y) (* bvm: "27-Jun-85 14:48")
(* * True if X and Y are equal atoms or strings without respect to alphabetic
case)
(PROG (CABASE LEN BASEX OFFSETX FATPX BASEY OFFSETY FATPY C1 C2)
(COND
((LITATOM X)
(SETQ LEN (ffetch (LITATOM PNAMELENGTH) of X))
(SETQ BASEX (ffetch (LITATOM PNAMEBASE) of X))
(SETQ OFFSETX 1)
(SETQ FATPX (ffetch (LITATOM FATPNAMEP) of X)))
((STRINGP X)
(SETQ LEN (ffetch (STRINGP LENGTH) of X))
(SETQ BASEX (ffetch (STRINGP BASE) of X))
(SETQ OFFSETX (ffetch (STRINGP OFFST) of X))
(SETQ FATPX (ffetch (STRINGP FATSTRINGP) of X)))
(T (RETURN NIL)))
(COND
((LITATOM Y)
(COND
((NEQ LEN (ffetch (LITATOM PNAMELENGTH) of Y))
(RETURN)))
(SETQ BASEY (ffetch (LITATOM PNAMEBASE) of Y))
(SETQ OFFSETY 1)
(SETQ FATPY (ffetch (LITATOM FATPNAMEP) of Y)))
((STRINGP Y)
(COND
((NEQ LEN (ffetch (STRINGP LENGTH) of Y))
(RETURN)))
(SETQ BASEY (ffetch (STRINGP BASE) of Y))
(SETQ OFFSETY (ffetch (STRINGP OFFST) of Y))
(SETQ FATPY (ffetch (STRINGP FATSTRINGP) of Y)))
(T (RETURN NIL)))
[COND
((NEQ (fetch (ARRAYP TYP) of (\DTEST UPPERCASEARRAY (QUOTE ARRAYP)))
\ST.BYTE) (* Someone smashed UPPERCASEARRAY ?)
(SETQ UPPERCASEARRAY (UPPERCASEARRAY]
(SETQ CABASE (fetch (ARRAYP BASE) of UPPERCASEARRAY))
(RETURN (COND
[(OR FATPX FATPY) (* Slow case)
(for BNX from OFFSETX as BNY from OFFSETY as I to LEN
always (PROGN (SETQ C1 (\GETBASECHAR FATPX BASEX BNX))
(SETQ C2 (\GETBASECHAR FATPY BASEY BNY))
(COND
((OR (IGREATERP C1 \MAXTHINCHAR)
(IGREATERP C2 \MAXTHINCHAR))
(* Fat chars not alphabetic)
(EQ C1 C2))
(T (EQ (\GETBASEBYTE CABASE C1)
(\GETBASEBYTE CABASE C2]
(T (for BNX from OFFSETX as BNY from OFFSETY as I to LEN
always (EQ (\GETBASEBYTE CABASE (\GETBASETHIN BASEX BNX))
(\GETBASEBYTE CABASE (\GETBASETHIN BASEY BNY])
(CHCON1
[LAMBDA (X) (* bvm: "28-Jun-85 12:56")
(* This is opencoded NTHCHARCODE for
the case where N=1 and FLG=NIL)
(SELECTC (NTYPX X)
(\STRINGP (AND (NEQ (fetch (STRINGP LENGTH) of X)
0)
(\GETBASECHAR (fetch (STRINGP FATSTRINGP) of X)
(fetch (STRINGP BASE) of X)
(fetch (STRINGP OFFST) of X))))
(\LITATOM (AND (NEQ (fetch (LITATOM PNAMELENGTH) of X)
0)
(\GETBASECHAR (fetch (LITATOM FATPNAMEP) of X)
(fetch (LITATOM PNAMEBASE) of X)
1)))
(NTHCHARCODE X 1])
(U-CASE
[LAMBDA (X) (* bvm: "26-Jun-85 17:38")
(SELECTC (NTYPX X)
(\LITATOM [WITH-RESOURCE (\PNAMESTRING)
(for C CHANGEFLG (BASE ← (ffetch (STRINGP BASE) of \PNAMESTRING))
inatom X as I from 0 do (\PNAMESTRINGPUTCHAR
BASE I (COND
[(AND (IGEQ C (CHARCODE a))
(ILEQ C (CHARCODE z)))
(SETQ CHANGEFLG
(IPLUS C (IDIFFERENCE (CHARCODE
A)
(CHARCODE a]
(T C)))
finally (RETURN (COND
(CHANGEFLG (\MKATOM BASE 0 I \FATPNAMESTRINGP))
(T (* Don't bother calling \MKATOM if X
already uppercase)
X])
(\STRINGP (for C BASE NEWSTRING (FATP ← (ffetch (STRINGP FATSTRINGP) of X)) instring X
as I from 0 first (SETQ NEWSTRING (ALLOCSTRING (\NSTRINGCHARS X)
NIL NIL FATP))
(SETQ BASE (ffetch (STRINGP XBASE) of NEWSTRING))
do (\PUTBASECHAR FATP BASE I (COND
[(AND (IGEQ C (CHARCODE a))
(ILEQ C (CHARCODE z)))
(IPLUS C (IDIFFERENCE (CHARCODE A)
(CHARCODE a]
(T C))) finally (RETURN NEWSTRING)))
(\LISTP [CONS (U-CASE (CAR X))
(AND (CDR X)
(U-CASE (CDR X])
X])
(L-CASE
[LAMBDA (X FLG) (* bvm: "26-Jun-85 17:41")
(SELECTC (NTYPX X)
(\LITATOM [WITH-RESOURCE (\PNAMESTRING)
(for C CHANGEFLG (BASE ← (ffetch (STRINGP XBASE) 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 C (IDIFFERENCE (CHARCODE
a)
(CHARCODE A]
([AND FLG (AND (IGEQ C (CHARCODE a))
(ILEQ C (CHARCODE z]
(SETQ FLG NIL)
(SETQ CHANGEFLG (SETQ C (IPLUS C (IDIFFERENCE (CHARCODE A)
(CHARCODE a]
(\PNAMESTRINGPUTCHAR BASE I C)
finally (RETURN (COND
(CHANGEFLG (\MKATOM BASE 0 I \FATPNAMESTRINGP))
(T X])
(\STRINGP (for C BASE NEWSTRING (FATP ← (ffetch (STRINGP FATSTRINGP) of X)) instring X
as I from 0 first (SETQ NEWSTRING (ALLOCSTRING (\NSTRINGCHARS X)
NIL NIL FATP))
(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 C (IPLUS C (IDIFFERENCE (CHARCODE a)
(CHARCODE A]
([AND FLG (AND (IGEQ C (CHARCODE a))
(ILEQ C (CHARCODE z]
(SETQ FLG NIL)
(SETQ C (IPLUS C (IDIFFERENCE (CHARCODE A)
(CHARCODE a]
(\PUTBASECHAR FATP BASE I C) finally (RETURN NEWSTRING)))
(\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])
(\SMASHABLESTRING
[LAMBDA (STR FATP) (* gbn "18-Apr-85 00:39")
(* Ensures that FATP characters can be
smashed into STR)
(COND
[(ffetch (STRINGP READONLY) of STR)
(\MAKEWRITABLESTRING STR (OR FATP (ffetch (STRINGP FATSTRINGP) of STR]
((AND FATP (NOT (ffetch (STRINGP FATSTRINGP) of STR)))
(\FATTENSTRING STR)))
STR])
(\MAKEWRITABLESTRING
[LAMBDA (STR NEWFATP) (* bvm: "28-Jun-85 12:58")
(* * takes a string pointing at a readonly pname and changes the string to
point to a block of writable memory of the appropriate width)
(PROG ((OLDBASE (ffetch (STRINGP BASE) of STR))
(OLDFATP (ffetch (STRINGP FATSTRINGP) of STR))
NEWBASE NCHARS NWORDS)
(* The offset of the basestring won't be zero for a string or substring on an
atom. We must preserve even the inaccessible characters so the offset remains
constant in this string and in other substrings on this string.)
(* (DECLARE (SPECVARS OLDBASE NEWBASE
NEWFATP)))
(SETQ NCHARS (\GETBASEBYTE OLDBASE 0))
(COND
[(AND NEWFATP (NOT OLDFATP)) (* we are copying from old thin
readonly to new fat writeable.
New block is NCHARS+1 words long,
including the first word for pname
length)
(SETQ NEWBASE (\ALLOCBLOCK (FOLDHI (ADD1 NCHARS)
WORDSPERCELL)))
(* the length byte on the front of the pname will now be in the second byte,
but that doesn't matter since it should never be used now)
(for I from 0 to NCHARS do (\PUTBASEFAT NEWBASE I (\GETBASETHIN OLDBASE I]
((AND OLDFATP (NOT NEWFATP))
(SHOULDNT "\MAKEWRITABLESTRING confused."))
(T (* the new and old ones are the same
size, doesn't matter which -
just copy the chars into a new
smashable block)
[SETQ NWORDS (COND
(OLDFATP (ADD1 NCHARS))
(T (FOLDHI (ADD1 NCHARS)
BYTESPERWORD]
(SETQ NEWBASE (\ALLOCBLOCK (FOLDHI NWORDS WORDSPERCELL)))
(\BLT NEWBASE OLDBASE NWORDS)))
(UNINTERRUPTABLY
(freplace (STRINGP READONLY) of STR with NIL)
(freplace (STRINGP BASE) of STR with NEWBASE)
(freplace (STRINGP FATSTRINGP) of STR with NEWFATP))
(* do not map, since we cannot provide a consistent semantics
(the order of various operations in multiple processes will produce race
conditions) (UNINTERRUPTABLY (\MAPMDS (QUOTE STRINGP)
(FUNCTION \UPDATE.SUBSTRINGS))) (* uses freely OLDBASE NEWBASE NEWFATP))
(RETURN STR])
(\SMASHSTRING
[LAMBDA (DEST POS SOURCE NC) (* bvm: "28-Jun-85 13:07")
(* 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. DEST is presumed to be not READONLY, long
enough for the smash, and to be fat if SOURCE contains any fat characters--the
caller must guarantee this.)
(* Only caller so far is \RSTRING2 in
the reader)
(OR NC (SETQ NC (ffetch (STRINGP LENGTH) of SOURCE)))
(add POS (ffetch (STRINGP OFFST) of DEST))
(COND
[(ffetch (STRINGP FATSTRINGP) of DEST) (* The destination is fat.)
(COND
((ffetch (STRINGP FATSTRINGP) of SOURCE) (* The source is also;
just copy the characters straight
across)
(\BLT (\ADDBASE (ffetch (STRINGP BASE) of DEST)
POS)
(\ADDBASE (ffetch (STRINGP BASE) of SOURCE)
(ffetch (STRINGP OFFST) of SOURCE))
NC))
(T (* Have to do thin-to-fat conversion)
(bind (DBASE ← (ffetch (STRINGP BASE) of DEST)) for C inthinstring SOURCE as DESTCH#
from POS as SRCH# from 1 to NC do (* Run thru chars 1..NC
(or len) of the source, moving them
into the destination)
(\PUTBASEFAT DBASE DESTCH# C]
((ffetch (STRINGP FATSTRINGP) of SOURCE) (* Assume that SOURCE is FATP with no
fat characters. This is a guarantee
made by \RSTRING2.)
(bind (DBASE ← (ffetch (STRINGP BASE) of DEST)) for C infatstring SOURCE as DESTCH#
from POS as SRCH# from 1 to NC do (* Run thru chars 1..NC
(or len) of the source, moving them
into the destination)
(AND (IGREATERP C \MAXTHINCHAR)
(SHOULDNT))
(* If we find an unexpected fat
character, complain!)
(\PUTBASETHIN DBASE DESTCH# C)))
(T (* The source and destination are both
thin. Just copy characters.)
(\MOVEBYTES (ffetch (STRINGP BASE) of SOURCE)
(ffetch (STRINGP OFFST) of SOURCE)
(ffetch (STRINGP BASE) of DEST)
POS NC)))
DEST])
(\FATTENSTRING
[LAMBDA (STR) (* bvm: " 5-Jul-85 22:29")
(* Assumes that STR is a thin string
to be fattened)
(* (DECLARE (SPECVARS NEWBASE OLDBASE
NEWFATP)))
(PROG ((NEWFATP T)
(OLDBASE (ffetch (STRINGP BASE) of STR))
NEWBASE NCELLS)
(* The offset of the basestring won't be zero for a string or substring on an
atom. We must preserve even the inaccessible characters so the offset remains
constant in this string and in other substrings on this string.)
(* The true character block)
(SETQ NEWBASE (\ALLOCBLOCK (UNFOLD (SETQ NCELLS (\#BLOCKDATACELLS OLDBASE))
BYTESPERWORD))) (* Each character now occupies a word
instead of a byte.)
(for I from 0 to (SUB1 (UNFOLD NCELLS BYTESPERCELL)) do (\PUTBASEFAT NEWBASE I
(\GETBASETHIN OLDBASE I)))
(UNINTERRUPTABLY
(freplace (STRINGP BASE) of STR with NEWBASE)
(freplace (STRINGP READONLY) of STR with NIL)
(freplace (STRINGP FATSTRINGP) of STR with T))
(* This code is to update any substrings to see the same characters.
Seems dubious -
(UNINTERRUPTABLY (* uses freely OLDBASE NEWBASE NEWFATP)
(\MAPMDS (QUOTE STRINGP) (FUNCTION \UPDATE.SUBSTRINGS))))
(RETURN STR])
(\UPDATE.SUBSTRINGS
[LAMBDA (STRINGPPAGE)
(DECLARE (USEDFREE OLDBASE NEWBASE NEWFATP)) (* jds "23-Apr-85 05:01")
(* This function is applied through \MAPMDS to each STRINGP page, in order to
update all sub-stringp's whose BASE is OLDBASE to be NEWBASE.
-
The EQ test is obviously correct for allocated STRINGP's and safe for free ones
because the free list is linked thru the 0th
(= base) cell and ends in NIL. -
Multiply WORDSPERPAGE by 2 because there are 2 pages per MDS chunk)
(SETQ STRINGPPAGE (create POINTER
PAGE# ← STRINGPPAGE))
(for (I ← STRINGPPAGE)
(LASTINCHUNK ← (\ADDBASE STRINGPPAGE (IDIFFERENCE \MDSIncrement #STRINGPWORDS)))
by (\ADDBASE I #STRINGPWORDS) when (EQ OLDBASE (ffetch (STRINGP BASE) of I))
do (freplace (STRINGP BASE) of I with NEWBASE)
(freplace (STRINGP READONLY) of I with NIL)
(freplace (STRINGP FATSTRINGP) of I with NEWFATP) repeatuntil (EQ I LASTINCHUNK])
)
(* Temporary until low level system is changed to call STRING.EQUAL again)
(MOVD? (QUOTE STRING.EQUAL)
(QUOTE STRING-EQUAL)
NIL T)
(DEFINEQ
(\GETBASESTRING
[LAMBDA (BASE BYTEOFFSET NCHARS FATP) (* bvm: "27-Jun-85 16:40")
(* * Makes a string consisting of NCHARS characters starting at BYTEOFFSET from
BASE -- note that caller must know whether the string is fat
(see \PUTBASESTRING); BYTEOFFSET is always a byte offset in either case)
(LET ((STR (ALLOCSTRING NCHARS NIL NIL FATP)))
(\MOVEBYTES BASE BYTEOFFSET (fetch (STRINGP BASE) of STR)
(fetch (STRINGP OFFST) of STR)
(COND
(FATP (UNFOLD NCHARS BYTESPERWORD))
(T NCHARS)))
STR])
(\PUTBASESTRING
[LAMBDA (BASE BYTEOFFSET SOURCE FATP) (* bvm: "27-Jun-85 16:50")
(* In addition to putting the bytes into memory, this guy returns the number of
characters "written" , since the source may not be a STRINGP, but will be
coerced to one.)
(* * Not clear what this fn should do with fat strings.
Caller is using this fn to store raw characters into some random location, so
must make some assumption about the format they are stored in.
Hence if there's a fat string, but FATP is false, we don't know what to do)
(SELECTC (NTYPX SOURCE)
(\STRINGP (COND
(FATP (\PUTBASESTRINGFAT BASE BYTEOFFSET (fetch (STRINGP BASE) of SOURCE)
(fetch (STRINGP OFFST) of SOURCE)
(fetch (STRINGP LENGTH) of SOURCE)
(fetch (STRINGP FATSTRINGP) of SOURCE)))
((fetch (STRINGP FATSTRINGP) of SOURCE)
(ERROR "Fat string in \PUTBASESTRING" SOURCE))
(T (\MOVEBYTES (fetch (STRINGP BASE) of SOURCE)
(fetch (STRINGP OFFST) of SOURCE)
BASE BYTEOFFSET (SETQ SOURCE (fetch (STRINGP LENGTH) of SOURCE)))
SOURCE)))
(\LITATOM (COND
(FATP (\PUTBASESTRINGFAT BASE BYTEOFFSET (fetch (LITATOM PNAMEBASE) of SOURCE)
1
(fetch (LITATOM PNAMELENGTH) of SOURCE)
(fetch (LITATOM FATPNAMEP) of SOURCE)))
((fetch (LITATOM FATPNAMEP) of SOURCE)
(ERROR "Fat string in \PUTBASESTRING" SOURCE))
(T (\MOVEBYTES (fetch (LITATOM PNAMEBASE) of SOURCE)
1 BASE BYTEOFFSET (SETQ SOURCE (fetch (LITATOM PNAMELENGTH)
of SOURCE)))
SOURCE)))
(\PUTBASESTRING BASE BYTEOFFSET (MKSTRING SOURCE)
FATP])
(\PUTBASESTRINGFAT
[LAMBDA (DBASE DBYTEOFFSET SBASE SOFFSET LEN FATP) (* bvm: "27-Jun-85 16:48")
(* * Store a fat string at byte offset from DBASE.
SBASE and SOFFSET are in the source's units
(bytes or words))
[COND
(FATP (\MOVEBYTES SBASE (UNFOLD SOFFSET BYTESPERWORD)
DBASE DBYTEOFFSET (UNFOLD LEN BYTESPERWORD)))
(T (* Store thin string in fat format)
(for I from 0 to (SUB1 LEN) as DOFF from DBYTEOFFSET by 2
do (\PUTBASETHIN DBASE DOFF 0)
(\PUTBASETHIN DBASE (ADD1 DOFF)
(\GETBASETHIN SBASE (IPLUS SOFFSET I]
LEN])
(GetBcplString
[LAMBDA (BASE ATOMFLG) (* bvm: " 5-Jul-85 21:48")
(* Returns as a Lisp string the Bcpl string stored at BS.
Format is one byte length, follwed by chars.
If ATOMFLG is true, returns result as an atom)
(LET ((L (\GETBASEBYTE BASE 0))
S)
(COND
((AND ATOMFLG (ILEQ L \PNAMELIMIT))
(\MKATOM BASE 1 L))
(T (SETQ S (\GETBASESTRING BASE 1 L))
(COND
(ATOMFLG (* Let MKATOM handle the error)
(MKATOM S))
(T S])
(SetBcplString
[LAMBDA (BASE STR) (* bvm: " 5-Jul-85 21:50")
(LET ((L (NCHARS STR)))
(COND
((IGREATERP L 255)
(LISPERROR "ILLEGAL ARG" BASE))
(T (\PUTBASEBYTE BASE 0 L)
(\PUTBASESTRING BASE 1 STR)))
BASE])
)
(DECLARE: DONTCOPY
(* Kludge not currently in effect)
(DECLARE: EVAL@COMPILE
(ADDTOVAR DONTCOMPILEFNS \UPDATE.SUBSTRINGS)
)
(* FOLLOWING DEFINITIONS EXPORTED)
[DECLARE: EVAL@COMPILE
(DATATYPE STRINGP ((ORIG BITS 1) (* ORIG is always 1)
(SUBSTRINGED FLAG)
(XREADONLY FLAG)
(NIL BITS 1)
(TYP BITS 4) (* TYP is \ST.BYTE for thin strings,
\ST.POS16 for fat ones, \ST.INDIRECT
if XBASE is an indirect to another
STRINGP)
(XBASE POINTER)
(LENGTH WORD)
(OFFST WORD))
[ACCESSFNS STRINGP ((BASE (ffetch (STRINGP XBASE) of DATUM)
(freplace (STRINGP XBASE) of DATUM with NEWVALUE))
(READONLY (ffetch (STRINGP XREADONLY) of DATUM)
(freplace (STRINGP XREADONLY) of DATUM with NEWVALUE))
(FATSTRINGP (SELECTC (ffetch (STRINGP TYP) of DATUM)
(\ST.BYTE NIL)
T)
(freplace (STRINGP TYP) of DATUM
with (if NEWVALUE
then \ST.POS16
else \ST.BYTE]
TYP ← \ST.BYTE ORIG ← 1 SUBSTRINGED ← NIL (* 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)
FLAG FLAG (BITS 1)
(BITS 4)
POINTER WORD WORD))
[QUOTE ((STRINGP 0 (BITS . 0))
(STRINGP 0 (FLAGBITS . 16))
(STRINGP 0 (FLAGBITS . 32))
(STRINGP 0 (BITS . 48))
(STRINGP 0 (BITS . 67))
(STRINGP 0 POINTER)
(STRINGP 2 (BITS . 15))
(STRINGP 3 (BITS . 15]
(QUOTE 4))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \OneCharAtomBase)
)
(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 NIL NIL \FATPNAMESTRINGP]
)
(DECLARE: EVAL@COMPILE
(RPAQQ \FATPNAMESTRINGP T)
(CONSTANTS (\FATPNAMESTRINGP T))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS \PNAMESTRINGPUTCHAR MACRO ((BASE OFFSET CODE)
(* For stuffing chars into resource \PNAMESTRING)
(\PUTBASECHAR \FATPNAMESTRINGP BASE OFFSET CODE)))
)
(PUTPROPS FCHARACTER DMACRO [OPENLAMBDA (N)
(COND ((IGREATERP N \MAXTHINCHAR)
(* The character we're getting is NOT a thin character --
do it the hard way)
(CHARACTER N))
((IGREATERP N (CHARCODE 9))
(\ADDBASE \OneCharAtomBase (IDIFFERENCE N 10)))
((IGEQ N (CHARCODE 0))
(IDIFFERENCE N (CHARCODE 0)))
(T (* The common case -- just add on the one-atom base.)
(\ADDBASE \OneCharAtomBase N])
(DECLARE: EVAL@COMPILE
(I.S.OPR (QUOTE inpname)
NIL
[QUOTE (SUBPAIR (QUOTE ($$END $$BODY $$FATP $$BASE $$OFFSET))
(LIST (GETDUMMYVAR)
(GETDUMMYVAR)
(GETDUMMYVAR)
(GETDUMMYVAR)
(GETDUMMYVAR))
(BQUOTE (bind $$OFFSET ← 0 $$BODY ← BODY $$BASE $$END $$FATP declare
(LOCALVARS $$END $$BODY $$FATP $$BASE $$OFFSET)
first
[PROG NIL $$RETRY (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 $$END (ffetch (PNAMEBASE
PNAMELENGTH)
of $$BASE))
(SETQ $$FATP (ffetch (LITATOM
FATPNAMEP)
of $$BODY)))
(PROGN (SETQ $$BODY (MKSTRING $$BODY))
(GO $$RETRY]
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 ($$OFFSET $$BODY $$BASE $$END $$FATP))
(LIST (GETDUMMYVAR)
(GETDUMMYVAR)
(GETDUMMYVAR)
(GETDUMMYVAR)
(GETDUMMYVAR))
(QUOTE (bind $$OFFSET ← 0 $$BODY ← BODY $$BASE $$END $$FATP declare
(LOCALVARS $$OFFSET $$BODY $$BASE $$END $$FATP)
first
(SETQ $$BASE (ffetch (LITATOM PNAMEBASE)
of $$BODY))
(SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH)
of $$BASE))
(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 ($$BODY $$END $$OFFSET $$BASE $$FATP))
(LIST (GETDUMMYVAR)
(GETDUMMYVAR)
(GETDUMMYVAR)
(GETDUMMYVAR)
(GETDUMMYVAR))
(QUOTE (bind $$BODY ← BODY $$END $$OFFSET $$BASE $$FATP declare
(LOCALVARS $$BODY $$END $$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 ($$OFFSET $$BODY $$BASE $$END))
(LIST (GETDUMMYVAR)
(GETDUMMYVAR)
(GETDUMMYVAR)
(GETDUMMYVAR))
(QUOTE (bind $$OFFSET ← 0 $$BODY ← BODY $$BASE $$END declare
(LOCALVARS $$OFFSET $$BODY $$BASE $$END)
first
(SETQ $$BASE (ffetch (LITATOM PNAMEBASE)
of $$BODY))
(SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH)
of $$BASE))
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 ($$OFFSET $$BODY $$BASE $$END))
(LIST (GETDUMMYVAR)
(GETDUMMYVAR)
(GETDUMMYVAR)
(GETDUMMYVAR))
(QUOTE (bind $$OFFSET ← 0 $$BODY ← BODY $$BASE $$END declare
(LOCALVARS $$OFFSET $$BODY $$BASE $$END)
first
(SETQ $$BASE (ffetch (LITATOM PNAMEBASE)
of $$BODY))
(SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH)
of $$BASE))
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 ($$BODY $$END $$OFFSET $$BASE))
(LIST (GETDUMMYVAR)
(GETDUMMYVAR)
(GETDUMMYVAR)
(GETDUMMYVAR))
(QUOTE (bind $$BODY ← BODY $$END $$OFFSET $$BASE declare
(LOCALVARS $$BODY $$END $$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 ($$BODY $$END $$OFFSET $$BASE))
(LIST (GETDUMMYVAR)
(GETDUMMYVAR)
(GETDUMMYVAR)
(GETDUMMYVAR))
(QUOTE (bind $$BODY ← BODY $$END $$OFFSET $$BASE declare
(LOCALVARS $$BODY $$END $$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)
(* used to also say (ILEQ X \MAXFATCHAR)
%, but that's implied by the first two clauses)
(AND (SMALLP X)
(IGEQ X 0]
[PUTPROPS \FATCHARCODEP DMACRO (OPENLAMBDA (X)
(* Used to also say (ILEQ X \MAXFATCHAR)
%, but that's implied by the first two clauses)
(AND (SMALLP X)
(IGREATERP X \MAXTHINCHAR]
[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 (OPENLAMBDA (FATP BASE OFFSET CODE)
(COND (FATP (\PUTBASEFAT BASE OFFSET CODE))
(T (\PUTBASETHIN BASE OFFSET CODE]
[PUTPROPS \GETBASECHAR MACRO ((FATP BASE N)
(COND (FATP (\GETBASEFAT BASE N))
(T (\GETBASETHIN BASE N]
)
(DECLARE: EVAL@COMPILE
(PUTPROPS \CHARSET MACRO ((CHARCODE)
(LRSH CHARCODE 8)))
(PUTPROPS \CHAR8CODE MACRO ((CHARCODE)
(LOGAND CHARCODE 255)))
)
(DECLARE: EVAL@COMPILE
(RPAQQ \ST.INDIRECT 3)
(RPAQQ \CHARMASK 255)
(RPAQQ \MAXCHAR 255)
(RPAQQ \MAXTHINCHAR 255)
(RPAQQ \MAXFATCHAR 65535)
(RPAQQ \MAXCHARSET 255)
(RPAQQ NSCHARSETSHIFT 255)
(RPAQQ #STRINGPWORDS 4)
(CONSTANTS (\ST.INDIRECT 3)
(\CHARMASK 255)
(\MAXCHAR 255)
(\MAXTHINCHAR 255)
(\MAXFATCHAR 65535)
(\MAXCHARSET 255)
(NSCHARSETSHIFT 255)
(#STRINGPWORDS 4))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS \NATOMCHARS DMACRO ((AT)
(fetch (LITATOM PNAMELENGTH)
of AT)))
(PUTPROPS \NSTRINGCHARS DMACRO ((S)
(fetch (STRINGP LENGTH)
of S)))
)
(* END EXPORTED DEFINITIONS)
)
(/SETTOPVAL (QUOTE \\NUMSTR.GLOBALRESOURCE))
(/SETTOPVAL (QUOTE \\NUMSTR1.GLOBALRESOURCE))
(/SETTOPVAL (QUOTE \\PNAMESTRING.GLOBALRESOURCE))
(MOVD? (QUOTE CHARACTER)
(QUOTE FCHARACTER)
NIL T)
(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))
(ADDTOVAR EXPANDMACROFNS \PUTBASETHIN \PUTBASEFAT \CHARCODEP \GETBASECHAR \GETBASETHIN \GETBASEFAT
\PUTBASECHAR)
(ADDTOVAR DONTCOMPILEFNS COPYSTRING)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(PUTPROPS LLCHAR COPYRIGHT ("Xerox Corporation" 1982 1983 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (3120 65824 (ALLOCSTRING 3130 . 5163) (MKATOM 5165 . 5783) (SUBATOM 5785 . 7562) (
CHARACTER 7564 . 8604) (MKNUMATOM 8606 . 16587) (\MKINTEGER 16589 . 17609) (MKSTRING 17611 . 19849) (
\PRINDATUM.TO.STRING 19851 . 24236) (BKSYSBUF 24238 . 24782) (NCHARS 24784 . 26525) (NTHCHARCODE 26527
. 28553) (RPLCHARCODE 28555 . 29599) (\RPLCHARCODE 29601 . 31109) (NTHCHAR 31111 . 32516) (RPLSTRING
32518 . 35436) (SUBSTRING 35438 . 40154) (GNC 40156 . 41385) (GNCCODE 41387 . 42289) (GLC 42291 .
43206) (GLCCODE 43208 . 43943) (STREQUAL 43945 . 45242) (STRING.EQUAL 45244 . 48331) (CHCON1 48333 .
49292) (U-CASE 49294 . 51750) (L-CASE 51752 . 54650) (U-CASEP 54652 . 55221) (\SMASHABLESTRING 55223
. 55793) (\MAKEWRITABLESTRING 55795 . 59058) (\SMASHSTRING 59060 . 62660) (\FATTENSTRING 62662 .
64636) (\UPDATE.SUBSTRINGS 64638 . 65822)) (65978 70866 (\GETBASESTRING 65988 . 66677) (\PUTBASESTRING
66679 . 69038) (\PUTBASESTRINGFAT 69040 . 69822) (GetBcplString 69824 . 70525) (SetBcplString 70527
. 70864)) (88944 89482 (COPYSTRING 88954 . 89480)))))
STOP