(FILECREATED "22-JUN-83 15:12:46" {PHYLUM}<LISPCORE>SOURCES>LLNEW.;23 105524Q
changes to: (FNS MAKEINITLAST)
previous date: "29-MAR-83 16:42:01" {PHYLUM}<LISPCORE>SOURCES>LLNEW.;22)
(* 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 \MAPMDS)
(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) (* lmm "11-FEB-83 07:37")
(* usually done in microcode -
this def used by MAKEINIT too)
(\PUTBASE PTR (LRSH DISP 1)
(SELECTQ (LOGAND DISP 1)
[0 (create WORD
using (\GETBASE PTR (LRSH DISP 1))
HIBYTE ←(SETQ BYTE (.COERCE.TO.BYTE. BYTE]
(create WORD using (\GETBASE PTR (LRSH DISP 1))
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) (* lmm "11-FEB-83 07:37")
(* case where H is byte and L is smallposp MUST be handled in microcode)
(\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)
10Q)
(LRSH (\LOLOC DATUM)
10Q)))
(WORDINPAGE (LOGAND (\LOLOC DATUM)
377Q))
(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)
177400Q]
(CREATE (\VAG2 (LRSH PAGE# 10Q)
(LLSH (LOGAND PAGE# 377Q)
10Q))))
(ACCESSFNS WORD ((HIBYTE (LRSH DATUM 10Q))
(LOBYTE (LOGAND DATUM 377Q)))
(CREATE (IPLUS (LLSH HIBYTE 10Q)
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. MACRO ((X)
(COND
([IGREATERP 0 (SETQ X (\DTEST X (QUOTE SMALLP]
(\ILLEGAL.ARG X))
(T X))))
(PUTPROPS .COERCE.TO.BYTE. MACRO ((X)
(COND
((OR [IGREATERP 0 (SETQ X (\DTEST X (QUOTE SMALLP]
(IGREATERP X 377Q))
(\ILLEGAL.ARG X))
(T 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 200Q)
(RPAQQ \CDR.NIL 200Q)
(RPAQQ \CDR.INDIRECT 0)
(RPAQQ \CDR.MAXINDIRECT 177Q)
(RPAQQ \CONSPAGE.LAST 177777Q)
(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])
(\MAPMDS
[LAMBDA (TYPE FN) (* lmm " 2-NOV-81 18:27")
(PROG ((PTR (create POINTER
PAGE# ← \FirstMDSPage))
TYP)
[AND TYPE (OR (FIXP TYPE)
(SETQ TYPE (\TYPENUMBERFROMNAME TYPE]
(* walk thru all MDS pages looking for pages of type TYPE)
LP1 [SELECTC (SETQ TYP (NTYPX PTR))
((LIST 0 \SMALLP)
(* reached end of allocated pages or smallposp pages)
(RETURN))
(COND
((OR (NULL TYPE)
(EQ TYP TYPE))
(SPREADAPPLY* FN (fetch (POINTER PAGE#) of PTR]
(SETQ PTR (\ADDBASE PTR \MDSIncrement))
(GO LP1])
)
(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 "22-JUN-83 15: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 page boundary -
output at least one page)
(SETQ MKI.CODELASTPAGE (PAGELOC AFL))
[LOCAL (BOUTZEROS (IDIFFERENCE 1000Q (LLSH (LOGAND (\LOLOC AFL)
377Q)
1]
(* 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 10Q)
MKI.CODESTARTOFFSET)))
[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 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" 3675Q 3676Q 3677Q))
(DECLARE: DONTCOPY
(FILEMAP (NIL (7153Q 22045Q (\ADDBASE 7165Q . 10477Q) (\GETBASE 10501Q . 11056Q) (\PUTBASE 11060Q .
11471Q) (\PUTBASE.UFN 11473Q . 12110Q) (\PUTBASEPTR.UFN 12112Q . 12601Q) (\PUTBITS.UFN 12603Q . 13644Q
) (\GETBASEBYTE 13646Q . 14442Q) (\PUTBASEBYTE 14444Q . 15424Q) (\GETBASEPTR 15426Q . 16142Q) (
\PUTBASEPTR 16144Q . 16627Q) (\HILOC 16631Q . 17101Q) (\LOLOC 17103Q . 17353Q) (\VAG2 17355Q . 17753Q)
(EQ 17755Q . 20217Q) (\RPLPTR 20221Q . 21007Q) (\RPLPTR.UFN 21011Q . 22043Q)) (22046Q 23163Q (LOC
22060Q . 22473Q) (VAG 22475Q . 23161Q)) (23164Q 24461Q (CREATEPAGES 23176Q . 24102Q) (\NEW4PAGE 24104Q
. 24457Q)) (32257Q 55302Q (CONS 32271Q . 32653Q) (\CONS.UFN 32655Q . 35167Q) (CAR 35171Q . 35370Q) (
\CAR.UFN 35372Q . 36572Q) (CDR 36574Q . 36773Q) (\CDR.UFN 36775Q . 40610Q) (RPLACA 40612Q . 41151Q) (
\RPLACA.UFN 41153Q . 42440Q) (RPLACD 42442Q . 42651Q) (\RPLACD.UFN 42653Q . 47506Q) (DOCOLLECT 47510Q
. 50040Q) (\RPLCONS 50042Q . 51744Q) (ENDCOLLECT 51746Q . 52204Q) (\INITCONSPAGE 52206Q . 53512Q) (
\NEXTCONSPAGE 53514Q . 55300Q)) (61633Q 66610Q (CHECKCONSPAGES 61645Q . 62371Q) (\CHECKCONSPAGE 62373Q
. 64150Q) (CHECKNEXTLST 64152Q . 64633Q) (INNEXTLST 64635Q . 65313Q) (\MAPMDS 65315Q . 66606Q)) (
67012Q 103724Q (MAKEINITFIRST 67024Q . 67460Q) (MAKEINITLAST 67462Q . 76343Q) (\COPY 76345Q . 101551Q)
(\UNCOPY 101553Q . 103722Q)))))
STOP