(FILECREATED "22-JUN-83 18:53:48" {PHYLUM}<LISPCORE>SOURCES>LLSTK.;34 151616Q
changes to: (FNS \SETUPSTACK1)
previous date: "22-JUN-83 15:11:07" {PHYLUM}<LISPCORE>SOURCES>LLSTK.;33)
(* Copyright (c) 1982, 1983 by Xerox Corporation)
(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 14Q)
))
(CONSTANTS \MAXSAFEUSECOUNT)
(RECORDS NAMETABLESLOT FVARSLOT PVARSLOT STKTEMPSLOT)
(CONSTANTS \NT.IVAR \NT.PVAR \NT.FVAR)))
(* FOR LAMBDA* FUNCTIONS)
(FNS \MYARGCOUNT \ARG0 \SETARG0)
(FNS \HARDRETURN \DOHARDRETURN \DOGC1 \DOGC \DOHARDRETURN1 \DOSTACKOVERFLOW \MOVEFRAME
\INCUSECOUNT \DECUSECOUNT \MAKESTACKP \SMASHLINK \MOVEBLOCK \FREESTACKBLOCK \EXTENDSTACK)
(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)
(\PENDINGINTERRUPT)
(\STACKOVERFLOW))
(ADDVARS (RESETFORMS (SETQ \STACKOVERFLOW)))
(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 10Q)
(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 10Q)
(#ALINK WORD)
(FNHEADLO WORD)
(FNHEADHI1 BYTE)
(FNHEADHI2 BYTE)
(NEXTBLOCK WORD)
(PC WORD)
(NAMETABLO WORD)
(NAMETABHI1 BYTE)
(NAMETABHI2 BYTE)
(#BLINK WORD)
(#CLINK WORD)))
(TYPE? (IEQ (fetch (FX FLAGS) of DATUM)
\STK.FX))
(ACCESSFNS FX ([FNHEADER (\VAG2 (fetch FNHEADHI of DATUM)
(fetch FNHEADLO of DATUM))
(PROGN (replace FNHEADHI of DATUM with (\HILOC NEWVALUE))
(replace FNHEADLO of DATUM with (\LOLOC NEWVALUE]
(FNHEADHI (fetch FNHEADHI2 of DATUM)
(PROGN (replace FNHEADHI1 of DATUM with NEWVALUE)
(replace FNHEADHI2 of DATUM with NEWVALUE)))
[NAMETABLE# (\VAG2 (fetch NAMETABHI of DATUM)
(fetch NAMETABLO of DATUM))
(PROGN (replace NAMETABHI of DATUM with (\HILOC NEWVALUE))
(replace NAMETABLO of DATUM with (\LOLOC NEWVALUE]
(NAMETABLE (COND
((fetch VALIDNAMETABLE of DATUM)
(fetch NAMETABLE# of DATUM))
(T (fetch FNHEADER of DATUM)))
(PROGN (replace FAST of DATUM with NIL)
(replace NAMETABLE# of DATUM with NEWVALUE)
(replace VALIDNAMETABLE of DATUM with T)))
(NAMETABHI (fetch NAMETABHI2 of DATUM)
(PROGN (replace NAMETABHI1 of DATUM with NEWVALUE)
(replace NAMETABHI2 of DATUM with NEWVALUE)))
(FRAMENAME (fetch (FNHEADER FRAMENAME) of (fetch (FX NAMETABLE)
of DATUM)))
(INVALIDP (ZEROP DATUM))
(FIRSTPVAR (IPLUS DATUM (fetch FXSIZE of T)))
(FXSIZE (PROGN 12Q))
[FASTP (EVENP (fetch #ALINK of DATUM)
WORDSPERCELL)
(PROGN (CHECK (NULL NEWVALUE))
(COND
((fetch (FX FASTP) of DATUM)
(replace #BLINK of DATUM with (fetch DUMMYBF
of DATUM))
(replace #CLINK of DATUM with (fetch #ALINK of DATUM))
(replace #ALINK of DATUM
with (IPLUS (fetch #ALINK of DATUM)
(SUB1 WORDSPERCELL]
(BLINK (COND
((fetch (FX FASTP) of DATUM)
(fetch DUMMYBF of DATUM))
(T (fetch #BLINK of DATUM)))
(PROGN (replace (FX FASTP) of DATUM with NIL)
(replace #BLINK of DATUM with NEWVALUE)))
[CLINK (IDIFFERENCE (COND
((fetch (FX FASTP) of DATUM)
(fetch #ALINK of DATUM))
(T (fetch #CLINK of DATUM)))
\#ALINK.OFFSET)
(PROGN (replace (FX FASTP) of DATUM with NIL)
(replace #CLINK of DATUM with (IPLUS NEWVALUE \#ALINK.OFFSET]
[ALINK (IDIFFERENCE (FLOOR (fetch #ALINK of DATUM)
WORDSPERCELL)
\#ALINK.OFFSET)
(PROGN (replace (FX FASTP) of DATUM with NIL)
(replace #ALINK of DATUM with (IPLUS NEWVALUE \#ALINK.OFFSET
(SUB1 WORDSPERCELL]
(DUMMYBF (IDIFFERENCE DATUM WORDSPERCELL))
(IVAR (fetch (BF IVAR) of (fetch 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 15Q)
(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 12Q)
(CONSTANTS \#ALINK.OFFSET)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR 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 15Q)
(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 1400Q)
(RPAQ \InitStackSize (ITIMES \StackAreaSize 14Q))
(CONSTANTS \StackAreaSize (\InitStackSize (ITIMES \StackAreaSize 14Q)))
)
(DECLARE: EVAL@COMPILE
(RPAQQ \MAXSAFEUSECOUNT 310Q)
(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 (ZEROP (fetch PVHI of DATUM])
(BLOCKRECORD STKTEMPSLOT ((STKTMPHI BYTE)
(VALUE XPOINTER))
[ACCESSFNS STKTEMPSLOT ((BINDINGPTRP (NOT (ZEROP (fetch STKTMPHI
of DATUM])
]
(DECLARE: EVAL@COMPILE
(RPAQQ \NT.IVAR 0)
(RPAQQ \NT.PVAR 200Q)
(RPAQQ \NT.FVAR 300Q)
(CONSTANTS \NT.IVAR \NT.PVAR \NT.FVAR)
)
(* END EXPORTED DEFINITIONS)
)
(* 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) (* lmm " 6-OCT-81 23:15")
(* 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 \STACKSPACE (IPLUS (fetch (BF IVAR) of BFLINK)
(LLSH (SUB1 N)
1))
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: " 4-JAN-83 15:25")
(* 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 (FNHEADER FRAMENAME) of (fetch (FX FNHEADER) 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 FASTP) of NEW with NIL)
(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 ALINK) of RETURNER with NEW)
(replace (FX CLINK) 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: " 4-JAN-83 15:07")
(FLIPCURSORBAR 10)
(PROG (AX NEW (SIZE (IPLUS (fetch (FX SIZE) of OLDFRAME)
WORDSPERCELL))
(NXT (fetch (FX NEXTBLOCK) of OLDFRAME)))
[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)
(ZEROP (fetch (FX USECNT) of OLDFRAME))
(NOT \INTERRUPTABLE)
(PROG ((FREESIZE 0)
(NXT (fetch (FX NEXTBLOCK) of OLDFRAME)))
(while (type? FSB NXT)
do (add FREESIZE (fetch (FSB SIZE) of NXT))
(add NXT (fetch (FSB SIZE) of NXT)))
(RETURN (ILEQ FREESIZE 1000]
(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))
(replace (FX FASTP) of NEW with NIL)
(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))
(CHECK ([LAMBDA (N)
(AND (IGREATERP N OLDFRAME)
(ILESSP N (fetch (FX NEXTBLOCK) of OLDFRAME]
(fetch (FX NAMETABLO) 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) (* lmm " 6-OCT-81 23:17")
[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)
(RAID "Stack frame use count maximum exceeded")))
(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) (* lmm "21-APR-80 12:59")
(* Create a STACKP cell, possibly reusing ED, and
pointing to FX)
[UNINTERRUPTABLY (COND
((NEQ FX 0)
(\INCUSECOUNT FX)))
(COND
((STACKP ED)
(PROG ((OLD (fetch EDFXP of ED)))
(COND
((NEQ OLD 0)
(\DECUSECOUNT OLD)))
(replace EDFXP of ED with FX)))
(T (SETQ ED (CREATECELL \STACKP))
(PUTBASE ED 0 \STACKHI)
(replace EDFXP of ED with FX]
ED])
(\SMASHLINK
[LAMBDA (CALLER ALINK CLINK) (* bvm: "16-OCT-81 10:40")
(* 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)))
(ZEROP (fetch (FX USECNT) of CLINK))
(EQ (SETQ BLINK (fetch (FX BLINK) of CALLER))
(fetch (FX DUMMYBF) of CALLER))
(EQ (fetch (BF IVAR) of BLINK)
(fetch (FX NEXTBLOCK) of CLINK))
(ZEROP (fetch (BF USECNT) of BLINK))
(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 #ALINK of CALLER with (IPLUS ALINK \#ALINK.OFFSET]
(RETURN CALLER)))])
(\MOVEBLOCK
[LAMBDA (TO FROM N) (* lmm " 5-NOV-80 16:07")
(* the caller will have to turn off INTs if it wants them off)
(PROG NIL
LP (COND
((ZEROP N)
NIL)
(T (PUTBASE TO (SETQ N (SUB1 N))
(GETBASE FROM N))
(GO LP])
(\FREESTACKBLOCK
[LAMBDA (N START) (* bvm: "28-OCT-82 12:28")
(* 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 (RAID "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])
)
(DEFINEQ
(\GCSCANSTACK
[LAMBDA NIL (* bvm: " 7-MAY-82 18:31")
(* scan stack space calling SCANREF on all pointers)
(PROG ((SCANPTR (fetch StackBase of \InterfacePage))
(EASP (fetch EndOfStack of \InterfacePage))
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 Q (fetch (FX FIRSTPVAR) of SCANPTR))
(FRPTQ (fetch (FX FNHEADER NLOCALS) of SCANPTR)
[COND
((fetch (PVARSLOT BOUND) of (ADDSTACKBASE Q))
(\STKREF (STACKGETBASEPTR Q]
(add Q 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)
(SCANREF (fetch (FX NAMETABLE) of SCANPTR]
(SETQ SCANPTR (fetch (FX FIRSTTEMP) of SCANPTR))
SCANTEMPS
(while (ILESSP SCANPTR Q) do [COND
((NOT (fetch (STKTEMPSLOT
BINDINGPTRP)
of (ADDSTACKBASE SCANPTR)))
(SCANREF (STACKGETBASEPTR SCANPTR]
(add SCANPTR 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)
(until (type? BF SCANPTR) do (CHECK (EQ (fetch (STK FLAGS) of SCANPTR)
\STK.NOTFLAG))
(\STKREF (STACKGETBASEPTR SCANPTR))
(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)))
(GO LP])
)
(DEFINEQ
(CLEARSTK
[LAMBDA (FLG) (* lmm "28-JUL-81 15:38")
(PROG (LST)
[\MAPMDS \STACKP (FUNCTION (LAMBDA (PAGE)
(PROG ((I 0)
(PTR (create POINTER
PAGE# ← PAGE))
FX)
LPE [COND
((AND (EQ (GETBASE PTR I)
\STACKHI)
(NEQ (SETQ FX (GETBASE PTR (ADD1 I)))
0))
(SELECTQ FLG
[NIL (UNINTERRUPTABLY (PROGN (replace EDFXP
of (ADDBASE PTR I)
with 0)
(\DECUSECOUNT FX]
(**CLEAR** (replace EDFXP of (ADDBASE PTR I) with 0))
(push LST (ADDBASE PTR I]
(COND
((NEQ (SETQ I (IPLUS I WORDSPERCELL))
\MDSIncrement)
(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) (* lmm "27-JUL-81 09:42")
(AND (STACKP X)
(ZEROP (fetch EDFXP of X])
)
(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 "22-JUN-83 18:50")
(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 (CAR ARGS))
(* store args)
(SETQ ARGS (CDR 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 177777Q)
(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)
(RPAQ? \PENDINGINTERRUPT )
(RPAQ? \STACKOVERFLOW )
(ADDTOVAR RESETFORMS (SETQ \STACKOVERFLOW))
(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" 3676Q 3677Q))
(DECLARE: DONTCOPY
(FILEMAP (NIL (30601Q 34442Q (\MYARGCOUNT 30613Q . 31336Q) (\ARG0 31340Q . 32767Q) (\SETARG0 32771Q .
34440Q)) (34443Q 104660Q (\HARDRETURN 34455Q . 35100Q) (\DOHARDRETURN 35102Q . 35522Q) (\DOGC1 35524Q
. 36122Q) (\DOGC 36124Q . 36371Q) (\DOHARDRETURN1 36373Q . 52351Q) (\DOSTACKOVERFLOW 52353Q . 53073Q)
(\MOVEFRAME 53075Q . 60633Q) (\INCUSECOUNT 60635Q . 62610Q) (\DECUSECOUNT 62612Q . 66223Q) (
\MAKESTACKP 66225Q . 67455Q) (\SMASHLINK 67457Q . 73374Q) (\MOVEBLOCK 73376Q . 74100Q) (
\FREESTACKBLOCK 74102Q . 102526Q) (\EXTENDSTACK 102530Q . 104656Q)) (104661Q 114021Q (\GCSCANSTACK
104673Q . 114017Q)) (114022Q 116761Q (CLEARSTK 114034Q . 115461Q) (HARDRESET 115463Q . 116036Q) (
RELSTK 116040Q . 116515Q) (RELSTKP 116517Q . 116757Q)) (116762Q 147564Q (SETUPSTACK 116774Q . 121717Q)
(\SETUPSTACK1 121721Q . 127116Q) (\MAKEFRAME 127120Q . 130020Q) (\RESETSTACK 130022Q . 130306Q) (
\RESETSTACK0 130310Q . 136355Q) (\SETUPGUARDBLOCK 136357Q . 136746Q) (\MAKEFREEBLOCK 136750Q . 137551Q
) (\REPEATEDLYEVALQT 137553Q . 140045Q) (\DUMMYKEYHANDLER 140047Q . 141101Q) (\DUMMYTELERAID 141103Q
. 141373Q) (\CAUSEINTERRUPT 141375Q . 143730Q) (\CONTEXTAPPLY 143732Q . 144335Q) (\INTERRUPTFRAME
144337Q . 144624Q) (\INTERRUPTED 144626Q . 145327Q) (\CODEFORTFRAME 145331Q . 145723Q) (\DOMISCAPPLY
145725Q . 146133Q) (\DOMISCAPPLY1 146135Q . 147562Q)))))
STOP