(FILECREATED " 5-Mar-85 18:21:50" {ERIS}<LISPCORE>SOURCES>LLINTERP.;16 78295
changes to: (FNS \PRINTFRAME)
previous date: "13-Feb-85 23:06:40" {ERIS}<LISPCORE>SOURCES>LLINTERP.;15)
(* Copyright (c) 1981, 1982, 1983, 1984, 1985 by Xerox Corporation. All rights reserved. The following
program was created in 1981 but has not been published within the meaning of the copyright law, is
furnished under license, and may not be used, copied and/or disclosed except in accordance with the
terms of said license.)
(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
EVALHOOK)
(DECLARE: DONTCOPY (MACROS .APPLY.))
(VARS (\DEFEVALFNS NIL)
(\EVALHOOK))
(SPECVARS *EVALHOOK*)
(GLOBALVARS \DEFEVALFNS \EVALHOOK)
(DECLARE: DONTEVAL@LOAD DOCOPY (VARS (CLISPARRAY)))
(GLOBALVARS CLISPARRAY)
(COMS (* Free variable manipulation)
(FNS EVALV \EVALV1 \EVALVAR BOUNDP SET \SETVAR SETQ SETN \STKSCAN \SETFVARSLOT))
(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 RAIDSTACKCMD RAIDROOTFRAME PRINTADDRS PRINTVA READVA
READATOM READOCT SHOWSTACKBLOCKS SHOWSTACKBLOCK1 PRINCOPY NOSUCHATOM)
(FNS BACKTRACE \BACKTRACE \SCANFORNTENTRY \PRINTSTK \PRINTFRAME \PRINTBF)
(DECLARE: EVAL@COMPILE DONTCOPY (COMS * RAIDCOMS)))
(COMS (FNS CCODEP EXPRP SUBRP FNTYP ARGTYPE NARGS ARGLIST \CCODEARGLIST \CCODEIVARSCAN)
(DECLARE: DONTCOPY (MACROS \CCODENARGS \CCODEFNTYP \CCODEARGTYPE)))
(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 "10-Apr-84 14:34")
(* 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 OPENLAMBDA]
[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)) (* lmm " 8-May-84 17:04")
(* eval of LISTP)
(PROG NIL
[COND
((AND \EVALHOOK (NOT TEMP))
(RETURN (PROG1 (SPREADAPPLY*(PROG1 (SETQ TEMP \EVALHOOK)
(SETQ \EVALHOOK))
*FORM*)
(SETQ \EVALHOOK TEMP]
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]
(OPENLAMBDA (GO EVLAM))
(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 "15-Aug-84 17:53")
(.APPLY. U V])
(APPLY*
[LAMBDA U (* lmm "15-Aug-84 01:19")
(PROG [(DEF (AND (IGREATERP U 0)
(ARG U 1]
LP (COND
[(LITATOM DEF)
(COND
[(fetch (LITATOM CCODEP) of DEF)
(COND
((EQ (fetch (LITATOM ARGTYPE) of DEF)
3)
(GO NOSPR))
(T (GO SPR]
(T (* EXPR)
(SETQ DEF (OR (LISTP (fetch (LITATOM DEFPOINTER) of DEF))
(GO FAULT]
((NLISTP DEF)
(GO FAULT)))
(SELECTQ (CAR DEF)
[LAMBDA NIL]
(FUNARG (SETQ DEF (CADR DEF))
(GO LP))
[NLAMBDA (COND
((AND (CAR (LISTP (CDR DEF)))
(NLISTP (CADR DEF)))
(GO NOSPR]
(OPENLAMBDA)
(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 DEF (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 "10-Apr-84 14:35")
(* 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 OPENLAMBDA 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])
(EVALHOOK
[LAMBDA (FORM EVALHOOKFN)
(DECLARE (LOCALVARS FORM EVALHOOKFN)) (* lmm " 8-May-84 16:42")
(COND
((LISTP FORM)
(SETQ \EVALHOOK EVALHOOKFN)
(PROG1 (\EVALFORM FORM T)
(SETQ \EVALHOOK)))
(T (\EVAL FORM])
)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS .APPLY. MACRO [(U V) (* body for APPLY, used by RETAPPLY too)
(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))
((NULL DEF)
(RETURN (FAULTAPPLY U V]
NORMAL
(RETURN (SPREADAPPLY U V))
NLSTAR (* NLAMBDA*)
(RETURN (SPREADAPPLY* U V])
)
)
(RPAQQ \DEFEVALFNS NIL)
(RPAQQ \EVALHOOK NIL)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(SPECVARS *EVALHOOK*)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \DEFEVALFNS \EVALHOOK)
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(RPAQQ CLISPARRAY NIL)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS CLISPARRAY)
)
(* Free variable manipulation)
(DEFINEQ
(EVALV
[LAMBDA (VAR POS RELFLG) (* lmm " 6-Apr-84 16:37")
(* EVAL of a LITATOM without uba error)
[COND
(POS (\SMASHLINK NIL (\STACKARGPTR POS]
(PROG1 (\EVALV1 VAR)
(COND
(RELFLG (RELSTK POS])
(\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: "18-Jan-85 14:21")
(* 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 (FLOOR (\HILOC VP)
2)
(\HILOC \VALSPACE))) (* Value is NOBIND and it was found as the top-level
value)
(FAULTEVAL VAR))
(T VAL])
(BOUNDP
[LAMBDA (VAR) (* bvm: "18-Jan-85 14:12")
(* True if VAR is bound or has top level value)
(AND (LITATOM VAR)
(OR (NEQ (GETTOPVAL VAR)
(QUOTE NOBIND))
(NEQ (PROGN
(* \VALSPACE is (potentially) two segments long, but continguous, so mask out the low bit of the binding pointer
segment. In the 32K litatom world this test would also succeed if the binding pointer were in plist space, but that
never happens)
(FLOOR (\HILOC (\STKSCAN VAR))
2))
(\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) (* bvm: "13-Feb-85 22:38")
(* 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 (fetch (VALINDEX VCELL) of ATOM#]
(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
((EQ (SETQ A (\GETBASE NT 0))
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 (STACKADDBASE 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])
(\SETFVARSLOT
[LAMBDA (VAR NEWBINDING) (* bvm: "13-Feb-85 22:39")
(* Sets the freevar binding slot of VAR in caller's
frame to point at NEWBINDING)
(PROG ((FX (\MYALINK))
(ATOM# (\ATOMVALINDEX VAR))
NTSIZE A VARINFO NT)
(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
((EQ (SETQ A (\GETBASE NT 0))
0) (* End of name table)
(ERROR "Binding slot not found in caller's frame" VAR))
((AND (EQ A ATOM#)
(EQ (fetch (NAMETABLESLOT VARTYPE) of (SETQ VARINFO (\ADDBASE NT NTSIZE)))
\NT.FVAR))
(replace (FVARSLOT BINDINGPTR) of (ADDSTACKBASE (IPLUS (UNFOLD (fetch (NAMETABLESLOT
VAROFFSET)
of VARINFO)
WORDSPERCELL)
(fetch (FX FIRSTPVAR)
of FX)))
with NEWBINDING)
(RETURN NEWBINDING)))
(SETQ NT (\ADDBASE NT 1))
(GO TABLELP])
)
(* 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) (* lmm "15-Aug-84 17:53")
(\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) (* lmm "15-Aug-84 17:55")
(\CALLME (QUOTE *ENV*))
(\SMASHLINK NIL (\STACKARGPTR POS))
(AND FLG (RELSTK POS))
(.APPLY. FN ARGS])
(RETEVAL
[LAMBDA (POS FORM FLG INTERNALFLG) (* lmm "28-Aug-84 12:20")
(\CALLME (QUOTE *ENV*))
(PROG ((FX (\STACKARGPTR POS)))
(\SMASHLINK NIL FX (COND
((fetch (FX INVALIDP) of (SETQ FX (fetch (FX CLINK) of FX)))
(LISPERROR "ILLEGAL STACK ARG" POS))
(T FX)))
(AND FLG (RELSTK POS))
(RETURN (\EVAL FORM])
(RETAPPLY
[LAMBDA (POS FN ARGS FLG) (* lmm "28-Aug-84 12:20")
(\CALLME (QUOTE *ENV*))
(PROG ((FX (\STACKARGPTR POS)))
(\SMASHLINK NIL FX (COND
((fetch (FX INVALIDP) of (SETQ FX (fetch (FX CLINK) of FX)))
(LISPERROR "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 "15-Aug-84 17:14")
(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 (NEQ NAME (fetch (FNHEADER FRAMENAME)
of (fetch (FX NAMETABLE) of FRAME]
((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
(GLOBALVARS BRKINFOLST)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \BLIPNAMES OPENFNS)
)
(DEFINEQ
(RAIDCOMMAND
[LAMBDA NIL (* bvm: "28-Jan-85 11:56")
(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]" NOECHOFLG
T CONFIRMFLG T RETURN (QUOTE ↑N))
(L "isp stack ")
(% "Lisp stack " NOECHOFLG T EXPLAINSTRING
"↑L -- Lisp stack from arbitrary frame or context"
RETURN
(QUOTE ↑L))
(F "rame ")
(%
"Next frame " EXPLAINSTRING
"LF - next frame"
RETURN
(QUOTE LF))
(↑ " Previous frame ")
(A "tom top-level value of atom: ")
(D "efinition for atom: ")
(P "roperty list for atom: ")
(V " -- show object at Virtual address: ")
(B "lock of storage starting at address: ")
(S "how raw stack from address: ")
(C "ode for function:")
(% "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))
(W "alk stack blocks starting at: ")
(K "" EXPLAINSTRING
"K -- Set linKtype for stack ops")
(← " Set word at address: ")
(% " Set value of atom " EXPLAINSTRING
"↑V -- Set value of atom"
RETURN
(QUOTE ↑V))
(% "atom number for atom: " EXPLAINSTRING
"↑O - look up atom"
RETURN
(QUOTE ↑O))
(I "nspect InterfacePage [confirm]"
CONFIRMFLG T)
(U " -- Show remote screen [confirm]"
CONFIRMFLG T)
("
" "" RETURN NIL)
(% " Enter Lisp " EXPLAINSTRING
"↑Y -- Enter Lisp"
RETURN
(QUOTE ↑Y]
T)))
(↑N (RETURN (QUOTE RETURN)))
(Q (TERPRI T)
(RETURN (QUOTE QUIT)))
(NIL)
(A (PRINT (\UNCOPY (GETTOPVAL (READATOM)))
T T))
(P (PRINT (\UNCOPY (GETPROPLIST (READATOM)))
T T))
(C (DPRINTCODE (READATOM)
T RAIDIX))
(V (PRINT (\UNCOPY (READVA))
T T))
(B (PRINTADDRS (READVA)
(READOCT " for (number of words): ")))
(S (PRINTADDRS (ADDSTACKBASE (READOCT))
(READOCT " for (number of words): ")))
(D (PRINTADDRS (fetch (LITATOM DEFINITIONCELL) of (READATOM))
2))
(↑O (PRINT (\ATOMVALINDEX (READATOM))
T T))
[↑V (PROG ((ATM (READATOM)))
(printout T " to be ")
(SETTOPVAL ATM (READ T T]
((L ↑L)
(RAIDSTACKCMD CMD))
[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 T " Currently ")
(PRINTNUM .I7 (GETBASE VA 0)
T)
(printout T " 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: "27-Jan-85 15:27")
(PROG [(FRAME (OR ROOTFRAME (RAIDROOTFRAME]
[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])
(RAIDSTACKCMD
[LAMBDA (CMD) (* bvm: "28-Jan-85 12:16")
(DECLARE (USEDFREE FRAME# ROOTFRAME))
(PROG (FRAME)
(SETQ FRAME# 0)
[COND
((EQ CMD (QUOTE L))
(RAIDROOTFRAME))
(T (SETQ ROOTFRAME (SELECTQ (SETQ FRAME (ASKUSER NIL NIL "in context (? for help): "
(QUOTE ((P "age fault")
(G "arbage collection")
(K "eyboard handler")
(H "ard Return")
(S "tack manipulator")
(R "eset")
(M "iscellaneous")
(F "rame at location: ")))
T))
(P (fetch (IFPAGE FAULTFXP) of \InterfacePage))
(G (fetch (IFPAGE GCFXP) of \InterfacePage))
(K (fetch (IFPAGE KbdFXP) of \InterfacePage))
(H (fetch (IFPAGE HardReturnFXP) of \InterfacePage))
(S (fetch (IFPAGE SubovFXP) of \InterfacePage))
(R (fetch (IFPAGE ResetFXP) of \InterfacePage))
(M (fetch (IFPAGE MiscFXP) of \InterfacePage))
(COND
((AND (ILESSP (SETQ FRAME (READOCT))
WORDSPERPAGE)
(ILESSP (\GETBASE \InterfacePage FRAME)
(fetch (IFPAGE EndOfStack) of \InterfacePage))
(type? FX (\GETBASE \InterfacePage FRAME)))
(\GETBASE \InterfacePage FRAME))
((type? FX FRAME)
FRAME)
(T (PRINTNUM .I7 FRAME)
(printout T " not a valid frame." T)
(RETURN]
(FRESHLINE T)
(\BACKTRACE ROOTFRAME NIL T NIL NIL NIL ALINKS? (FUNCTION PRINCOPY)
1 RAIDIX])
(RAIDROOTFRAME
[LAMBDA NIL (* bvm: "27-Jan-85 15:26")
(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])
(PRINTADDRS
[LAMBDA (BASE CNT) (* bvm: "13-Feb-85 22:42")
(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
((EVENP (\LOLOC NB)
8)
(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) (* bvm: "12-Feb-85 10:41")
(PRIN1 "{")
(PRINTNUM .I2 (HILOC X))
(PRIN1 ",")
(PRINTNUM .I2 (LOLOC X))
(PRIN1 "}"])
(READVA
[LAMBDA NIL (* lmm "21-AUG-81 12:55")
(VAG2 (READOCT)
(READOCT])
(READATOM
[LAMBDA NIL (* bvm: "18-Jan-85 14:42")
(PROG1 (READ T T)
(READC T])
(READOCT
[LAMBDA (PROMPT) (* bvm: "28-Jan-85 11:51")
(DECLARE (USEDFREE RAIDIX))
(COND
((AND PROMPT (NOT (READP T)))
(printout T PROMPT)))
(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])
(NOSUCHATOM
[LAMBDA (ATM) (* bvm: "18-Jan-85 17:52")
(* Called only under TeleRaid when V\MKATOM fails to
find atom ATM)
(printout T "No such atom: " ATM T)
(ERROR!])
)
(DEFINEQ
(BACKTRACE
[LAMBDA (IPOS EPOS FLAGS FILE PRINTFN) (* bvm: "13-Feb-85 22:42")
(RESETFORM (OUTPUT FILE)
(\BACKTRACE (\STACKARGPTR (OR IPOS -1))
(\STACKARGPTR (OR EPOS T))
[EQ 0 (LOGAND 8 (OR FLAGS (SETQ FLAGS 0]
(NEQ 0 (LOGAND FLAGS 1))
(NEQ 0 (LOGAND FLAGS 4))
(NEQ 0 (LOGAND FLAGS 32))
(EQ 0 (LOGAND FLAGS 16))
(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) (* bvm: "13-Feb-85 22:42")
(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
((EQ (SETQ NM (\GETBASE NMT NT1))
0)
(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: " 5-Mar-85 18:14")
(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=" (NEQ USECNT 0)
NIL ", ")
(PSTKFLD SLOWP "X, " SLOWP)
(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 WORDSPERCELL 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 (ADDSTACKBASE I)
0)))
((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 (FLOOR TMP 2)
(\HILOC \VALSPACE))
(* See comment in BOUNDP)
" 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 (* 2 = WORDSPERCELL but for doesn't translate correctly
with WORDSPERCELL)
(\PRINTSTK I)
(COND
((fetch (PVARSLOT BOUND) of (ADDSTACKBASE I))
(APPLY* PRINTFN (\GETBASEPTR (ADDSTACKBASE I)
0)))
(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: EVAL@COMPILE DONTCOPY
(RPAQQ RAIDCOMS ((MACROS PSTKFLD PRINTSTKFIELDS PSTK PRINTVA)
(ADDVARS (RDCOMS (FNS RAIDCOMMAND RAIDSHOWFRAME RAIDSTACKCMD RAIDROOTFRAME PRINTADDRS PRINTVA
READVA READOCT READATOM SHOWSTACKBLOCKS SHOWSTACKBLOCK1 PRINCOPY
NOSUCHATOM)
(FNS \BACKTRACE \PRINTBF \PRINTFRAME \SCANFORNTENTRY \PRINTSTK))
(EXPANDMACROFNS PSTKFLD PRINTSTKFIELDS PSTK PRINTVA))
(ADDVARS (DONTCOMPILEFNS RAIDCOMMAND RAIDSHOWFRAME RAIDSTACKCMD RAIDROOTFRAME PRINTADDRS
PRINTVA READVA READATOM READOCT SHOWSTACKBLOCKS SHOWSTACKBLOCK1
PRINCOPY NOSUCHATOM))))
(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 RAIDSTACKCMD RAIDROOTFRAME PRINTADDRS PRINTVA READVA
READOCT READATOM SHOWSTACKBLOCKS SHOWSTACKBLOCK1 PRINCOPY NOSUCHATOM)
(FNS \BACKTRACE \PRINTBF \PRINTFRAME \SCANFORNTENTRY \PRINTSTK))
(ADDTOVAR EXPANDMACROFNS PSTKFLD PRINTSTKFIELDS PSTK PRINTVA)
(ADDTOVAR DONTCOMPILEFNS RAIDCOMMAND RAIDSHOWFRAME RAIDSTACKCMD RAIDROOTFRAME PRINTADDRS PRINTVA
READVA READATOM READOCT SHOWSTACKBLOCKS SHOWSTACKBLOCK1 PRINCOPY
NOSUCHATOM)
)
(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 "10-Apr-84 14:36")
(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 OPENLAMBDA]
(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 "10-Apr-84 14:36")
(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 OPENLAMBDA]
(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 "10-Apr-84 14:36")
(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 OPENLAMBDA]
(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 "10-Apr-84 14:37")
(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 OPENLAMBDA]
(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) (* bvm: "13-Feb-85 22:43")
(PROG ((N (fetch (FNHEADER NA) of FNHD))
IVARS NM SIZE ENDT)
(COND
((ILESSP N 0) (* LAMBDA*)
(RETURN (QUOTE U)))
((EQ N 0)
(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
((EQ SIZE 0)
(* 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))))
(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)))
)
)
(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" T 1981 1982 1983 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (3007 9781 (\INTERPRETER 3017 . 5818) (\INTERPRETER1 5820 . 9779)) (9816 16820 (EVAL
9826 . 9982) (\EVAL 9984 . 10247) (\EVALFORM 10249 . 12169) (\EVALOTHER 12171 . 12479) (APPLY 12481 .
12631) (APPLY* 12633 . 14243) (\CHECKAPPLY* 14245 . 15752) (\CKAPPLYARGS 15754 . 16214) (DEFEVAL 16216
. 16536) (EVALHOOK 16538 . 16818)) (18239 26108 (EVALV 18249 . 18578) (\EVALV1 18580 . 18801) (
\EVALVAR 18803 . 19442) (BOUNDP 19444 . 20137) (SET 20139 . 20642) (\SETVAR 20644 . 21151) (SETQ 21153
. 21611) (SETN 21613 . 22071) (\STKSCAN 22073 . 24776) (\SETFVARSLOT 24778 . 26106)) (26138 34849 (
PROG 26148 . 27502) (\PROG0 27504 . 29843) (\EVPROG1 29845 . 30131) (RETURN 30133 . 30801) (GO 30803
. 32005) (EVALA 32007 . 32895) (\EVALA 32897 . 34744) (ERRORSET 34746 . 34847)) (34850 36827 (QUOTE
34860 . 34894) (AND 34896 . 35166) (OR 35168 . 35393) (PROGN 35395 . 35760) (COND 35762 . 36219) (
\EVPROGN 36221 . 36491) (PROG1 36493 . 36825)) (36882 41753 (ENVEVAL 36892 . 37225) (ENVAPPLY 37227 .
37543) (FUNCTION 37545 . 37851) (\FUNCT1 37853 . 39541) (\MAKEFUNARGFRAME 39543 . 40504) (STKEVAL
40506 . 40711) (STKAPPLY 40713 . 40935) (RETEVAL 40937 . 41342) (RETAPPLY 41344 . 41751)) (41797 46453
(BLIPVAL 41807 . 43962) (SETBLIPVAL 43964 . 45783) (BLIPSCAN 45785 . 46451)) (46454 48625 (
DUMMYFRAMEP 46464 . 46576) (REALFRAMEP 46578 . 46881) (REALSTKNTH 46883 . 47621) (\REALFRAMEP 47623 .
48623)) (48991 61477 (RAIDCOMMAND 49001 . 53831) (RAIDSHOWFRAME 53833 . 54385) (RAIDSTACKCMD 54387 .
56111) (RAIDROOTFRAME 56113 . 56509) (PRINTADDRS 56511 . 57317) (PRINTVA 57319 . 57550) (READVA 57552
. 57696) (READATOM 57698 . 57852) (READOCT 57854 . 59013) (SHOWSTACKBLOCKS 59015 . 60820) (
SHOWSTACKBLOCK1 60822 . 61023) (PRINCOPY 61025 . 61154) (NOSUCHATOM 61156 . 61475)) (61478 68359 (
BACKTRACE 61488 . 62008) (\BACKTRACE 62010 . 63667) (\SCANFORNTENTRY 63669 . 64194) (\PRINTSTK 64196
. 64422) (\PRINTFRAME 64424 . 67267) (\PRINTBF 67269 . 68357)) (70327 77230 (CCODEP 70337 . 70642) (
EXPRP 70644 . 71033) (SUBRP 71035 . 71120) (FNTYP 71122 . 72160) (ARGTYPE 72162 . 72986) (NARGS 72988
. 73740) (ARGLIST 73742 . 74769) (\CCODEARGLIST 74771 . 76576) (\CCODEIVARSCAN 76578 . 77228)))))
STOP