(FILECREATED "15-Feb-85 18:21:43" {ERIS}<LISPCORE>SOURCES>LLNEW.;10 36906
changes to: (FNS \UNCOPY)
(VARS LLNEWCOMS)
previous date: "12-Feb-85 11:21:19" {ERIS}<LISPCORE>SOURCES>LLNEW.;9)
(* Copyright (c) 1981, 1982, 1983, 1984, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT LLNEWCOMS)
(RPAQQ LLNEWCOMS ([COMS (* low level memory access)
(FNS \ADDBASE \GETBASE \PUTBASE \PUTBASE.UFN \PUTBASEPTR.UFN \PUTBITS.UFN
\GETBASEBYTE \PUTBASEBYTE \GETBASEPTR \PUTBASEPTR \HILOC \LOLOC \VAG2 EQ
\RPLPTR \RPLPTR.UFN)
(FNS LOC VAG)
(FNS CREATEPAGES \NEW4PAGE)
(DECLARE: DONTCOPY (EXPORT (RECORDS POINTER WORD)
(MACROS PTRGTP .COERCE.TO.SMALLPOSP.
.COERCE.TO.BYTE.))
(ADDVARS (INEWCOMS (FNS \GETBASEBYTE \PUTBASEBYTE CREATEPAGES
\NEW4PAGE))
(RDCOMS (FNS \CAR.UFN \CDR.UFN)
(FNS \COPY \UNCOPY)
(FNS \GETBASEBYTE \PUTBASEBYTE))
(INITPTRS (\LISTPDTD))
(MKI.SUBFNS (\ADDBASE . I.ADDBASE)
(\\ADDBASE . I.ADDBASE)
(\GETBASE . I.GETBASE)
(\PUTBASE . I.PUTBASE)
(\GETBASEBYTE . I.GETBASEBYTE)
(\PUTBASEBYTE . I.PUTBASEBYTE)
(\GETBASEPTR . I.GETBASEPTR)
(\PUTBASEPTR . I.PUTBASEPTR)
(\HILOC . I.HILOC)
(\LOLOC . I.LOLOC)
(\VAG2 . I.VAG2)
(.COERCE.TO.SMALLPOSP. . PROG1)
(.COERCE.TO.BYTE. . PROG1)
(LOCKEDPAGEP . MKI.LOCKEDPAGEP)
(\RPLPTR . I.PUTBASEPTR)
(CONS . I.\CONS.UFN))
(RD.SUBFNS (\ADDBASE . VADDBASE)
(\\ADDBASE . VADDBASE)
(\GETBASE . VGETBASE)
(\PUTBASE . VPUTBASE)
(\GETBASEPTR . VGETBASEPTR)
(\PUTBASEPTR . VPUTBASEPTR)
(\HILOC . VHILOC)
(\LOLOC . VLOLOC)
(\VAG2 . VVAG2)
(.COERCE.TO.SMALLPOSP. . PROG1)
(.COERCE.TO.BYTE. . PROG1)
(CONS . VCONS)
(CREATECELL . VCREATECELL)
(COPYSTRING . VCOPYSTRING)
(PTRGTP . IGREATERP)
(\RPLPTR . VPUTBASEPTR)
(CAR . V\CAR.UFN)
(CDR . V\CDR.UFN)
(CAR/CDRERR . T)))
EVAL@COMPILE
(ADDVARS (DONTCOMPILEFNS CREATEPAGES]
[COMS (* cons cells)
(FNS CONS \CONS.UFN CAR \CAR.UFN CDR \CDR.UFN RPLACA \RPLACA.UFN RPLACD \RPLACD.UFN
DOCOLLECT \RPLCONS ENDCOLLECT \INITCONSPAGE \NEXTCONSPAGE)
(INITVARS (CAR/CDRERR (QUOTE CDR)))
(DECLARE: DONTCOPY (GLOBALVARS CAR/CDRERR)
(EXPORT (RECORDS LISTP CONSPAGE)
(CONSTANTS * CONSCONSTANTS))
(MACROS .MAKECONSCELL.)
(* for MAKEINIT)
(ADDVARS (INEWCOMS (FNS \CONS.UFN \INITCONSPAGE \NEXTCONSPAGE))
(EXPANDMACROFNS .MAKECONSCELL.)))
(COMS (* testing out CONSes)
(FNS CHECKCONSPAGES \CHECKCONSPAGE)
(DECLARE: DONTCOPY (MACROS !CHECK]
[COMS (* other random stuff for makeinit)
(FNS MAKEINITFIRST MAKEINITLAST \COPY \UNCOPY)
(DECLARE: DONTCOPY (EXPORT (MACROS LOCAL ALLOCAL))
(ADDVARS (MKI.SUBFNS (CHECK . *)
(RAID . HELP)
(UNINTERRUPTABLY
. PROGN)
(\StatsAdd1 . *)
(EVQ . I.\COPY)
(COPY . I.\COPY))
(RD.SUBFNS (CHECK . *)
(RAID . HELP)
(UNINTERRUPTABLY
. PROGN)
(\StatsAdd1 . *)
(EVQ . V\COPY)
(COPY . V\COPY)
(1ST . V\UNCOPY)))
(ADDVARS (INEWCOMS (FNS MAKEINITFIRST \COPY MAKEINITLAST)))
EVAL@COMPILE
(ADDVARS (DONTCOMPILEFNS MAKEINITFIRST \COPY MAKEINITLAST \UNCOPY]
(LOCALVARS . T)))
(* low level memory access)
(DEFINEQ
(\ADDBASE
[LAMBDA (X D) (* lmm " 2-NOV-81 18:33")
(* usually done in microcode; this version uses only arithmetic and \VAG2)
(PROG (NH NL (XH (\HILOC X))
(XL (\LOLOC X)))
(.UNBOX. D NH NL)
(COND
[(IGREATERP XL (IDIFFERENCE MAX.SMALL.INTEGER NL))
(* carry)
(add XH 1)
(SETQ XL (SUB1 (IDIFFERENCE XL (IDIFFERENCE MAX.SMALL.INTEGER NL]
(T (add XL NL)))
(COND
[(IGREATERP NH MAX.POS.HINUM)
(SETQ XH (SUB1 (IDIFFERENCE XH (IDIFFERENCE MAX.SMALL.INTEGER NH]
(T (add XH NH)))
(RETURN (\VAG2 XH XL])
(\GETBASE
[LAMBDA (X D) (* lmm " 2-NOV-81 18:33")
(* usually done in microcode; case where D=0 MUST be done in microcode)
(\GETBASE (\ADDBASE X D)
0])
(\PUTBASE
[LAMBDA (X D V) (* lmm "11-FEB-83 07:35")
(* usually done in microcode; case where D=0 MUST be handled there)
(\PUTBASE (\ADDBASE X D)
0
(.COERCE.TO.SMALLPOSP. V])
(\PUTBASE.UFN
[LAMBDA (X V D) (* lmm "11-FEB-83 07:35")
(* usually done in microcode; case where D=0 MUST be handled there)
(\PUTBASE (\ADDBASE X D)
0
(.COERCE.TO.SMALLPOSP. V])
(\PUTBASEPTR.UFN
[LAMBDA (X V D) (* lmm "10-NOV-81 15:12")
(* usually done in microcode; this def uses only PUTBASE, ADDBASE, etc)
(\PUTBASE X D (\HILOC V))
(\PUTBASE (\ADDBASE X D)
1
(\LOLOC V))
V])
(\PUTBITS.UFN
[LAMBDA (X V N.FD) (* lmm "11-FEB-83 07:35")
(PROG ((NV (.COERCE.TO.SMALLPOSP. V))
(WIDTH (ADD1 (LOGAND N.FD 15)))
(FIRST (LRSH (LOGAND N.FD 255)
4))
MASK SHIFT)
(SETQ SHIFT (IDIFFERENCE 16 (IPLUS FIRST WIDTH)))
(SETQ MASK (SUB1 (LLSH 1 WIDTH)))
(\PUTBASE (SETQ X (\ADDBASE X (LRSH N.FD 8)))
0
(LOGOR (LOGAND (\GETBASE X 0)
(LOGXOR 65535 (LLSH MASK SHIFT)))
(LLSH (LOGAND NV MASK)
SHIFT)))
(RETURN NV])
(\GETBASEBYTE
[LAMBDA (PTR N) (* bvm: " 5-Feb-85 12:05")
(* usually done in microcode;
this def. uses only \GETBASE and arithmetic -
used by MAKEINIT too)
(COND
[(EVENP N)
(fetch (WORD HIBYTE) of (\GETBASE PTR (FOLDLO N BYTESPERWORD]
(T (fetch (WORD LOBYTE) of (\GETBASE PTR (FOLDLO N BYTESPERWORD])
(\PUTBASEBYTE
(LAMBDA (PTR DISP BYTE) (* JonL "31-Dec-83 23:48")
(* usually done in microcode -
this def used by MAKEINIT too)
(SETQ BYTE (.COERCE.TO.BYTE. BYTE))
(\PUTBASE PTR (FOLDLO (SETQ DISP (\DTEST DISP (QUOTE SMALLP)))
BYTESPERWORD)
(COND
((EVENP DISP BYTESPERWORD)
(create WORD using (\GETBASE PTR (FOLDLO DISP BYTESPERWORD))
HIBYTE ← BYTE))
(T (create WORD using (\GETBASE PTR (FOLDLO DISP BYTESPERWORD))
LOBYTE ← BYTE))))
BYTE))
(\GETBASEPTR
[LAMBDA (X D) (* lmm " 2-NOV-81 18:34")
(* usually done in microcode; this def. uses GETBASE, VAG2, etc. and handles
overflows too)
(\VAG2 (fetch LOBYTE of (\GETBASE X D))
(\GETBASE (\ADDBASE X 1)
D])
(\PUTBASEPTR
[LAMBDA (X D V) (* lmm " 2-NOV-81 18:35")
(* usually done in microcode; this def uses only PUTBASE, ADDBASE, etc)
(\PUTBASE X D (\HILOC V))
(\PUTBASE (\ADDBASE X D)
1
(\LOLOC V))
V])
(\HILOC
[LAMBDA (X) (* lmm "10-MAR-81 15:02")
(* MUST be handled in microcode)
(\HILOC X])
(\LOLOC
[LAMBDA (X) (* lmm "10-MAR-81 15:03")
(* MUST be handled in microcode)
(\LOLOC X])
(\VAG2
(LAMBDA (H L) (* JonL "31-Dec-83 23:39")
(* case where H is byte and L is smallposp MUST be
handled in microcode. Other cases may run error here.)
(\VAG2 (.COERCE.TO.BYTE. H)
(.COERCE.TO.SMALLPOSP. L))))
(EQ
[LAMBDA (X Y) (* lmm "10-MAR-81 15:04")
(* MUST be handled in microcode)
(EQ X Y])
(\RPLPTR
[LAMBDA (OBJ OFFSET VAL) (* lmm " 3-NOV-81 12:10")
(UNINTERRUPTABLY
(\ADDREF VAL)
(\DELREF (\GETBASEPTR (SETQ OBJ (\ADDBASE OBJ OFFSET))
0))
(\PUTBASEBYTE OBJ 1 (\HILOC VAL)) (* \PUTBASEPTR smashes the high byte)
(\PUTBASE OBJ 1 (\LOLOC VAL))
VAL)])
(\RPLPTR.UFN
[LAMBDA (OBJ VAL OFFSET) (* lmm " 3-NOV-81 12:10")
(* UFN is different from function since the offset
(inline) gets pushed last)
(UNINTERRUPTABLY
(\ADDREF VAL)
(\DELREF (\GETBASEPTR (SETQ OBJ (\ADDBASE OBJ OFFSET))
0))
(\PUTBASEBYTE OBJ 1 (\HILOC VAL)) (* \PUTBASEPTR smashes the high byte)
(\PUTBASE OBJ 1 (\LOLOC VAL))
VAL)])
)
(DEFINEQ
(LOC
[LAMBDA (X) (* lmm " 2-NOV-81 18:29")
(* Return HILOC-LOLOC pair, for easier traffic with RAID.
VAG interprets such pairs correctly.)
(CONS (\HILOC X)
(\LOLOC X])
(VAG
[LAMBDA (LOC) (* lmm " 2-NOV-81 18:28")
(* LOC can be a HILOC-LOLOC pair)
(COND
[(LISTP LOC)
(\VAG2 (CAR LOC)
(OR (FIXP (CDR LOC))
(FIX (CADR LOC]
(T (\VAG2 (\HINUM LOC)
(\LONUM LOC])
)
(DEFINEQ
(CREATEPAGES
[LAMBDA (VA N BLANKFLG LOCKFLG) (* bvm: "29-MAR-83 16:35")
(* called only under MAKEINIT -
BLANKFLG means that MAKEINIT won't write on this page, so fake it -
to prevent storage overflow when running on Maxc and init'ing GC table)
(for I from 0 to (SUB1 N) do (\NEWPAGE (\ADDBASE VA (UNFOLD I WORDSPERPAGE))
NIL LOCKFLG BLANKFLG))
VA])
(\NEW4PAGE
[LAMBDA (PTR) (* lmm "11-FEB-83 07:47")
(\NEWPAGE (\ADDBASE (\NEWPAGE (\ADDBASE (\NEWPAGE (\ADDBASE (\NEWPAGE PTR)
WORDSPERPAGE))
WORDSPERPAGE))
WORDSPERPAGE])
)
(DECLARE: DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
[DECLARE: EVAL@COMPILE
(ACCESSFNS POINTER [(PAGE# (IPLUS (LLSH (\HILOC DATUM)
8)
(LRSH (\LOLOC DATUM)
8)))
(WORDINPAGE (LOGAND (\LOLOC DATUM)
255))
(CELLINPAGE (LRSH (fetch WORDINPAGE of DATUM)
1))
(BYTEINPAGE (LLSH (fetch WORDINPAGE of DATUM)
1))
(SEGMENT# (\HILOC DATUM))
(WORDINSEGMENT (\LOLOC DATUM))
(CELLINSEGMENT (LRSH (fetch WORDINSEGMENT of DATUM)
1))
(WORD# (fetch WORDINPAGE of DATUM))
(DBLWORD# (fetch CELLINPAGE of DATUM))
(PAGEBASE (\VAG2 (\HILOC DATUM)
(LOGAND (\LOLOC DATUM)
65280]
(CREATE (\VAG2 (LRSH PAGE# 8)
(LLSH (LOGAND PAGE# 255)
8))))
(ACCESSFNS WORD ((HIBYTE (LRSH DATUM 8))
(LOBYTE (LOGAND DATUM 255)))
(CREATE (IPLUS (LLSH HIBYTE 8)
LOBYTE)))
]
(DECLARE: EVAL@COMPILE
(PUTPROPS PTRGTP MACRO [OPENLAMBDA (X Y)
(OR (IGREATERP (\HILOC X)
(\HILOC Y))
(AND (EQ (\HILOC X)
(\HILOC Y))
(IGREATERP (\LOLOC X)
(\LOLOC Y])
(PUTPROPS .COERCE.TO.SMALLPOSP. DMACRO [OPENLAMBDA (X)
(COND ((SMALLPOSP X)
X)
(T (\ILLEGAL.ARG X])
(PUTPROPS .COERCE.TO.BYTE. DMACRO [OPENLAMBDA (X)
(COND ([AND (SMALLPOSP X)
(ILESSP X (CONSTANT (LLSH 1 BITSPERBYTE]
X)
(T (\ILLEGAL.ARG X])
)
(* END EXPORTED DEFINITIONS)
(ADDTOVAR INEWCOMS (FNS \GETBASEBYTE \PUTBASEBYTE CREATEPAGES \NEW4PAGE))
(ADDTOVAR RDCOMS (FNS \CAR.UFN \CDR.UFN)
(FNS \COPY \UNCOPY)
(FNS \GETBASEBYTE \PUTBASEBYTE))
(ADDTOVAR INITPTRS (\LISTPDTD))
(ADDTOVAR MKI.SUBFNS (\ADDBASE . I.ADDBASE)
(\\ADDBASE . I.ADDBASE)
(\GETBASE . I.GETBASE)
(\PUTBASE . I.PUTBASE)
(\GETBASEBYTE . I.GETBASEBYTE)
(\PUTBASEBYTE . I.PUTBASEBYTE)
(\GETBASEPTR . I.GETBASEPTR)
(\PUTBASEPTR . I.PUTBASEPTR)
(\HILOC . I.HILOC)
(\LOLOC . I.LOLOC)
(\VAG2 . I.VAG2)
(.COERCE.TO.SMALLPOSP. . PROG1)
(.COERCE.TO.BYTE. . PROG1)
(LOCKEDPAGEP . MKI.LOCKEDPAGEP)
(\RPLPTR . I.PUTBASEPTR)
(CONS . I.\CONS.UFN))
(ADDTOVAR RD.SUBFNS (\ADDBASE . VADDBASE)
(\\ADDBASE . VADDBASE)
(\GETBASE . VGETBASE)
(\PUTBASE . VPUTBASE)
(\GETBASEPTR . VGETBASEPTR)
(\PUTBASEPTR . VPUTBASEPTR)
(\HILOC . VHILOC)
(\LOLOC . VLOLOC)
(\VAG2 . VVAG2)
(.COERCE.TO.SMALLPOSP. . PROG1)
(.COERCE.TO.BYTE. . PROG1)
(CONS . VCONS)
(CREATECELL . VCREATECELL)
(COPYSTRING . VCOPYSTRING)
(PTRGTP . IGREATERP)
(\RPLPTR . VPUTBASEPTR)
(CAR . V\CAR.UFN)
(CDR . V\CDR.UFN)
(CAR/CDRERR . T))
EVAL@COMPILE
(ADDTOVAR DONTCOMPILEFNS CREATEPAGES)
)
(* cons cells)
(DEFINEQ
(CONS
[LAMBDA (X Y) (* lmm "11-FEB-82 13:55")
(* use microcode UFN to get to \CONS.UFN)
((OPCODES CONS)
X Y])
(\CONS.UFN
[LAMBDA (X Y) (* bvm: " 5-Feb-85 12:13")
[COND
((ZEROP CDRCODING)
(RAID)
(PROG ((CELL (CREATECELL \LISTP)))
(replace (LISTP CAR) of CELL with X)
(replace (LISTP CDR) of CELL with Y)
(RETURN CELL]
(UNINTERRUPTABLY
(\ADDREF X)
(\ADDREF Y)
(\StatsAdd1 (fetch DTDCNTLOC of \LISTPDTD))
(.INCREMENT.ALLOCATION.COUNT. 1)
(PROG (CNS.PAGE)
[SETQ CNS.PAGE (COND
[(AND (EQ (NTYPX Y)
\LISTP)
(IGREATERP (fetch (CONSPAGE CNT) of (SETQ CNS.PAGE (fetch (POINTER PAGEBASE)
of Y)))
0)) (* Test for any cells left on page -
NTYPX rather than LISTP test for benefit of MAKEINIT)
(.MAKECONSCELL. CNS.PAGE X (IPLUS \CDR.ONPAGE (fetch (POINTER DBLWORD#)
of Y]
(T (.MAKECONSCELL. (SETQ CNS.PAGE (\NEXTCONSPAGE))
X
(COND
((NULL Y)
\CDR.NIL)
(T (IPLUS \CDR.INDIRECT (fetch (POINTER DBLWORD#)
of (.MAKECONSCELL. CNS.PAGE Y 0]
(\DELREF CNS.PAGE)
(RETURN CNS.PAGE)))])
(CAR
[LAMBDA (X) (* lmm "11-FEB-82 13:56")
((OPCODES CAR)
X])
(\CAR.UFN
[LAMBDA (X) (* lmm "18-Jul-84 00:07")
(* most cases handled in microcode -
this code also used by MAKEINIT/READSYS)
(\CALLME (QUOTE CAR))
(COND
[(LISTP X)
(COND
((ZEROP CDRCODING)
(fetch (LISTP CAR) of X))
(T (COND
((EQ (fetch CDRCODE of X)
\CDR.INDIRECT)
(fetch CARFIELD of (fetch CARFIELD of X)))
(T (fetch CARFIELD of X]
((NULL X)
NIL)
(T (SELECTQ CAR/CDRERR
(T (LISPERROR "ARG NOT LIST" X))
[(NIL CDR)
(COND
((EQ X T)
T)
((LITATOM X)
NIL)
(T (QUOTE "{car of non-list}"]
(COND
((EQ X T)
T)
((STRINGP X)
(LISPERROR "ARG NOT LIST" X))
(T (QUOTE "{car of non-list}"])
(CDR
[LAMBDA (X) (* lmm "11-FEB-82 13:56")
((OPCODES CDR)
X])
(\CDR.UFN
[LAMBDA (X) (* lmm "17-Jul-84 22:26")
(* most cases handled in microcode -
this code also used by MAKEINIT/READSYS)
(\CALLME (QUOTE CDR))
(COND
[(LISTP X)
(COND
((ZEROP CDRCODING)
(fetch (LISTP CDR) of X))
(T (PROG ((Q (fetch CDRCODE of X)))
(RETURN (COND
((EQ Q \CDR.NIL)
NIL)
((IGREATERP Q \CDR.ONPAGE)
(\ADDBASE (fetch (POINTER PAGEBASE) of X)
(LLSH (IDIFFERENCE Q \CDR.ONPAGE)
1)))
((EQ Q \CDR.INDIRECT)
(\CDR.UFN (fetch CARFIELD of X)))
(T (fetch CARFIELD of (\ADDBASE (fetch PAGEBASE of X)
(LLSH Q 1]
((NULL X)
NIL)
(T (SELECTQ CAR/CDRERR
((T CDR)
(LISPERROR "ARG NOT LIST" X))
(NIL (COND
((LITATOM X)
(GETPROPLIST X))
(T "{cdr of non-list}")))
(COND
((STRINGP X)
(LISPERROR "ARG NOT LIST" X))
(T "{cdr of non-list}"])
(RPLACA
[LAMBDA (X Y) (* lmm "11-FEB-82 13:55")
(* invoke \RPLACA.UFN)
((OPCODES RPLACA)
X Y])
(\RPLACA.UFN
[LAMBDA (X Y) (* lmm " 1-DEC-81 21:17")
(COND
[(NLISTP X)
(COND
[(NULL X) (* if X is NIL and Y is NIL ok)
(COND
(Y (LISPERROR "ATTEMPT TO RPLAC NIL" Y]
(T (LISPERROR "ARG NOT LIST" X]
(T (COND
((ZEROP CDRCODING)
(replace (LISTP CAR) of X with Y)
X)
(T (UNINTERRUPTABLY
(\DELREF (CAR X))
(\ADDREF Y)
(replace CARFIELD of (COND
((EQ (fetch CDRCODE of X)
\CDR.INDIRECT)
(fetch CARFIELD of X))
(T X))
with Y)
X)])
(RPLACD
[LAMBDA (X Y) (* lmm "11-FEB-82 13:55")
((OPCODES RPLACD)
X Y])
(\RPLACD.UFN
[LAMBDA (X Y) (* lmm "11-JAN-82 10:15")
(COND
[(NLISTP X)
(COND
[(NULL X) (* if X is NIL and Y is NIL ok)
(COND
(Y (LISPERROR "ATTEMPT TO RPLAC NIL" Y]
(T (LISPERROR "ARG NOT LIST" X]
((ZEROP CDRCODING)
(replace (LISTP CDR) of X with Y)
X)
(T (UNINTERRUPTABLY
(\DELREF (CDR X))
(\ADDREF Y)
(PROG (RP.PAGE (RP.Q (fetch CDRCODE of X)))
(COND
((EQ RP.Q \CDR.INDIRECT)
(SETQ RP.PAGE (fetch CARFIELD of X))
(CHECK (ILEQ (fetch CDRCODE of RP.PAGE)
\CDR.MAXINDIRECT)
(NEQ (fetch CDRCODE of RP.PAGE)
\CDR.INDIRECT))
(SETQ RP.PAGE (\ADDBASE (fetch PAGEBASE of RP.PAGE)
(LLSH (IDIFFERENCE (fetch CDRCODE of RP.PAGE)
\CDR.INDIRECT)
1)))
(CHECK (LISTP RP.PAGE)
(EQ 0 (fetch CDRCODE of RP.PAGE)))
(replace FULLCARFIELD of RP.PAGE with Y))
((ILEQ RP.Q \CDR.MAXINDIRECT)
(SETQ RP.PAGE (\ADDBASE (fetch PAGEBASE of X)
(LLSH (IDIFFERENCE RP.Q \CDR.INDIRECT)
1)))
(CHECK (LISTP RP.PAGE)
(EQ 0 (fetch CDRCODE of RP.PAGE)))
(replace FULLCARFIELD of RP.PAGE with Y))
((NULL Y)
(replace CDRCODE of X with \CDR.NIL))
[(EQ (SETQ RP.PAGE (fetch PAGEBASE of X))
(fetch PAGEBASE of Y)) (* New CDR on same page)
(replace CDRCODE of X with (IPLUS \CDR.ONPAGE (fetch (POINTER DBLWORD#)
of Y]
[(IGREATERP (fetch (CONSPAGE CNT) of RP.PAGE)
0) (* Room on page for cdr cell)
(replace CDRCODE of X with (IPLUS \CDR.INDIRECT (fetch (POINTER DBLWORD#)
of (.MAKECONSCELL. RP.PAGE
Y 0]
(T [replace FULLCARFIELD of X with (.MAKECONSCELL. (SETQ RP.PAGE (\NEXTCONSPAGE))
(fetch CARFIELD of X)
(IPLUS \CDR.INDIRECT
(fetch (POINTER
DBLWORD#)
of (.MAKECONSCELL.
RP.PAGE Y 0]
(replace CDRCODE of X with \CDR.INDIRECT)))
(RETURN X)))])
(DOCOLLECT
[LAMBDA (ITEM LST) (* lmm: "30-SEP-76 13:03:33")
(COND
((NLISTP LST)
(FRPLACD (SETQ LST (LIST ITEM))
LST))
(T (CDR (FRPLACD LST (CONS ITEM (CDR LST])
(\RPLCONS
[LAMBDA (LST ITEM) (* bvm: " 5-Feb-85 22:49")
(* (CDR (RPLACD LST (CONS ITEM NIL))))
(COND
[(AND (NEQ CDRCODING 0)
(LISTP LST)
(UNINTERRUPTABLY (* Have to go uninterruptable here so that someone
doesn't change the CNT field to zero out from under us)
[PROG ((CPAGE (fetch (POINTER PAGEBASE) of LST))
CELL)
(RETURN (COND
((AND (NEQ (fetch (CONSPAGE CNT) of CPAGE)
0)
(IGREATERP (fetch CDRCODE of LST)
\CDR.MAXINDIRECT))
(\ADDREF ITEM)
(\DELREF (CDR LST))
(SETQ CELL (.MAKECONSCELL. CPAGE ITEM \CDR.NIL))
(\StatsAdd1 (fetch DTDCNTLOC of \LISTPDTD))
(.INCREMENT.ALLOCATION.COUNT. 1)
(replace CDRCODE of LST with (IPLUS \CDR.ONPAGE
(fetch (POINTER DBLWORD#)
of CELL)))
CELL])]
(T (SETQ ITEM (CONS ITEM NIL)) (* Have to be careful how this part is written, or
compiler will turn it into RPLCONS !)
(RPLACD LST ITEM)
ITEM])
(ENDCOLLECT
[LAMBDA (X Y) (* lmm "21-MAR-81 13:37")
(COND
((NULL X)
Y)
(T (PROG1 (CDR X)
(RPLACD X Y])
(\INITCONSPAGE
[LAMBDA (BASE LINK) (* lmm "20-DEC-81 23:11")
(COND
((ZEROP CDRCODING)
(RAID))
(T (PROG ((J (replace NEXTCELL of BASE with 254))
CELL)
LP (COND
((NEQ J 0)
(SETQ CELL (\ADDBASE BASE J))
(replace FULLCARFIELD of CELL with NIL)
(replace CDRCODE of CELL with (SETQ J (IDIFFERENCE J 2)))
(GO LP)))
(replace (CONSPAGE CNT) of BASE with 127)
(* if LINK=NIL, stores a 0.0 This assumes that the pagebase of NIL is NIL)
(replace NEXTPAGE of BASE with (fetch (POINTER PAGE#) of LINK))
(RETURN BASE])
(\NEXTCONSPAGE
[LAMBDA NIL (* bvm: " 4-Feb-85 12:34")
(CHECK (NULL \INTERRUPTABLE))
(PROG ((N (fetch DTDNEXTPAGE of \LISTPDTD))
PG)
LP [COND
((EQ N 0)
(SETQ PG (\ALLOCMDSPAGE \LISTP))
(\INITCONSPAGE PG (\INITCONSPAGE (\ADDBASE PG WORDSPERPAGE)
NIL))
(replace DTDNEXTPAGE of \LISTPDTD with (PAGELOC PG)))
(T (SETQ PG (create POINTER
PAGE# ← N]
(COND
((IGREATERP (fetch (CONSPAGE CNT) of PG)
1)
(RETURN PG)))
(replace DTDNEXTPAGE of \LISTPDTD with (SETQ N (fetch (CONSPAGE NEXTPAGE) of PG)))
(replace (CONSPAGE NEXTPAGE) of PG with \CONSPAGE.LAST)
(* Take off free list)
(GO LP])
)
(RPAQ? CAR/CDRERR (QUOTE CDR))
(DECLARE: DONTCOPY
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS CAR/CDRERR)
)
(* FOLLOWING DEFINITIONS EXPORTED)
[DECLARE: EVAL@COMPILE
(BLOCKRECORD LISTP ((CAR POINTER)
(CDR POINTER))
(CREATE (CREATECELL \LISTP)) (* FOLLOWING ARE CDR-CODE FIELDS)
(BLOCKRECORD LISTP ((CDRCODE BYTE)
(CARFIELD XPOINTER)))
[ACCESSFNS LISTP ((FULLCARFIELD NIL (\PUTBASEPTR DATUM 0 NEWVALUE]
(* because replace of XPOINTER is slow, the CAR field
is stored with PUTBASEPTR, even though that smashes the
hi byte)
)
(BLOCKRECORD CONSPAGE ((CNT BYTE)
(NEXTCELL BYTE)
(NEXTPAGE WORD)))
]
(RPAQQ CONSCONSTANTS (\CDR.ONPAGE \CDR.NIL \CDR.INDIRECT \CDR.MAXINDIRECT \CONSPAGE.LAST))
(DECLARE: EVAL@COMPILE
(RPAQQ \CDR.ONPAGE 128)
(RPAQQ \CDR.NIL 128)
(RPAQQ \CDR.INDIRECT 0)
(RPAQQ \CDR.MAXINDIRECT 127)
(RPAQQ \CONSPAGE.LAST 65535)
(CONSTANTS \CDR.ONPAGE \CDR.NIL \CDR.INDIRECT \CDR.MAXINDIRECT \CONSPAGE.LAST)
)
(* END EXPORTED DEFINITIONS)
(DECLARE: EVAL@COMPILE
(PUTPROPS .MAKECONSCELL. MACRO (OPENLAMBDA (PAGE A D)
(PROG [(.MK.NEWCELL (\ADDBASE PAGE (fetch (CONSPAGE
NEXTCELL)
of PAGE]
(CHECK (NEQ (fetch (CONSPAGE CNT) of PAGE)
0)
(EVENP (fetch (CONSPAGE NEXTCELL)
of PAGE)))
(replace (CONSPAGE NEXTCELL) of PAGE
with (fetch (LISTP CDRCODE) of .MK.NEWCELL))
(CHECK (EVENP (fetch (CONSPAGE NEXTCELL)
of PAGE)))
(add (fetch (CONSPAGE CNT) of PAGE)
-1)
(replace (LISTP FULLCARFIELD) of .MK.NEWCELL
with A)
(replace (LISTP CDRCODE) of .MK.NEWCELL
with D)
(RETURN .MK.NEWCELL))))
)
(ADDTOVAR INEWCOMS (FNS \CONS.UFN \INITCONSPAGE \NEXTCONSPAGE))
(ADDTOVAR EXPANDMACROFNS .MAKECONSCELL.)
)
(* testing out CONSes)
(DEFINEQ
(CHECKCONSPAGES
[LAMBDA NIL (* bvm: "29-Jan-85 22:51")
(COND
((ZEROP CDRCODING)
NIL)
(T [for (CPAGE ←(create POINTER
PAGE# ←(fetch DTDNEXTPAGE of \LISTPDTD)))
do (COND
((NULL CPAGE) (* End of free list)
(RETURN))
((NEQ (NTYPX CPAGE)
\LISTP)
(* Free list not pointing at a cons page. Test is not for LISTP because LISTP is formally defined to be false for
list page bases)
(HELP CPAGE))
(T (SETQ CPAGE (create POINTER
PAGE# ←(fetch (CONSPAGE NEXTPAGE) of CPAGE]
(\MAPMDS (QUOTE LISTP)
(FUNCTION \CHECKCONSPAGE])
(\CHECKCONSPAGE
[LAMBDA (PN) (* bvm: "27-Jan-85 14:52")
(* check if page PN is ok)
(PROG ((PTR (create POINTER
PAGE# ← PN))
NXT CNT)
(SETQ CNT (fetch (CONSPAGE CNT) of PTR))
(!CHECK (EVENP (SETQ NXT (fetch (CONSPAGE NEXTCELL) of PTR))
WORDSPERCELL))
LP (COND
((IGREATERP CNT 0)
(!CHECK (AND (NEQ NXT 0)
(EVENP (SETQ NXT (fetch (LISTP CDRCODE) of (\ADDBASE PTR NXT)))
WORDSPERCELL)))
(add CNT -1)
(GO LP)))
(!CHECK (EQ NXT 0])
)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS !CHECK MACRO [(X)
(OR X (RAID (QUOTE X])
)
)
(* other random stuff for makeinit)
(DEFINEQ
(MAKEINITFIRST
[LAMBDA NIL (* bvm: "29-MAR-83 16:35")
(CREATEMDSTYPETABLE)
(INITDATATYPES)
(PREINITARRAYS)
(INITATOMS)
(INITDATATYPENAMES)
(INITUFNTABLE)
(INITGC)
(\NEWPAGE \InterfacePage NIL T])
(MAKEINITLAST
[LAMBDA (VERSIONS) (* bvm: "14-Jan-85 14:15")
(SETUPSTACK T)
(MAKEINITBFS)
(PROGN (* fold in property list and values gathered from boot
files)
[SELECTQ (SYSTEMTYPE)
[(D ALTO)
[LOCAL (MAPHASH MKI.PLHA (FUNCTION (LAMBDA (P A)
(SETPROPLIST A (COPY P]
(LOCAL (MAPHASH MKI.TVHA (FUNCTION (LAMBDA (V A)
(SETTOPVAL A (COPY (LOCAL (CDR V]
(PROG (AL GAG)
(* the reason this is set up this way is because there is a bug in Interlisp-10 suchthat if a garbage collection
happens in the middle of a MAPHASH, some of the values in the hash array may be missed because the garbage collector
has moved stuff around and rehashed the data in the array. Thus we are careful to set things up so that no garbage
collection happens)
[ALLOCAL (PROGN [MINFS (IMAX (MINFS)
(ITIMES 2 (ARRAYSIZE (CAR MKI.PLHA)))
(ARRAYSIZE (CAR MKI.TVHA]
(RECLAIM)
(SETQ GAG (GCGAG
"[***** GARBAGE COLLECTION - ERROR ******]"))
[MAPHASH MKI.PLHA (FUNCTION (LAMBDA (P A)
(push AL (CONS A P]
(SETQ GAG (GCGAG GAG]
[LOCAL (MAPC AL (FUNCTION (LAMBDA (X)
(SETPROPLIST (CAR X)
(COPY (CDR X]
(ALLOCAL (PROGN (SETQ AL)
(RECLAIM)
(SETQ GAG (GCGAG GAG))
[MAPHASH MKI.TVHA (FUNCTION (LAMBDA (V A)
(push AL (RPLACA V A]
(GCGAG GAG)))
(LOCAL (MAPC AL (FUNCTION (LAMBDA (X)
(SETTOPVAL (CAR X)
(COPY (CDR X]
(* set most initial variables)
)
(PROG ((AFL (FILEARRAYBASE))) (* put output on a double page boundary -
output at least one page)
[LOCAL (BOUTZEROS (IDIFFERENCE (TIMES 2 BYTESPERPAGE)
(UNFOLD (IMOD (\LOLOC AFL)
(TIMES 2 WORDSPERPAGE))
BYTESPERWORD]
(SETQ MKI.CODELASTPAGE (PAGELOC (FILEARRAYBASE)))
(* now we can update the string/array space freelist to point beyond the code area -
We call POSTINITARRAYS with (a) pointer to word after end of compiled code, (b) page number of beginning of compiled
code, and (c) page number after compiled code)
(POSTINITARRAYS AFL (IPLUS \FirstArrayPage MKI.CODESTARTOFFSET)
MKI.CODELASTPAGE))
[MAPC (ALLOCAL (APPEND INITVALUES INITPTRS))
(FUNCTION (LAMBDA (X) (* make sure atoms exist for initial atoms)
(\ATOMVALINDEX (LOCAL (CAR X]
[for X in INITVALUES as A in MKI.VALUES
do (SETQ A (LOCAL (EVALV A)))
(SETTOPVAL (LOCAL (CAR X))
(COND
([ALLOCAL (OR (EQ A T)
(EQ A NIL)
(AND (FIXP A)
(IGEQ A -200000Q)
(ILEQ A 177777Q]
(COPY A))
(T (SHOULDNT]
[for X in INITPTRS as A in MKI.PTRS do (SETTOPVAL (LOCAL (CAR X))
(LOCAL (EVALV A]
(for X in LOCKEDVARS
do (OR (GETHASH X MKI.ATOMARRAY)
(printout T "***Note: Locked var " X " does not exist" T))
(\LOCKVAR X))
(SETUPPAGEMAP)
(DUMPINITPAGES (IPLUS \FirstArrayPage MKI.CODESTARTOFFSET)
MKI.CODELASTPAGE VERSIONS])
(\COPY
[LAMBDA (X) (* lmm " 2-NOV-81 18:22")
(* Prints X into the MAKEINIT / READSYS system)
(SELECTQ (LOCAL (TYPENAME X))
(LITATOM (UNLESSRDSYS (MKI.ATOM X)
(VATOMNUMBER X T)))
(LISTP (PROG [(R (LOCAL (REVERSE X)))
(V (\COPY (LOCAL (CDR (LOCAL (LAST X]
LP (COND
((LOCAL (LISTP R))
(SETQ V (CONS (\COPY (LOCAL (CAR R)))
V))
(SETQ R (LOCAL (CDR R)))
(GO LP)))
(RETURN V)))
((FIXP SMALLP)
(PROG (V)
[COND
[(LOCAL (IGREATERP 0 X))
(* negative)
(COND
((LOCAL (IGREATERP X -65537))
(* small neg)
(RETURN (\ADDBASE \SMALLNEGSPACE (LOCAL (LOGAND X 65535]
((LOCAL (ILESSP X 65536))
(* small pos)
(RETURN (\ADDBASE \SMALLPOSPSPACE X]
(* need to create a boxed integer)
(SETQ V (CREATECELL \FIXP))
(\PUTBASE V 0 (LOGOR (COND
((IGREATERP 0 X)
32768)
(T 0))
(LOGAND (LRSH X 16)
32767)))
(\PUTBASE V 1 (LOGAND X 65535))
(RETURN V)))
(STRINGP (COPYSTRING X))
(FLOATP (PROG ((VAL (CREATECELL \FLOATP)))
(SELECTQ (SYSTEMTYPE)
[(ALTO D)
(\PUTBASE VAL 0 (LOCAL (\GETBASE X 0)))
(\PUTBASE VAL 1 (LOCAL (\GETBASE X 1]
(MKI.IEEE X VAL))
(RETURN VAL)))
(ERROR X (QUOTE (can't be copied to remote file])
(\UNCOPY
[LAMBDA (X) (* bvm: "15-Feb-85 18:02")
(SELECTC (NTYPX X)
[\SMALLP (COND
((EQ (\HILOC X)
\SmallPosHi) (* This test used to be SMALLPOSP until its definition
changed to test (IGREATERP X 0), which doesn't work
renamed)
(\LOLOC X))
(T (IPLUS (\LOLOC X)
-65536]
(\FIXP (* INTEGER)
(IPLUS (LLSH (\GETBASE X 0)
16)
(\GETBASE X 1)))
(\LITATOM (VATOM (\LOLOC X)))
(\STRINGP (PROG ((PTR (ffetch (STRINGP BASE) of X))
(OFFST (ffetch (STRINGP OFFST) of X))
(LENGTH (ffetch (STRINGP LENGTH) of X))
(I 1)
STR) (* Use ffetch to avoid bogus DTEST's in the renamed
version)
(SETQ STR (ALLOCSTRING LENGTH))
(FRPTQ LENGTH [LOCAL (RPLSTRING STR I (LOCAL (FCHARACTER (\GETBASEBYTE
PTR OFFST]
(add I 1)
(add OFFST 1))
(RETURN STR)))
[\LISTP (COND
[(LISTP X)
(LOCAL (CONS (\UNCOPY (CAR X))
(\UNCOPY (CDR X]
(T (* Redundant test in case is list page header)
(LOCAL (VTYPEDPOINTER (QUOTE LISTP)
X]
(0 (LOCAL (VTYPEDPOINTER NIL X)))
(LOCAL (VTYPEDPOINTER (TYPENAME X)
X])
)
(DECLARE: DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(PUTPROPS LOCAL MACRO ((X)
X))
(PUTPROPS ALLOCAL MACRO ((X)
X))
)
(* END EXPORTED DEFINITIONS)
(ADDTOVAR MKI.SUBFNS (CHECK . *)
(RAID . HELP)
(UNINTERRUPTABLY
. PROGN)
(\StatsAdd1 . *)
(EVQ . I.\COPY)
(COPY . I.\COPY))
(ADDTOVAR RD.SUBFNS (CHECK . *)
(RAID . HELP)
(UNINTERRUPTABLY
. PROGN)
(\StatsAdd1 . *)
(EVQ . V\COPY)
(COPY . V\COPY)
(1ST . V\UNCOPY))
(ADDTOVAR INEWCOMS (FNS MAKEINITFIRST \COPY MAKEINITLAST))
EVAL@COMPILE
(ADDTOVAR DONTCOMPILEFNS MAKEINITFIRST \COPY MAKEINITLAST \UNCOPY)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS)
)
(PUTPROPS LLNEW COPYRIGHT ("Xerox Corporation" 1981 1982 1983 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (3770 9702 (\ADDBASE 3780 . 4494) (\GETBASE 4496 . 4733) (\PUTBASE 4735 . 5000) (
\PUTBASE.UFN 5002 . 5271) (\PUTBASEPTR.UFN 5273 . 5584) (\PUTBITS.UFN 5586 . 6131) (\GETBASEBYTE 6133
. 6631) (\PUTBASEBYTE 6633 . 7276) (\GETBASEPTR 7278 . 7610) (\PUTBASEPTR 7612 . 7919) (\HILOC 7921
. 8089) (\LOLOC 8091 . 8259) (\VAG2 8261 . 8620) (EQ 8622 . 8784) (\RPLPTR 8786 . 9160) (\RPLPTR.UFN
9162 . 9700)) (9703 10292 (LOC 9713 . 9980) (VAG 9982 . 10290)) (10293 10994 (CREATEPAGES 10303 .
10755) (\NEW4PAGE 10757 . 10992)) (14052 24761 (CONS 14062 . 14304) (\CONS.UFN 14306 . 15595) (CAR
15597 . 15724) (\CAR.UFN 15726 . 16639) (CDR 16641 . 16768) (\CDR.UFN 16770 . 17905) (RPLACA 17907 .
18130) (\RPLACA.UFN 18132 . 18825) (RPLACD 18827 . 18962) (\RPLACD.UFN 18964 . 21423) (DOCOLLECT 21425
. 21641) (\RPLCONS 21643 . 22943) (ENDCOLLECT 22945 . 23103) (\INITCONSPAGE 23105 . 23813) (
\NEXTCONSPAGE 23815 . 24759)) (26987 28501 (CHECKCONSPAGES 26997 . 27773) (\CHECKCONSPAGE 27775 .
28499)) (28665 36011 (MAKEINITFIRST 28675 . 28959) (MAKEINITLAST 28961 . 32727) (\COPY 32729 . 34397)
(\UNCOPY 34399 . 36009)))))
STOP