(FILECREATED "18-AUG-83 13:16:52" {PHYLUM}<LISPCORE>SOURCES>LLINTERP.;33 213611Q
changes to: (FNS SHOWSTACKBLOCKS RAIDCOMMAND)
previous date: " 7-AUG-83 00:23:52" {PHYLUM}<LISPCORE>SOURCES>LLINTERP.;32)
(* Copyright (c) 1981, 1982, 1983 by Xerox Corporation)
(PRETTYCOMPRINT LLINTERPCOMS)
(RPAQQ LLINTERPCOMS ([E (* Don't fontify these common functions)
(SETQ FNSLST
(LDIFFERENCE FNSLST
(QUOTE (PROG EVALV SET SETQ RETURN GO QUOTE AND OR PROGN
COND PROG1 FUNCTION EVAL APPLY]
(COMS (* For calling interpreted functions)
(FNS \INTERPRETER \INTERPRETER1))
(COMS (* recursive interpreter)
(FNS EVAL \EVAL \EVALFORM \EVALOTHER APPLY APPLY* \CHECKAPPLY* \CKAPPLYARGS DEFEVAL)
(VARS (\DEFEVALFNS NIL))
(GLOBALVARS \DEFEVALFNS)
(DECLARE: DONTEVAL@LOAD DOCOPY (VARS (CLISPARRAY)))
(GLOBALVARS CLISPARRAY)
(COMS (* Free variable manipulation)
(FNS EVALV \EVALV1 \EVALVAR BOUNDP SET \SETVAR SETQ SETN \STKSCAN))
(COMS (* PROG and friends)
(FNS PROG \PROG0 \EVPROG1 RETURN GO EVALA \EVALA ERRORSET))
(FNS QUOTE AND OR PROGN COND \EVPROGN PROG1)
(COMS (* Evaluating in different stack environment)
(FNS ENVEVAL ENVAPPLY FUNCTION \FUNCT1 \MAKEFUNARGFRAME STKEVAL STKAPPLY RETEVAL
RETAPPLY))
(COMS (* Blip and other stack funniness)
(FNS BLIPVAL SETBLIPVAL BLIPSCAN)
(FNS DUMMYFRAMEP REALFRAMEP REALSTKNTH \REALFRAMEP)
[INITVARS (OPENFNS (QUOTE (SETQ AND OR COND SELECTQ PROG PROGN PROG1 ARG SETARG
ERSETQ NLSETQ RESETFORM RESETLST RESETVARS RPTQ
SAVESETQ SETN UNDONLSETQ XNLSETQ APPLY*]
(VARS \BLIPNAMES)
(GLOBALVARS BRKINFOLST)
(GLOBALVARS \BLIPNAMES OPENFNS)))
[COMS (FNS RAIDCOMMAND RAIDSHOWFRAME PRINTADDRS PRINTVA READVA READOCT SHOWSTACKBLOCKS
SHOWSTACKBLOCK1 PRINCOPY)
(FNS BACKTRACE \BACKTRACE \SCANFORNTENTRY \PRINTSTK \PRINTFRAME \PRINTBF)
(DECLARE: DONTCOPY (MACROS PSTKFLD PRINTSTKFIELDS PSTK PRINTVA)
(ADDVARS (RDCOMS (FNS RAIDCOMMAND RAIDSHOWFRAME PRINTADDRS PRINTVA READVA
READOCT SHOWSTACKBLOCKS SHOWSTACKBLOCK1 PRINCOPY)
(FNS \BACKTRACE \PRINTBF \PRINTFRAME \SCANFORNTENTRY
\PRINTSTK))
(EXPANDMACROFNS PSTKFLD PRINTSTKFIELDS PSTK PRINTVA))
EVAL@COMPILE
(ADDVARS (DONTCOMPILEFNS RAIDCOMMAND RAIDSHOWFRAME PRINTADDRS PRINTVA READVA
READOCT SHOWSTACKBLOCKS SHOWSTACKBLOCK1 PRINCOPY]
(FNS CCODEP EXPRP SUBRP FNTYP ARGTYPE NARGS ARGLIST \CCODEARGLIST \CCODEIVARSCAN)
(DECLARE: DONTCOPY (MACROS \CCODENARGS))
(MACROS \CCODEFNTYP \CCODEARGTYPE \CCODEPNARGS)
(DECLARE: EVAL@COMPILE DONTCOPY (ADDVARS (LAMS FAULTEVAL FAULTAPPLY)))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA PROG1 COND PROGN OR AND QUOTE GO PROG SETN SETQ)
(NLAML FUNCTION)
(LAMA APPLY* \INTERPRETER)))
(LOCALVARS . T)
(SPECVARS *TAIL* *FN* *FORM* *ARGVAL* *ARGVAL1* *ARGVAL2*)))
(* For calling interpreted functions)
(DEFINEQ
(\INTERPRETER
[LAMBDA N (* lmm "11-JUN-82 13:30")
(* the microcode calls this function instead if it is given an expr or an undefined function to call -
the name of the function/sexpression which is supposed to be called is given as an extra argument)
(PROG ((FN (ARG N N))
(NA 0)
(NACTUAL (SUB1 N))
DEF ARGLIST NEXTRA NTSIZE TYPE NNILS)
(COND
((LITATOM FN)
(CHECK (NOT (fetch (LITATOM CCODEP) of FN)))
(SETQ DEF (fetch (LITATOM DEFPOINTER) of FN)))
(T (SETQ DEF FN)))
(COND
((NLISTP DEF)
(GO ERR)))
(RETURN (.CALLAFTERPUSHINGNILS.
(SELECTQ (CAR DEF)
[[LAMBDA NLAMBDA]
[SETQ ARGLIST (CAR (OR (LISTP (CDR DEF))
(GO ERR]
(SETQ NNILS (IPLUS (SETQ NEXTRA
(COND
((LISTP ARGLIST)
(* spread function)
(for X in ARGLIST
do (COND
((OR (NULL (\DTEST X (QUOTE LITATOM)))
(EQ X T))
(LISPERROR
"ATTEMPT TO BIND NIL OR T"
X)))
(* Process one argument)
(SETQ NA (ADD1 NA)))
(COND
((IGREATERP NA NACTUAL)
(IDIFFERENCE NA NACTUAL))
(T 0)))
((NULL ARGLIST)
(* spread function)
0)
((EQ ARGLIST T)
(LISPERROR "ATTEMPT TO BIND NIL OR T" ARGLIST)
)
(T
(* Nospread--needs to bind exactly one variable, the arg name. LAMBDA* also needs to set that arg to the number of
actual args, but that can be done by diddling the slot currently occupied by the fn name. Never any "extra" args
to worry about)
(\DTEST ARGLIST (QUOTE LITATOM))
(SETQ NA 1)
0)))
(PROG1 (SETQ NTSIZE (CEIL (ADD1 NA)
WORDSPERQUAD))
(* round number of nametable entries up to next quadword, leaving room for a zero. add in overhead.
NA is now in units of "cells" since there two words in a cell.)
)
(FOLDHI (fetch (FNHEADER OVERHEADWORDS)
of T)
WORDSPERCELL)
(SUB1 CELLSPERQUAD]
(FUNARG (GO FUN))
(GO ERR))
(\INTERPRETER1 ARGLIST NNILS NTSIZE NACTUAL NEXTRA FN DEF)))
FUN [RETURN (PROGN (\SMASHLINK NIL (\STACKARGPTR (CADDR DEF)))
(SPREADAPPLY (CADR DEF)
(for I from 1 to (SUB1 N) collect (ARG N I]
ERR (RETURN (FAULTAPPLY FN (for I from 1 to NACTUAL collect (ARG N I])
(\INTERPRETER1
[LAMBDA (ARGLIST NNILS NTSIZE NACTUAL NPVARARGS FN DEF)
(* lmm "13-FEB-83 13:52")
(PROG ((*TAIL*(CDDR DEF))
(INTERPFRAME (\MYALINK))
RESULT HEADER NT NILSTART)
(SETQ HEADER (fetch (FX FNHEADER) of INTERPFRAME))
(* The function header of code for \INTERPRETER)
(* * Build a nametable for INTERPFRAME that identifies the vars in ARGLIST as the NACTUAL IVAR's that were passed to
it as arguments plus the NPVARARGS extra NIL's that we implement as PVAR's. We build the nametable out of space that
was allocated on the stack by \INTERPRETER pushing many NIL's)
(SETQ NT (ADDSTACKBASE (CEIL (IPLUS (SETQ NILSTART (IDIFFERENCE (fetch (FX NEXTBLOCK)
of INTERPFRAME)
(UNFOLD NNILS WORDSPERCELL))
)
(UNFOLD NPVARARGS WORDSPERCELL))
WORDSPERQUAD)))
(* Address of our synthesized nametable: NNILS cells back from the end of INTERPFRAME, leaving space for additional
"PVARs" we are using as extra NIL args, rounded up to quadword)
(UNINTERRUPTABLY
[COND
((NOT ARGLIST) (* No args, no nametable)
)
((LISTP ARGLIST)
[for ARG in ARGLIST as ARG# from 0 as NT1 from (fetch (FNHEADER OVERHEADWORDS)
of T)
as NT2 from (IPLUS (fetch (FNHEADER OVERHEADWORDS) of T)
NTSIZE)
do (PUTBASE NT NT1 (\ATOMVALINDEX ARG))
(PUTBASE NT NT2 (COND
((ILESSP ARG# NACTUAL)
(IPLUS IVARCODE ARG#))
(T
(* Say it's the nth PVAR, where n is out of the range of the real PVARs)
(IPLUS PVARCODE (FOLDLO (IDIFFERENCE NILSTART
(fetch (FX FIRSTPVAR)
of INTERPFRAME))
WORDSPERCELL)
(IDIFFERENCE ARG# NACTUAL]
(* Note: area is initialize to NIL's (zero), so end of nametable already has its
zeroes)
)
(T (* Nospread. Store lone arg in nametable)
(PUTBASE NT (fetch (FNHEADER OVERHEADWORDS) of T)
(\ATOMVALINDEX ARGLIST))
(PUTBASE NT (IPLUS (fetch (FNHEADER OVERHEADWORDS) of T)
NTSIZE)
(IPLUS IVARCODE (COND
((EQ (CAR DEF)
(QUOTE NLAMBDA))
(* It's the first (and only) arg)
0)
(T
(* Use the n+1'st arg, which currently is our framename
(FN))
(PUTBASEPTR \STACKSPACE (IPLUS (fetch (BF IVAR)
of (fetch (FX BLINK)
of INTERPFRAME))
(UNFOLD NACTUAL WORDSPERCELL))
NACTUAL)
(* set arg's value to be number of real args)
NACTUAL]
(* * now fix up header of NT)
(replace (FNHEADER #FRAMENAME) of NT with FN)
(* use #FRAMENAME to denote no reference counting)
(replace (FNHEADER NTSIZE) of NT with NTSIZE)
(replace (FNHEADER NLOCALS) of NT with (fetch (FNHEADER NLOCALS) of HEADER))
(* Probably doesn't matter, since there are no FVARS in that frame)
(* Do I need to worry about STK, NA, PV, START, ARGTYPE ? -
probably not)
(replace (FX NAMETABLE) of INTERPFRAME with NT))
EVLP
(* * Now that we have "bound" the arguments, just evaluate the forms in the LAMBDA/NLAMBDA as progn)
(SETQ RESULT (\EVAL (CAR *TAIL*)))
(COND
((LISTP (SETQ *TAIL*(CDR *TAIL*)))
(GO EVLP))
(T (RETURN RESULT])
)
(* recursive interpreter)
(DEFINEQ
(EVAL
[LAMBDA (U \INTERNAL)
(DECLARE (SPECVARS \INTERNAL))
(* lmm "19-AUG-81 23:04")
(\EVAL U])
(\EVAL
[LAMBDA (FORM) (* lmm " 3-NOV-81 15:42")
(COND
((LISTP FORM)
(\EVALFORM FORM))
((LITATOM FORM)
(\EVALVAR FORM))
((NUMBERP FORM)
FORM)
(T (\EVALOTHER FORM])
(\EVALFORM
[LAMBDA (*FORM* TEMP)
(DECLARE (SPECVARS *FORM*)
(ADDTOVAR LAMS FAULTEVAL)) (* bvm: "16-AUG-81 22:14")
(* eval of LISTP)
(PROG NIL
RETRY
[COND
((LITATOM (SETQ TEMP (CAR *FORM*)))
(COND
((fetch (LITATOM CCODEP) of TEMP)
(SELECTQ (fetch (LITATOM ARGTYPE) of TEMP)
(1 (GO NLSPREAD))
(3 (GO NLNOSPREAD))
(GO EVLAM)))
(T (* EXPR OR UDF)
(SETQ TEMP (fetch (LITATOM DEFPOINTER) of TEMP]
(* TEMP is now definition of EXPR)
(SELECTQ (CAR (OR (LISTP TEMP)
(GO FAULT)))
[LAMBDA (GO EVLAM]
[NLAMBDA (COND
((OR (LISTP (SETQ TEMP (CADR TEMP)))
(NULL TEMP))
(GO NLSPREAD))
(T (GO NLNOSPREAD]
(GO FAULT))
EVLAM (* THIS FUNCTION'S DEFINITION VERY DEPENDENT ON THE SPECIAL
MACRO IN ALAP FOR COMPILING IT.
-
SEE CEVALFORM)
[RETURN (PROG ((*ARGVAL* 0)
(*TAIL* *FORM*)
(*FN*(CAR *FORM*)))
(DECLARE (SPECVARS *ARGVAL* *FN* *TAIL*))
(RETURN (.EVALFORM.]
NLSPREAD
(RETURN (SPREADAPPLY (CAR *FORM*)
(CDR *FORM*)))
NLNOSPREAD
(RETURN (SPREADAPPLY*(CAR *FORM*)
(CDR *FORM*)))
FAULT
(COND
([AND CLISPARRAY (LISTP (SETQ TEMP (GETHASH *FORM* CLISPARRAY]
(SETQ *FORM* TEMP)
(GO RETRY)))
(RETURN (FAULTEVAL *FORM*])
(\EVALOTHER
[LAMBDA (X) (* lmm "10-MAY-80 17:03")
(* evaluate some other data type (not atom or list))
(PROG NIL
(RETURN (SPREADAPPLY*(CDR (OR (FASSOC (TYPENAME X)
\DEFEVALFNS)
(RETURN X)))
X])
(APPLY
[LAMBDA (U V \INTERNAL)
(DECLARE (SPECVARS \INTERNAL)) (* lmm "10-JUN-82 17:01")
(PROG ((DEF U))
LP [COND
((LITATOM DEF)
(COND
((NOT (fetch (LITATOM CCODEP) of DEF)) (* EXPR)
(SETQ DEF (fetch (LITATOM DEFPOINTER) of DEF)))
((EQ (fetch (LITATOM ARGTYPE) of DEF)
3)
(GO NLSTAR))
(T (GO NORMAL]
(COND
((LISTP DEF)
(SELECTQ (CAR DEF)
[NLAMBDA (AND (NLISTP (CADR DEF))
(CADR DEF)
(GO NLSTAR]
(FUNARG (SETQ DEF (CADR DEF))
(GO LP))
NIL)))
NORMAL
(RETURN (SPREADAPPLY U V))
NLSTAR (* NLAMBDA*)
(RETURN (SPREADAPPLY* U V])
(APPLY*
[LAMBDA U (* lmm "10-JUN-82 16:56")
(PROG ((DEF (ARG U 1)))
LP [COND
((LITATOM DEF)
(COND
((NOT (fetch (LITATOM CCODEP) of DEF)) (* EXPR)
(SETQ DEF (fetch (LITATOM DEFPOINTER) of DEF)))
((EQ (fetch (LITATOM ARGTYPE) of DEF)
3)
(GO NOSPR))
(T (GO SPR]
(COND
((NLISTP DEF)
(GO FAULT)))
(SELECTQ (CAR DEF)
(FUNARG (SETQ DEF (CADR DEF))
(GO LP))
[NLAMBDA (COND
((AND (CAR (LISTP (CDR DEF)))
(NLISTP (CADR DEF)))
(GO NOSPR]
[LAMBDA]
(GO FAULT))
SPR [RETURN (SELECTQ U
(1 (* no args)
(SPREADAPPLY*(ARG U 1)))
(2 (* 1 arg)
(SPREADAPPLY*(ARG U 1)
(ARG U 2)))
(3 (* 2 args)
(SPREADAPPLY*(ARG U 1)
(ARG U 2)
(ARG U 3)))
(4 (* 3 args)
(SPREADAPPLY*(ARG U 1)
(ARG U 2)
(ARG U 3)
(ARG U 4)))
(SPREADAPPLY (ARG U 1)
(for I from 2 to U collect (ARG U I]
FAULT
[RETURN (FAULTAPPLY (ARG U 1)
(for I from 2 to U collect (ARG U I]
NOSPR (* NLAMBDA*)
(RETURN (SPREADAPPLY*(ARG U 1)
(for I from 2 to U collect (ARG U I])
(\CHECKAPPLY*
[LAMBDA (FN) (* lmm "13-OCT-82 09:48")
(* APPLY* COMPILES OPEN AS: PUSH ARGS, PUSH #ARGS, PUSH FN, DO CHECKAPPLY*, DO APPLYFN -
CHECKAPPLY* SHOULD MERELY RETURN FN IN THE CASE WHERE FN IS A LAMBDA OR A NLAMBDA SPREAD. IT NEEDS TO HANDLE THE
NLAMBDA-NOSPREAD CASE, AND ALSO THE FAULT CASE)
(PROG ((DEF FN))
LP (COND
[(LITATOM DEF)
(COND
((NOT (fetch (LITATOM CCODEP) of DEF)) (* EXPR)
(SETQ DEF (fetch (LITATOM DEFPOINTER) of DEF)))
((EQ (fetch (LITATOM ARGTYPE) of DEF)
3)
(GO NOSPR))
(T (RETURN FN]
((AND (ARRAYP DEF)
(EQ (fetch (ARRAYP TYP) of DEF)
\ST.CODE)) (* hack for ccodep)
(\PUTD (QUOTE *\CHECKAPPLY*\HACK)
DEF)
(SETQ DEF (QUOTE *\CHECKAPPLY*\HACK))
(GO LP)))
(COND
((NLISTP DEF)
(GO FAULT)))
(SELECTQ (CAR DEF)
([LAMBDA FUNARG]
(RETURN FN))
[NLAMBDA (COND
((NLISTP (SETQ DEF (CDR DEF)))
(GO FAULT))
((AND (CAR DEF)
(NLISTP (CAR DEF)))
(GO NOSPR))
(T (RETURN FN]
(GO FAULT))
FAULT
[RETURN (LIST (QUOTE LAMBDA)
NIL
(LIST (QUOTE QUOTE)
(FAULTAPPLY FN (\CKAPPLYARGS]
NOSPR
(RETURN (LIST (QUOTE LAMBDA)
NIL
(LIST (QUOTE QUOTE)
(SPREADAPPLY* FN (\CKAPPLYARGS])
(\CKAPPLYARGS
[LAMBDA NIL (* lmm "10-NOV-81 22:26")
(PROG ((FRAME (fetch (FX ALINK) of (\MYALINK)))
ACNT PTR VAL)
[SETQ ACNT (STACKGETBASEPTR (SETQ PTR (IDIFFERENCE (fetch (FX NEXTBLOCK) of FRAME)
WORDSPERCELL]
(CHECK (SMALLPOSP ACNT))
[FRPTQ ACNT (push VAL (STACKGETBASEPTR (SETQ PTR (IDIFFERENCE PTR WORDSPERCELL]
(RETURN VAL])
(DEFEVAL
[LAMBDA (TYPE FN) (* edited: "13-DEC-78 23:18")
(PROG ((F (FASSOC TYPE \DEFEVALFNS)))
[COND
(F (SETQ \DEFEVALFNS (DREMOVE F \DEFEVALFNS]
[COND
(FN (SETQ \DEFEVALFNS (CONS (CONS TYPE FN)
\DEFEVALFNS]
(RETURN (CDR F])
)
(RPAQQ \DEFEVALFNS NIL)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \DEFEVALFNS)
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(RPAQQ CLISPARRAY NIL)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS CLISPARRAY)
)
(* Free variable manipulation)
(DEFINEQ
(EVALV
[LAMBDA (VAR POS) (* lmm "24-DEC-81 00:08")
(* EVAL of a LITATOM without uba error)
[COND
(POS (\SMASHLINK NIL (\STACKARGPTR POS]
(\EVALV1 VAR])
(\EVALV1
[LAMBDA (VAR) (* lmm "24-DEC-81 00:08")
(COND
((OR (NULL (\DTEST VAR (QUOTE LITATOM)))
(EQ VAR T))
VAR)
(T (\GETBASEPTR (\STKSCAN VAR)
0])
(\EVALVAR
[LAMBDA (VAR) (* bvm: "23-MAR-83 12:19")
(* EVAL of a LITATOM)
(COND
((OR (NULL VAR)
(EQ VAR T))
VAR)
(T (PROG ((VP (\STKSCAN VAR))
VAL)
(RETURN (COND
((AND (EQ (SETQ VAL (\GETBASEPTR VP 0))
(QUOTE NOBIND))
(EQ (\HILOC VP)
(\HILOC \VALSPACE))) (* Value is NOBIND and it was found as the top-level
value)
(FAULTEVAL VAR))
(T VAL])
(BOUNDP
[LAMBDA (VAR) (* bvm: "23-MAR-83 12:19")
(* True if VAR is bound or has top level value)
(AND (LITATOM VAR)
(OR (NEQ (GETTOPVAL VAR)
(QUOTE NOBIND))
(NEQ (\HILOC (\STKSCAN VAR))
(\HILOC \VALSPACE])
(SET
[LAMBDA (VAR VALUE) (* lmm "24-FEB-82 16:11")
(COND
((NULL VAR)
(AND VALUE (LISPERROR "ATTEMPT TO SET NIL OR T" VALUE)))
(T (PROG [(VP (\STKSCAN (\DTEST VAR (QUOTE LITATOM]
(COND
((EQ (\HILOC VP)
\STACKHI)
(\PUTBASEPTR VP 0 VALUE))
((EQ VAR T)
(OR (EQ VALUE T)
(LISPERROR "ATTEMPT TO SET NIL OR T" VALUE)))
(T (\RPLPTR VP 0 VALUE)))
(RETURN VALUE])
(\SETVAR
[LAMBDA (VAR VALUE) (* lmm "24-FEB-82 16:11")
(COND
((NULL VAR)
(AND VALUE (LISPERROR "ATTEMPT TO SET NIL OR T" VALUE)))
(T (PROG [(VP (\STKSCAN (\DTEST VAR (QUOTE LITATOM]
(COND
((EQ (\HILOC VP)
\STACKHI)
(\PUTBASEPTR VP 0 VALUE))
((EQ VAR T)
(OR (EQ VALUE T)
(LISPERROR "ATTEMPT TO SET NIL OR T" VALUE)))
(T (\RPLPTR VP 0 VALUE)))
(RETURN VALUE])
(SETQ
[NLAMBDA U (* lmm "24-DEC-81 00:19")
(* (SETQ X Y + 3) MUST TRY TO EVAL +)
(\SETVAR (CAR U)
(PROG ((*TAIL*(CDR U)))
(DECLARE (SPECVARS *TAIL*))
(RETURN (PROG1 (\EVAL (CAR *TAIL*))
(PROG NIL
LP (COND
((LISTP (SETQ *TAIL*(CDR *TAIL*)))
(\EVAL (CAR *TAIL*))
(GO LP])
(SETN
[NLAMBDA U (* lmm "24-DEC-81 00:19")
(* (SETN X Y + 3) MUST TRY TO EVAL +)
(\SETVAR (CAR U)
(PROG ((*TAIL*(CDR U)))
(DECLARE (SPECVARS *TAIL*))
(RETURN (PROG1 (\EVAL (CAR *TAIL*))
(PROG NIL
LP (COND
((LISTP (SETN *TAIL*(CDR *TAIL*)))
(\EVAL (CAR *TAIL*))
(GO LP])
(\STKSCAN
[LAMBDA (VAR) (* lmm "13-FEB-83 13:52")
(* RETURNS POINTER TO PLACE WHERE VAR IS BOUND)
(PROG ((FX (fetch (FX ALINK) of (\MYALINK)))
(ATOM# (\ATOMVALINDEX VAR))
NTSIZE A VARINFO PVAROFFSET NT FVAR)
FRAMELP
[COND
((fetch (FX INVALIDP) of FX)
(* Reached top of stack without finding a binding)
(RETURN (\ADDBASE \VALSPACE (LLSH ATOM# 1]
(SETQ NT (fetch (FX NAMETABLE) of FX))
(SETQ NTSIZE (fetch (FNHEADER NTSIZE) of NT))
(SETQ NT (ADDBASE NT (fetch (FNHEADER OVERHEADWORDS) of T)))
TABLELP
[COND
((ZEROP (SETQ A (GETBASE NT 0)))
(* End of name table)
(GO ENDTABLE))
((EQ A ATOM#) (* Found ATOM#. See if it is really bound here)
(SELECTC (fetch (NAMETABLESLOT VARTYPE) of (SETQ VARINFO (ADDBASE NT NTSIZE)))
[\NT.IVAR
(* Is bound in BF)
(* IVAR)
(RETURN (STACKADDBASE (IPLUS (UNFOLD (fetch (NAMETABLESLOT VAROFFSET)
of VARINFO)
WORDSPERCELL)
(fetch (BF IVAR)
of (fetch (FX BLINK) of FX]
[\NT.PVAR
(* Local may or may not be bound yet)
(SETQ PVAROFFSET (IPLUS (UNFOLD (fetch (NAMETABLESLOT VAROFFSET)
of VARINFO)
WORDSPERCELL)
(fetch (FX FIRSTPVAR) of FX)))
(COND
((fetch (PVARSLOT BOUND) of (ADDSTACKBASE PVAROFFSET))
(* PVAR)
(RETURN (STACKADDBASE PVAROFFSET]
[\NT.FVAR
(* If FVAR is looked up, we can use it.)
[SETQ FVAR (ADDSTACKBASE (IPLUS (UNFOLD (fetch (NAMETABLESLOT
VAROFFSET)
of VARINFO)
WORDSPERCELL)
(fetch (FX FIRSTPVAR) of FX]
(COND
((fetch (FVARSLOT LOOKEDUP) of FVAR)
(SETQ FVAR (fetch (FVARSLOT BINDINGPTR) of FVAR))
(RETURN FVAR))
(T (GO ENDTABLE]
(SHOULDNT]
(SETQ NT (ADDBASE NT 1))
(GO TABLELP)
ENDTABLE
(SETQ FX (fetch (FX ALINK) of FX))
(GO FRAMELP])
)
(* PROG and friends)
(DEFINEQ
(PROG
[NLAMBDA U (* bvm: "29-AUG-81 22:41")
(* PROG unpacks the argument list and changes any EVAL
type forms by evaluating the form and then smashing the
name and value)
(* NOTE --- this mechanism might confuse DWIM someday because the arguments inside the PROG are evaluated at a time
when the PROG frame is in a very funny state: the "values" are the variables, and the variables are NIL)
(PROG ((NVARS 0)
(VARLST (CAR U))
NTSIZE NNILS)
(for VAR in VARLST do (* Count number of vars to bind, check validity)
(COND
((OR (NULL (\DTEST (COND
((LISTP VAR)
(SETQ VAR (CAR VAR)))
(T VAR))
(QUOTE LITATOM)))
(EQ VAR T))
(LISPERROR "ATTEMPT TO BIND NIL OR T" VAR)))
(add NVARS 1))
(RETURN (.CALLAFTERPUSHINGNILS. (SETQ NNILS (IPLUS NVARS (SETQ NTSIZE (CEIL (ADD1 NVARS)
WORDSPERQUAD))
(FOLDHI (fetch (FNHEADER OVERHEADWORDS)
of T)
WORDSPERCELL)
(SUB1 CELLSPERQUAD)))
(\PROG0 U U NNILS NVARS NTSIZE VARLST])
(\PROG0
[LAMBDA (*FIRSTTAIL* *TAIL* NNILS NVARS NTSIZE VARLST)
(* lmm "13-FEB-83 13:52")
(DECLARE (SPECVARS *TAIL* *FIRSTTAIL*))
(PROG NIL
[COND
(VARLST
(* * Create a nametable inside progframe where PROG pushed all those nils)
(PROG ((PROGFRAME (\MYALINK))
HEADER NT NILSTART)
(SETQ HEADER (fetch (FX FNHEADER) of PROGFRAME))
(SETQ NT (ADDSTACKBASE (CEIL (IPLUS (SETQ NILSTART
(IDIFFERENCE (fetch (FX NEXTBLOCK)
of PROGFRAME)
(UNFOLD NNILS
WORDSPERCELL)))
(UNFOLD NVARS WORDSPERCELL))
WORDSPERQUAD)))
(* NT is address of our synthesized nametable: beginning of NIL's, not counting
additional PVARs we are about to bind, rounded up to quadword)
[for VAR in VARLST as VALUEOFF from NILSTART by WORDSPERCELL
do (* evaluate initial values first)
(COND
((LISTP VAR)
(PUTBASEPTR \STACKSPACE VALUEOFF (\EVPROG1 (CDR VAR]
(* then build NT)
(UNINTERRUPTABLY
(for VAR in VARLST as VAR# from (FOLDLO (IDIFFERENCE
NILSTART
(fetch (FX FIRSTPVAR)
of PROGFRAME))
WORDSPERCELL)
as NT1 from (fetch (FNHEADER OVERHEADWORDS) of T) as NT2
from (IPLUS (fetch (FNHEADER OVERHEADWORDS) of T)
NTSIZE)
do [PUTBASE NT NT1 (\ATOMVALINDEX (COND
((LISTP VAR)
(CAR VAR))
(T VAR]
(PUTBASE NT NT2 (IPLUS PVARCODE VAR#)))
(replace (FNHEADER #FRAMENAME) of NT with (QUOTE PROG))
(replace (FNHEADER NTSIZE) of NT with NTSIZE)
(* Do I need to worry about STK, NA, PV, START, ARGTYPE NLOCALS ? -
no)
(replace (FX NAMETABLE) of PROGFRAME with NT))]
EVLP(COND
((NULL (SETQ *TAIL*(CDR *TAIL*)))
(RETURN NIL))
(T (\EVAL (OR (LISTP (CAR *TAIL*))
(GO EVLP)))
(GO EVLP])
(\EVPROG1
[LAMBDA (*TAIL*) (* lmm "14-MAY-80 13:00")
(DECLARE (SPECVARS *TAIL*))
(PROG1 (\EVAL (CAR *TAIL*))
(PROG NIL
LP (COND
((LISTP (SETQ *TAIL*(CDR *TAIL*)))
(\EVAL (CAR *TAIL*))
(GO LP])
(RETURN
[LAMBDA (X) (* lmm "24-DEC-81 00:32")
(PROG ((FRAME (\MYALINK)))
LP (COND
((EQ (fetch (FNHEADER FRAMENAME) of (fetch (FX NAMETABLE) of FRAME))
(FUNCTION \PROG0))
(SETQ FRAME (fetch (FX CLINK) of FRAME))
(* Its caller, i.e. PROG)
(\SMASHLINK NIL FRAME FRAME)
(* Make us return to PROG with this value)
(RETURN X))
([NOT (fetch (FX INVALIDP) of (SETQ FRAME (fetch (FX CLINK) of FRAME]
(GO LP))
(T (LISPERROR "ILLEGAL RETURN" X])
(GO
[NLAMBDA U (* lmm "23-DEC-81 11:28")
(PROG ((FRAME (\MYALINK))
(LABEL (CAR U))
GOTAIL FIRSTARG)
LP [COND
((EQ (fetch (FNHEADER FRAMENAME) of (fetch (FX NAMETABLE) of FRAME))
(FUNCTION \PROG0))
(COND
([SETQ GOTAIL (FMEMB LABEL (CDR (STACKGETBASEPTR (SETQ FIRSTARG
(fetch (BF IVAR)
of (fetch (FX BLINK)
of FRAME]
(* first argument of \PROG0 is the actual tail of the
prog, which can contain the labels.
Second argument is the "current" *TAIL*)
(STACKPUTBASEPTR (IPLUS FIRSTARG WORDSPERCELL)
GOTAIL) (* Reset *TAIL* in the \PROG0 frame)
(\SMASHLINK NIL FRAME FRAME) (* Fix it so we return to \PROG0 to continue evaluating
after label)
(RETURN NIL]
(COND
([NOT (fetch (FX INVALIDP) of (SETQ FRAME (fetch (FX CLINK) of FRAME]
(GO LP))
(T (LISPERROR "UNDEFINED OR ILLEGAL GO" LABEL])
(EVALA
[LAMBDA (X A) (* lmm " 4-SEP-81 10:57")
(* * Evaluate X after spreading alist A on stack)
(PROG ((NVARS 0)
NTSIZE NNILS TMP)
(for VAR in A do (* Count number of vars to bind, check validity)
(COND
((OR [NULL (SETQ TMP (\DTEST (CAR (\DTEST VAR (QUOTE LISTP)))
(QUOTE LITATOM]
(EQ TMP T))
(LISPERROR "ATTEMPT TO BIND NIL OR T" TMP)))
(add NVARS 1))
(RETURN (.CALLAFTERPUSHINGNILS. (SETQ NNILS (IPLUS NVARS (SETQ NTSIZE (CEIL (ADD1 NVARS)
WORDSPERQUAD))
(FOLDHI (fetch (FNHEADER OVERHEADWORDS)
of T)
WORDSPERCELL)
(SUB1 CELLSPERQUAD)))
(\EVALA NNILS NVARS NTSIZE X A])
(\EVALA
[LAMBDA (NNILS NVARS NTSIZE FORM ALIST)
(* lmm "13-FEB-83 13:52")
(PROG ((CALLER (\MYALINK))
NILSTART NT HEADER)
(* * Create a nametable inside CALLER where EVALA pushed all those nils)
(SETQ HEADER (fetch (FX FNHEADER) of CALLER))
(* The function header of code for EVALA)
(SETQ NT (ADDSTACKBASE (CEIL (IPLUS (SETQ NILSTART (IDIFFERENCE (fetch (FX NEXTBLOCK)
of CALLER)
(UNFOLD NNILS WORDSPERCELL))
)
(UNFOLD NVARS WORDSPERCELL))
WORDSPERQUAD)))
(* Address of our synthesized nametable: beginning of NIL's, not counting
additional PVARs we are about to bind, rounded up to quadword)
(UNINTERRUPTABLY
(for PAIR in ALIST as VAR# from (FOLDLO (IDIFFERENCE NILSTART (fetch (FX FIRSTPVAR)
of CALLER))
WORDSPERCELL)
as NT1 from (fetch (FNHEADER OVERHEADWORDS) of T) as NT2
from (IPLUS (fetch (FNHEADER OVERHEADWORDS) of T)
NTSIZE)
as VALUEOFF from NILSTART by WORDSPERCELL
do (PUTBASEPTR \STACKSPACE VALUEOFF (CDR PAIR))
(PUTBASE NT NT1 (\ATOMVALINDEX (CAR PAIR)))
(PUTBASE NT NT2 (IPLUS PVARCODE VAR#)))
(* * now fix up header of NT)
(replace (FNHEADER #FRAMENAME) of NT with (QUOTE EVALA))
(replace (FNHEADER NTSIZE) of NT with NTSIZE)
(* Do I need to worry about STK, NA, PV, START, ARGTYPE ? -
probably not)
(replace (FX NAMETABLE) of CALLER with NT))
(RETURN (\EVAL FORM])
(ERRORSET
[LAMBDA (U V W) (* lmm "18-APR-80 13:40")
(LIST (\EVAL U])
)
(DEFINEQ
(QUOTE
[NLAMBDA U
(CAR U])
(AND
[NLAMBDA U
(DECLARE (SPECVARS *TAIL*))
(OR (NLISTP U)
(PROG ((*TAIL* U))
LP (RETURN (COND
((NLISTP (CDR *TAIL*))
(\EVAL (CAR *TAIL*)))
((\EVAL (CAR *TAIL*))
(SETQ *TAIL*(CDR *TAIL*))
(GO LP])
(OR
[NLAMBDA U
(DECLARE (SPECVARS *TAIL*))
(AND (LISTP U)
(PROG ((*TAIL* U))
LP (RETURN (OR (\EVAL (CAR *TAIL*))
(AND (LISTP (SETQ *TAIL*(CDR *TAIL*)))
(GO LP])
(PROGN
[NLAMBDA U (* MUST be a NLAMBDA* with internal call to EVAL for dwimsake)
(DECLARE (SPECVARS *TAIL*))
(AND (LISTP U)
(PROG ((*TAIL* U))
LP (COND
[(NLISTP (CDR *TAIL*))
(RETURN (\EVAL (CAR *TAIL*]
(T (\EVAL (CAR *TAIL*))
(SETQ *TAIL*(CDR *TAIL*))
(GO LP])
(COND
[NLAMBDA U
(DECLARE (SPECVARS *TAIL*)) (* lmm "25-APR-80 18:03")
(PROG ((*TAIL* U)
VAL)
LP (RETURN (COND
((NLISTP *TAIL*)
(COND
(*TAIL* (LISPERROR "UNUSUAL CDR ARG LIST" *TAIL*))
(T NIL)))
((SETQ VAL (\EVAL (CAAR *TAIL*)))
(COND
((CDAR *TAIL*)
(\EVPROGN (CDAR *TAIL*)))
(T VAL)))
(T (SETQ *TAIL*(CDR *TAIL*))
(GO LP])
(\EVPROGN
[LAMBDA (*TAIL*) (* lmm "14-FEB-82 13:59")
(DECLARE (SPECVARS *TAIL*))
(PROG NIL
LP (RETURN (PROG1 (\EVAL (CAR *TAIL*))
(COND
((LISTP (SETQ *TAIL*(CDR *TAIL*)))
(GO LP])
(PROG1
[NLAMBDA U
(DECLARE (SPECVARS *TAIL*)) (* lmm "14-MAY-80 12:59")
(AND (LISTP U)
(PROG ((*TAIL* U))
(RETURN (PROG1 (\EVAL (CAR *TAIL*))
(PROG NIL
LP (COND
((LISTP (SETQ *TAIL*(CDR *TAIL*)))
(\EVAL (CAR *TAIL*))
(GO LP])
)
(* Evaluating in different stack environment)
(DEFINEQ
(ENVEVAL
[LAMBDA (FORM APOS CPOS AFLG CFLG) (* bvm: "18-AUG-81 23:29")
(\CALLME (QUOTE *ENV*))
(\SMASHLINK NIL (AND APOS (\STACKARGPTR APOS))
(AND CPOS (\STACKARGPTR CPOS)))
(COND
(AFLG (RELSTK APOS)))
(COND
(CFLG (RELSTK CPOS)))
(\EVAL FORM])
(ENVAPPLY
[LAMBDA (FN ARGS APOS CPOS AFLG CFLG) (* bvm: "18-AUG-81 23:29")
(\CALLME (QUOTE *ENV*))
(\SMASHLINK NIL (AND APOS (\STACKARGPTR APOS))
(AND CPOS (\STACKARGPTR CPOS)))
(COND
(AFLG (RELSTK APOS)))
(COND
(CFLG (RELSTK CPOS)))
(APPLY FN ARGS])
(FUNCTION
[NLAMBDA (FN ENV) (* lmm "26-MAY-82 23:15")
(COND
((NULL ENV)
FN)
(T [COND
((LITATOM ENV)
(SETQ ENV (\EVAL ENV]
(LIST (QUOTE FUNARG)
FN
(COND
((STACKP ENV)
ENV)
(T (\MAKEFUNARGFRAME ENV])
(\FUNCT1
[LAMBDA (NNILS NVARS NTSIZE VARLST)
(* lmm "13-FEB-83 13:52")
(PROG ((FUNCTFRAME (\MYALINK))
HEADER NT NILSTART)
(SETQ HEADER (fetch (FX FNHEADER) of FUNCTFRAME))
(SETQ NT (ADDSTACKBASE (CEIL (IPLUS (SETQ NILSTART (IDIFFERENCE (fetch (FX NEXTBLOCK)
of FUNCTFRAME)
(UNFOLD NNILS WORDSPERCELL))
)
(UNFOLD NVARS WORDSPERCELL))
WORDSPERQUAD)))
(* NT is address of our synthesized nametable: beginning of NIL's, not counting
additional PVARs we are about to bind, rounded up to quadword)
(for VAR in VARLST as VALUEOFF from NILSTART by WORDSPERCELL do (\PUTBASEPTR (ADDSTACKBASE
VALUEOFF)
0
(\EVAL VAR)))
(* then build NT)
(UNINTERRUPTABLY
(for VAR in VARLST as VAR# from (FOLDLO (IDIFFERENCE NILSTART (fetch (FX FIRSTPVAR)
of FUNCTFRAME))
WORDSPERCELL)
as NT1 from (fetch (FNHEADER OVERHEADWORDS) of T) as NT2
from (IPLUS (fetch (FNHEADER OVERHEADWORDS) of T)
NTSIZE)
do (\PUTBASE NT NT1 (\ATOMVALINDEX VAR))
(\PUTBASE NT NT2 (IPLUS PVARCODE VAR#)))
(replace (FNHEADER #FRAMENAME) of NT with (QUOTE *FUNARG*))
(replace (FNHEADER NTSIZE) of NT with NTSIZE)
(replace (FX NAMETABLE) of FUNCTFRAME with NT))
(RETURN (\MAKESTACKP NIL FUNCTFRAME])
(\MAKEFUNARGFRAME
[LAMBDA (ENV) (* lmm "26-MAY-82 23:14")
(\CALLME (QUOTE FUNARG))
(PROG ((NVARS 0)
NTSIZE NNILS)
(for VAR in ENV do (* Count number of vars to bind, check validity)
(COND
((OR (NULL (\DTEST VAR (QUOTE LITATOM)))
(EQ VAR T))
(LISPERROR "ATTEMPT TO BIND NIL OR T" VAR)))
(add NVARS 1))
(SETQ ENV (.CALLAFTERPUSHINGNILS. (SETQ NNILS (IPLUS NVARS (SETQ NTSIZE
(CEIL (ADD1 NVARS)
WORDSPERQUAD))
(FOLDHI (fetch (FNHEADER OVERHEADWORDS)
of T)
WORDSPERCELL)
(SUB1 CELLSPERQUAD)))
(\FUNCT1 NNILS NVARS NTSIZE ENV)))
(* ENV POINTS TO COPY OF FUNCTION FRAME)
(\SMASHLINK (fetch (STACKP EDFXP) of ENV)
0 0)
(RETURN ENV])
(STKEVAL
[LAMBDA (POS FORM FLG INTERNALFLG)
(* lmm "25-APR-80 00:08")
(\SMASHLINK NIL (\STACKARGPTR POS))
(AND FLG (RELSTK POS))
(\EVAL FORM])
(STKAPPLY
[LAMBDA (POS FN ARGS FLG INTERNALFLG)
(* lmm "25-APR-80 00:08")
(\SMASHLINK NIL (\STACKARGPTR POS))
(AND FLG (RELSTK POS))
(APPLY FN ARGS INTERNALFLG])
(RETEVAL
[LAMBDA (POS FORM FLG INTERNALFLG) (* bvm: "19-AUG-81 01:17")
(\CALLME (QUOTE *ENV*))
(PROG ((FX (\STACKARGPTR POS)))
(\SMASHLINK NIL FX (COND
((fetch (FX INVALIDP) of (SETQ FX (fetch (FX CLINK) of FX)))
(\ILLEGAL.STACK.ARG POS))
(T FX)))
(AND FLG (RELSTK POS))
(RETURN (\EVAL FORM])
(RETAPPLY
[LAMBDA (POS FN ARGS FLG) (* lmm "18-DEC-81 15:13")
(\CALLME (QUOTE *ENV*))
(PROG ((FX (\STACKARGPTR POS)))
(\SMASHLINK NIL FX (COND
((fetch (FX INVALIDP) of (SETQ FX (fetch (FX CLINK) of FX)))
(\ILLEGAL.STACK.ARG POS))
(T FX)))
(AND FLG (RELSTK POS))
(RETURN (APPLY FN ARGS])
)
(* Blip and other stack funniness)
(DEFINEQ
(BLIPVAL
[LAMBDA (BLIPTYP IPOS FLG) (* lmm "13-FEB-83 13:52")
(PROG ([FRAME (COND
((NULL IPOS)
(\MYALINK))
(T (\STACKARGPTR IPOS]
(A (\ATOMVALINDEX BLIPTYP))
I)
(SELECTQ BLIPTYP
((*TAIL* *FORM* *FN* *ARGVAL*))
(RETURN (AND (EQ FLG T)
0)))
(RETURN
(COND
((EQ FLG T) (* Count number of blips of type BLIPTYP at FRAME)
(COND
((NOT (SETQ I (\VAROFFSET FRAME A)))
0)
((EQ BLIPTYP (QUOTE *ARGVAL*))
(* the value of *ARGVAL* is the number of *ARGVAL* blips in this frame)
(OR (\GETBASEPTR \STACKSPACE I)
0))
(T 1)))
(T
(PROG NIL
(OR FLG (SETQ FLG 1))
FRAMELP
[COND
((SETQ I (\VAROFFSET FRAME A))
(SELECTQ
BLIPTYP
[*ARGVAL* (COND
((IGREATERP FLG (SETQ I (OR (\GETBASEPTR \STACKSPACE I)
0)))
(* Fewer blips here than FLG)
(SETQ FLG (IDIFFERENCE FLG I)))
(T
(* Scan the temporary region for the value of the FLG'th *ARGVAL* blip)
(RETURN (PROG ((NXT (fetch (FX NEXTBLOCK) of FRAME))
(P (fetch (FX FIRSTTEMP) of FRAME)))
LP (CHECK (ILESSP P NXT))
[COND
((EQ (\GETBASEPTR \STACKSPACE P)
(QUOTE *ARGVAL*))
(* \EVALFORM pushes the atom *ARGVAL*, then each argument.
We want the FLG'th arg, counting from the end backwards)
(add P (UNFOLD (ADD1 (IDIFFERENCE I FLG))
WORDSPERCELL))
(CHECK (ILESSP P NXT))
(RETURN (\GETBASEPTR \STACKSPACE P]
(add P WORDSPERCELL)
(GO LP]
(COND
((ILESSP (SETQ FLG (SUB1 FLG))
1)
(RETURN (\GETBASEPTR \STACKSPACE I]
NEXT(COND
([NOT (fetch (FX INVALIDP) of (SETQ FRAME (fetch (FX CLINK) of FRAME]
(GO FRAMELP])
(SETBLIPVAL
[LAMBDA (BLIPTYP IPOS N VAL) (* lmm "13-FEB-83 13:53")
(PROG ([FRAME (COND
((NULL IPOS)
(\MYALINK))
(T (\STACKARGPTR IPOS]
(A (\ATOMVALINDEX BLIPTYP))
I)
(SELECTQ BLIPTYP
((*TAIL* *FORM* *FN* *ARGVAL*))
(RETURN))
(COND
((NOT N)
(SETQ N 1))
((ILESSP N 1)
(\ILLEGAL.ARG N)))
FRAMELP
[COND
((SETQ I (\VAROFFSET FRAME A))
(SELECTQ BLIPTYP
[*ARGVAL* (COND
((NOT (SETQ I (\GETBASEPTR \STACKSPACE I)))
(* No argvals)
)
((IGREATERP N I)
(SETQ N (IDIFFERENCE N I)))
(T
(* Scan the temporary region for the value of the Nth *ARGVAL* blip)
(RETURN (PROG ((NXT (fetch (FX NEXTBLOCK) of FRAME))
(P (fetch (FX FIRSTTEMP) of FRAME)))
LP (CHECK (ILESSP P NXT))
[COND
((EQ (\GETBASEPTR \STACKSPACE P)
(QUOTE *ARGVAL*))
(* \EVALFORM pushes the atom *ARGVAL*, then each argument.
We want the N'th arg from the end)
(add P (UNFOLD (ADD1 (IDIFFERENCE I N))
WORDSPERCELL))
(CHECK (ILESSP P NXT))
(RETURN (\PUTBASEPTR \STACKSPACE P VAL]
(add P WORDSPERCELL)
(GO LP]
(COND
((ILESSP (SETQ N (SUB1 N))
1)
(* All other blip types are just the value of the blip binding)
(RETURN (\PUTBASEPTR \STACKSPACE I VAL]
(COND
([NOT (fetch (FX INVALIDP) of (SETQ FRAME (fetch (FX CLINK) of FRAME]
(GO FRAMELP])
(BLIPSCAN
[LAMBDA (BLIPTYP IPOS) (* lmm "13-FEB-83 13:52")
(PROG ([FRAME (COND
((NULL IPOS)
(\MYALINK))
(T (\STACKARGPTR IPOS]
OFF A)
(SETQ A (SELECTQ BLIPTYP
((*FORM* *TAIL* *FN* *ARGVAL*)
(\ATOMVALINDEX BLIPTYP))
(RETURN)))
LP (COND
([AND (SETQ OFF (\VAROFFSET FRAME A))
(NOT (AND (EQ BLIPTYP (QUOTE *ARGVAL*))
(NULL (GETBASEPTR \STACKSPACE OFF]
(RETURN (\MAKESTACKP NIL FRAME)))
([NOT (fetch (FX INVALIDP) of (SETQ FRAME (fetch (FX CLINK) of FRAME]
(GO LP))
(T (RETURN])
)
(DEFINEQ
(DUMMYFRAMEP
[LAMBDA (POS) (* wt: "20-AUG-80 23:39")
(NOT (REALFRAMEP POS T])
(REALFRAMEP
[LAMBDA (POS INTERPFLG) (* lmm "27-MAY-80 22:00")
(* Value is T if user did write a call to the function at POS, and either INTERPFLG is T, or else the functio call
would also exist if compiled)
(\REALFRAMEP (\STACKARGPTR POS)
INTERPFLG])
(REALSTKNTH
[LAMBDA (N POS INTERPFLG OLDPOS)
(* lmm "27-MAY-80 22:00")
(* skips back N (or -N) real frames on the stack.
i.e. frames for which (REALFRAMEP POS INTERPFLG) is true)
(PROG [(FX (\STACKARGPTR POS))
(K (COND
((ILESSP N 0)
(IMINUS N))
(T N]
LP (COND
([EQ 0 (SETQ FX (COND
((IGREATERP 0 N)
(fetch (FX CLINK) of FX))
(T (fetch (FX ALINK) of FX]
(RETURN NIL)))
[COND
((\REALFRAMEP FX INTERPFLG)
(COND
((ILEQ (SETQ K (SUB1 K))
0)
(RETURN (\MAKESTACKP OLDPOS FX]
(GO LP])
(\REALFRAMEP
[LAMBDA (FRAME INTERPFLG) (* lmm "18-NOV-82 23:54")
(PROG ((NAME (fetch (FNHEADER FRAMENAME) of (fetch (FX FNHEADER) of FRAME)))
BFLINK) (* NOTE THAT WE SELECT ON THE FNHEADER'S NAME RATHER THAN THE NAMETABLE NAME.
THUS, REALFRAMEP IS NOT AFFECTED BY SETSTKNAME)
(RETURN (SELECTQ NAME
(*ENV*
(* *ENV* is used by ENVEVAL etc.)
NIL)
(\INTERPRETER T)
((EVAL APPLY)
(\SMASHLINK NIL FRAME)
(SELECTQ \INTERNAL
((INTERNAL SELECTQ)
NIL)
T))
(OR (NOT (LITATOM NAME))
(COND
((FMEMB NAME OPENFNS)
INTERPFLG)
(T (OR (NEQ (CHCON1 NAME)
(CHARCODE \))
(EXPRP NAME)
(FASSOC NAME BRKINFOLST])
)
(RPAQ? OPENFNS (QUOTE (SETQ AND OR COND SELECTQ PROG PROGN PROG1 ARG SETARG ERSETQ NLSETQ RESETFORM
RESETLST RESETVARS RPTQ SAVESETQ SETN UNDONLSETQ XNLSETQ APPLY*)))
(RPAQQ \BLIPNAMES (*TAIL* *FORM* *FN* *ARGVALS*))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS BRKINFOLST)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \BLIPNAMES OPENFNS)
)
(DEFINEQ
(RAIDCOMMAND
[LAMBDA NIL (* bvm: "18-AUG-83 13:13")
(DECLARE (USEDFREE ROOTFRAME ALINKS? RAIDIX FRAME#))
(PROG (CMD)
(SELECTQ (ALLOCAL (SETQ CMD (ASKUSER NIL NIL "@" (QUOTE ((Q "uit [confirm]" CONFIRMFLG T)
(%
"↑N - remote return [confirm]"
CONFIRMFLG T RETURN
(QUOTE ↑N))
(% "Basic frame at: "
EXPLAINSTRING
"↑F - print basic frame at octal address"
RETURN
(QUOTE ↑F))
(% "frame extension at: "
EXPLAINSTRING
"↑X - print frame extension at octal address"
RETURN
(QUOTE ↑X))
(%
"Next frame " EXPLAINSTRING
"LF - next frame"
RETURN
(QUOTE LF))
(↑ " Previous frame ")
(% "atom number for atom: "
EXPLAINSTRING
"↑O - look up atom"
RETURN
(QUOTE ↑O))
(A
"tom top-level value of atom: ")
(P "roperty list for atom: ")
(D "efinition for atom: ")
(L "isp stack ")
(%
"Lisp stack from frame or context "
EXPLAINSTRING
"↑L -- Lisp stack from arbitrary frame"
RETURN
(QUOTE ↑L))
(F "rame ")
(S "how stack addresses: ")
(V "irtual address: ")
(B "lock from address: ")
(C "ode for function:")
(W
"alk stack blocks starting at: ")
(% " Enter Lisp " EXPLAINSTRING
"↑Y -- Enter Lisp"
RETURN
(QUOTE ↑Y))
(K "" EXPLAINSTRING
"K -- Set linKtype for stack ops")
(← " Set word at address: ")
(I "nspect InterfacePage")
(U " -- Show remote screen")
("
" "" RETURN NIL)))
T)))
(↑N (RETURN (QUOTE RETURN)))
(Q (TERPRI T)
(RETURN (QUOTE QUIT)))
(NIL)
(A (PRINT [\UNCOPY (GETTOPVAL (PROG1 (READ T T)
(READC T]
T T))
(P (PRINT [\UNCOPY (GETPROPLIST (PROG1 (READ T T)
(READC T]
T T))
(C (DPRINTCODE (PROG1 (READ T T)
(READC T))
T RAIDIX))
(V (PRINT (\UNCOPY (READVA))
T T))
(B (PRINTADDRS (READVA)
(READOCT)))
(S (PRINTADDRS (ADDSTACKBASE (READOCT))
(READOCT)))
(D (PRINTADDRS (\ADDBASE \DEFSPACE (LLSH (\ATOMDEFINDEX (PROG1 (READ T T)
(READC T)))
1))
2))
((L ↑L)
(SETQ FRAME# 0)
[COND
[(EQ CMD (QUOTE L))
(SETQ ROOTFRAME (PROG1 (COND
((ALLOCAL (LISTP VMEMFILE))
(PRIN1 "in TeleRaid Context" T)
(fetch (IFPAGE TELERAIDFXP) of \InterfacePage))
(T (fetch (IFPAGE CurrentFXP) of \InterfacePage)))
(TERPRI T]
((AND (ILESSP (SETQ ROOTFRAME (READOCT))
WORDSPERPAGE)
(ILESSP (GETBASE \InterfacePage ROOTFRAME)
(fetch (IFPAGE EndOfStack) of \InterfacePage))
(type? FX (GETBASE \InterfacePage ROOTFRAME)))
(SETQ ROOTFRAME (GETBASE \InterfacePage ROOTFRAME]
(\BACKTRACE ROOTFRAME NIL T NIL NIL NIL ALINKS? (FUNCTION PRINCOPY)
1 RAIDIX))
[F (RAIDSHOWFRAME (SETQ FRAME# (PROG1 (READ T T)
(READC T]
(LF (OR FRAME# (SETQ FRAME# 0))
(printout T "(" .I1 (add FRAME# 1)
")" T)
(RAIDSHOWFRAME FRAME#))
[↑ (COND
((OR (NULL FRAME#)
(ILEQ FRAME# 1))
(printout T "No previous frame" T))
(T (printout T "(" .I1 (add FRAME# -1)
")" T)
(RAIDSHOWFRAME FRAME#]
(↑F (\PRINTBF (READOCT)
NIL
(FUNCTION PRINCOPY)))
[W (SHOWSTACKBLOCKS (COND
((EQ (PEEKC T)
(QUOTE %
))
(READC T)
0)
(T (READOCT]
(↑X (\PRINTFRAME (READOCT)
(QUOTE PRINCOPY)))
(↑Y (TERPRI T)
(USEREXEC (QUOTE ::)))
[K (SETQ ALINKS? (EQ (ASKUSER NIL NIL " Set link type for stack operations to "
(QUOTE ((A "links
")
(C "links
")))
T)
(QUOTE A]
[← (PROG ((VA (READVA)))
(printout " Currently ")
(PRINTNUM .I7 (GETBASE VA 0))
(printout " to be ")
(PUTBASE VA 0 (READOCT]
(I [ALLOCAL (COND
[(NULL (GETD (QUOTE INSPECT]
((RECLOOK (QUOTE IFPAGE))
(INSPECT [COND
((LISTP VMEMFILE)
(VMAPPAGE (fetch (POINTER PAGE#) of \InterfacePage)))
(T (PROG [(PAGE (NCREATE (QUOTE VMEMPAGEP]
(SETVMPTR (VGETTOPVAL (QUOTE \InterfacePage)))
(\BINS (GETSTREAM VMEMFILE)
PAGE 0 BYTESPERPAGE)
(RETURN PAGE]
(QUOTE IFPAGE)))
(T (PRIN1 " Can't -- no record for IFPAGE"]
(TERPRI T))
(U (SHOWREMOTESCREEN))
(HELP))
(RETURN NIL])
(RAIDSHOWFRAME
[LAMBDA (N) (* bvm: " 3-AUG-83 22:48")
(PROG [(FRAME (OR ROOTFRAME (SETQ ROOTFRAME (fetch (IFPAGE CurrentFXP) of \InterfacePage]
[FRPTQ (SUB1 N)
(COND
([fetch (FX INVALIDP) of (SETQ FRAME (COND
(ALINKS? (fetch (FX ALINK) of FRAME))
(T (fetch (FX CLINK) of FRAME]
(RETURN (printout T N " is beyond the bottom of the stack" T]
(\BACKTRACE FRAME FRAME T NIL T T NIL (FUNCTION PRINCOPY)
NIL RAIDIX])
(PRINTADDRS
[LAMBDA (BASE CNT) (* lmm "23-MAY-82 21:54")
(PRIN1 "words from ")
(PRINTVA BASE)
(PRIN1 " to ")
(PRINTVA (ADDBASE BASE (SUB1 CNT)))
(TERPRI)
(SPACES 7)
(for I from 0 to 7 do (PRINTNUM .I7 I))
(PROG ((NB (VAG2 (HILOC BASE)
(FLOOR (LOLOC BASE)
8)))
(LB (ADDBASE BASE CNT)))
(do (COND
((ZEROP (LOGAND (LOLOC NB)
7))
(TAB 0 0)
(PRINTNUM .I5 (LOLOC NB))
(PRIN1 ": ")))
[COND
((PTRGTP BASE NB)
(SPACES 7))
(T (PRINTNUM .I7 (GETBASE NB 0]
(SETQ NB (ADDBASE NB 1)) repeatwhile (PTRGTP LB NB))
(TAB 0 0])
(PRINTVA
[LAMBDA (X) (* lmm "23-MAY-82 21:48")
(PRIN1 "{")
(PRINTNUM .I2 (HILOC X))
(PRIN1 ",")
(PRINTNUM .I6 (LOLOC X))
(PRIN1 "}"])
(READVA
[LAMBDA NIL (* lmm "21-AUG-81 12:55")
(VAG2 (READOCT)
(READOCT])
(READOCT
[LAMBDA NIL (* lmm "23-MAY-82 22:03")
(bind STR while (EQUAL (SETQ STR (RSTRING T T))
"")
do (READC T)
finally
(RETURN (PROG1 (OR (FIXP (SELECTQ RAIDIX
(8 (MKATOM (CONCAT STR "Q")))
(16 (bind N←0
CHAR while (SETQ CHAR (GNC STR))
do [SETQ N (IPLUS (ITIMES N 16)
(COND
((FIXP CHAR)
CHAR)
((AND (IGEQ (SETQ CHAR
(CHCON1 CHAR))
(CHARCODE A))
(ILEQ CHAR (CHARCODE
F)))
(IPLUS (IDIFFERENCE
CHAR
(CHARCODE A))
10))
(T (ERROR CHAR (QUOTE ?)
T]
finally (RETURN N)))
(SHOULDNT)))
(PROGN (PRIN1 "?" T)
(ERROR!)))
(READC T])
(SHOWSTACKBLOCKS
[LAMBDA (SCANPTR WAITFLG) (* bvm: "18-AUG-83 12:05")
(* show stack)
(PROG ((EASP (fetch EndOfStack of \InterfacePage)))
SCAN[SELECTC (fetch (STK FLAGS) of SCANPTR)
(\STK.FSB (SHOWSTACKBLOCK1 SCANPTR "free block" (fetch (FSB CHECKED) of SCANPTR))
(add SCANPTR (fetch (FSB SIZE) of SCANPTR)))
(\STK.GUARD (SHOWSTACKBLOCK1 SCANPTR "guard block" T)
(add SCANPTR (fetch (FSB SIZE) of SCANPTR)))
(\STK.FX (* frame extension)
(SHOWSTACKBLOCK1 SCANPTR "Frame extn = " (fetch (FX CHECKED)
of SCANPTR))
(PRIN2 (\UNCOPY (fetch (FX FRAMENAME) of SCANPTR)))
(SETQ SCANPTR (fetch (FX NEXTBLOCK) of SCANPTR)))
(PROG ((ORIG SCANPTR)
IVAR) (* must be a basic frame)
(while (EQ (fetch (STK FLAGS) of SCANPTR)
\STK.NOTFLAG)
do (add SCANPTR WORDSPERCELL))
(COND
((NOT (type? BF SCANPTR))
(SHOWSTACKBLOCK1 ORIG "Garbage" T))
(T (SETQ IVAR (fetch (BF IVAR) of SCANPTR))
[COND
((fetch (BF RESIDUAL) of SCANPTR)
(SHOWSTACKBLOCK1 SCANPTR "Residual BF" (EQ SCANPTR ORIG))
(PRIN1 " with IVar = ")
(PRINTNUM .I7 IVAR))
(T (SHOWSTACKBLOCK1 SCANPTR "Basic frame" (AND (EQ ORIG IVAR)
(fetch (BF CHECKED)
of SCANPTR]
(add SCANPTR WORDSPERCELL]
(TERPRI)
(COND
((IGREATERP SCANPTR EASP)
(RETURN)))
(AND WAITFLG (READC T))
(GO SCAN])
(SHOWSTACKBLOCK1
[LAMBDA (PTR STR GOODFLG) (* bvm: " 6-AUG-83 23:59")
(PRINTNUM .I7 PTR)
(SPACES 1)
(OR GOODFLG (PRIN1 "[bad] "))
(PRIN1 STR])
(PRINCOPY
[LAMBDA (X) (* bvm: " 9-DEC-81 15:22")
(PRINT (\UNCOPY X])
)
(DEFINEQ
(BACKTRACE
[LAMBDA (IPOS EPOS FLAGS FILE PRINTFN) (* bvm: " 9-DEC-81 17:09")
(RESETFORM (OUTPUT FILE)
(\BACKTRACE (\STACKARGPTR (OR IPOS -1))
(\STACKARGPTR (OR EPOS T))
[ZEROP (LOGAND 10Q (OR FLAGS (SETQ FLAGS 0]
(NEQ 0 (LOGAND FLAGS 1))
(NEQ 0 (LOGAND FLAGS 4))
(NEQ 0 (LOGAND FLAGS 40Q))
(EQ 0 (LOGAND FLAGS 20Q))
(OR PRINTFN (FUNCTION PRINT))
NIL])
(\BACKTRACE
[LAMBDA (IPOS EPOS NAMES VARS LOCALS JUNK ALINKS PRINTFN CNT RADIX)
(* rmk: " 5-JUN-82 15:28")
(OR RADIX (SETQ RADIX 8))
(PROG [NARGS NPVARS NAME ARGNAME BLINK (.I7 (NUMFORMATCODE (LIST (QUOTE FIX)
7 RADIX]
(DECLARE (SPECVARS .I7))
POSLP
(COND
(CNT (printout NIL .I3 CNT ": ")
(add CNT 1)))
(SETQ NAME (fetch (FNHEADER FRAMENAME) of (fetch (FX NAMETABLE) of IPOS)))
(COND
(JUNK (TERPRI)
(TERPRI)
(PRIN1 "Basic frame at ")
(PRINTNUM .I7 (SETQ BLINK (fetch (FX BLINK) of IPOS)))
(TERPRI)
(\PRINTBF BLINK (fetch (FX NAMETABLE) of IPOS)
PRINTFN)
(PROGN (TERPRI)
(PRIN1 "Frame xtn at ")
(PRINTNUM .I7 IPOS)
(PRIN1 ", frame name= "))
(APPLY* PRINTFN NAME)
(\PRINTFRAME IPOS PRINTFN))
[(OR VARS LOCALS)
(\PRINTBF (fetch (FX BLINK) of IPOS)
(fetch (FX NAMETABLE) of IPOS)
PRINTFN
(COND
(LOCALS (QUOTE LOCALS))
(T T)))
(COND
(NAMES (APPLY* PRINTFN NAME)
(TERPRI)))
(\PRINTFRAME IPOS PRINTFN (COND
(LOCALS (QUOTE LOCALS))
(T T]
(NAMES (APPLY* PRINTFN NAME)))
(COND
([AND (NEQ EPOS IPOS)
(NOT (fetch (FX INVALIDP) of (SETQ IPOS (COND
(ALINKS (fetch (FX ALINK) of IPOS))
(T (fetch (FX CLINK) of IPOS]
(GO POSLP)))
(RETURN T])
(\SCANFORNTENTRY
[LAMBDA (NMT NTENTRY) (* lmm "13-FEB-83 13:55")
(bind NM for NT1 from (fetch (FNHEADER OVERHEADWORDS) of T) as NT2
from (IPLUS (fetch (FNHEADER OVERHEADWORDS) of T)
(fetch (FNHEADER NTSIZE) of NMT))
do (COND
((ZEROP (SETQ NM (\GETBASE NMT NT1)))
(RETURN)))
(COND
((IEQ NTENTRY (\GETBASE NMT NT2))
(RETURN (\INDEXATOMVAL NM])
(\PRINTSTK
[LAMBDA (I) (* lmm "23-MAY-82 22:09")
(PRINTNUM .I7 I)
(PRIN1 ": ")
(PRINTNUM .I7 (GETBASE \STACKSPACE I))
(PRINTNUM .I7 (GETBASE \STACKSPACE (ADD1 I)))
(SPACES 1])
(\PRINTFRAME
[LAMBDA (FRAME PRINTFN VARSONLY) (* bvm: "23-MAR-83 12:22")
(PROG ((NMT (fetch (FX NAMETABLE) of FRAME))
(I 0)
(FT (fetch (FX FIRSTTEMP) of FRAME))
TMP NLOCALS)
[COND
((NOT VARSONLY)
(\PRINTSTK FRAME)
(PRIN1 "[")
(PROGN (PSTKFLD FAST "F, " FAST)
(PSTKFLD INCALL "C, " INCALL)
(PSTKFLD VALIDNAMETABLE "V, " VALIDNAMETABLE)
(PSTKFLD NOPUSH "N, " NOPUSH)
(PSTKFLD USECNT "USE=" (NOT (ZEROP USECNT))
NIL ", ")
(PSTKFLD FASTP "X, " (NOT FASTP))
(PSTKFLD ALINK " alink]" T))
(TERPRI)
(PSTK 2 (FNHEADER "[fn header]" T))
(PSTK 4 (NEXTBLOCK "[next, pc]" T))
(PSTK 6 (NAMETABLE "[nametable]" T))
(PSTK 8 (BLINK "[blink, clink]" T]
(SETQ NLOCALS (fetch (FNHEADER NLOCALS) of NMT))
[for old I from (fetch (FX FIRSTPVAR) of FRAME) by 2 while (ILESSP I FT) as J from 0
do (OR VARSONLY (\PRINTSTK I))
(COND
[(ILESSP J NLOCALS)
(COND
([OR (SETQ TMP (\SCANFORNTENTRY NMT (IPLUS PVARCODE J)))
(AND (NEQ VARSONLY T)
(SETQ TMP (QUOTE *local*]
(COND
((fetch (PVARSLOT BOUND) of (ADDSTACKBASE I))
(AND VARSONLY (SPACES 3))
(PRIN2 TMP)
(SPACES 1)
(APPLY* PRINTFN (GETBASEPTR \STACKSPACE I)))
((NOT VARSONLY)
(printout NIL TMP " [unbound]" T]
((NOT VARSONLY)
(COND
((SETQ TMP (\SCANFORNTENTRY NMT (IPLUS FVARCODE J)))
(printout NIL "[fvar " .P2 TMP " "
(COND
((fetch (FVARSLOT LOOKEDUP) of (ADDSTACKBASE I))
(COND
((EQ [SETQ TMP (\HILOC (fetch (FVARSLOT BINDINGPTR)
of (ADDSTACKBASE I]
\STACKHI)
" on stack]")
((NEQ TMP (\HILOC \VALSPACE))
" non-stack binding]")
(T " top value]")))
(T " not looked up]"))
T))
(T (printout NIL "[padding]" T]
(COND
((NOT VARSONLY)
(SETQ FT (fetch (FX NEXTBLOCK) of FRAME))
(for old I by 2 while (ILESSP I FT)
do (\PRINTSTK I)
(COND
((fetch (PVARSLOT BOUND) of (ADDSTACKBASE I))
(APPLY* PRINTFN (GETBASEPTR \STACKSPACE I)))
(T (TERPRI])
(\PRINTBF
[LAMBDA (BL NMT PRINTFN VARSONLY) (* bvm: " 9-DEC-81 16:44")
[bind NM for I from (fetch (BF IVAR) of BL) by 2 as J from 0 to (SUB1 (fetch (BF NARGS)
of BL))
do (OR VARSONLY (\PRINTSTK I))
[COND
([OR (SETQ NM (\SCANFORNTENTRY [OR NMT (RETURN (OR VARSONLY (TERPRI]
(IPLUS IVARCODE J)))
(AND (NEQ VARSONLY T)
(SETQ NM (QUOTE *local*]
(AND VARSONLY (SPACES 3))
(PRIN2 NM)
(SPACES 1)
(APPLY* PRINTFN (GETBASEPTR \STACKSPACE I]
finally (OR VARSONLY (while (ILESSP I BL) do (\PRINTSTK I)
(printout NIL "[padding]" T)
(add I 2]
(COND
((NOT VARSONLY)
(\PRINTSTK BL)
(COND
((fetch (BF RESIDUAL) of BL)
(PRIN1 "residual ")))
(COND
((NEQ (fetch (BF USECNT) of BL)
0)
(printout NIL "usecnt= " (fetch (BF USECNT) of BL)
,)))
(TERPRI])
)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS PSTKFLD MACRO [(FLD STR TEST FMT STR2)
(PROG ((FLD (fetch (FX FLD) of FRAME)))
(DECLARE (LOCALVARS FLD))
(COND
(TEST (PRIN1 (QUOTE STR))
(SELECTQ (CONSTANT (NTHCHAR (QUOTE STR)
-1))
(= (printout NIL , FLD STR2))
NIL)
T])
(PUTPROPS PRINTSTKFIELDS MACRO [FIELDS (CONS (QUOTE PROGN)
(MAPCAR FIELDS (FUNCTION (LAMBDA (X)
(CONS (QUOTE PSTKFLD)
X])
(PUTPROPS PSTK MACRO ((N . FIELDS)
(\PRINTSTK (IPLUS FRAME N))
(PRINTSTKFIELDS . FIELDS)
(TERPRI)))
(PUTPROPS PRINTVA MACRO [LAMBDA (X)
(printout NIL "{" (HILOC X)
","
(LOLOC X)
"}"])
)
(ADDTOVAR RDCOMS (FNS RAIDCOMMAND RAIDSHOWFRAME PRINTADDRS PRINTVA READVA READOCT SHOWSTACKBLOCKS
SHOWSTACKBLOCK1 PRINCOPY)
(FNS \BACKTRACE \PRINTBF \PRINTFRAME \SCANFORNTENTRY \PRINTSTK))
(ADDTOVAR EXPANDMACROFNS PSTKFLD PRINTSTKFIELDS PSTK PRINTVA)
EVAL@COMPILE
(ADDTOVAR DONTCOMPILEFNS RAIDCOMMAND RAIDSHOWFRAME PRINTADDRS PRINTVA READVA READOCT SHOWSTACKBLOCKS
SHOWSTACKBLOCK1 PRINCOPY)
)
(DEFINEQ
(CCODEP
[LAMBDA (FN) (* lmm "17-FEB-82 23:48")
(COND
[(LITATOM FN)
(AND (fetch (LITATOM CCODEP) of FN)
(NOT (fetch (LITATOM PSEUDOCODEP) of FN]
(T (AND (ARRAYP FN)
(EQ (fetch (ARRAYP TYP) of FN)
\ST.CODE])
(EXPRP
[LAMBDA (FN) (* lmm "17-FEB-82 23:50")
(PROG ((DEF FN))
[COND
((LITATOM DEF)
[COND
((fetch (LITATOM CCODEP) of DEF)
(RETURN (fetch (LITATOM PSEUDOCODEP) of DEF]
(SETQ DEF (fetch (LITATOM DEFPOINTER) of DEF]
(RETURN (COND
((LISTP DEF)
T])
(SUBRP
[LAMBDA (FN) (* lmm "17-AUG-81 21:57")
NIL])
(FNTYP
[LAMBDA (FN) (* lmm "17-FEB-82 23:53")
(PROG ((DEF FN))
[COND
((LITATOM DEF)
(SETQ DEF (fetch (LITATOM DEFINITIONCELL) of DEF))
(COND
((fetch (DEFINITIONCELL PSEUDOCODEP) of DEF)
(SETQ DEF (\PSEUDOCODE.REALDEF DEF)))
((PROG1 (fetch (DEFINITIONCELL CCODEP) of DEF)
(SETQ DEF (fetch (DEFINITIONCELL DEFPOINTER) of DEF)))
(RETURN (\CCODEFNTYP DEF]
(RETURN (COND
((LISTP DEF)
(SELECTQ (CAR DEF)
[LAMBDA (COND
((AND (NLISTP (SETQ DEF (CADR DEF)))
DEF)
(QUOTE EXPR*))
(T (QUOTE EXPR]
[NLAMBDA (COND
((AND (NLISTP (SETQ DEF (CADR DEF)))
DEF)
(QUOTE FEXPR*))
(T (QUOTE FEXPR]
(FUNARG (QUOTE FUNARG))
(FNTYP1 DEF)))
((AND (ARRAYP DEF)
(EQ (fetch (ARRAYP TYP) of DEF)
\ST.CODE))
(\CCODEFNTYP (fetch (ARRAYP BASE) of DEF])
(ARGTYPE
[LAMBDA (FN) (* lmm "17-AUG-81 21:57")
(PROG ((DEF FN))
[COND
((LITATOM DEF)
(COND
((PROG1 (fetch (LITATOM CCODEP) of DEF)
(SETQ DEF (fetch (LITATOM DEFPOINTER) of DEF)))
(RETURN (\CCODEARGTYPE DEF]
(RETURN (COND
((LISTP DEF)
(SELECTQ (CAR DEF)
[LAMBDA (COND
((AND (NLISTP (SETQ DEF (CADR DEF)))
DEF)
2)
(T 0]
[NLAMBDA (COND
((AND (NLISTP (SETQ DEF (CADR DEF)))
DEF)
3)
(T 1]
(FUNARG (ARGTYPE (CADR DEF)))
NIL))
((AND (ARRAYP DEF)
(EQ (fetch (ARRAYP TYP) of DEF)
\ST.CODE))
(\CCODEARGTYPE (fetch (ARRAYP BASE) of DEF])
(NARGS
[LAMBDA (FN) (* lmm "17-AUG-81 21:57")
(PROG ((DEF FN))
[COND
((LITATOM DEF)
(COND
((PROG1 (fetch (LITATOM CCODEP) of DEF)
(SETQ DEF (fetch (LITATOM DEFPOINTER) of DEF)))
(RETURN (\CCODENARGS DEF]
(RETURN (COND
((LISTP DEF)
(SELECTQ (CAR DEF)
[[LAMBDA NLAMBDA]
(COND
((NULL (SETQ DEF (CADR DEF)))
0)
((NLISTP DEF)
1)
(T (in DEF sum 1]
(FUNARG (NARGS (CADR DEF)))
NIL))
((AND (ARRAYP DEF)
(EQ (fetch (ARRAYP TYP) of DEF)
\ST.CODE))
(\CCODENARGS (fetch (ARRAYP BASE) of DEF])
(ARGLIST
[LAMBDA (FN) (* lmm "17-AUG-81 21:40")
(DECLARE (GLOBALVARS LAMBDASPLST))
(PROG ((DEF FN))
[COND
((LITATOM DEF)
(COND
((PROG1 (fetch (LITATOM CCODEP) of DEF)
(SETQ DEF (fetch (LITATOM DEFPOINTER) of DEF)))
(RETURN (\CCODEARGLIST DEF)))
(T (OR DEF (SETQ DEF (GETPROP FN (QUOTE EXPR]
[RETURN (COND
[(LISTP DEF)
(SELECTQ (CAR DEF)
([LAMBDA NLAMBDA]
(CADR DEF))
(FUNARG (ARGLIST (CADR DEF)))
(COND
((MEMB (CAR DEF)
LAMBDASPLST)
(CADR DEF))
(T (GO UNDEF]
((AND (ARRAYP DEF)
(EQ (fetch (ARRAYP TYP) of DEF)
\ST.CODE))
(\CCODEARGLIST (fetch (ARRAYP BASE) of DEF)))
(T (GO UNDEF]
UNDEF
(COND
((AND (SETQ DEF (FNCHECK FN T))
(NEQ DEF FN))
(RETURN (ARGLIST DEF)))
(T (ERROR (QUOTE "Args not available:")
FN])
(\CCODEARGLIST
[LAMBDA (FNHD) (* lmm "14-MAY-82 21:54")
(PROG ((N (fetch (FNHEADER NA) of FNHD))
IVARS NM SIZE ENDT)
(COND
((ILESSP N 0) (* LAMBDA*)
(RETURN (QUOTE U)))
((ZEROP N)
(RETURN)))
[COND
((NEQ (SETQ SIZE (fetch (FNHEADER NTSIZE) of FNHD))
0)
(SETQ IVARS (\CCODEIVARSCAN FNHD (fetch (FNHEADER OVERHEADWORDS) of T)
SIZE]
[COND
((IGREATERP [SETQ SIZE (IDIFFERENCE (FOLDLO (fetch (FNHEADER STARTPC) of FNHD)
BYTESPERWORD)
(SETQ ENDT (IPLUS (fetch (FNHEADER OVERHEADWORDS)
of T)
(COND
((ZEROP SIZE)
(* No nametable, but there's a quad of zeros there anyway)
WORDSPERQUAD)
(T (UNFOLD SIZE 2]
0) (* There is a second nametable between the first and the code)
(SETQ IVARS (\CCODEIVARSCAN FNHD ENDT (FOLDLO SIZE 2)
IVARS]
[SETQ IVARS (for I from 0 to (SUB1 N)
collect (COND
((SETQ NM (ASSOC I IVARS))
(CDR NM))
([AND (SETQ NM (NTH (QUOTE (U V W X Y Z))
(ADD1 I)))
(NOT (find X in IVARS suchthat (EQ (CADR X)
(CAR NM]
(CAR NM))
(T (PACK* (QUOTE *ARG*)
I]
(RETURN (SELECTQ (fetch (FNHEADER ARGTYPE) of FNHD)
(3 (CAR IVARS))
IVARS])
(\CCODEIVARSCAN
[LAMBDA (FNHD START SIZE IVARS)
(* lmm "13-FEB-83 13:55")
(* * Search nametable starting at offset START in FNHD for all ivars. Return list of dotted pairs
(index . name) consed onto front of IVARS. NTSIZE is size of nt in words)
(for OFFSET from START bind NM CODE while (SETQ NM (\INDEXATOMVAL (\GETBASE FNHD OFFSET)))
do [COND
((EQ [LOGAND VARCODEMASK (SETQ CODE (GETBASE FNHD (IPLUS OFFSET SIZE]
IVARCODE)
(push IVARS (CONS (IDIFFERENCE CODE IVARCODE)
NM]
finally (RETURN IVARS])
)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS \CCODENARGS MACRO ((FNH)
([LAMBDA (N)
(COND
((ILESSP N 0)
1)
(T N]
(FETCH (FNHEADER NA) OF FNH))))
)
)
(DECLARE: EVAL@COMPILE
(PUTPROPS \CCODEFNTYP MACRO ((FNH)
(SELECTQ (\CCODEARGTYPE FNH)
(0 (QUOTE CEXPR))
(1 (QUOTE CFEXPR))
(2 (QUOTE CEXPR*))
(QUOTE CFEXPR*))))
(PUTPROPS \CCODEARGTYPE MACRO ((FNH)
(fetch (FNHEADER ARGTYPE) of FNH)))
(PUTPROPS \CCODEPNARGS MACRO ((FNH)
([LAMBDA (N)
(IF N LT 0
THEN 1
ELSE N]
(FETCH (FNHEADER NA) OF FNH))))
)
(DECLARE: EVAL@COMPILE DONTCOPY
(ADDTOVAR LAMS FAULTEVAL FAULTAPPLY)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA PROG1 COND PROGN OR AND QUOTE GO PROG SETN SETQ)
(ADDTOVAR NLAML FUNCTION)
(ADDTOVAR LAMA APPLY* \INTERPRETER)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(SPECVARS *TAIL* *FN* *FORM* *ARGVAL* *ARGVAL1* *ARGVAL2*)
)
(PUTPROPS LLINTERP COPYRIGHT ("Xerox Corporation" 3675Q 3676Q 3677Q))
(DECLARE: DONTCOPY
(FILEMAP (NIL (5730Q 23257Q (\INTERPRETER 5742Q . 13464Q) (\INTERPRETER1 13466Q . 23255Q)) (23322Q
41630Q (EVAL 23334Q . 23570Q) (\EVAL 23572Q . 24201Q) (\EVALFORM 24203Q . 27602Q) (\EVALOTHER 27604Q
. 30270Q) (APPLY 30272Q . 32022Q) (APPLY* 32024Q . 35100Q) (\CHECKAPPLY* 35102Q . 40206Q) (
\CKAPPLYARGS 40210Q . 41124Q) (DEFEVAL 41126Q . 41626Q)) (42250Q 55677Q (EVALV 42262Q . 42637Q) (
\EVALV1 42641Q . 43176Q) (\EVALVAR 43200Q . 44316Q) (BOUNDP 44320Q . 45071Q) (SET 45073Q . 46062Q) (
\SETVAR 46064Q . 47057Q) (SETQ 47061Q . 47773Q) (SETN 47775Q . 50707Q) (\STKSCAN 50711Q . 55675Q)) (
55735Q 76744Q (PROG 55747Q . 60461Q) (\PROG0 60463Q . 65126Q) (\EVPROG1 65130Q . 65566Q) (RETURN
65570Q . 67024Q) (GO 67026Q . 71310Q) (EVALA 71312Q . 73102Q) (\EVALA 73104Q . 76573Q) (ERRORSET
76575Q . 76742Q)) (76745Q 102636Q (QUOTE 76757Q . 77021Q) (AND 77023Q . 77441Q) (OR 77443Q . 100004Q)
(PROGN 100006Q . 100563Q) (COND 100565Q . 101476Q) (\EVPROGN 101500Q . 102116Q) (PROG1 102120Q .
102634Q)) (102725Q 114416Q (ENVEVAL 102737Q . 103454Q) (ENVAPPLY 103456Q . 104177Q) (FUNCTION 104201Q
. 104663Q) (\FUNCT1 104665Q . 110115Q) (\MAKEFUNARGFRAME 110117Q . 112020Q) (STKEVAL 112022Q .
112337Q) (STKAPPLY 112341Q . 112701Q) (RETEVAL 112703Q . 113544Q) (RETAPPLY 113546Q . 114414Q)) (
114472Q 125552Q (BLIPVAL 114504Q . 120657Q) (SETBLIPVAL 120661Q . 124314Q) (BLIPSCAN 124316Q . 125550Q
)) (125553Q 131532Q (DUMMYFRAMEP 125565Q . 125745Q) (REALFRAMEP 125747Q . 126426Q) (REALSTKNTH 126430Q
. 127772Q) (\REALFRAMEP 127774Q . 131530Q)) (132332Q 155153Q (RAIDCOMMAND 132344Q . 144113Q) (
RAIDSHOWFRAME 144115Q . 145203Q) (PRINTADDRS 145205Q . 146467Q) (PRINTVA 146471Q . 146761Q) (READVA
146763Q . 147203Q) (READOCT 147205Q . 151014Q) (SHOWSTACKBLOCKS 151016Q . 154433Q) (SHOWSTACKBLOCK1
154435Q . 154746Q) (PRINCOPY 154750Q . 155151Q)) (155154Q 171557Q (BACKTRACE 155166Q . 156113Q) (
\BACKTRACE 156115Q . 161306Q) (\SCANFORNTENTRY 161310Q . 162250Q) (\PRINTSTK 162252Q . 162614Q) (
\PRINTFRAME 162616Q . 167453Q) (\PRINTBF 167455Q . 171555Q)) (174056Q 211276Q (CCODEP 174070Q .
174551Q) (EXPRP 174553Q . 175360Q) (SUBRP 175362Q . 175507Q) (FNTYP 175511Q . 177606Q) (ARGTYPE
177610Q . 201321Q) (NARGS 201323Q . 202712Q) (ARGLIST 202714Q . 204772Q) (\CCODEARGLIST 204774Q .
210060Q) (\CCODEIVARSCAN 210062Q . 211274Q)))))
STOP