(FILECREATED " 5-Nov-85 11:23:56" {ERIS}<LISPCORE>SOURCES>LLSTK.;14 60305
changes to: (FNS \CLEANUP.STACKFULL STACK.FULL.WARNING \FREESTACKBLOCK)
(VARS LLSTKCOMS)
previous date: " 8-Jun-85 22:48:59" {ERIS}<LISPCORE>SOURCES>LLSTK.;10)
(* Copyright (c) 1982, 1983, 1984, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT LLSTKCOMS)
(RPAQQ LLSTKCOMS [(DECLARE: DONTCOPY (EXPORT (RECORDS BF FX FSB STK)
(CONSTANTS \#ALINK.OFFSET)
(GLOBALVARS \PENDINGINTERRUPT \KBDSTACKBASE
\MISCSTACKBASE \STACKOVERFLOW)
(MACROS \MYALINK ADDSTACKBASE STACKADDBASE
STACKGETBASE STACKGETBASEPTR STACKPUTBASE
STACKPUTBASEPTR \MISCAPPLY*)
(RECORDS STACKP)
(CONSTANTS * STACKTYPES)
(CONSTANTS \StackAreaSize (\InitStackSize
(ITIMES \StackAreaSize 12)))
(CONSTANTS \MAXSAFEUSECOUNT)
(RECORDS NAMETABLESLOT FVARSLOT PVARSLOT STKTEMPSLOT)
(CONSTANTS \NT.IVAR \NT.PVAR \NT.FVAR))
(RECORDS STACKCELL))
(* FOR LAMBDA* FUNCTIONS)
(FNS \MYARGCOUNT \ARG0 \SETARG0)
(FNS \HARDRETURN \DOHARDRETURN \DOGC1 \DOGC \DOHARDRETURN1 \DOSTACKOVERFLOW \MOVEFRAME
\INCUSECOUNT \DECUSECOUNT \MAKESTACKP \SMASHLINK \FREESTACKBLOCK \EXTENDSTACK
\SLOWRETURN \COPY.N.UFN \POP.N.UFN \STORE.N.UFN)
(FNS \GCSCANSTACK)
(FNS CLEARSTK HARDRESET RELSTK RELSTKP)
(FNS SETUPSTACK \SETUPSTACK1 \MAKEFRAME \RESETSTACK \RESETSTACK0 \SETUPGUARDBLOCK
\MAKEFREEBLOCK \REPEATEDLYEVALQT \DUMMYKEYHANDLER \DUMMYTELERAID \CAUSEINTERRUPT
\CONTEXTAPPLY \INTERRUPTFRAME \INTERRUPTED \CODEFORTFRAME \DOMISCAPPLY \DOMISCAPPLY1)
(INITVARS (STACKTESTING T))
(COMS (* Stack overflow handler)
(FNS \DOSTACKFULLINTERRUPT STACK.FULL.WARNING \CLEANUP.STACKFULL)
(INITVARS (\PENDINGINTERRUPT)
(\STACKOVERFLOW)
(AUTOHARDRESETFLG T))
(ADDVARS (RESETFORMS (SETQ \STACKOVERFLOW)))
(GLOBALVARS AUTOHARDRESETFLG))
(DECLARE: DONTCOPY
(ADDVARS [INEWCOMS (FNS SETUPSTACK \SETUPSTACK1 \SETUPGUARDBLOCK \MAKEFREEBLOCK)
(ALLOCAL (ADDVARS (LOCKEDFNS \RESETSTACK0 \MAKEFRAME
\SETUPSTACK1 \MAKEFREEBLOCK
\FAULTHANDLER \KEYHANDLER
\DUMMYKEYHANDLER \DOTELERAID
\DUMMYTELERAID \DOHARDRETURN \DOGC
\CAUSEINTERRUPT \INTERRUPTFRAME
\CODEFORTFRAME \DOSTACKOVERFLOW
\UNLOCKPAGES \DOMISCAPPLY)
(LOCKEDVARS \InterfacePage \DEFSPACE
\STACKSPACE \KBDSTACKBASE
\MISCSTACKBASE]
(EXPANDMACROFNS ADDSTACKBASE STACKADDBASE))
EVAL@COMPILE
(ADDVARS (DONTCOMPILEFNS SETUPSTACK)))
(LOCALVARS . T)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA \INTERRUPTFRAME])
(DECLARE: DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
[DECLARE: EVAL@COMPILE
(ACCESSFNS BF ((BFBLOCK (ADDSTACKBASE DATUM))) (* basic frame pointer)
(BLOCKRECORD BFBLOCK ((FLAGS BITS 3)
(NIL BITS 3)
(RESIDUAL FLAG)
(PADDING BITS 1)
(USECNT BITS 8)
(IVAR WORD)))
(TYPE? (IEQ (fetch (BF FLAGS) of DATUM)
\STK.BF))
[ACCESSFNS BF ((NARGS (IDIFFERENCE (FOLDLO (IDIFFERENCE DATUM
(fetch
(BF IVAR)
of DATUM))
WORDSPERCELL)
(fetch (BF PADDING) of DATUM)))
[SIZE (IPLUS 2 (IDIFFERENCE DATUM (fetch (BF IVAR) of DATUM]
(CHECKED (AND (type? BF DATUM)
(for I from (fetch (BF IVAR) of DATUM)
to (IDIFFERENCE DATUM 2) by 2
always (IEQ \STK.NOTFLAG (fetch (BF FLAGS)
of I])
(ACCESSFNS FX ((FXBLOCK (ADDSTACKBASE DATUM))) (* frame extension index)
(BLOCKRECORD FXBLOCK ((FLAGS BITS 3)
(FAST FLAG)
(NIL FLAG)
(INCALL FLAG)
(VALIDNAMETABLE FLAG)
(NOPUSH FLAG)
(USECNT BITS 8)
(#ALINK WORD)
(FNHEADLO WORD)
(FNHEADHI1 BYTE)
(FNHEADHI2 BYTE)
(NEXTBLOCK WORD)
(PC WORD)
(NAMETABLO WORD)
(NAMETABHI1 BYTE)
(NAMETABHI2 BYTE)
(#BLINK WORD)
(#CLINK WORD)))
(BLOCKRECORD FXBLOCK ((FLAGBYTE BYTE)
(NIL BYTE)
(NIL BITS 15) (* #ALINK)
(SLOWP FLAG)))
(TYPE? (IEQ (fetch (FX FLAGS) of DATUM)
\STK.FX))
(ACCESSFNS FX ([FNHEADER (\VAG2 (fetch (FX FNHEADHI) of DATUM)
(fetch (FX FNHEADLO) of DATUM))
(PROGN (replace (FX FNHEADHI) of DATUM
with (\HILOC NEWVALUE))
(replace (FX FNHEADLO) of DATUM
with (\LOLOC NEWVALUE]
(FNHEADHI (fetch (FX FNHEADHI2) of DATUM)
(PROGN (replace (FX FNHEADHI1) of DATUM with NEWVALUE)
(replace (FX FNHEADHI2) of DATUM with NEWVALUE)
))
[NAMETABLE# (\VAG2 (fetch (FX NAMETABHI) of DATUM)
(fetch (FX NAMETABLO) of DATUM))
(PROGN (replace (FX NAMETABHI) of DATUM
with (\HILOC NEWVALUE))
(replace (FX NAMETABLO) of DATUM
with (\LOLOC NEWVALUE]
(NAMETABLE (COND
((fetch (FX VALIDNAMETABLE) of DATUM)
(fetch (FX NAMETABLE#) of DATUM))
(T (fetch (FX FNHEADER) of DATUM)))
(PROGN (replace (FX FAST) of DATUM with NIL)
(replace (FX NAMETABLE#) of DATUM with
NEWVALUE)
(replace (FX VALIDNAMETABLE) of DATUM
with T)))
(NAMETABHI (fetch (FX NAMETABHI2) of DATUM)
(PROGN (replace (FX NAMETABHI1) of DATUM with
NEWVALUE)
(replace (FX NAMETABHI2) of DATUM with
NEWVALUE)))
(FRAMENAME (fetch (FNHEADER FRAMENAME) of (fetch (FX NAMETABLE)
of DATUM)))
(INVALIDP (EQ DATUM 0))
(FIRSTPVAR (IPLUS DATUM (fetch (FX FXSIZE) of T)))
(FXSIZE (PROGN 10))
[FASTP (NOT (fetch (FX SLOWP) of DATUM))
(PROGN (CHECK (NULL NEWVALUE))
(COND
((fetch (FX FASTP) of DATUM)
(replace (FX #BLINK) of DATUM
with (fetch (FX DUMMYBF) of DATUM))
(replace (FX #CLINK) of DATUM
with (fetch (FX #ALINK) of DATUM))
(replace (FX SLOWP) of DATUM with T]
[BLINK (COND
((fetch (FX FASTP) of DATUM)
(fetch (FX DUMMYBF) of DATUM))
(T (fetch (FX #BLINK) of DATUM)))
(PROGN (replace (FX #BLINK) of DATUM with NEWVALUE)
(COND
((fetch (FX FASTP) of DATUM)
(replace (FX #CLINK) of DATUM
with (fetch (FX #ALINK) of DATUM))
(replace (FX SLOWP) of DATUM with T]
[CLINK (IDIFFERENCE (COND
((fetch (FX FASTP) of DATUM)
(fetch (FX #ALINK) of DATUM))
(T (fetch (FX #CLINK) of DATUM)))
\#ALINK.OFFSET)
(PROGN (replace (FX #CLINK) of DATUM
with (IPLUS NEWVALUE \#ALINK.OFFSET))
(COND
((fetch (FX FASTP) of DATUM)
(replace (FX #BLINK) of DATUM
with (fetch (FX DUMMYBF) of DATUM))
(replace (FX SLOWP) of DATUM with T]
[ALINK (IDIFFERENCE (FLOOR (fetch (FX #ALINK) of DATUM)
WORDSPERCELL)
\#ALINK.OFFSET)
(PROGN [COND
((fetch (FX FASTP) of DATUM)
(replace (FX #BLINK) of DATUM
with (fetch (FX DUMMYBF) of DATUM))
(replace (FX #CLINK) of DATUM
with (fetch (FX #ALINK) of DATUM]
(replace (FX #ALINK) of DATUM
with (IPLUS NEWVALUE \#ALINK.OFFSET
(SUB1 WORDSPERCELL]
[ACLINK (SHOULDNT)
(PROGN [COND
((fetch (FX FASTP) of DATUM)
(replace (FX #BLINK) of DATUM
with (fetch (FX DUMMYBF) of DATUM]
(replace (FX #CLINK) of DATUM
with (IPLUS NEWVALUE \#ALINK.OFFSET))
(replace (FX #ALINK) of DATUM
with (IPLUS NEWVALUE \#ALINK.OFFSET
(SUB1 WORDSPERCELL]
(DUMMYBF (IDIFFERENCE DATUM WORDSPERCELL))
(IVAR (fetch (BF IVAR) of (fetch (FX DUMMYBF) of DATUM)))
[CHECKED (AND (type? FX DATUM)
(OR (IEQ (fetch (FX DUMMYBF) of DATUM)
(fetch (FX BLINK) of DATUM))
(AND (fetch (BF RESIDUAL)
of (fetch (FX DUMMYBF)
of DATUM))
(IEQ (fetch (BF IVAR)
of (fetch (FX DUMMYBF)
of DATUM))
(fetch (BF IVAR)
of (fetch (FX BLINK)
of DATUM]
(PADDING (PROGN 4))
(FIRSTTEMP (IPLUS (fetch (FX FIRSTPVAR) of DATUM)
(fetch (FX NPVARWORDS) of DATUM)
(fetch (FX PADDING) of DATUM)))
(SIZE (IDIFFERENCE (fetch (FX NEXTBLOCK) of DATUM)
DATUM)))
(* FNHEADER: note FNHEADER pointer is swapped order with \HILOC duplicated -
NAMETABLE: use FNHEADER unless VALIDNAMETABLE bit set -
INVALIDP is used when scanning up ALINK/CLINK chains -
FIRSTPVAR is "pointer" to first PVAR slot -
FXSIZE is constant which is size of "fixed" overhead -
FASTP is the "field" which says that the BLINK and CLINK fields are valid -
IVAR: a FX is ALWAYS preceded by enough of its basic frame to find its IVAR slot. This means however that when a FX
is copied, the cell preceding the FX is copied too -
FIRSTTEMP: note that NPVARWORDS is obtained from the FNHEADER; WORDSPERQUAD addition is doublecell of garbage for
microcode use)
))
(ACCESSFNS FSB ((FSBBLOCK (ADDSTACKBASE DATUM))
(CHECKED (IEQ (fetch (FSB FLAGWORD) of DATUM)
\STK.FSB.WORD)))
(BLOCKRECORD FSBBLOCK ((FLAGS BITS 3)
(DUMMY BITS 13)
(SIZE WORD)))
(BLOCKRECORD FSBBLOCK ((FLAGWORD WORD)
(SIZE WORD))) (* free stack block)
(TYPE? (IEQ (fetch (FSB FLAGS) of DATUM)
\STK.FSB)))
(ACCESSFNS STK ((STKBLOCK (ADDSTACKBASE DATUM))) (* random stack pointer)
(BLOCKRECORD STKBLOCK ((FLAGS BITS 3)))
(BLOCKRECORD STKBLOCK ((FLAGWORD WORD))))
]
(DECLARE: EVAL@COMPILE
(RPAQQ \#ALINK.OFFSET 10)
(CONSTANTS \#ALINK.OFFSET)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \PENDINGINTERRUPT \KBDSTACKBASE \MISCSTACKBASE \STACKOVERFLOW)
)
(DECLARE: EVAL@COMPILE
[PUTPROPS \MYALINK DMACRO (NIL ((OPCODES MYALINK]
(PUTPROPS ADDSTACKBASE DMACRO (= . STACKADDBASE))
(PUTPROPS STACKADDBASE DMACRO ((N)
(VAG2 \STACKHI N)))
(PUTPROPS STACKGETBASE DMACRO ((N)
(\GETBASE (STACKADDBASE N)
0)))
(PUTPROPS STACKGETBASEPTR DMACRO ((N)
(\GETBASEPTR (STACKADDBASE N)
0)))
(PUTPROPS STACKPUTBASE DMACRO ((N V)
(\PUTBASE (STACKADDBASE N)
0 V)))
(PUTPROPS STACKPUTBASEPTR DMACRO ((N V)
(\PUTBASEPTR (STACKADDBASE N)
0 V)))
[PUTPROPS \MISCAPPLY* MACRO ((FN ARG1 ARG2)
(UNINTERRUPTABLY
(replace (IFPAGE MISCSTACKFN) of \InterfacePage with FN)
(replace (IFPAGE MISCSTACKARG1) of \InterfacePage with ARG1)
(replace (IFPAGE MISCSTACKARG2) of \InterfacePage with ARG2)
(\CONTEXTSWITCH \MiscFXP)
(fetch (IFPAGE MISCSTACKRESULT) of \InterfacePage))]
)
[DECLARE: EVAL@COMPILE
(BLOCKRECORD STACKP ((STACKP0 WORD)
(EDFXP WORD))
(BLOCKRECORD STACKP ((STACKPOINTER FULLXPOINTER)))
(TYPE? (STACKP DATUM)))
]
(RPAQQ STACKTYPES (\STK.GUARD \STK.FX \STK.BF \STK.NOTFLAG \STK.FSB \STK.FLAGS.SHIFT
(\STK.FSB.WORD (LLSH \STK.FSB \STK.FLAGS.SHIFT))
(\STK.GUARD.WORD (LLSH \STK.GUARD \STK.FLAGS.SHIFT))
(\STK.BF.WORD (LLSH \STK.BF \STK.FLAGS.SHIFT))))
(DECLARE: EVAL@COMPILE
(RPAQQ \STK.GUARD 7)
(RPAQQ \STK.FX 6)
(RPAQQ \STK.BF 4)
(RPAQQ \STK.NOTFLAG 0)
(RPAQQ \STK.FSB 5)
(RPAQQ \STK.FLAGS.SHIFT 13)
(RPAQ \STK.FSB.WORD (LLSH \STK.FSB \STK.FLAGS.SHIFT))
(RPAQ \STK.GUARD.WORD (LLSH \STK.GUARD \STK.FLAGS.SHIFT))
(RPAQ \STK.BF.WORD (LLSH \STK.BF \STK.FLAGS.SHIFT))
(CONSTANTS \STK.GUARD \STK.FX \STK.BF \STK.NOTFLAG \STK.FSB \STK.FLAGS.SHIFT (\STK.FSB.WORD
(LLSH \STK.FSB \STK.FLAGS.SHIFT))
(\STK.GUARD.WORD (LLSH \STK.GUARD \STK.FLAGS.SHIFT))
(\STK.BF.WORD (LLSH \STK.BF \STK.FLAGS.SHIFT)))
)
(DECLARE: EVAL@COMPILE
(RPAQQ \StackAreaSize 768)
(RPAQ \InitStackSize (ITIMES \StackAreaSize 12))
(CONSTANTS \StackAreaSize (\InitStackSize (ITIMES \StackAreaSize 12)))
)
(DECLARE: EVAL@COMPILE
(RPAQQ \MAXSAFEUSECOUNT 200)
(CONSTANTS \MAXSAFEUSECOUNT)
)
[DECLARE: EVAL@COMPILE
(BLOCKRECORD NAMETABLESLOT ((VARTYPE BYTE)
(VAROFFSET BYTE)))
(BLOCKRECORD FVARSLOT ((BINDLO WORD)
(BINDHI1 BYTE)
(BINDHI2 BYTE))
[ACCESSFNS FVARSLOT ((LOOKEDUP (EVENP (fetch BINDLO of DATUM)))
(BINDINGPTR (\VAG2 (fetch BINDHI1 of DATUM)
(fetch BINDLO of DATUM))
(PROGN (replace BINDLO of DATUM
with (\LOLOC NEWVALUE))
(replace BINDHI1 of DATUM
with (replace BINDHI2 of DATUM
with (\HILOC NEWVALUE])
(BLOCKRECORD PVARSLOT ((PVHI BYTE)
(PVVALUE XPOINTER))
[ACCESSFNS PVARSLOT ((BOUND (EQ (fetch PVHI of DATUM)
0])
(BLOCKRECORD STKTEMPSLOT ((STKTMPHI BYTE)
(VALUE XPOINTER))
[ACCESSFNS STKTEMPSLOT ((BINDINGPTRP (NEQ (fetch STKTMPHI
of DATUM)
0])
]
(DECLARE: EVAL@COMPILE
(RPAQQ \NT.IVAR 0)
(RPAQQ \NT.PVAR 128)
(RPAQQ \NT.FVAR 192)
(CONSTANTS \NT.IVAR \NT.PVAR \NT.FVAR)
)
(* END EXPORTED DEFINITIONS)
[DECLARE: EVAL@COMPILE
(BLOCKRECORD STACKCELL ((STACKNONPOINTERBITS BITS 8)
(STACKHIBITS BITS 8)
(STACKLOBITS WORD))
[ACCESSFNS STACKCELL ((VALIDPOINTERP (EQ 0 (fetch (STACKCELL
STACKNONPOINTERBITS)
of DATUM)))
(VALIDPOINTER (\GETBASEPTR DATUM 0])
]
)
(* FOR LAMBDA* FUNCTIONS)
(DEFINEQ
(\MYARGCOUNT
[LAMBDA NIL (* lmm " 6-OCT-81 23:15")
(* Put out by the compiler in lambda* functions, returns number of arguments of the caller, to be bound to the
lambda* variable. Eventually will be an opcode)
(fetch (BF NARGS) of (fetch (FX BLINK) of (\MYALINK])
(\ARG0
[LAMBDA (N) (* lmm " 6-OCT-81 23:15")
(* call to this function put out by compiler when compiling ARG for local
argument. Returns Nth argument of parent's frame)
(PROG [(BFLINK (fetch (FX BLINK) of (\MYALINK]
(* BFLINK is the basic frame we are looking at)
(CHECK (type? BF BFLINK))
(RETURN (COND
[[AND (IGREATERP N 0)
(NOT (IGREATERP N (fetch (BF NARGS) of BFLINK]
(* N must be between 1 and the number of arguments)
(GETBASEPTR \STACKSPACE (IPLUS (fetch (BF IVAR) of BFLINK)
(LLSH (SUB1 N)
1]
(T (LISPERROR "ILLEGAL ARG" N])
(\SETARG0
[LAMBDA (N VAL) (* bvm: " 5-Feb-85 16:10")
(* call to this function put out by compiler when
compiling SETARG for local argument.
Sets Nth argument of parent's frame)
(PROG [(BFLINK (fetch (FX BLINK) of (\MYALINK] (* BFLINK is the basic frame we are looking at)
(CHECK (type? BF BFLINK))
(RETURN (COND
([AND (IGREATERP N 0)
(NOT (IGREATERP N (fetch (BF NARGS) of BFLINK]
(* N must be between 1 and the number of arguments)
(\PUTBASEPTR (ADDSTACKBASE (IPLUS (fetch (BF IVAR) of BFLINK)
(UNFOLD (SUB1 N)
WORDSPERCELL)))
0 VAL))
(T (LISPERROR "ILLEGAL ARG" N])
)
(DEFINEQ
(\HARDRETURN
[LAMBDA (VAL) (* lmm "20-JUL-81 13:45")
(* Called by the microcode instead of returning to a frame whose use count is
greater than one.)
(\CONTEXTSWITCH \HardReturnFXP)
VAL])
(\DOHARDRETURN
[LAMBDA NIL (* lmm "27-JUL-81 09:07")
(PROG NIL
LP (\DOHARDRETURN1 (fetch (IFPAGE HardReturnFXP) of \InterfacePage))
(\CONTEXTSWITCH \HardReturnFXP)
(GO LP])
(\DOGC1
[LAMBDA NIL (* lmm " 1-SEP-81 00:53")
(\GCSCANSTACK)
(\GCMAPSCAN) (* map thru, releasing entries)
(\GCMAPUNSCAN) (* map thru, unmarking stack entries)
])
(\DOGC
[LAMBDA NIL (* lmm " 1-SEP-81 00:52")
(PROG NIL
LP (\DOGC1)
(\CONTEXTSWITCH \GCFXP)
(GO LP])
(\DOHARDRETURN1
[LAMBDA (HRFRAME) (* bvm: " 8-Jun-85 22:33")
(* executed in the hard return context. HRFRAME is the context in which \HARDRETURN was invoked.
We want to fix \HARDRETURN's caller to do a return to its caller)
[COND
((EQ (fetch (FX FNHEADER FRAMENAME) of HRFRAME)
(QUOTE \CONTEXTSWITCH)) (* We really want to mung \HARDRETURN frame, not
\CONTEXTSWITCH. Test is needed in case \CONTEXTSWITCH
is microcode)
(SETQ HRFRAME (fetch (FX CLINK) of HRFRAME]
(PROG ((RETURNER (fetch (FX CLINK) of HRFRAME))
RETURNEE AX NEW SIZE RETBF)
(CHECK (EQ (fetch (FX FNHEADER FRAMENAME) of HRFRAME)
(QUOTE \HARDRETURN)))
(SETQ RETURNEE (fetch (FX CLINK) of RETURNER))
[CHECK (fetch (FX CHECKED) of RETURNEE)
(fetch (FX CHECKED) of RETURNER)
(NOT (fetch (FX FASTP) of RETURNER))
(OR (NEQ RETURNEE (fetch (FX ALINK) of RETURNER))
(COND
((NEQ (fetch (FX USECNT) of RETURNEE)
0) (* use count of RETURNEE gt 1, must copy RETURNEE)
T)
((type? FSB (SETQ AX (fetch (FX NEXTBLOCK) of RETURNEE)))
(* returnee followed by a free block, but that free
block is too small)
(ILEQ (fetch (FSB SIZE) of AX)
\MinExtraStackWords))
(T
(* used to check ((EQ AX (fetch (BF IVAR) of (SETQ AX (fetch (FX BLINK) of RETURNER)))) (* returnee followed by
RETURNER's BF but it doesn't have a non-zero usecount) (NEQ (fetch (BF USECNT) of AX) 0)))
(* must copy in all other cases)
T]
(COND
((NEQ RETURNEE (SETQ AX (fetch (FX ALINK) of RETURNER)))
(* ALINK and CLINK of returner not the same.
Fix.)
(* Set new ALINK before decrementing count on old
value)
(replace (FX ALINK) of RETURNER with RETURNEE)
(\DECUSECOUNT AX)))
(COND
((COND
((NEQ (fetch (FX USECNT) of RETURNEE)
0) (* use count of RETURNEE gt 1, must copy RETURNEE)
T)
((type? FSB (SETQ AX (fetch (FX NEXTBLOCK) of RETURNEE)))
(* returnee followed by a free block, but that free
block is too small)
(* SHOULD REALLY REQUIRE MICROCODE MERGE THE FREE
BLOCKS)
(while [type? FSB (SETQ NEW (IPLUS AX (fetch (FSB SIZE) of AX]
do (add (fetch (FSB SIZE) of AX)
(fetch (FSB SIZE) of NEW)))
(ILEQ (fetch (FSB SIZE) of AX)
\MinExtraStackWords))
([EQ AX (fetch (BF IVAR) of (SETQ AX (fetch (FX BLINK) of RETURNER]
(* returnee followed by RETURNER's BF but it doesn't
have a non-zero usecount)
(NEQ (fetch (BF USECNT) of AX)
0))
(T (* must copy in all other cases)
T)) (* Must copy returnee to a new block because there
isn't enough room to return a value to it)
(FLIPCURSORBAR 5)
(SETQ SIZE (IPLUS (fetch (FX SIZE) of RETURNEE)
WORDSPERCELL))
(SETQ NEW (\FREESTACKBLOCK SIZE RETURNER)) (* Find a free stack block)
(\BLT (ADDSTACKBASE NEW)
(ADDSTACKBASE (IDIFFERENCE RETURNEE WORDSPERCELL))
SIZE) (* copy frame and dummy bf pointer too)
(replace (BF RESIDUAL) of NEW with T)
(add NEW WORDSPERCELL) (* now NEW points to the FX)
(replace (FX NEXTBLOCK) of NEW with (IDIFFERENCE (IPLUS NEW SIZE)
WORDSPERCELL))
(replace (FX BLINK) of NEW with (SETQ RETBF (fetch (FX BLINK) of RETURNEE)))
(* Point to the real BF, not the residual)
(replace (FX USECNT) of NEW with 0)
(CHECK (fetch (BF CHECKED) of RETBF))
[COND
((AND (fetch (FX VALIDNAMETABLE) of NEW)
(EQ (fetch (FX NAMETABHI) of NEW)
\STACKHI))
(CHECK ([LAMBDA (N)
(AND (IGREATERP N RETURNEE)
(ILESSP N (fetch (FX NEXTBLOCK) of RETURNEE]
(fetch (FX NAMETABLO) of RETURNEE)))
(add (fetch (FX NAMETABLO) of NEW)
(IDIFFERENCE NEW RETURNEE]
(add (fetch (BF USECNT) of RETBF)
1) (* increment use count of basic frame of returnee
because we made another FX which points to it)
(replace (FX FASTP) of RETURNEE with NIL)
(\INCUSECOUNT (SETQ AX (fetch (FX CLINK) of RETURNEE)))
(* increment use count of CLINK of returnee because we
made a copy of returnee)
(COND
((NEQ AX (SETQ AX (fetch (FX ALINK) of RETURNEE)))
(\INCUSECOUNT AX)))
(\DECUSECOUNT RETURNEE)
(replace (FX ACLINK) of RETURNER with NEW)
(CHECK (fetch (FX CHECKED) of NEW)
(fetch (FX CHECKED) of RETURNER))
(SETQ RETURNEE NEW)
(FLIPCURSORBAR 5)))
(\SMASHLINK HRFRAME RETURNEE RETURNEE])
(\DOSTACKOVERFLOW
[LAMBDA NIL (* lmm "27-JUL-81 15:52")
(PROG NIL
LP (replace (IFPAGE SubovFXP) of \InterfacePage with (\MOVEFRAME (fetch (IFPAGE SubovFXP)
of \InterfacePage)))
(\CONTEXTSWITCH \SubovFXP)
(GO LP])
(\MOVEFRAME
[LAMBDA (OLDFRAME) (* bvm: " 8-Jun-85 22:29")
(FLIPCURSORBAR 10)
(* * Called from \DOSTACKOVERFLOW when there isn't enough space to run in OLDFRAME -
Either we're at the end of stack space, in which case we can just extend the stack a bit, or we need to move
OLDFRAME to somewhere else that has more free space after it.)
(PROG ((SIZE (IPLUS (fetch (FX SIZE) of OLDFRAME)
WORDSPERCELL))
(NXT (fetch (FX NEXTBLOCK) of OLDFRAME))
AX NEW)
[COND
((type? FSB NXT)
(while [type? FSB (SETQ NEW (IPLUS NXT (fetch (FSB SIZE) of NXT]
do (* merge free blocks)
(add (fetch (FSB SIZE) of NXT)
(fetch (FSB SIZE) of NEW)))
(COND
((AND (EQ NEW (fetch (IFPAGE EndOfStack) of \InterfacePage))
(\EXTENDSTACK))
(SETQ NEW OLDFRAME)
(GO OUT] (* Must copy OLDFRAME to a new block because there
isn't enough room to run in it)
(CHECK (fetch (FX CHECKED) of OLDFRAME)
(EQ (fetch (FX USECNT) of OLDFRAME)
0)
(NOT \INTERRUPTABLE))
(SETQ NEW (\FREESTACKBLOCK SIZE OLDFRAME)) (* Find a free stack block)
(\BLT (ADDSTACKBASE NEW)
(ADDSTACKBASE (IDIFFERENCE OLDFRAME WORDSPERCELL))
SIZE) (* copy frame and dummy bf pointer too)
(replace (BF RESIDUAL) of NEW with T)
(add NEW WORDSPERCELL) (* now NEW points to the FX)
(replace (FX NEXTBLOCK) of NEW with (IDIFFERENCE (IPLUS NEW SIZE)
WORDSPERCELL))
(CHECK (fetch (BF CHECKED) of (fetch (FX BLINK) of OLDFRAME)))
(replace (FX BLINK) of NEW with (fetch (FX BLINK) of OLDFRAME))
(* Point at true BF, not residual)
[COND
((AND (fetch (FX VALIDNAMETABLE) of NEW)
(EQ (fetch (FX NAMETABHI) of NEW)
\STACKHI)) (* Frame's nametable is on the stack, so it moved at
the same time the frame did)
[CHECK (LET ((N (fetch (FX NAMETABLO) of OLDFRAME)))
(AND (IGREATERP N OLDFRAME)
(ILESSP N (fetch (FX NEXTBLOCK) of OLDFRAME]
(add (fetch (FX NAMETABLO) of NEW)
(IDIFFERENCE NEW OLDFRAME]
[COND
((fetch (BF RESIDUAL) of (fetch (FX DUMMYBF) of OLDFRAME))
(\MAKEFREEBLOCK (IDIFFERENCE OLDFRAME WORDSPERCELL)
SIZE))
(T (\MAKEFREEBLOCK OLDFRAME (IDIFFERENCE SIZE WORDSPERCELL]
OUT (FLIPCURSORBAR 10) (* Restore cursor)
(RETURN NEW])
(\INCUSECOUNT
[LAMBDA (FRAME) (* bvm: "23-Mar-84 18:01")
[COND
((NOT (fetch (FX INVALIDP) of FRAME))
(CHECK (NOT \INTERRUPTABLE)
(fetch (FX CHECKED) of FRAME))
(COND
((IGREATERP (add (fetch (FX USECNT) of FRAME)
1)
\MAXSAFEUSECOUNT)
(\MP.ERROR \MP.USECOUNTOVERFLOW "Stack frame use count maximum exceeded" FRAME)))
(PROG ((SCANPTR (fetch (FX NEXTBLOCK) of FRAME))) (* scan for BF ptr)
(SELECTC (fetch (STK FLAGS) of SCANPTR)
[\STK.NOTFLAG (until (type? BF (add SCANPTR WORDSPERCELL]
(\STK.BF)
(RETURN))
[CHECK (OR (fetch (BF RESIDUAL) of SCANPTR)
(EQ (fetch (BF IVAR) of SCANPTR)
(fetch (FX NEXTBLOCK) of FRAME]
(COND
((type? FX (add SCANPTR WORDSPERCELL))
(CHECK (fetch (FX CHECKED) of SCANPTR))
(replace (FX FASTP) of SCANPTR with NIL]
FRAME])
(\DECUSECOUNT
[LAMBDA (FRAME) (* lmm " 4-SEP-81 09:29")
(PROG (TEMP ALINK BLINK SIZE CLINK)
(CHECK (NOT \INTERRUPTABLE))
TOP (COND
((fetch (FX INVALIDP) of FRAME) (* reached top of stack)
(RETURN)))
(CHECK (fetch (FX CHECKED) of FRAME))
(COND
((NEQ (fetch (FX USECNT) of FRAME)
0) (* USECNT (= use count + 1) greater than 1, merely
decrement it)
(add (fetch (FX USECNT) of FRAME)
-1)
(RETURN FRAME))) (* ok, now free it)
(SETQ ALINK (fetch (FX ALINK) of FRAME))
(SETQ BLINK (fetch (FX BLINK) of FRAME))
(SETQ CLINK (fetch (FX CLINK) of FRAME))
(SETQ SIZE (fetch (FX SIZE) of FRAME))
(COND
((fetch (BF RESIDUAL) of (fetch (FX DUMMYBF) of FRAME))
(\MAKEFREEBLOCK (IDIFFERENCE FRAME WORDSPERCELL)
(IPLUS SIZE WORDSPERCELL)))
(T (\MAKEFREEBLOCK FRAME SIZE)))
(CHECK (fetch (BF CHECKED) of BLINK))
(COND
((EQ (fetch (BF USECNT) of BLINK)
0) (* frame extension count+1=0 -
release basic frame)
(\MAKEFREEBLOCK (fetch (BF IVAR) of BLINK)
(fetch (BF SIZE) of BLINK)))
(T (* merely decrement extension count)
(add (fetch (BF USECNT) of BLINK)
-1)))
(COND
((NEQ ALINK CLINK)
(\DECUSECOUNT ALINK)))
(SETQ FRAME CLINK)
(GO TOP])
(\MAKESTACKP
[LAMBDA (ED FX) (* bvm: " 5-Jun-85 17:21")
(* Create a STACKP cell, possibly reusing ED, and
pointing to FX)
(UNINTERRUPTABLY
(COND
((NEQ FX 0)
(\INCUSECOUNT FX)))
(COND
[(OR (STACKP ED)
(TYPENAMEP ED (QUOTE PROCESS)))
(LET ((OLDFX (fetch (STACKP EDFXP) of ED)))
(COND
((NEQ OLDFX 0)
(\DECUSECOUNT OLDFX]
(T (SETQ ED (CREATECELL \STACKP))
(replace (STACKP STACKP0) of ED with \STACKHI)))
(replace (STACKP EDFXP) of ED with FX))
ED])
(\SMASHLINK
[LAMBDA (CALLER ALINK CLINK) (* bvm: " 5-Feb-85 16:19")
(* Smashes caller's ALINK and/or CLINK with ALINK and
CLINK)
(OR CALLER (SETQ CALLER (\MYALINK)))
(UNINTERRUPTABLY
(PROG ((OLDALINK (fetch (FX ALINK) of CALLER))
(OLDCLINK (fetch (FX CLINK) of CALLER))
BLINK)
(COND
(ALINK (COND
((NEQ ALINK (OR CLINK OLDCLINK)) (* Don't increment twice if ALINK comes out same as
CLINK)
(\INCUSECOUNT ALINK)))
(replace (FX ALINK) of CALLER with ALINK)))
(COND
(CLINK (COND
((OR ALINK (NEQ CLINK OLDALINK)) (* If we're only setting the CLINK, and we're setting
it to be the same as the ALINK, don't bump count)
(\INCUSECOUNT CLINK)))
(replace (FX CLINK) of CALLER with CLINK)
(\DECUSECOUNT OLDCLINK))) (* must be careful to increment any use counts before
decrementing any)
(COND
((AND (NEQ OLDALINK OLDCLINK)
ALINK)
(\DECUSECOUNT OLDALINK)))
(COND
((AND (EQ (OR ALINK (SETQ ALINK OLDALINK))
(OR CLINK (SETQ CLINK OLDCLINK)))
(EQ (fetch (FX USECNT) of CLINK)
0)
(EQ (SETQ BLINK (fetch (FX BLINK) of CALLER))
(fetch (FX DUMMYBF) of CALLER))
(EQ (fetch (BF IVAR) of BLINK)
(fetch (FX NEXTBLOCK) of CLINK))
(EQ (fetch (BF USECNT) of BLINK)
0)
(NOT (fetch (FX NOPUSH) of CLINK))
(NOT (fetch (FX INCALL) of CLINK)))
(* We have made CALLER fast again: its alink and clink are same, usecnt of blink and caller are normal, bf is
contiguous with CALLER and CALLER's caller)
(replace (FX SLOWP) of CALLER with NIL)))
(RETURN CALLER)))])
(\FREESTACKBLOCK
[LAMBDA (N START) (* bvm: " 4-Nov-85 17:23")
(* Scan stack space searching for a free block of size at least n, starting scan at start (or beginning of
stackspace if START=NIL))
(PROG ((WANTEDSIZE (IPLUS N \StackAreaSize \MinExtraStackWords))
FREEPTR FREESIZE (EASP (fetch EndOfStack of \InterfacePage))
SCANPTR)
[CHECK (OR (NULL START)
(IGEQ START (fetch StackBase of \InterfacePage]
STARTOVER
(SETQ SCANPTR (OR START (fetch StackBase of \InterfacePage)))
SCAN(SELECTC (fetch (STK FLAGS) of SCANPTR)
(\STK.FSB (GO FREESCAN))
[\STK.GUARD (COND
((ILESSP SCANPTR EASP)
(* Guard block not at end of stack, treat as a free
block)
(GO FREESCAN))) (* reached end)
(COND
(START (* had a starting place, just wrap around)
(SETQ SCANPTR (fetch StackBase of \InterfacePage))
(GO SCAN))
(T (* Scanned the entire stack -
add a new page)
(GO NEWPAGE]
(\STK.FX (* frame extension)
(CHECK (fetch (FX CHECKED) of SCANPTR))
(SETQ SCANPTR (fetch (FX NEXTBLOCK) of SCANPTR)))
(PROG ((ORIG SCANPTR)) (* must be a basic frame)
(until (type? BF SCANPTR)
do (CHECK (EQ (fetch (STK FLAGS) of SCANPTR)
\STK.NOTFLAG))
(add SCANPTR WORDSPERCELL))
[CHECK (COND
((fetch (BF RESIDUAL) of SCANPTR)
(EQ SCANPTR ORIG))
(T (AND (fetch (BF CHECKED) of SCANPTR)
(EQ ORIG (fetch (BF IVAR) of SCANPTR]
(add SCANPTR WORDSPERCELL)))
NEXT(COND
((NEQ SCANPTR START)
(CHECK (ILEQ SCANPTR EASP))
(GO SCAN)))
NEWPAGE
[COND
((SETQ EASP (\EXTENDSTACK))
(GO STARTOVER))
(T (while T do (\MP.ERROR \MP.STACKFULL
"Stack Full -- Type LU to see stack; ↑D to flush to top"]
FREESCAN
(SETQ FREEPTR SCANPTR)
(SETQ FREESIZE (fetch (FSB SIZE) of SCANPTR))
FREE (* MERGE FREE BLOCKS)
(SETQ SCANPTR (IPLUS FREEPTR FREESIZE))
(COND
((SELECTC (fetch (STK FLAGS) of SCANPTR)
(\STK.FSB T)
(\STK.GUARD (ILESSP SCANPTR EASP))
NIL)
(add FREESIZE (fetch (FSB SIZE) of SCANPTR))
(GO FREE)))
(COND
((IGEQ FREESIZE WANTEDSIZE) (* Found a large enough block -
Split the block)
[SETQ WANTEDSIZE (COND
((EVENP FREEPTR WORDSPERQUAD) (* alignment ok)
\MinExtraStackWords)
(T (* no, adjust alignment)
(IPLUS WORDSPERCELL \MinExtraStackWords]
(SETQ SCANPTR (\SETUPGUARDBLOCK (IPLUS FREEPTR WANTEDSIZE)
N))
(\MAKEFREEBLOCK FREEPTR WANTEDSIZE)
(\MAKEFREEBLOCK (IPLUS SCANPTR N)
(IDIFFERENCE (IDIFFERENCE FREESIZE WANTEDSIZE)
N))
(RETURN SCANPTR))
(T (\MAKEFREEBLOCK FREEPTR FREESIZE)))
(GO NEXT])
(\EXTENDSTACK
[LAMBDA NIL (* bvm: "18-JAN-83 12:12")
(PROG ((EASP (fetch (IFPAGE EndOfStack) of \InterfacePage))
SCANPTR)
(RETURN (COND
((ILESSP EASP \LastStackAddr)
(if (AND (IGREATERP EASP \GuardStackAddr)
(NOT \STACKOVERFLOW))
then (replace STACKOVERFLOW of \INTERRUPTSTATE with T)
(SETQ \STACKOVERFLOW (SETQ \PENDINGINTERRUPT T)))
(OR (\DONEWPAGE (ADDSTACKBASE (SETQ SCANPTR (IPLUS EASP 2)))
T)
(\DOLOCKPAGES (ADDSTACKBASE SCANPTR)
1))
(* Create, if necessary, new page and lock it. Second clause happens when page already existed.
\DONEWPAGE instead of \NEWPAGE etc. because we are in a safe context (and might even be in the misc context))
(\MAKEFREEBLOCK SCANPTR (IDIFFERENCE WORDSPERPAGE 2))
(\SETUPGUARDBLOCK (SETQ SCANPTR (IPLUS EASP WORDSPERPAGE))
2)
(replace EndOfStack of \InterfacePage with SCANPTR)
(\MAKEFREEBLOCK EASP 2)
SCANPTR])
(\SLOWRETURN
[LAMBDA NIL (* lmm "30-Dec-84 03:31")
(* cause caller to slow return)
(replace (FX FASTP) of (\MYALINK) with NIL])
(\COPY.N.UFN
[LAMBDA (ALPHA) (* lmm " 2-Jan-85 01:29")
(\.GETBASE32 \STACKSPACE (IDIFFERENCE (fetch (FX NEXTBLOCK) of (\MYALINK))
(IPLUS ALPHA WORDSPERCELL])
(\POP.N.UFN
[LAMBDA (N) (* lmm "11-Apr-85 22:12")
(\SLOWRETURN)
(LET ((AL (\MYALINK))
NEXT VAL LEN)
(SETQ NEXT (fetch (FX NEXTBLOCK) of AL))
[SETQ VAL (\GETBASEPTR \STACKSPACE (SETQ NEXT (IDIFFERENCE NEXT (SETQ LEN (UNFOLD (ADD1 N)
WORDSPERCELL]
(\MAKEFREEBLOCK NEXT LEN)
(replace (FX NEXTBLOCK) of AL with NEXT)
VAL])
(\STORE.N.UFN
[LAMBDA (VAL ALPHA) (* lmm " 2-Jan-85 01:30")
(\.PUTBASE32 \STACKSPACE (IDIFFERENCE (fetch (FX NEXTBLOCK) of (\MYALINK))
(IPLUS ALPHA WORDSPERCELL))
VAL])
)
(DEFINEQ
(\GCSCANSTACK
[LAMBDA NIL (* bvm: "11-Jun-84 13:02")
(* scan stack space calling SCANREF on all pointers)
(PROG ((SCANPTR (fetch StackBase of \InterfacePage))
(EASP (fetch EndOfStack of \InterfacePage))
SCANBASE Q)
LP (SELECTC (fetch (STK FLAGS) of SCANPTR)
[\STK.FX (* frame extension)
(PROG (NTEND NEXT)
(CHECK (fetch (FX CHECKED) of SCANPTR))
(\STKREF (fetch (FX FNHEADER) of SCANPTR))
[SETQ SCANBASE (ADDSTACKBASE (SETQ Q (fetch (FX FIRSTPVAR)
of SCANPTR]
(FRPTQ (fetch (FX FNHEADER NLOCALS) of SCANPTR)
[COND
((fetch (PVARSLOT BOUND) of SCANBASE)
(\STKREF (fetch (STACKCELL VALIDPOINTER) of SCANBASE]
(SETQ SCANBASE (\ADDBASE SCANBASE WORDSPERCELL)))
(SETQ NEXT (SETQ Q (fetch (FX NEXTBLOCK) of SCANPTR)))
[COND
((fetch (FX VALIDNAMETABLE) of SCANPTR)
(* Frame has separate nametable.)
(COND
((EQ (fetch (FX NAMETABHI) of SCANPTR)
\STACKHI) (* Nametable is on stack. Need to refcnt its framename
and skip that section of the stack, since it does not
contain pointers)
(CHECK (ILEQ (fetch (FX NAMETABLO) of SCANPTR)
Q))
(\STKREF (fetch (FNHEADER FRAMENAME)
of (fetch (FX NAMETABLE#) of SCANPTR)))
(SETQ Q (fetch (FX NAMETABLO) of SCANPTR))
(SETQ NTEND (IPLUS Q (fetch (FNHEADER OVERHEADWORDS)
of T)
(UNFOLD (fetch (FNHEADER NTSIZE)
of (ADDSTACKBASE Q))
2)))
(* Need to skip the region from Q to NTEND)
)
(T (* Nametable elsewhere, just reference it)
(\STKREF (fetch (FX NAMETABLE) of SCANPTR]
(SETQ SCANPTR (fetch (FX FIRSTTEMP) of SCANPTR))
SCANTEMPS
(SETQ SCANBASE (ADDSTACKBASE SCANPTR))
(while (ILESSP SCANPTR Q)
do [COND
((fetch (STACKCELL VALIDPOINTERP) of SCANBASE)
(\STKREF (fetch (STACKCELL VALIDPOINTER) of SCANBASE]
(add SCANPTR WORDSPERCELL)
(SETQ SCANBASE (\ADDBASE SCANBASE WORDSPERCELL)))
(COND
(NTEND (* Skip over NT, scan after it)
(SETQ SCANPTR NTEND)
(SETQ Q NEXT)
(SETQ NTEND)
(GO SCANTEMPS]
(\STK.GUARD (AND (EQ SCANPTR EASP)
(RETURN))
(add SCANPTR (fetch (FSB SIZE) of SCANPTR)))
(\STK.FSB
(* to merge free blocks (SETQ Q (IPLUS SCANPTR (fetch (FSB SIZE) of SCANPTR))) (CHECK (NEQ SCANPTR Q))
(while (type? FSB Q) do (add (fetch (FSB SIZE) of SCANPTR) (SETQ NV (fetch (FSB SIZE) of Q)))
(add Q NV)) (SETQ SCANPTR Q))
(add SCANPTR (fetch (FSB SIZE) of SCANPTR)))
(PROG ((ORIG SCANPTR)) (* must be a basic frame)
(SETQ SCANBASE (ADDSTACKBASE SCANPTR))
(until (type? BF SCANPTR)
do (CHECK (EQ (fetch (STK FLAGS) of SCANPTR)
\STK.NOTFLAG))
(\STKREF (fetch (STACKCELL VALIDPOINTER) of SCANBASE))
(add SCANPTR WORDSPERCELL)
(SETQ SCANBASE (\ADDBASE SCANBASE WORDSPERCELL)))
[CHECK (COND
((fetch (BF RESIDUAL) of SCANPTR)
(EQ SCANPTR ORIG))
(T (AND (fetch (BF CHECKED) of SCANPTR)
(EQ ORIG (fetch (BF IVAR) of SCANPTR]
(add SCANPTR WORDSPERCELL)))
(GO LP])
)
(DEFINEQ
(CLEARSTK
[LAMBDA (FLG) (* bvm: " 5-Feb-85 16:29")
(PROG (LST)
[\MAPMDS \STACKP (FUNCTION (LAMBDA (PAGE)
(PROG ((I 0)
(PTR (create POINTER
PAGE# ← PAGE))
FX)
LPE [COND
((AND (EQ (fetch (STACKP STACKP0) of PTR)
\STACKHI)
(NEQ (SETQ FX (fetch (STACKP EDFXP) of PTR))
0))
(SELECTQ FLG
[NIL (COND
(NIL (* Disallow this, we can't have this global smashing in
the process world)
(UNINTERRUPTABLY
(PROGN (replace (STACKP EDFXP)
of PTR with 0)
(\DECUSECOUNT FX)))]
(**CLEAR** (* Called by HARDRESET)
(replace (STACKP EDFXP) of PTR with 0))
(push LST PTR]
(COND
((NEQ (SETQ I (IPLUS I WORDSPERCELL))
\MDSIncrement)
(SETQ PTR (\ADDBASE PTR WORDSPERCELL))
(GO LPE]
(RETURN LST])
(HARDRESET
[LAMBDA NIL (* bvm: "12-JAN-82 12:06")
(* this is what Raid's ↑D does)
(\CONTEXTSWITCH \ResetFXP])
(RELSTK
[LAMBDA (POS) (* lmm "27-JUL-81 09:42")
[AND (STACKP POS)
(PROG ((FX (fetch EDFXP of POS)))
(COND
((NEQ FX 0)
(UNINTERRUPTABLY (\DECUSECOUNT FX)
(replace EDFXP of POS with 0]
POS])
(RELSTKP
[LAMBDA (X) (* bvm: " 5-Feb-85 15:41")
(AND (STACKP X)
(EQ (fetch EDFXP of X)
0])
)
(DEFINEQ
(SETUPSTACK
[LAMBDA (INITFLG) (* lmm "22-JUN-83 15:08")
(* INITFLG is on if coming from MAKEINIT.
Kludge because fn definitions are not available during
MAKEINIT)
(CREATEPAGES \STACKSPACE (IQUOTIENT \InitStackSize WordsPerPage)
NIL T) (* create initial stack pages)
(\SETUPGUARDBLOCK 0 WORDSPERCELL) (* start stack with mini-guard block)
(replace (IFPAGE CurrentFXP) of \InterfacePage with (\SETUPSTACK1 WORDSPERCELL 0 0
(IDIFFERENCE \StackAreaSize 2)
0 RESETPC RESETPTR NIL INITFLG))
(replace (IFPAGE ResetFXP) of \InterfacePage with 0)
(replace (IFPAGE FAULTFXP) of \InterfacePage with 0)
(replace (IFPAGE SubovFXP) of \InterfacePage with 0)
(replace (IFPAGE KbdFXP) of \InterfacePage with 0)
(\SETUPGUARDBLOCK (IDIFFERENCE \StackAreaSize 2)
2)
(replace (IFPAGE StackBase) of \InterfacePage with (\SETUPGUARDBLOCK \StackAreaSize
(IDIFFERENCE (IDIFFERENCE
\InitStackSize
\StackAreaSize)
2)))
(replace (IFPAGE EndOfStack) of \InterfacePage with (\SETUPGUARDBLOCK (IDIFFERENCE \InitStackSize
2)
2])
(\SETUPSTACK1
[LAMBDA (STKP ALINK CLINK STKEND NARGS PC DEFPTR ARGS INITFLG)
(* lmm "28-May-85 14:04")
(COND
([OR INITFLG (IGREATERP (IDIFFERENCE STKEND STKP)
(IPLUS (PROG1 (fetch (FNHEADER STKMIN) of DEFPTR)
(* Space needed to call this fn)
)
(PROG1 WORDSPERQUAD (* Extra slop)]
(* Don't build a frame if there isn't space!)
(PROG ((SP STKP))
(FRPTQ NARGS (PUTBASEPTR \STACKSPACE SP (AND ARGS (POP ARGS)))
(* store args)
(add SP WORDSPERCELL))
(AND (PROG1 (COND
((ODDP SP WORDSPERQUAD)
(PUTBASEPTR \STACKSPACE SP NIL)
(* Clear out the padding word)
(add SP WORDSPERCELL)
T))
(replace (STK FLAGWORD) of SP with \STK.BF.WORD))
(replace (BF PADDING) of SP with 1))
(replace (BF IVAR) of SP with STKP)
(SETQ STKP (IPLUS SP WORDSPERCELL))
(replace (FX FLAGS) of STKP with \STK.FX)
(replace (FX NOPUSH) of STKP with T)
(replace (FX INCALL) of STKP with NIL)
(replace (FX FAST) of STKP with NIL)
(replace (FX VALIDNAMETABLE) of STKP with NIL)
(replace (FX USECNT) of STKP with 0)
(replace (FX #BLINK) of STKP with SP)
(replace (FX #ALINK) of STKP with (IPLUS ALINK \#ALINK.OFFSET 1))
(replace (FX #CLINK) of STKP with (IPLUS CLINK \#ALINK.OFFSET))
(replace (FX FNHEADER) of STKP with DEFPTR)
(replace (FX PC) of STKP with PC)
(SETQ SP (fetch (FX FIRSTPVAR) of STKP))
[COND
((NOT INITFLG) (* function definitions not available during MAKEINIT)
(RPTQ (UNFOLD (ADD1 (fetch (FNHEADER PV) of DEFPTR))
CELLSPERQUAD)
(PROGN (* Fill in Pvar region with "unbound")
(\PUTBASE \STACKSPACE SP 65535)
(add SP 2]
(replace (FX NEXTBLOCK) of STKP with (add SP (fetch (FX PADDING) of STKP)))
(* Need extra junk quad after the
(null) pvar region)
(\MAKEFREEBLOCK SP (IDIFFERENCE STKEND SP))
(RETURN STKP])
(\MAKEFRAME
[LAMBDA (FN ST END ALINK CLINK ARGS) (* bvm: "22-JUN-83 11:34")
(CHECK (fetch (LITATOM CCODEP) of FN))
(PROG ((DEF (fetch (LITATOM DEFPOINTER) of FN)))
(RETURN (\SETUPSTACK1 ST ALINK CLINK END (COND
((fetch (FNHEADER LSTARP) of DEF)
0)
(T (fetch (FNHEADER NA) of DEF)))
(fetch (FNHEADER STARTPC) of DEF)
DEF ARGS])
(\RESETSTACK
[LAMBDA NIL (* lmm "23-MAY-81 05:30")
(PROG NIL
LP (\RESETSTACK0)
(\CONTEXTSWITCH \ResetFXP)
(GO LP])
(\RESETSTACK0
[LAMBDA NIL (* bvm: "14-MAR-83 22:11")
(PROG ((BASE \StackAreaSize))
(replace (IFPAGE FAULTFXP) of \InterfacePage with (\MAKEFRAME (FUNCTION \FAULTHANDLER)
BASE
(SETQ BASE (IPLUS BASE
\StackAreaSize))
0 0))
(replace (IFPAGE HardReturnFXP) of \InterfacePage with (\MAKEFRAME (FUNCTION \DOHARDRETURN)
BASE
(SETQ BASE
(IPLUS BASE
\StackAreaSize))
0 0))
(replace (IFPAGE TELERAIDFXP) of \InterfacePage
with (\MAKEFRAME (COND
((fetch (LITATOM CCODEP) of (FUNCTION \DOTELERAID))
(FUNCTION \DOTELERAID))
(T (FUNCTION \DUMMYTELERAID)))
BASE
(SETQ BASE (IPLUS BASE \StackAreaSize))
0 0)) (* NOTE: Anything below the key handler is considered
super uninterruptable)
(replace (IFPAGE KbdFXP) of \InterfacePage with (\MAKEFRAME (COND
((fetch (LITATOM CCODEP)
of (QUOTE \KEYHANDLER))
(FUNCTION \KEYHANDLER))
(T (QUOTE \DUMMYKEYHANDLER)))
(SETQ \KBDSTACKBASE BASE)
(SETQ BASE (IPLUS BASE
\StackAreaSize))
0 0))
(replace (IFPAGE GCFXP) of \InterfacePage with (\MAKEFRAME (FUNCTION \DOGC)
BASE
(SETQ BASE (IPLUS BASE
\StackAreaSize))
0 0))
(replace (IFPAGE SubovFXP) of \InterfacePage with (\MAKEFRAME (FUNCTION \DOSTACKOVERFLOW)
BASE
(SETQ BASE (IPLUS BASE
\StackAreaSize))
0 0))
(replace (IFPAGE MiscFXP) of \InterfacePage with (\MAKEFRAME (FUNCTION \DOMISCAPPLY)
(SETQ \MISCSTACKBASE BASE)
(SETQ BASE (IPLUS BASE
\StackAreaSize))
0 0))
(replace (IFPAGE StackBase) of \InterfacePage with BASE)
(* tell BCPL not to mess with previous stack areas)
(replace (IFPAGE ResetFXP) of \InterfacePage
with (\MAKEFRAME (FUNCTION \CODEFORTFRAME)
BASE
(PROGN [COND
((IGREATERP (SETQ BASE (fetch (IFPAGE EndOfStack)
of \InterfacePage))
\InitStackSize)
(* Trim stack back, unlocking pages.
This way you don't permanently lock entire stack segment
if you get a stack overflow)
[\UNLOCKPAGES (ADDSTACKBASE \InitStackSize)
(ADD1 (IDIFFERENCE (FOLDLO BASE WORDSPERPAGE)
(FOLDLO \InitStackSize
WORDSPERPAGE]
(replace (IFPAGE EndOfStack) of \InterfacePage
with (SETQ BASE (IDIFFERENCE \InitStackSize 2]
BASE)
0 0))
(\SETUPGUARDBLOCK BASE 2])
(\SETUPGUARDBLOCK
[LAMBDA (STKP LEN) (* lmm "27-JUL-81 09:34")
(replace (FSB FLAGWORD) of STKP with \STK.GUARD.WORD)
(replace (FSB SIZE) of STKP with LEN)
STKP])
(\MAKEFREEBLOCK
[LAMBDA (STK SIZE) (* lmm "27-JUL-81 09:33")
(PROGN (* must be careful here, because stack is inconsistent
in this region)
(replace (FSB SIZE) of STK with SIZE)
(replace (FSB FLAGWORD) of STK with \STK.FSB.WORD])
(\REPEATEDLYEVALQT
[LAMBDA NIL (* lmm "10-JUN-81 16:41")
(PROG ((\INTERRUPTABLE T))
LP (\RESETSYSTEMSTATE)
(EVALQT)
(GO LP])
(\DUMMYKEYHANDLER
[LAMBDA NIL (* lmm " 4-APR-82 21:47")
(* installed instead of KEYHANDLER by RESETSTACK when KEYHANDLER is not CCODEP,
e.g. inside MICROTEST where LLKEY is not loaded)
(PROG NIL (* FOR PRE-WIND VERSION ACTUALLY. INCLUDED SO THAT MICROTEST CAN RUN WITHOUT KBD
HANDLER)
LP (\CONTEXTAPPLY \KbdFXP (FUNCTION \CAUSEINTERRUPT)
\KbdFXP)
(\CONTEXTSWITCH \KbdFXP)
(GO LP])
(\DUMMYTELERAID
[LAMBDA NIL (* bvm: "14-MAR-83 22:09")
(PROG NIL
LP (\CONTEXTSWITCH \TeleRaidFXP)
(GO LP])
(\CAUSEINTERRUPT
[LAMBDA (CNTXT FN) (* bvm: " 6-APR-83 15:40")
(* Builds a frame for FN (default is \INTERRUPTFRAME) on top of the fx in the CNTXT slot of interface page,
returning T on success)
(PROG ((FRAME (\GETBASE \InterfacePage CNTXT))
NXT)
(COND
((ILESSP FRAME (fetch (IFPAGE StackBase) of \InterfacePage))
(* I can't actually test \INTERRUPTABLE, because that might fault! I assume that any context that lives lower than
the keyboard handler is uninterruptable. This is mainly so I don't build an \INTERRUPTED frame on top of the fault
handler)
(* You might want to allow a RAID interrupt here, but that could be VERY dangerous if a fault is in progress, so
best wait.)
(RETURN)))
(SETQ NXT (fetch (FX NEXTBLOCK) of FRAME))
(CHECK (fetch (FX CHECKED) of FRAME)
(type? FSB NXT))
(RETURN (COND
((SETQ FRAME (\MAKEFRAME (OR FN (FUNCTION \INTERRUPTFRAME))
NXT
(IPLUS NXT (fetch (FSB SIZE) of NXT))
FRAME FRAME))
(\PUTBASE \InterfacePage CNTXT FRAME)
T])
(\CONTEXTAPPLY
[LAMBDA (CNTXT FN ARG) (* lmm "13-OCT-81 10:01")
(PROG ((MYALINK (\MYALINK)))
(\SMASHLINK NIL (GETBASE \InterfacePage CNTXT))
(RETURN (PROG1 (SPREADAPPLY* FN ARG)
(\SMASHLINK NIL MYALINK])
(\INTERRUPTFRAME
[LAMBDA NOBIND (* bvm: " 7-MAY-82 16:55")
(COND
(WINDFLG (\INTERRUPTED))
(T (INTERRUPTED])
(\INTERRUPTED
[LAMBDA NIL (* lmm " 5-DEC-82 20:53")
(COND
(\INTERRUPTABLE (INTERRUPTED))
(T (SETQ \PENDINGINTERRUPT T) (* Wrong, we weren't interruptable after all.
Tell keyboard to try again later)
])
(\CODEFORTFRAME
[LAMBDA NIL (* lmm "23-JUL-81 08:54")
(\CALLME T)
(CLEARSTK (QUOTE **CLEAR**))
(INITIALEVALQT)
(PROG NIL
LP (\REPEATEDLYEVALQT)
(GO LP])
(\DOMISCAPPLY
[LAMBDA NIL (* bvm: "30-NOV-82 12:28")
(\DOMISCAPPLY1])
(\DOMISCAPPLY1
[LAMBDA NIL (* bvm: "30-NOV-82 12:29")
(* * Utility context to perform selected operations in a "safe" area of the stack. Use \MISCAPPLY* macro to "call"
)
(* * The compiler emits a BIND for the SPREADAPPLY* below, hence we cannot do this at the root of the stack.
Sigh)
(PROG NIL
LP (replace (IFPAGE MISCSTACKRESULT) of \InterfacePage with (SPREADAPPLY*(fetch (IFPAGE
MISCSTACKFN)
of \InterfacePage)
(fetch (IFPAGE MISCSTACKARG1)
of \InterfacePage)
(fetch (IFPAGE MISCSTACKARG2)
of \InterfacePage)))
(\CONTEXTSWITCH \MiscFXP)
(GO LP])
)
(RPAQ? STACKTESTING T)
(* Stack overflow handler)
(DEFINEQ
(\DOSTACKFULLINTERRUPT
[LAMBDA NIL (* bvm: " 4-Nov-85 17:34")
(replace STACKOVERFLOW of \INTERRUPTSTATE with NIL)
(RESETLST (RESETSAVE NIL (LIST (FUNCTION \CLEANUP.STACKFULL)))
(STACK.FULL.WARNING T])
(STACK.FULL.WARNING
[LAMBDA (FLG) (* bvm: " 4-Nov-85 18:11")
(DECLARE (SPECVARS FLG)) (* Otherwise compiler optimizes this away)
(COND
(FLG (* True on call from \DOSTACKFULLINTERRUPT and NIL
after we get into break. This way user can say OK to
resume computation)
(SETQ FLG NIL)
(PROG ((HELPFLAG (QUOTE BREAK!)))
(LISPERROR "STACK OVERFLOW" NIL T])
(\CLEANUP.STACKFULL
[LAMBDA NIL (* bvm: " 5-Nov-85 11:22")
(* * On a RESETSAVE around the stack full break, so that ↑ or ↑D from the break will do a HARDRESET)
(COND
((SELECTQ AUTOHARDRESETFLG
(NIL NIL)
((ERROR RESET)
(EQ RESETSTATE AUTOHARDRESETFLG))
(SELECTQ RESETSTATE
((ERROR RESET)
T)
NIL))
(SETQ \STACKOVERFLOW)
(HARDRESET])
)
(RPAQ? \PENDINGINTERRUPT )
(RPAQ? \STACKOVERFLOW )
(RPAQ? AUTOHARDRESETFLG T)
(ADDTOVAR RESETFORMS (SETQ \STACKOVERFLOW))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS AUTOHARDRESETFLG)
)
(DECLARE: DONTCOPY
(ADDTOVAR INEWCOMS (FNS SETUPSTACK \SETUPSTACK1 \SETUPGUARDBLOCK \MAKEFREEBLOCK)
(ALLOCAL (ADDVARS (LOCKEDFNS \RESETSTACK0 \MAKEFRAME \SETUPSTACK1 \MAKEFREEBLOCK
\FAULTHANDLER \KEYHANDLER \DUMMYKEYHANDLER \DOTELERAID
\DUMMYTELERAID \DOHARDRETURN \DOGC \CAUSEINTERRUPT
\INTERRUPTFRAME \CODEFORTFRAME \DOSTACKOVERFLOW \UNLOCKPAGES
\DOMISCAPPLY)
(LOCKEDVARS \InterfacePage \DEFSPACE \STACKSPACE \KBDSTACKBASE
\MISCSTACKBASE))))
(ADDTOVAR EXPANDMACROFNS ADDSTACKBASE STACKADDBASE)
EVAL@COMPILE
(ADDTOVAR DONTCOMPILEFNS SETUPSTACK)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA \INTERRUPTFRAME)
)
(PUTPROPS LLSTK COPYRIGHT ("Xerox Corporation" 1982 1983 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (14877 16963 (\MYARGCOUNT 14887 . 15226) (\ARG0 15228 . 16019) (\SETARG0 16021 . 16961))
(16964 39156 (\HARDRETURN 16974 . 17249) (\DOHARDRETURN 17251 . 17523) (\DOGC1 17525 . 17779) (\DOGC
17781 . 17946) (\DOHARDRETURN1 17948 . 24138) (\DOSTACKOVERFLOW 24140 . 24476) (\MOVEFRAME 24478 .
27576) (\INCUSECOUNT 27578 . 28608) (\DECUSECOUNT 28610 . 30411) (\MAKESTACKP 30413 . 31153) (
\SMASHLINK 31155 . 33268) (\FREESTACKBLOCK 33270 . 36798) (\EXTENDSTACK 36800 . 37910) (\SLOWRETURN
37912 . 38177) (\COPY.N.UFN 38179 . 38416) (\POP.N.UFN 38418 . 38905) (\STORE.N.UFN 38907 . 39154)) (
39157 43152 (\GCSCANSTACK 39167 . 43150)) (43153 45062 (CLEARSTK 43163 . 44339) (HARDRESET 44341 .
44576) (RELSTK 44578 . 44879) (RELSTKP 44881 . 45060)) (45063 57720 (SETUPSTACK 45073 . 46564) (
\SETUPSTACK1 46566 . 49234) (\MAKEFRAME 49236 . 49684) (\RESETSTACK 49686 . 49866) (\RESETSTACK0 49868
. 52977) (\SETUPGUARDBLOCK 52979 . 53226) (\MAKEFREEBLOCK 53228 . 53613) (\REPEATEDLYEVALQT 53615 .
53801) (\DUMMYKEYHANDLER 53803 . 54341) (\DUMMYTELERAID 54343 . 54527) (\CAUSEINTERRUPT 54529 . 55772)
(\CONTEXTAPPLY 55774 . 56033) (\INTERRUPTFRAME 56035 . 56216) (\INTERRUPTED 56218 . 56539) (
\CODEFORTFRAME 56541 . 56791) (\DOMISCAPPLY 56793 . 56927) (\DOMISCAPPLY1 56929 . 57718)) (57784 59176
(\DOSTACKFULLINTERRUPT 57794 . 58093) (STACK.FULL.WARNING 58095 . 58680) (\CLEANUP.STACKFULL 58682 .
59174)))))
STOP