(FILECREATED " 2-Jul-86 13:20:28" {ERIS}<LISPCORE>SOURCES>ASTACK.;7 36232
changes to: (FNS STKNAME \STACKARGPTR STKPOS \STKNAME)
(VARS ASTACKCOMS)
previous date: " 1-Jun-86 17:48:18" {ERIS}<LISPCORE>SOURCES>ASTACK.;6)
(* Copyright (c) 1982, 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT ASTACKCOMS)
(RPAQQ ASTACKCOMS [(COMS (* ARG and SETARG, unusual cases)
(FNS ARG SETARG \ARG \ARGPTR \SETARG))
(COMS (FNS \RETURN \STACKARGPTR))
(COMS (* User level stack management)
(FNS STKNTH STKNTHNAME STKNAME \STKNAME SETSTKNAME \COPYFNHEADER)
(FNS STKPOS STKSCAN SETCLINK RETFROM RETTO RESUME \RESUME RESET ERROR!)
(FNS STKARG SETSTKARG STKARGNAME \SPREADFRAMEP SETSTKARGNAME STKNARGS
FRAMESCAN \INTERPFRAMENT \FRAMESCAN \VAROFFSET))
(LOCALVARS . T)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML SETARG ARG)
(LAMA])
(* ARG and SETARG, unusual cases)
(DEFINEQ
(ARG
[NLAMBDA (VAR M) (* lmm "24-JUL-81 07:43")
(GETBASEPTR \STACKSPACE (\ARGPTR VAR (\EVAL M])
(SETARG
[NLAMBDA (VAR M X) (* lmm "24-JUL-81 07:43")
(PUTBASEPTR \STACKSPACE (\ARGPTR VAR (\EVAL M))
(\EVAL X])
(\ARG
[LAMBDA (VAR M) (* lmm "24-JUL-81 07:43")
(* Version of ARG which doesn't EVAL 2nd argument)
(GETBASEPTR \STACKSPACE (\ARGPTR VAR M])
(\ARGPTR
[LAMBDA (VAR N) (* lmm "13-FEB-83 14:17")
(* * Returns a pointer to the basic frame corresponding to the lambda* variable VAR, and tests that N is a legal
arg#)
(PROG ((FRAME (\MYALINK))
(A (\ATOMVALINDEX VAR))
(INTERPDEF (fetch (LITATOM DEFPOINTER) of (QUOTE \INTERPRETER)))
BFLINK P DEF NARGS)
LP (COND
((fetch (FX INVALIDP) of FRAME)
(* No frame found)
(LISPERROR "ILLEGAL ARG" VAR)))
(COND
((EQ (SETQ DEF (fetch (FX FNHEADER) of FRAME))
INTERPDEF) (* See if this is \INTERPRETER running a LAMBDA*)
(OR [AND (SETQ P (\VAROFFSET FRAME A))
(EQ P (IPLUS (fetch (BF IVAR) of (SETQ BFLINK (fetch (FX BLINK) of FRAME)))
(UNFOLD (SETQ NARGS (SUB1 (fetch (BF NARGS) of BFLINK)))
WORDSPERCELL]
(GO NXT)))
[(AND (EQ (fetch (FNHEADER NA) of DEF)
-1)
(SETQ P (\VAROFFSET FRAME A))
(EQ P (fetch (FX FIRSTPVAR) of FRAME)))
(SETQ NARGS (fetch (BF NARGS) of (SETQ BFLINK (fetch (FX BLINK) of FRAME]
(T (GO NXT))) (* Found the variable as the first PROG variable of a LSTARP frame)
[RETURN (COND
((AND (IGREATERP N 0)
(NOT (IGREATERP N NARGS)))
(IPLUS (fetch (BF IVAR) of BFLINK)
(UNFOLD (SUB1 N)
WORDSPERCELL)))
(T (LISPERROR "ILLEGAL ARG" N]
NXT (SETQ FRAME (fetch (FX ALINK) of FRAME))
(GO LP])
(\SETARG
[LAMBDA (VAR M X) (* lmm "24-JUL-81 07:43")
(* VERSION OF SETARG WHICH DOESN'T EVAL 2ND AND 3RD ARGUMENTS.)
(PUTBASEPTR \STACKSPACE (\ARGPTR VAR M)
X])
)
(DEFINEQ
(\RETURN
[LAMBDA (X) (* lmm " 6-OCT-81 23:28")
(DECLARE (LOCALVARS . T)) (* for use by the LLBREAK package)
(RAID X)
(PROG1 X (\SMASHLINK NIL (SETQ X (fetch (FX CLINK) of (\MYALINK)))
X])
(\STACKARGPTR
[LAMBDA (POS) (* lmm " 2-Jul-86 12:55")
(* return the index of the frame
extension corresponding to POS or
cause appropriate error)
(COND
[(OR (STACKP POS)
(TYPENAMEP POS (QUOTE PROCESS))) (* if POS is STACKP, it is merely the
contents)
(COND
((EQ (fetch EDFXP of POS)
0)
(LISPERROR "STACK PTR HAS BEEN RELEASED" POS))
(T (fetch EDFXP of POS]
(T (PROG ((FX (\MYALINK))
(P POS))
[COND
((NULL POS) (* those functions which allow NIL
should explicitly check for it.)
(LISPERROR "ILLEGAL STACK ARG" POS))
[(EQ POS T) (* scan up for top frame.
This could possibly be a constant,
although there might be some
circumstances where it could move)
(PROG NIL
TOPLP
(COND
([NOT (fetch (FX INVALIDP) of (SETQ P (fetch (FX CLINK) of FX]
(SETQ FX P)
(GO TOPLP]
[(NUMBERP POS)
(COND
((EQ (SETQ P (FIX POS))
0)
(SETQ P 1)))
(COND
[(IGREATERP P 0)
(PROG NIL
ALP (COND
((fetch (FX INVALIDP) of (SETQ FX (fetch (FX ALINK) of FX)))
(LISPERROR "ILLEGAL STACK ARG" POS))
((NEQ (SETQ P (SUB1 P))
0)
(GO ALP]
(T (PROG NIL
(SETQ P (IMINUS P))
CLP (COND
((fetch (FX INVALIDP) of (SETQ FX (fetch (FX CLINK) of FX)))
(LISPERROR "ILLEGAL STACK ARG" POS))
((NEQ (SETQ P (SUB1 P))
0)
(GO CLP]
(T (* implicit STKPOS searching for a
given name)
(PROG NIL
SCNLP
(COND
((fetch (FX INVALIDP) of (SETQ FX (fetch (FX CLINK) of FX)))
(LISPERROR "ILLEGAL STACK ARG" POS))
((NOT (EQMEMB (\STKNAME FX)
POS))
(GO SCNLP]
(COND
((IGEQ (fetch (FX USECNT) of FX)
\MAXSAFEUSECOUNT)
(LISPERROR "ILLEGAL STACK ARG" POS)))
(RETURN FX])
)
(* User level stack management)
(DEFINEQ
(STKNTH
[LAMBDA (N IPOS OPOS) (* bvm: " 5-Feb-85 15:50")
(PROG ((I (OR N -1))
CFLAG FRAME)
[COND
((ILESSP I 0)
(SETQ CFLAG T)
(SETQ I (IMINUS I]
[SETQ FRAME (COND
(IPOS (\STACKARGPTR IPOS))
((EQ I 0)
(LISPERROR "ILLEGAL STACK ARG" N))
(T (add I -1)
(\MYALINK]
LP [COND
((fetch (FX INVALIDP) of FRAME)
(RELSTK OPOS)
(RETURN))
((EQ I 0)
(RETURN (\MAKESTACKP OPOS FRAME)))
(CFLAG (SETQ FRAME (fetch (FX CLINK) of FRAME)))
(T (SETQ FRAME (fetch (FX ALINK) of FRAME]
(SETQ I (SUB1 I))
(GO LP])
(STKNTHNAME
[LAMBDA (N POS) (* bvm: " 5-Feb-85 15:51")
(PROG ((I (OR N -1))
CFLAG FRAME)
[COND
((ILESSP I 0)
(SETQ CFLAG T)
(SETQ I (IMINUS I]
[SETQ FRAME (COND
(POS (\STACKARGPTR POS))
((EQ I 0)
(LISPERROR "ILLEGAL STACK ARG" N))
(T (add I -1)
(\MYALINK]
LP [COND
((fetch (FX INVALIDP) of FRAME)
(RETURN))
((EQ I 0)
(RETURN (fetch (FX FRAMENAME) of FRAME)))
(CFLAG (SETQ FRAME (fetch (FX CLINK) of FRAME)))
(T (SETQ FRAME (fetch (FX ALINK) of FRAME]
(SETQ I (SUB1 I))
(GO LP])
(STKNAME
[LAMBDA (POS) (* lmm " 2-Jul-86 12:37")
(\STKNAME (\STACKARGPTR POS])
(\STKNAME
[LAMBDA (POS) (* lmm " 2-Jul-86 12:37")
(LET* ((NAME (fetch (FX FRAMENAME) of POS)))
(if (EQ NAME (QUOTE \INTERPRETER))
then [\GETBASEPTR \STACKSPACE (LET ((BFLINK (fetch (FX BLINK) of POS)))
(IPLUS (fetch (BF IVAR) of BFLINK)
(TIMES (SUB1 (fetch (BF NARGS) of BFLINK))
WORDSPERCELL]
else NAME])
(SETSTKNAME
[LAMBDA (POS NAME) (* bvm: "15-Aug-84 11:13")
(PROG ((FRAME (\STACKARGPTR POS))
FNH)
[COND
((fetch (FX VALIDNAMETABLE) of FRAME) (* There is already a copied nametable here, just smash
it)
(SETQ FNH (fetch (FX NAMETABLE#) of FRAME))
(UNINTERRUPTABLY
(replace (FX VALIDNAMETABLE) of FRAME with NIL)
(* Do this so that the stack remains consistent, even
while uninterruptable. This for SPY etc.)
(COND
((EQ (\HILOC FNH)
\STACKHI) (* Don't refcnt on the stack)
(replace (FNHEADER #FRAMENAME) of FNH with NAME))
(T (replace (FNHEADER FRAMENAME) of FNH with NAME)))
(replace (FX VALIDNAMETABLE) of FRAME with T)))
(T (SETQ FNH (\COPYFNHEADER (fetch (FX FNHEADER) of FRAME)))
(replace (FNHEADER FRAMENAME) of FNH with NAME)
(UNINTERRUPTABLY
(replace (FX NAMETABLE) of FRAME with FNH))]
(RETURN NAME])
(\COPYFNHEADER
[LAMBDA (FNHD) (* bvm: " 5-Feb-85 15:51")
(PROG ((HEADWORDS (UNFOLD (fetch (FNHEADER NTSIZE) of FNHD)
2))
NEWFNHD)
[SETQ HEADWORDS (IPLUS (fetch (FNHEADER OVERHEADWORDS) of T)
(COND
((EQ HEADWORDS 0) (* No name table, but still need to copy quad of zeros)
WORDSPERQUAD)
(T HEADWORDS]
(SETQ NEWFNHD (\ALLOCBLOCK (FOLDHI HEADWORDS WORDSPERCELL)
NIL HEADWORDS))
(\BLT NEWFNHD FNHD HEADWORDS)
(RETURN NEWFNHD])
)
(DEFINEQ
(STKPOS
[LAMBDA (FRAMENAME N IPOS OPOS) (* lmm " 2-Jul-86 13:02")
(PROG (FLAG [FX (COND
((NULL IPOS)
(\MYALINK))
(T (\STACKARGPTR IPOS]
(I (OR N -1)))
[COND
((IGREATERP 0 I)
(SETQ FLAG (SETQ I (IDIFFERENCE 0 I]
LP [COND
((EQ (\STKNAME FX)
FRAMENAME)
(COND
((ILEQ (SETQ I (SUB1 I))
0)
(RETURN (\MAKESTACKP OPOS FX]
(COND
([fetch (FX INVALIDP) of (SETQ FX (COND
(FLAG (fetch (FX CLINK) of FX))
(T (fetch (FX ALINK) of FX]
(RELSTK OPOS)
(RETURN)))
(GO LP])
(STKSCAN
[LAMBDA (VAR IPOS OPOS) (* lmm "13-FEB-83 14:15")
(AND (LITATOM VAR)
(PROG ([FX (COND
((NULL IPOS)
(\MYALINK))
(T (\STACKARGPTR IPOS]
(A (\ATOMVALINDEX VAR)))
LP (COND
((\FRAMESCAN FX A)
(RETURN (\MAKESTACKP OPOS FX)))
((fetch (FX INVALIDP) of (SETQ FX (fetch (FX ALINK) of FX)))
(RELSTK OPOS)
(RETURN))
(T (GO LP])
(SETCLINK
[LAMBDA (FRAME NEWLINK RELEASEFLG)
(* lmm " 6-OCT-81 23:34")
(PROG (PX (FX (\STACKARGPTR FRAME))
(NX (\STACKARGPTR NEWLINK)))
(SETQ PX NX)
LP (COND
((EQ PX FX) (* Circular stack would result)
(RETURN NIL))
((fetch (FX INVALIDP) of PX)
(* Got to the top first. We're safe)
(GO OUT)))
(SETQ PX (fetch (FX CLINK) of PX))
(GO LP)
OUT (\SMASHLINK FX NIL NX)
(COND
(RELEASEFLG (RELSTK NEWLINK)))
(RETURN FRAME])
(RETFROM
[LAMBDA (POS VAL FLG) (* bvm: " 5-Feb-85 15:52")
(PROG ((P (\STACKARGPTR POS)))
(COND
((fetch (FX INVALIDP) of (SETQ P (fetch (FX CLINK) of P)))
(LISPERROR "ILLEGAL RETURN" VAL)))
(\SMASHLINK NIL P P)
(AND FLG (RELSTK POS))
(RETURN VAL])
(RETTO
[LAMBDA (POS VAL FLG) (* lmm "13-Mar-85 11:56")
(if (EQ POS T)
then (RESET)
else (PROG ((P (\STACKARGPTR POS)))
(\SMASHLINK NIL P P)
(AND FLG (RELSTK POS))
(RETURN VAL])
(RESUME
[LAMBDA (FROMPTR TOPTR VAL) (* lmm " 6-OCT-81 23:35")
(* FROMPTR is a stkptr which is smashed to contain a pointer to the caller of RESUME. Control is transfered to the
frame specified by TOPTR, releasing that stack pointer. A call to this RESUME returns VAL as the value of the RESUME
specified by TOPTR.)
(PROG [[FROMFX (fetch EDFXP of (\DTEST FROMPTR (QUOTE STACKP]
(TOFX (fetch EDFXP of (\DTEST TOPTR (QUOTE STACKP]
(COND
((fetch (FX INVALIDP) of TOFX)
(LISPERROR "STACK PTR HAS BEEN RELEASED" TOPTR)))
(UNINTERRUPTABLY
(COND
((NOT (fetch (FX INVALIDP) of FROMFX))
(* Release FROMPTR if it hasn't been yet)
(\DECUSECOUNT FROMFX)))
(replace EDFXP of FROMPTR with (\MYALINK))
(replace EDFXP of TOPTR with 0)
(\RESUME TOFX)))
VAL])
(\RESUME
[LAMBDA (FRAME) (* bvm: " 5-Jun-85 17:08")
(replace (FX ACLINK) of (\MYALINK) with FRAME)
FRAME])
(RESET
[LAMBDA NIL (* bvm: "24-JUL-83 16:28")
(PROG ((FX (\MYALINK)))
LP [COND
((SELECTQ (fetch (FX FRAMENAME) of FX)
((T \MAKE.PROCESS0 \REPEATEDLYEVALQT)
T)
NIL)
(* In process world, try to return to top level exec frame (\REPEATEDLYEVALQT), or to the top of the process,
which will decide whether to restart or kill the process. In non-process world, we eventually return to the T
frame)
(\SMASHLINK NIL FX FX)
(RETURN \PROC.RESETME))
((fetch (FX INVALIDP) of (SETQ FX (fetch (FX CLINK) of FX)))
(RETURN (printout PROMPTWINDOW .TAB0 0 "Can't find top of stack!!!"]
(GO LP])
(ERROR!
[LAMBDA NIL (* lmm " 6-OCT-81 23:36")
(PROG ((FX (\MYALINK))
NFX)
LP (COND
((EQ (fetch (FX FRAMENAME) of FX)
(QUOTE ERRORSET))
(\SMASHLINK NIL (fetch (FX CLINK) of FX)
(fetch (FX ALINK) of FX))
(RETURN))
([NOT (fetch (FX INVALIDP) of (SETQ NFX (fetch (FX CLINK) of FX]
(SETQ FX NFX)
(GO LP))
(T (* return to top)
(\SMASHLINK NIL FX FX)
(RETURN])
)
(DEFINEQ
(STKARG
[LAMBDA (N POS DEFAULT) (* lmm " 1-Jun-86 17:38")
(PROG ((FRAME (\STACKARGPTR POS))
(INDEX N)
BLINK NARGS NT NTSIZE)
(SETQ NT (\INTERPFRAMENT FRAME))
[COND
((LITATOM N)
(SETQ INDEX (OR (\FRAMESCAN FRAME (\ATOMVALINDEX N)
NT)
(LISPERROR "ILLEGAL STACK ARG" N]
(COND
((ILESSP INDEX 1)
(LISPERROR "ILLEGAL STACK ARG" INDEX))
[NT (* Interpreter frame)
(COND
[(\SPREADFRAMEP FRAME)
(OR [AND (IGREATERP INDEX 0)
(ILEQ INDEX (SETQ NARGS (fetch (BF NARGS)
of
(SETQ BLINK (fetch (FX BLINK)
of FRAME]
(LISPERROR "ILLEGAL STACK ARG" INDEX))
(SETQ INDEX (IPLUS (fetch (BF IVAR)
of BLINK)
(UNFOLD (SUB1 INDEX)
WORDSPERCELL]
((OR (IGEQ INDEX (SETQ NTSIZE (fetch (FNHEADER NTSIZE)
of NT)))
(EQ (\GETBASE NT (IPLUS (fetch (FNHEADER OVERHEADWORDS)
of T)
INDEX -1))
0)) (* Out of range)
(LISPERROR "ILLEGAL STACK ARG" INDEX))
(T (SETQ INDEX (IPLUS (SELECTC [fetch (NAMETABLESLOT VARTYPE)
of
(SETQ NT (\ADDBASE
NT
(IPLUS NTSIZE (fetch (FNHEADER
OVERHEADWORDS
)
of T)
INDEX -1]
(\NT.IVAR (fetch (BF IVAR)
of
(fetch (FX BLINK)
of FRAME)))
(\NT.PVAR (fetch (FX FIRSTPVAR)
of FRAME))
(SHOULDNT))
(UNFOLD (fetch (NAMETABLESLOT VAROFFSET)
of NT)
WORDSPERCELL]
[[ILEQ INDEX (SETQ NARGS (fetch (BF NARGS)
of
(SETQ BLINK (fetch (FX BLINK)
of FRAME]
(SETQ INDEX (IPLUS (fetch (BF IVAR)
of BLINK)
(UNFOLD (SUB1 INDEX)
WORDSPERCELL]
[(ILEQ (SETQ INDEX (IDIFFERENCE INDEX NARGS))
(fetch (FX FNHEADER NLOCALS)
of FRAME))
(SETQ INDEX (IPLUS (fetch (FX FIRSTPVAR)
of FRAME)
(UNFOLD (SUB1 INDEX)
WORDSPERCELL]
(T (LISPERROR "ILLEGAL STACK ARG" N)))
(RETURN (COND
((NOT (fetch (PVARSLOT BOUND)
of
(STACKADDBASE INDEX)))
DEFAULT)
(T (STACKGETBASEPTR INDEX])
(SETSTKARG
[LAMBDA (N POS VAL) (* bvm: " 5-Feb-85 15:55")
(PROG ((FRAME (\STACKARGPTR POS))
(INDEX N)
BLINK NARGS NT NTSIZE)
(SETQ NT (\INTERPFRAMENT FRAME))
[COND
((LITATOM N)
(SETQ INDEX (OR (\FRAMESCAN FRAME (\ATOMVALINDEX N)
NT)
(LISPERROR "ILLEGAL STACK ARG" N]
[SETQ INDEX (COND
((ILESSP INDEX 1)
(LISPERROR "ILLEGAL STACK ARG" INDEX))
[NT (* Interpreter frame)
(COND
((OR (IGEQ INDEX (SETQ NTSIZE (fetch (FNHEADER NTSIZE) of NT)))
(EQ (\GETBASE NT (IPLUS (fetch (FNHEADER OVERHEADWORDS) of T)
INDEX -1))
0)) (* Out of range)
(LISPERROR "ILLEGAL STACK ARG" INDEX))
(T (IPLUS (SELECTC [fetch (NAMETABLESLOT VARTYPE)
of (SETQ NT (\ADDBASE NT (IPLUS NTSIZE (fetch (FNHEADER
OVERHEADWORDS)
of T)
INDEX -1]
(\NT.IVAR (fetch (BF IVAR) of (fetch (FX BLINK) of FRAME)))
(\NT.PVAR (fetch (FX FIRSTPVAR) of FRAME))
(SHOULDNT))
(UNFOLD (fetch (NAMETABLESLOT VAROFFSET) of NT)
WORDSPERCELL]
([ILEQ INDEX (SETQ NARGS (fetch (BF NARGS) of (SETQ BLINK (fetch (FX BLINK)
of FRAME]
(IPLUS (fetch (BF IVAR) of BLINK)
(UNFOLD (SUB1 INDEX)
WORDSPERCELL)))
((ILEQ (SETQ INDEX (IDIFFERENCE INDEX NARGS))
(fetch (FX FNHEADER NLOCALS) of FRAME))
(IPLUS (fetch (FX FIRSTPVAR) of FRAME)
(UNFOLD (SUB1 INDEX)
WORDSPERCELL)))
(T (LISPERROR "ILLEGAL STACK ARG" N]
(RETURN (COND
((fetch (PVARSLOT BOUND) of (STACKADDBASE INDEX))
(STACKPUTBASEPTR INDEX VAL))
(T (LISPERROR "ILLEGAL STACK ARG" N])
(STKARGNAME
[LAMBDA (N POS) (* lmm " 1-Jun-86 17:41")
(PROG ((FRAME (\STACKARGPTR POS))
NT NM (NTENTRY N)
NARGS)
(SETQ NT (\INTERPFRAMENT FRAME))
[COND
((LITATOM NTENTRY)
(SETQ NTENTRY (\FRAMESCAN FRAME (\ATOMVALINDEX NTENTRY)
NT]
[COND
(NT (* Interpreted frame)
(RETURN (COND
((\SPREADFRAMEP FRAME) (* LIST (QUOTE ARG) (\INDEXATOMVAL
(\GETBASE NT (fetch (FNHEADER
OVERHEADWORDS) of T))) N)
NIL)
(T (OR [AND (IGREATERP NTENTRY 0)
(ILESSP NTENTRY (fetch (FNHEADER NTSIZE)
of NT))
(\INDEXATOMVAL (\GETBASE NT (IPLUS (fetch (FNHEADER
OVERHEADWORDS
)
of T)
NTENTRY -1]
(LISPERROR "ILLEGAL STACK ARG" N]
(SETQ NT (fetch (FX NAMETABLE)
of FRAME))
[SETQ NTENTRY (COND
((ILEQ NTENTRY 0)
(LISPERROR "ILLEGAL STACK ARG" N))
([ILEQ NTENTRY (SETQ NARGS (fetch (BF NARGS)
of
(fetch (FX BLINK)
of FRAME]
(LOGOR (SUB1 NTENTRY)
IVARCODE))
((ILEQ (SETQ NTENTRY (IDIFFERENCE NTENTRY NARGS))
(fetch (FNHEADER NLOCALS)
of NT))
(COND
([NOT (fetch (PVARSLOT BOUND)
of
(STACKADDBASE (IPLUS (fetch (FX FIRSTPVAR)
of FRAME)
(UNFOLD (SUB1 NTENTRY)
WORDSPERCELL]
(RETURN)))
(LOGOR (SUB1 NTENTRY)
PVARCODE))
(T (LISPERROR "ILLEGAL STACK ARG" N]
(RETURN (for NT1 from (fetch (FNHEADER OVERHEADWORDS)
of T)
as NT2 from (IPLUS (fetch (FNHEADER OVERHEADWORDS)
of NT)
(fetch (FNHEADER NTSIZE)
of NT))
until
(EQ (SETQ NM (\GETBASE NT NT1))
0)
do
(COND
((EQ NTENTRY (\GETBASE NT NT2))
(RETURN (\INDEXATOMVAL NM])
(\SPREADFRAMEP
[LAMBDA (FRAME) (* lmm " 1-Jun-86 17:19")
(LET (NARGS BFLINK)
(EQ (\GETBASEPTR \STACKSPACE (IPLUS (fetch (BF IVAR)
of
(SETQ BFLINK (fetch (FX BLINK)
of FRAME)))
(UNFOLD (SETQ NARGS (SUB1 (fetch (BF NARGS)
of BFLINK)))
WORDSPERCELL)))
NARGS])
(SETSTKARGNAME
[LAMBDA (N POS NAME) (* bvm: " 5-Feb-85 15:56")
(PROG ((FRAME (\STACKARGPTR POS))
NT NM (NTENTRY N)
NARGS)
(SETQ NT (\INTERPFRAMENT FRAME))
[COND
((LITATOM NTENTRY)
(SETQ NTENTRY (\FRAMESCAN FRAME (\ATOMVALINDEX NTENTRY)
NT]
[COND
(NT (* Interpreted frame)
(RETURN (OR [AND (IGREATERP NTENTRY 0)
(ILESSP NTENTRY (fetch (FNHEADER NTSIZE) of NT))
(\INDEXATOMVAL (\GETBASE NT (IPLUS (fetch (FNHEADER OVERHEADWORDS)
of T)
NTENTRY -1]
(LISPERROR "ILLEGAL STACK ARG" N]
(SETQ NT (\COPYFNHEADER (fetch (FX NAMETABLE) of FRAME)))
(* Need to copy nametable in order to smash the var
name)
[SETQ NTENTRY (COND
((ILEQ NTENTRY 0)
(LISPERROR "ILLEGAL STACK ARG" N))
([ILEQ NTENTRY (SETQ NARGS (fetch (BF NARGS) of (fetch (FX BLINK) of FRAME]
(IPLUS (SUB1 NTENTRY)
IVARCODE))
((ILEQ (SETQ NTENTRY (IDIFFERENCE NTENTRY NARGS))
(fetch (FNHEADER NLOCALS) of NT))
(IPLUS (SUB1 NTENTRY)
PVARCODE))
(T (LISPERROR "ILLEGAL STACK ARG" N]
(for NT1 from (fetch (FNHEADER OVERHEADWORDS) of T) as NT2
from (IPLUS (fetch (FNHEADER OVERHEADWORDS) of T)
(fetch (FNHEADER NTSIZE) of NT))
until (EQ (SETQ NM (\GETBASE NT NT1))
0)
do (COND
((EQ NTENTRY (\GETBASE NT NT2))
(\PUTBASE NT NT1 (\ATOMVALINDEX NAME))
(UNINTERRUPTABLY
(replace (FX NAMETABLE) of FRAME with NT))
(RETURN NAME])
(STKNARGS
[LAMBDA (POS INCLUDEPVARS) (* lmm " 1-Jun-86 17:30")
(PROG ((FRAME (\STACKARGPTR POS))
NA INTERPNT)
(RETURN (COND
((SETQ INTERPNT (\INTERPFRAMENT FRAME)) (* this is an interpreted frame.
INTERPNT points at the name table of
the frame)
[COND
((\SPREADFRAMEP FRAME)
(RETURN (SUB1 (fetch (BF NARGS)
of
(fetch (FX BLINK)
of FRAME]
(SETQ NA (fetch (FNHEADER NTSIZE)
of INTERPNT)) (* Return number of vars in nt.
Padded with up to 4 zeros at end, so
have to check)
[COND
((IGREATERP NA 0)
(do (add NA -1)
repeatwhile
(EQ (\GETBASE INTERPNT (IPLUS (fetch (FNHEADER OVERHEADWORDS)
of T)
NA -1))
0]
NA)
(T (SETQ NA (fetch (BF NARGS)
of
(fetch (FX BLINK)
of FRAME)))
(RETURN (COND
(INCLUDEPVARS (IPLUS NA (fetch (FX FNHEADER NLOCALS)
of FRAME)))
(T NA])
(FRAMESCAN
[LAMBDA (ATOM POS) (* lmm "13-FEB-83 14:17")
(PROG ((FX (\STACKARGPTR POS)))
(RETURN (\FRAMESCAN FX (COND
((LITATOM ATOM)
(\ATOMVALINDEX ATOM))
(T (RETURN NIL)))
(\INTERPFRAMENT FX])
(\INTERPFRAMENT
[LAMBDA (FX) (* bvm: " 2-OCT-81 23:32")
(* If FX is an interpreter frame
(nametable is on stack), returns its nametable)
(AND (fetch (FX VALIDNAMETABLE) of FX)
(EQ (fetch (FX NAMETABHI) of FX)
\STACKHI)
(fetch (FX NAMETABLE#) of FX])
(\FRAMESCAN
[LAMBDA (FRAME ATOM# INTERPNT) (* bvm: " 5-Feb-85 15:57")
(* * Returns index of binding of atom number ATOM# in FRAME. Indices of ivars start at 1, of pvars at nargs+1.
If INTERPNT is given, this is an interpreter frame, and we merely return index of atom in its nametable, regardless
of type)
(for OFFSET from (fetch (FNHEADER OVERHEADWORDS) of T) bind (NT ←(OR INTERPNT
(fetch (FX NAMETABLE)
of FRAME)))
TMP NAME
until (EQ (SETQ NAME (\GETBASE NT OFFSET))
0)
do (COND
((EQ NAME ATOM#) (* Found ATOM# in nametable.
Now look in second half of table to see what kind of
binding and where it lies)
(COND
[INTERPNT (RETURN (ADD1 (IDIFFERENCE OFFSET (fetch (FNHEADER OVERHEADWORDS)
of T]
(T (SELECTC (LOGAND [SETQ TMP (\GETBASE NT (IPLUS OFFSET (fetch (FNHEADER NTSIZE)
of NT]
VARCODEMASK)
[IVARCODE (RETURN (ADD1 (IDIFFERENCE TMP IVARCODE]
[PVARCODE (AND [fetch (PVARSLOT BOUND)
of (ADDSTACKBASE (IPLUS (fetch (FX FIRSTPVAR)
of FRAME)
(UNFOLD (SETQ TMP
(IDIFFERENCE TMP
PVARCODE))
WORDSPERCELL]
(RETURN (IPLUS TMP (fetch (BF NARGS)
of (fetch (FX BLINK) of FRAME))
1]
(FVARCODE (RETURN))
(RAID])
(\VAROFFSET
[LAMBDA (FRAME ATN) (* bvm: " 5-Feb-85 15:57")
(* * Returns stack offset to binding of atom number ATN in FRAME, or NIL if it is not bound here.)
(for OFFSET from (fetch (FNHEADER OVERHEADWORDS) of T) bind (NT ←(fetch (FX NAMETABLE)
of FRAME))
TMP NAME
until (EQ (SETQ NAME (\GETBASE NT OFFSET))
0)
do (COND
((EQ NAME ATN) (* Found ATN in nametable. Now look in second half of
table to see what kind of binding and where it lies)
(SELECTC (LOGAND [SETQ TMP (\GETBASE NT (IPLUS OFFSET (fetch (FNHEADER NTSIZE)
of NT]
VARCODEMASK)
[IVARCODE (RETURN (IPLUS (fetch (BF IVAR) of (fetch (FX BLINK) of FRAME))
(UNFOLD (IDIFFERENCE TMP IVARCODE)
WORDSPERCELL]
(PVARCODE (AND [fetch (PVARSLOT BOUND)
of (ADDSTACKBASE (SETQ TMP (IPLUS (fetch (FX FIRSTPVAR)
of FRAME)
(UNFOLD (IDIFFERENCE
TMP PVARCODE)
WORDSPERCELL]
(RETURN TMP)))
(FVARCODE (RETURN))
(RAID])
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML SETARG ARG)
(ADDTOVAR LAMA )
)
(PUTPROPS ASTACK COPYRIGHT ("Xerox Corporation" 1982 1983 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1275 3618 (ARG 1285 . 1414) (SETARG 1416 . 1561) (\ARG 1563 . 1776) (\ARGPTR 1778 .
3380) (\SETARG 3382 . 3616)) (3619 7601 (\RETURN 3629 . 3884) (\STACKARGPTR 3886 . 7599)) (7642 11883
(STKNTH 7652 . 8448) (STKNTHNAME 8450 . 9234) (STKNAME 9236 . 9385) (\STKNAME 9387 . 10003) (
SETSTKNAME 10005 . 11246) (\COPYFNHEADER 11248 . 11881)) (11884 17055 (STKPOS 11894 . 12819) (STKSCAN
12821 . 13244) (SETCLINK 13246 . 13887) (RETFROM 13889 . 14290) (RETTO 14292 . 14600) (RESUME 14602 .
15573) (\RESUME 15575 . 15754) (RESET 15756 . 16521) (ERROR! 16523 . 17053)) (17056 35940 (STKARG
17066 . 21641) (SETSTKARG 21643 . 23775) (STKARGNAME 23777 . 27511) (\SPREADFRAMEP 27513 . 28203) (
SETSTKARGNAME 28205 . 30204) (STKNARGS 30206 . 32247) (FRAMESCAN 32249 . 32515) (\INTERPFRAMENT 32517
. 32942) (\FRAMESCAN 32944 . 34604) (\VAROFFSET 34606 . 35938)))))
STOP