(FILECREATED "28-Aug-84 12:20:54" {ERIS}<LISPCORE>SOURCES>LLINTERP.;7 73606
changes to: (FNS RETAPPLY RETEVAL)
previous date: "15-Aug-84 18:03:55" {ERIS}<LISPCORE>SOURCES>LLINTERP.;6)
(* Copyright (c) 1981, 1982, 1983, 1984 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 PRINTADDRS PRINTVA READVA READOCT SHOWSTACKBLOCKS
SHOWSTACKBLOCK1 PRINCOPY)
(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: "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])
(\SETFVARSLOT
[LAMBDA (VAR NEWBINDING) (* bvm: "23-MAR-83 23:29")
(* 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
((ZEROP (SETQ A (\GETBASE NT 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: "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: EVAL@COMPILE DONTCOPY
(RPAQQ RAIDCOMS ((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))
(ADDVARS (DONTCOMPILEFNS RAIDCOMMAND RAIDSHOWFRAME PRINTADDRS PRINTVA READVA READOCT
SHOWSTACKBLOCKS SHOWSTACKBLOCK1 PRINCOPY))))
(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)
(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 "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) (* 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))))
(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))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2957 9731 (\INTERPRETER 2967 . 5768) (\INTERPRETER1 5770 . 9729)) (9766 16770 (EVAL
9776 . 9932) (\EVAL 9934 . 10197) (\EVALFORM 10199 . 12119) (\EVALOTHER 12121 . 12429) (APPLY 12431 .
12581) (APPLY* 12583 . 14193) (\CHECKAPPLY* 14195 . 15702) (\CKAPPLYARGS 15704 . 16164) (DEFEVAL 16166
. 16486) (EVALHOOK 16488 . 16768)) (18069 25294 (EVALV 18079 . 18408) (\EVALV1 18410 . 18631) (
\EVALVAR 18633 . 19223) (BOUNDP 19225 . 19586) (SET 19588 . 20091) (\SETVAR 20093 . 20600) (SETQ 20602
. 21060) (SETN 21062 . 21520) (\STKSCAN 21522 . 24070) (\SETFVARSLOT 24072 . 25292)) (25324 34035 (
PROG 25334 . 26688) (\PROG0 26690 . 29029) (\EVPROG1 29031 . 29317) (RETURN 29319 . 29987) (GO 29989
. 31191) (EVALA 31193 . 32081) (\EVALA 32083 . 33930) (ERRORSET 33932 . 34033)) (34036 36013 (QUOTE
34046 . 34080) (AND 34082 . 34352) (OR 34354 . 34579) (PROGN 34581 . 34946) (COND 34948 . 35405) (
\EVPROGN 35407 . 35677) (PROG1 35679 . 36011)) (36068 40939 (ENVEVAL 36078 . 36411) (ENVAPPLY 36413 .
36729) (FUNCTION 36731 . 37037) (\FUNCT1 37039 . 38727) (\MAKEFUNARGFRAME 38729 . 39690) (STKEVAL
39692 . 39897) (STKAPPLY 39899 . 40121) (RETEVAL 40123 . 40528) (RETAPPLY 40530 . 40937)) (40983 45639
(BLIPVAL 40993 . 43148) (SETBLIPVAL 43150 . 44969) (BLIPSCAN 44971 . 45637)) (45640 47811 (
DUMMYFRAMEP 45650 . 45762) (REALFRAMEP 45764 . 46067) (REALSTKNTH 46069 . 46807) (\REALFRAMEP 46809 .
47809)) (48177 57794 (RAIDCOMMAND 48187 . 53154) (RAIDSHOWFRAME 53156 . 53722) (PRINTADDRS 53724 .
54414) (PRINTVA 54416 . 54600) (READVA 54602 . 54746) (READOCT 54748 . 55651) (SHOWSTACKBLOCKS 55653
. 57458) (SHOWSTACKBLOCK1 57460 . 57661) (PRINCOPY 57663 . 57792)) (57795 64198 (BACKTRACE 57805 .
58274) (\BACKTRACE 58276 . 59933) (\SCANFORNTENTRY 59935 . 60415) (\PRINTSTK 60417 . 60643) (
\PRINTFRAME 60645 . 63106) (\PRINTBF 63108 . 64196)) (65888 72574 (CCODEP 65898 . 66203) (EXPRP 66205
. 66594) (SUBRP 66596 . 66681) (FNTYP 66683 . 67721) (ARGTYPE 67723 . 68547) (NARGS 68549 . 69301) (
ARGLIST 69303 . 70330) (\CCODEARGLIST 70332 . 71920) (\CCODEIVARSCAN 71922 . 72572)))))
STOP