(FILECREATED "31-Dec-83 23:53:26" {PHYLUM}<LISPCORE>SOURCES>LLNEW.;28 35140
changes to: (FNS \VAG2 \PUTBASEBYTE)
(MACROS .COERCE.TO.SMALLPOSP. .COERCE.TO.BYTE.)
previous date: " 8-SEP-83 07:19:44" {PHYLUM}<LISPCORE>SOURCES>LLNEW.;27)
(* Copyright (c) 1981, 1982, 1983 by Xerox Corporation)
(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)))
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)
(VARS (CAR/CDRERR))
(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 CHECKNEXTLST INNEXTLST)
(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) (* lmm " 2-NOV-81 18:34")
(* usually done in microcode; this def. uses only \GETBASE and arithmetic -
used by MAKEINIT too)
(COND
[(ZEROP (LOGAND N 1))
(fetch HIBYTE (\GETBASE PTR (LRSH N 1]
(T (fetch LOBYTE of (\GETBASE PTR (LRSH N 1])
(\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
((EQ \SmallPosHi (\HILOC X))
X)
(T (\ILLEGAL.ARG X)))))
(PUTPROPS .COERCE.TO.BYTE. DMACRO (OPENLAMBDA (X)
(COND
((AND (EQ \SmallPosHi (\HILOC 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))
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) (* lmm "11-FEB-82 13:45")
[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
((NULL Y)
(.MAKECONSCELL. (\NEXTCONSPAGE)
X \CDR.NIL))
[(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
(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 "24-MAY-82 21:16")
(* most cases handled in microcode -
this code also used by MAKEINIT/READSYS)
(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)
(CAR/CDRERR (LISPERROR "ARG NOT LIST" X))
((EQ X T)
T)
((LITATOM X)
NIL)
(T (QUOTE "{car of non-list}"])
(CDR
[LAMBDA (X) (* lmm "11-FEB-82 13:56")
((OPCODES CDR)
X])
(\CDR.UFN
[LAMBDA (X) (* lmm "24-MAY-82 21:19")
(* most cases handled in microcode -
this code also used by MAKEINIT/READSYS)
(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)
(CAR/CDRERR (LISPERROR "ARG NOT LIST" X))
((LITATOM X)
(GETPROPLIST 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) (* lmm "11-JAN-82 10:15")
(* (CDR (RPLACD LST (CONS ITEM NIL))))
(COND
[(AND (NEQ CDRCODING 0)
(LISTP LST)
(NEQ (fetch (CONSPAGE CNT) of (fetch (POINTER PAGEBASE) of LST))
0)
(IGREATERP (fetch CDRCODE of LST)
\CDR.MAXINDIRECT))
(UNINTERRUPTABLY
(\ADDREF ITEM)
(\DELREF (CDR LST))
(PROG ((CELL (.MAKECONSCELL. (fetch (POINTER PAGEBASE) of LST)
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)))
(RETURN CELL)))]
(T (* (CDR (RPLACD LST (CONS ITEM LST))))
(SETQ ITEM (CONS ITEM NIL))
(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 (* lmm "11-JAN-82 10:11")
(PROG (PG N)
LP [COND
((ZEROP (SETQ N (fetch DTDNEXTPAGE of \LISTPDTD)))
(SETQ PG (\ALLOCMDSPAGE \LISTP))
(\INITCONSPAGE PG (\INITCONSPAGE (\ADDBASE PG WORDSPERPAGE)
NIL))
(replace DTDNEXTPAGE of \LISTPDTD with (SETQ N (PAGELOC PG]
(COND
((IGREATERP [SETQ N (fetch (CONSPAGE CNT) of (SETQ PG (create POINTER
PAGE# ← N]
1)
(RETURN PG)))
(SETQ N (fetch (CONSPAGE NEXTPAGE) of PG))
(replace (CONSPAGE NEXTPAGE) of PG with \CONSPAGE.LAST)
(* Take off free list)
(replace DTDNEXTPAGE of \LISTPDTD with N)
(GO LP])
)
(RPAQQ CAR/CDRERR NIL)
(DECLARE: DONTCOPY
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR 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 (NOT (ZEROP (fetch (CONSPAGE CNT) of PAGE)))
(ZEROP (LOGAND (fetch (CONSPAGE NEXTCELL) of PAGE)
1)))
(replace (CONSPAGE NEXTCELL) of PAGE with (fetch (LISTP CDRCODE) of .MK.NEWCELL))
(CHECK (ZEROP (LOGAND (fetch (CONSPAGE NEXTCELL) of PAGE)
1)))
(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))))
)
(* for MAKEINIT)
(ADDTOVAR INEWCOMS (FNS \CONS.UFN \INITCONSPAGE \NEXTCONSPAGE))
(ADDTOVAR EXPANDMACROFNS .MAKECONSCELL.)
)
(* testing out CONSes)
(DEFINEQ
(CHECKCONSPAGES
[LAMBDA NIL (* lmm "11-JAN-82 10:11")
(COND
((ZEROP CDRCODING)
NIL)
(T (CHECKNEXTLST (create POINTER
PAGE# ←(fetch DTDNEXTPAGE of \LISTPDTD))
\LastMDSPage)
(\MAPMDS (QUOTE LISTP)
(FUNCTION \CHECKCONSPAGE])
(\CHECKCONSPAGE
[LAMBDA (PN) (* lmm "11-JAN-82 10:12")
(* check if page PN is ok)
(PROG ((PTR (create POINTER
PAGE# ← PN))
NXT CNT)
(!CHECK (OR (EQ \CONSPAGE.LAST (SETQ NXT (fetch (CONSPAGE NEXTPAGE) of PTR)))
(INNEXTLST (create POINTER
PAGE# ←(fetch DTDNEXTPAGE of \LISTPDTD))
PTR \LastMDSPage)))
(SETQ CNT (fetch (CONSPAGE CNT) of PTR))
[!CHECK (ZEROP (LOGAND 1 (SETQ NXT (fetch (CONSPAGE NEXTCELL) of PTR]
LP (COND
((IGREATERP CNT 0)
[!CHECK (AND (NOT (ZEROP NXT))
(ZEROP (LOGAND 1 (SETQ NXT (fetch (LISTP CDRCODE) of (\ADDBASE PTR NXT]
(add CNT -1)
(GO LP)))
(!CHECK (ZEROP CNT])
(CHECKNEXTLST
[LAMBDA (NXTPG N) (* lmm " 8-MAY-81 10:28")
(COND
((ILEQ N 0)
(HELP))
((NULL NXTPG)
NIL)
((NLISTP NXTPG)
(HELP))
(T (CHECKNEXTLST (create POINTER
PAGE# ←(fetch (CONSPAGE NEXTPAGE) of NXTPG))
(SUB1 N])
(INNEXTLST
[LAMBDA (NXTPG PTR N) (* lmm " 8-MAY-81 10:18")
(COND
((ILEQ N 0)
(HELP))
((NULL NXTPG)
NIL)
((EQ PTR NXTPG)
T)
(T (INNEXTLST (create POINTER
PAGE# ←(fetch (CONSPAGE NEXTPAGE) of NXTPG))
PTR
(SUB1 N])
)
(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 NIL (* lmm " 7-SEP-83 16:04")
(SETUPSTACK T)
(MAKEINITBFS)
(\MAKEMDSENTRY (fetch (POINTER PAGE#) of \MISCSTATS)
\FIXP) (* Make \MISCSTATS look like a page of FIXP's)
(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 (UNFOLD (IDIFFERENCE (CEIL (\LOLOC AFL)
(TIMES 2 WORDSPERPAGE))
(\LOLOC AFL))
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, and (b) page number of beginning of
compiled code)
(POSTINITARRAYS AFL (IPLUS (LLSH \ARRAYspace 8)
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 -65536)
(ILEQ A 65535]
(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 MKI.CODESTARTOFFSET MKI.CODELASTPAGE])
(\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) (* lmm " 2-NOV-81 18:23")
(PROG ((TYP (NTYPX X)))
(RETURN (COND
[(EQ TYP \SMALLP)
(COND
((SMALLPOSP X)
(\LOLOC X))
(T (IPLUS (\LOLOC X)
-65536]
((EQ TYP \FIXP)
(* INTEGER)
(IPLUS (LLSH (\GETBASE X 0)
16)
(\GETBASE X 1)))
((EQ TYP \LITATOM)
(VATOM (\LOLOC X)))
((EQ TYP \STRINGP)
(PROG (STR (OFFST (\GETBASE X 3))
(I 1)
(PTR (\GETBASEPTR X 0))
(LENGTH (\GETBASE X 2)))
(SETQ STR (ALLOCSTRING LENGTH))
(FRPTQ LENGTH [LOCAL (RPLSTRING STR I (LOCAL (FCHARACTER (\GETBASEBYTE
PTR OFFST]
(add I 1)
(add OFFST 1))
(RETURN STR)))
[(EQ TYP \LISTP)
(LOCAL (CONS (\UNCOPY (CAR X))
(\UNCOPY (CDR X]
[(ZEROP TYP)
(LOCAL (LIST (QUOTE #)
(\HILOC X)
(\LOLOC X]
(T (LOCAL (LIST (TYPENAME X)
(\HILOC X)
(\LOLOC 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 . T)
)
(PUTPROPS LLNEW COPYRIGHT ("Xerox Corporation" 1981 1982 1983))
(DECLARE: DONTCOPY
(FILEMAP (NIL (3748 9562 (\ADDBASE 3758 . 4472) (\GETBASE 4474 . 4711) (\PUTBASE 4713 . 4978) (
\PUTBASE.UFN 4980 . 5249) (\PUTBASEPTR.UFN 5251 . 5562) (\PUTBITS.UFN 5564 . 6109) (\GETBASEBYTE 6111
. 6491) (\PUTBASEBYTE 6493 . 7136) (\GETBASEPTR 7138 . 7470) (\PUTBASEPTR 7472 . 7779) (\HILOC 7781
. 7949) (\LOLOC 7951 . 8119) (\VAG2 8121 . 8480) (EQ 8482 . 8644) (\RPLPTR 8646 . 9020) (\RPLPTR.UFN
9022 . 9560)) (9563 10152 (LOC 9573 . 9840) (VAG 9842 . 10150)) (10153 10854 (CREATEPAGES 10163 .
10615) (\NEW4PAGE 10617 . 10852)) (13744 23491 (CONS 13754 . 13996) (\CONS.UFN 13998 . 15224) (CAR
15226 . 15353) (\CAR.UFN 15355 . 15995) (CDR 15997 . 16124) (\CDR.UFN 16126 . 17033) (RPLACA 17035 .
17258) (\RPLACA.UFN 17260 . 17953) (RPLACD 17955 . 18090) (\RPLACD.UFN 18092 . 20551) (DOCOLLECT 20553
. 20769) (\RPLCONS 20771 . 21733) (ENDCOLLECT 21735 . 21893) (\INITCONSPAGE 21895 . 22603) (
\NEXTCONSPAGE 22605 . 23489)) (25599 27441 (CHECKCONSPAGES 25609 . 25949) (\CHECKCONSPAGE 25951 .
26828) (CHECKNEXTLST 26830 . 27135) (INNEXTLST 27137 . 27439)) (27575 34260 (MAKEINITFIRST 27585 .
27869) (MAKEINITLAST 27871 . 31459) (\COPY 31461 . 33129) (\UNCOPY 33131 . 34258)))))
STOP