(FILECREATED "10-Jul-85 11:30:04" {ERIS}<LISPCORE>SOURCES>LLCHAR.;20
changes to: (VARS LLCHARCOMS)
(FNS NCHARS \FATTENSTRING GetBcplString SetBcplString STRING-EQUAL)
previous date: " 7-Jul-85 13:28:35" {ERIS}<LISPCORE>SOURCES>LLCHAR.;19)
(* Copyright (c) 1982, 1983, 1984, 1985 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 STRING-EQUAL CHCON1 U-CASE L-CASE U-CASEP
\SMASHABLESTRING \MAKEWRITABLESTRING \SMASHSTRING \FATTENSTRING
\UPDATE.SUBSTRINGS)
(COMS (* Temporary)
(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: "28-Jun-85 19:01")
(* Coerce X to be a string. The string will be FAT if X
is)
(DECLARE (GLOBALVARS PRXFLG \PRINTRADIX \SIGNFLAG))
(PROG NIL
(OR FLG (SELECTC (NTYPX X)
(\STRINGP (* Strings coerce to themselves)
(RETURN X))
[\LITATOM (* LITATOMs have a new descriptor created, pointing to
the same characters.)
(RETURN (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]
[(LIST \FIXP \SMALLP \FLOATP) (* Otherwise, try converting it to a number;
failing that we'll print it.)
(RETURN (GLOBALRESOURCE
(\NUMSTR \NUMSTR1)
(LET [(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]
(RPLSTRING (ALLOCSTRING (NCHARS STR))
1 STR]
NIL))
(RETURN (LET ((S (ALLOCSTRING (NCHARS X FLG RDTBL)))
(J 1))
(DECLARE (SPECVARS S J))
(\MAPCHARS [FUNCTION (LAMBDA (CODE)
(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)
J -1)
CODE))
((ILEQ CODE \MAXTHINCHAR)
(* Thin char & String; just smash the char in)
(\PUTBASETHIN (fetch (STRINGP BASE) of S)
(IPLUS (fetch (STRINGP OFFST) of S)
J -1)
CODE))
(T (* Need to fatten the string, then smash in the char.)
(\SMASHABLESTRING S T)
(\PUTBASEFAT (fetch (STRINGP BASE) of S)
(IPLUS (fetch (STRINGP OFFST) of S)
J -1)
CODE)))
(SETQ J (ADD1 J]
X FLG RDTBL)
S])
(BKSYSBUF
[LAMBDA (X FLG RDTBL) (* rmk: " 3-Apr-85 10:01")
[COND
(FLG (\MAPCHARS (FUNCTION BKSYSCHARCODE)
X FLG RDTBL))
(T (SELECTC (NTYPX X)
(\LITATOM (for C inatom X do (BKSYSCHARCODE C)))
(\STRINGP (for C instring X do (BKSYSCHARCODE C)))
(\MAPCHARS (FUNCTION BKSYSCHARCODE)
X FLG RDTBL]
X])
(NCHARS
[LAMBDA (X FLG RDTBL) (* bvm: " 6-Jul-85 17:29")
(SELECTC (NTYPX X)
[\LITATOM (COND
[FLG (IPLUS (fetch (LITATOM PNAMELENGTH) of X)
(for C inatom X
bind (SA ←(fetch READSA of (\GTREADTABLE RDTBL)))
(FIRSTFLG ← T)
SYN
count (PROG1 (AND (fetch (READCODE ESCQUOTE)
of (SETQ SYN (\SYNCODE SA C)))
(OR FIRSTFLG (fetch (READCODE INNERESCQUOTE)
of SYN)))
(SETQ FIRSTFLG NIL]
(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: "25-Mar-85 16:32")
(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
((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 (\GETBASECHAR FATP 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) (* 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)
(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 $$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 ($$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 (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 ($$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 (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 ($$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 (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 ($$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))
STOP