(FILECREATED " 5-Sep-84 13:26:24" {ERIS}<LISPCORE>LIBRARY>RDSYS.;6
previous date: "14-Aug-84 12:30:37" {ERIS}<LISPCORE>LIBRARY>RDSYS.;5)
(PRETTYCOMPRINT RDSYSCOMS)
(RPAQQ RDSYSCOMS ((FNS VREADPAGEMAP VREADPAGEMAPBLOCK VCHECKIFPAGE VFIXIFPAGE) (FNS VRAIDCOMMAND
VRAIDSHOWFRAME VPRINTADDRS VPRINTVA VREADVA VREADOCT VSHOWSTACKBLOCKS VSHOWSTACKBLOCK1 VPRINCOPY) (FNS
V\BACKTRACE V\PRINTBF V\PRINTFRAME V\SCANFORNTENTRY V\PRINTSTK) (FNS VDPRINTCODE VPRINTCODENT
VBROKENDEF) (MACROS PCVAR) (FNS V\CAR.UFN V\CDR.UFN) (FNS V\COPY V\UNCOPY) (FNS V\GETBASEBYTE
V\PUTBASEBYTE) (FNS VNTYPX VTYPENAME) (FNS VCOPYATOM VUNCOPYATOM V\MKATOM VGETTOPVAL VGETPROPLIST
VSETTOPVAL VGETDEFN V\SMASHATOM) (FNS VLISTP) (VARS (COPYATOMSTR)) (FNS V\FINDOP) (VARS \OPCODES) (
VARS (\OPCODEARRAY)) (GLOBALVARS \OPCODEARRAY \OPCODES) (DECLARE: DONTCOPY (RECORDS OPCODE)) (FILES
VMEM) (VARS RDVALS RDPTRS) (DECLARE: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) VMEM))))
(DEFINEQ
(VREADPAGEMAP
(LAMBDA NIL (*) (*) (PROG (FIRSTPMT D) (MAPVMPAGE (IPLUS (LLSH (VHILOC (VVAG2 22 4096)) 8) (LRSH (
VLOLOC (VVAG2 22 4096)) 8)) 1) (*) (MAPVMPAGE (IPLUS (LLSH (VHILOC (VVAG2 21 0)) 8) (LRSH (VLOLOC (
VVAG2 21 0)) 8)) (SUB1 (VGETBASE (VVAG2 22 4096) 22))) (*) (SETQ FIRSTPMT (SUB1 (VGETBASE (VVAG2 22
4096) 23))) (SETVMPTR (VVAG2 21 0)) (VREADPAGEMAPBLOCK (IPLUS (LLSH (VHILOC (VVAG2 21 0)) 8) (LRSH (
VLOLOC (VVAG2 21 0)) 8))) (*) (for J from 0 to (SUB1 2) do (MAPVMPAGE (IPLUS (IPLUS (LLSH (VHILOC (
VVAG2 22 0)) 8) (LRSH (VLOLOC (VVAG2 22 0)) 8)) J) (IPLUS FIRSTPMT J))) (for I from 0 to (SUB1 (LLSH 2
8)) do (COND ((IEQ (SETQ D (VGETBASE (VVAG2 22 0) I)) 65535)) (T (SETVMPTR (VADDBASE (VVAG2 21 0) D))
(VREADPAGEMAPBLOCK (LLSH I 5))))))))
(VREADPAGEMAPBLOCK
(LAMBDA (VP) (*) (PROG ((B VP) P) (FRPTQ 32 (COND ((NEQ (SETQ P (VBIN2)) 0) (MAPVMPAGE B (SUB1 P)))) (
SETQ B (ADD1 B))))))
(VCHECKIFPAGE
(LAMBDA NIL (*) (COND ((NOT (EQUAL 5603 (VGETBASE (VVAG2 22 4096) 15))) (printout T "Warning: "
"Interface page key" "= " (PROGN 5603) ", but \InterfacePage says " (VGETBASE (VVAG2 22 4096) 15) T)))
))
(VFIXIFPAGE
(LAMBDA (RPT RPTSIZE RPOFFSET RPTLAST EMBUFVP) (*) (*) (VPUTBASE (VVAG2 22 4096) 11 \MinRamVersion) (
VPUTBASE (VVAG2 22 4096) 12 65535) (VPUTBASE (VVAG2 22 4096) 13 6) (VPUTBASE (VVAG2 22 4096) 16 0) (
VPUTBASE (VVAG2 22 4096) 17 0) (VPUTBASE (VVAG2 22 4096) 18 64) (VPUTBASE (VVAG2 22 4096) 28 0) (
VPUTBASE (VVAG2 22 4096) 29 0) (VPUTBASE (VVAG2 22 4096) 33 RPT) (VPUTBASE (VVAG2 22 4096) 34 RPTSIZE)
(VPUTBASE (VVAG2 22 4096) 35 (UNSIGNED RPOFFSET 16)) (VPUTBASE (VVAG2 22 4096) 36 RPTLAST) (VPUTBASE
(VVAG2 22 4096) 37 EMBUFVP) (*) NIL))
)
(DEFINEQ
(VRAIDCOMMAND
(LAMBDA NIL (*) (DECLARE (USEDFREE ROOTFRAME ALINKS? RAIDIX FRAME#)) (PROG (CMD) (SELECTQ (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 (V\UNCOPY (VGETTOPVAL (PROG1 (READ T T) (READC T)))) T T)) (P (PRINT (V\UNCOPY (VGETPROPLIST (
PROG1 (READ T T) (READC T)))) T T)) (C (VDPRINTCODE (PROG1 (READ T T) (READC T)) T RAIDIX)) (V (PRINT
(V\UNCOPY (VREADVA)) T T)) (B (VPRINTADDRS (VREADVA) (VREADOCT))) (S (VPRINTADDRS (VVAG2 23 (VREADOCT)
) (VREADOCT))) (D (VPRINTADDRS (VADDBASE (VVAG2 17 0) (LLSH (VATOMNUMBER (PROG1 (READ T T) (READC T)))
1)) 2)) ((L ↑L) (SETQ FRAME# 0) (COND ((EQ CMD (QUOTE L)) (SETQ ROOTFRAME (PROG1 (COND ((LISTP
VMEMFILE) (PRIN1 "in TeleRaid Context" T) (VGETBASE (VVAG2 22 4096) 24)) (T (VGETBASE (VVAG2 22 4096)
0))) (TERPRI T)))) ((AND (ILESSP (SETQ ROOTFRAME (VREADOCT)) 256) (ILESSP (VGETBASE (VVAG2 22 4096)
ROOTFRAME) (VGETBASE (VVAG2 22 4096) 7)) (IEQ (LRSH (VGETBASE (VVAG2 23 (PROGN (PROGN (VGETBASE (VVAG2
22 4096) ROOTFRAME)))) 0) 13) 6)) (SETQ ROOTFRAME (VGETBASE (VVAG2 22 4096) ROOTFRAME)))) (
V\BACKTRACE ROOTFRAME NIL T NIL NIL NIL ALINKS? (FUNCTION VPRINCOPY) 1 RAIDIX)) (F (VRAIDSHOWFRAME (
SETQ FRAME# (PROG1 (READ T T) (READC T))))) (LF (OR FRAME# (SETQ FRAME# 0)) (printout T "(" .I1 (SETQ
FRAME# (IPLUS FRAME# 1)) ")" T) (VRAIDSHOWFRAME FRAME#)) (↑ (COND ((OR (NULL FRAME#) (ILEQ FRAME# 1))
(printout T "No previous frame" T)) (T (printout T "(" .I1 (SETQ FRAME# (IPLUS FRAME# -1)) ")" T) (
VRAIDSHOWFRAME FRAME#)))) (↑F (V\PRINTBF (VREADOCT) NIL (FUNCTION VPRINCOPY))) (W (VSHOWSTACKBLOCKS (
COND ((EQ (PEEKC T) (QUOTE %
)) (READC T) 0) (T (VREADOCT))))) (↑X (V\PRINTFRAME (VREADOCT) (QUOTE VPRINCOPY))) (↑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 (VREADVA))) (printout " Currently ") (PRINTNUM .I7 (VGETBASE VA 0))
(printout " to be ") (VPUTBASE VA 0 (VREADOCT)))) (I (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))))
(VRAIDSHOWFRAME
(LAMBDA (N) (*) (PROG ((FRAME (OR ROOTFRAME (SETQ ROOTFRAME (VGETBASE (VVAG2 22 4096) 0))))) (FRPTQ (
SUB1 N) (COND ((ZEROP (PROGN (SETQ FRAME (COND (ALINKS? (IDIFFERENCE (LOGAND (VGETBASE (VVAG2 23 FRAME
) 1) (CONSTANT (LOGXOR (SUB1 2) -1))) 10)) (T (IDIFFERENCE (COND ((EVENP (VGETBASE (VVAG2 23 FRAME) 1)
2) (VGETBASE (VVAG2 23 FRAME) 1)) (T (VGETBASE (VVAG2 23 FRAME) 9))) 10)))))) (RETURN (printout T N
" is beyond the bottom of the stack" T))))) (V\BACKTRACE FRAME FRAME T NIL T T NIL (FUNCTION VPRINCOPY
) NIL RAIDIX))))
(VPRINTADDRS
(LAMBDA (BASE CNT) (*) (PRIN1 "words from ") (VPRINTVA BASE) (PRIN1 " to ") (VPRINTVA (VADDBASE BASE (
SUB1 CNT))) (TERPRI) (SPACES 7) (for I from 0 to 7 do (PRINTNUM .I7 I)) (PROG ((NB (VVAG2 (VHILOC BASE
) (LOGAND (VLOLOC BASE) (CONSTANT (LOGXOR (SUB1 8) -1))))) (LB (VADDBASE BASE CNT))) (do (COND ((ZEROP
(LOGAND (VLOLOC NB) 7)) (TAB 0 0) (PRINTNUM .I5 (VLOLOC NB)) (PRIN1 ": "))) (COND ((IGREATERP BASE NB
) (SPACES 7)) (T (PRINTNUM .I7 (VGETBASE NB 0)))) (SETQ NB (VADDBASE NB 1)) repeatwhile (IGREATERP LB
NB)) (TAB 0 0))))
(VPRINTVA
(LAMBDA (X) (*) (PRIN1 "{") (PRINTNUM .I2 (VHILOC X)) (PRIN1 ",") (PRINTNUM .I6 (VLOLOC X)) (PRIN1 "}"
)))
(VREADVA
(LAMBDA NIL (*) (VVAG2 (VREADOCT) (VREADOCT))))
(VREADOCT
(LAMBDA NIL (*) (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))))))
(VSHOWSTACKBLOCKS
(LAMBDA (SCANPTR WAITFLG) (*) (*) (PROG ((EASP (VGETBASE (VVAG2 22 4096) 7))) SCAN (SELECTC (LRSH (
VGETBASE (VVAG2 23 SCANPTR) 0) 13) (5 (VSHOWSTACKBLOCK1 SCANPTR "free block" (IEQ (VGETBASE (VVAG2 23
SCANPTR) 0) 40960)) (SETQ SCANPTR (IPLUS SCANPTR (VGETBASE (VVAG2 23 SCANPTR) 1)))) (7 (
VSHOWSTACKBLOCK1 SCANPTR "guard block" T) (SETQ SCANPTR (IPLUS SCANPTR (VGETBASE (VVAG2 23 SCANPTR) 1)
))) (6 (*) (VSHOWSTACKBLOCK1 SCANPTR "Frame extn = " (AND (IEQ (LRSH (VGETBASE (VVAG2 23 SCANPTR) 0)
13) 6) (OR (IEQ (IDIFFERENCE SCANPTR 2) (COND ((EVENP (VGETBASE (VVAG2 23 SCANPTR) 1) 2) (IDIFFERENCE
SCANPTR 2)) (T (VGETBASE (VVAG2 23 SCANPTR) 8)))) (AND (NOT (ZEROP (LOGAND (LRSH (VGETBASE (VVAG2 23 (
PROGN (IDIFFERENCE SCANPTR 2))) 0) 9) 1))) (IEQ (VGETBASE (VVAG2 23 (PROGN (IDIFFERENCE SCANPTR 2))) 1
) (VGETBASE (VVAG2 23 (PROGN (COND ((EVENP (VGETBASE (VVAG2 23 SCANPTR) 1) 2) (IDIFFERENCE SCANPTR 2))
(T (VGETBASE (VVAG2 23 SCANPTR) 8))))) 1)))))) (PRIN2 (V\UNCOPY (VGETBASEPTR (PROGN (COND ((NOT (
ZEROP (LOGAND (LRSH (VGETBASE (VVAG2 23 SCANPTR) 0) 9) 1))) (VVAG2 (LOGAND (VGETBASE (VVAG2 23 SCANPTR
) 7) 255) (VGETBASE (VVAG2 23 SCANPTR) 6))) (T (VVAG2 (LOGAND (VGETBASE (VVAG2 23 SCANPTR) 3) 255) (
VGETBASE (VVAG2 23 SCANPTR) 2))))) 4))) (SETQ SCANPTR (VGETBASE (VVAG2 23 SCANPTR) 4))) (PROG ((ORIG
SCANPTR) IVAR) (*) (while (EQ (LRSH (VGETBASE (VVAG2 23 SCANPTR) 0) 13) 0) do (SETQ SCANPTR (IPLUS
SCANPTR 2))) (COND ((NOT (IEQ (LRSH (VGETBASE (VVAG2 23 SCANPTR) 0) 13) 4)) (VSHOWSTACKBLOCK1 ORIG
"Garbage" T)) (T (SETQ IVAR (VGETBASE (VVAG2 23 SCANPTR) 1)) (COND ((NOT (ZEROP (LOGAND (LRSH (
VGETBASE (VVAG2 23 SCANPTR) 0) 9) 1))) (VSHOWSTACKBLOCK1 SCANPTR "Residual BF" (EQ SCANPTR ORIG)) (
PRIN1 " with IVar = ") (PRINTNUM .I7 IVAR)) (T (VSHOWSTACKBLOCK1 SCANPTR "Basic frame" (AND (EQ ORIG
IVAR) (AND (IEQ (LRSH (VGETBASE (VVAG2 23 SCANPTR) 0) 13) 4) (for I from (VGETBASE (VVAG2 23 SCANPTR)
1) to (IDIFFERENCE SCANPTR 2) by 2 always (IEQ 0 (LRSH (VGETBASE (VVAG2 23 I) 0) 13)))))))) (SETQ
SCANPTR (IPLUS SCANPTR 2)))))) (TERPRI) (COND ((IGREATERP SCANPTR EASP) (RETURN))) (AND WAITFLG (READC
T)) (GO SCAN))))
(VSHOWSTACKBLOCK1
(LAMBDA (PTR STR GOODFLG) (*) (PRINTNUM .I7 PTR) (SPACES 1) (OR GOODFLG (PRIN1 "[bad] ")) (PRIN1 STR))
)
(VPRINCOPY
(LAMBDA (X) (*) (PRINT (V\UNCOPY X))))
)
(DEFINEQ
(V\BACKTRACE
(LAMBDA (IPOS EPOS NAMES VARS LOCALS JUNK ALINKS PRINTFN CNT RADIX) (*) (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 ": ") (SETQ CNT (IPLUS CNT 1)))) (SETQ NAME (
VGETBASEPTR (PROGN (COND ((NOT (ZEROP (LOGAND (LRSH (VGETBASE (VVAG2 23 IPOS) 0) 9) 1))) (VVAG2 (
LOGAND (VGETBASE (VVAG2 23 IPOS) 7) 255) (VGETBASE (VVAG2 23 IPOS) 6))) (T (VVAG2 (LOGAND (VGETBASE (
VVAG2 23 IPOS) 3) 255) (VGETBASE (VVAG2 23 IPOS) 2))))) 4)) (COND (JUNK (TERPRI) (TERPRI) (PRIN1
"Basic frame at ") (PRINTNUM .I7 (SETQ BLINK (COND ((EVENP (VGETBASE (VVAG2 23 IPOS) 1) 2) (
IDIFFERENCE IPOS 2)) (T (VGETBASE (VVAG2 23 IPOS) 8))))) (TERPRI) (V\PRINTBF BLINK (COND ((NOT (ZEROP
(LOGAND (LRSH (VGETBASE (VVAG2 23 IPOS) 0) 9) 1))) (VVAG2 (LOGAND (VGETBASE (VVAG2 23 IPOS) 7) 255) (
VGETBASE (VVAG2 23 IPOS) 6))) (T (VVAG2 (LOGAND (VGETBASE (VVAG2 23 IPOS) 3) 255) (VGETBASE (VVAG2 23
IPOS) 2)))) PRINTFN) (PROGN (TERPRI) (PRIN1 "Frame xtn at ") (PRINTNUM .I7 IPOS) (PRIN1
", frame name= ")) (APPLY* PRINTFN NAME) (V\PRINTFRAME IPOS PRINTFN)) ((OR VARS LOCALS) (V\PRINTBF (
COND ((EVENP (VGETBASE (VVAG2 23 IPOS) 1) 2) (IDIFFERENCE IPOS 2)) (T (VGETBASE (VVAG2 23 IPOS) 8))) (
COND ((NOT (ZEROP (LOGAND (LRSH (VGETBASE (VVAG2 23 IPOS) 0) 9) 1))) (VVAG2 (LOGAND (VGETBASE (VVAG2
23 IPOS) 7) 255) (VGETBASE (VVAG2 23 IPOS) 6))) (T (VVAG2 (LOGAND (VGETBASE (VVAG2 23 IPOS) 3) 255) (
VGETBASE (VVAG2 23 IPOS) 2)))) PRINTFN (COND (LOCALS (QUOTE LOCALS)) (T T))) (COND (NAMES (APPLY*
PRINTFN NAME) (TERPRI))) (V\PRINTFRAME IPOS PRINTFN (COND (LOCALS (QUOTE LOCALS)) (T T)))) (NAMES (
APPLY* PRINTFN NAME))) (COND ((AND (NEQ EPOS IPOS) (NOT (ZEROP (PROGN (SETQ IPOS (COND (ALINKS (
IDIFFERENCE (LOGAND (VGETBASE (VVAG2 23 IPOS) 1) (CONSTANT (LOGXOR (SUB1 2) -1))) 10)) (T (IDIFFERENCE
(COND ((EVENP (VGETBASE (VVAG2 23 IPOS) 1) 2) (VGETBASE (VVAG2 23 IPOS) 1)) (T (VGETBASE (VVAG2 23
IPOS) 9))) 10)))))))) (GO POSLP))) (RETURN T))))
(V\PRINTBF
(LAMBDA (BL NMT PRINTFN VARSONLY) (*) (bind NM for I from (VGETBASE (VVAG2 23 BL) 1) by 2 as J from 0
to (SUB1 (IDIFFERENCE (LRSH (IDIFFERENCE BL (VGETBASE (VVAG2 23 BL) 1)) 1) (LOGAND (LRSH (VGETBASE (
VVAG2 23 BL) 0) 8) 1))) do (OR VARSONLY (V\PRINTSTK I)) (COND ((OR (SETQ NM (V\SCANFORNTENTRY (OR NMT
(RETURN (OR VARSONLY (TERPRI)))) (IPLUS 0 J))) (AND (NEQ VARSONLY T) (SETQ NM (QUOTE *local*)))) (AND
VARSONLY (SPACES 3)) (PRIN2 NM) (SPACES 1) (APPLY* PRINTFN (VGETBASEPTR (VVAG2 23 0) I)))) finally (OR
VARSONLY (while (ILESSP I BL) do (V\PRINTSTK I) (printout NIL "[padding]" T) (SETQ I (IPLUS I 2)))))
(COND ((NOT VARSONLY) (V\PRINTSTK BL) (COND ((NOT (ZEROP (LOGAND (LRSH (VGETBASE (VVAG2 23 BL) 0) 9) 1
))) (PRIN1 "residual "))) (COND ((NEQ (LOGAND (VGETBASE (VVAG2 23 BL) 0) 255) 0) (printout NIL
"usecnt= " (LOGAND (VGETBASE (VVAG2 23 BL) 0) 255) ,))) (TERPRI)))))
(V\PRINTFRAME
(LAMBDA (FRAME PRINTFN VARSONLY) (*) (PROG ((NMT (COND ((NOT (ZEROP (LOGAND (LRSH (VGETBASE (VVAG2 23
FRAME) 0) 9) 1))) (VVAG2 (LOGAND (VGETBASE (VVAG2 23 FRAME) 7) 255) (VGETBASE (VVAG2 23 FRAME) 6))) (T
(VVAG2 (LOGAND (VGETBASE (VVAG2 23 FRAME) 3) 255) (VGETBASE (VVAG2 23 FRAME) 2))))) (I 0) (FT (IPLUS
(IPLUS FRAME (PROGN 10)) (LLSH (ADD1 (SIGNED (VGETBASE (PROGN (VVAG2 (LOGAND (VGETBASE (VVAG2 23 FRAME
) 3) 255) (VGETBASE (VVAG2 23 FRAME) 2))) 2) 16)) 2) (PROGN 4))) TMP NLOCALS) (COND ((NOT VARSONLY) (
V\PRINTSTK FRAME) (PRIN1 "[") (PROGN (PROG ((FAST (NOT (ZEROP (LOGAND (LRSH (VGETBASE (VVAG2 23 FRAME)
0) 12) 1))))) (DECLARE (LOCALVARS FAST)) (COND (FAST (PRIN1 (QUOTE "F, ")) (SELECTQ (CONSTANT (
NTHCHAR (QUOTE "F, ") -1)) (= (printout NIL , FAST NIL)) NIL) T))) (PROG ((INCALL (NOT (ZEROP (LOGAND
(LRSH (VGETBASE (VVAG2 23 FRAME) 0) 10) 1))))) (DECLARE (LOCALVARS INCALL)) (COND (INCALL (PRIN1 (
QUOTE "C, ")) (SELECTQ (CONSTANT (NTHCHAR (QUOTE "C, ") -1)) (= (printout NIL , INCALL NIL)) NIL) T)))
(PROG ((VALIDNAMETABLE (NOT (ZEROP (LOGAND (LRSH (VGETBASE (VVAG2 23 FRAME) 0) 9) 1))))) (DECLARE (
LOCALVARS VALIDNAMETABLE)) (COND (VALIDNAMETABLE (PRIN1 (QUOTE "V, ")) (SELECTQ (CONSTANT (NTHCHAR (
QUOTE "V, ") -1)) (= (printout NIL , VALIDNAMETABLE NIL)) NIL) T))) (PROG ((NOPUSH (NOT (ZEROP (LOGAND
(LRSH (VGETBASE (VVAG2 23 FRAME) 0) 8) 1))))) (DECLARE (LOCALVARS NOPUSH)) (COND (NOPUSH (PRIN1 (
QUOTE "N, ")) (SELECTQ (CONSTANT (NTHCHAR (QUOTE "N, ") -1)) (= (printout NIL , NOPUSH NIL)) NIL) T)))
(PROG ((USECNT (LOGAND (VGETBASE (VVAG2 23 FRAME) 0) 255))) (DECLARE (LOCALVARS USECNT)) (COND ((NOT
(ZEROP USECNT)) (PRIN1 (QUOTE "USE=")) (SELECTQ (CONSTANT (NTHCHAR (QUOTE "USE=") -1)) (= (printout
NIL , USECNT ", ")) NIL) T))) (PROG ((FASTP (EVENP (VGETBASE (VVAG2 23 FRAME) 1) 2))) (DECLARE (
LOCALVARS FASTP)) (COND ((NOT FASTP) (PRIN1 (QUOTE "X, ")) (SELECTQ (CONSTANT (NTHCHAR (QUOTE "X, ")
-1)) (= (printout NIL , FASTP NIL)) NIL) T))) (PROG ((ALINK (IDIFFERENCE (LOGAND (VGETBASE (VVAG2 23
FRAME) 1) (CONSTANT (LOGXOR (SUB1 2) -1))) 10))) (DECLARE (LOCALVARS ALINK)) (COND (T (PRIN1 (QUOTE
" alink]")) (SELECTQ (CONSTANT (NTHCHAR (QUOTE " alink]") -1)) (= (printout NIL , ALINK NIL)) NIL) T))
)) (TERPRI) (PROGN (V\PRINTSTK (IPLUS FRAME 2)) (PROGN (PROG ((FNHEADER (VVAG2 (LOGAND (VGETBASE (
VVAG2 23 FRAME) 3) 255) (VGETBASE (VVAG2 23 FRAME) 2)))) (DECLARE (LOCALVARS FNHEADER)) (COND (T (
PRIN1 (QUOTE "[fn header]")) (SELECTQ (CONSTANT (NTHCHAR (QUOTE "[fn header]") -1)) (= (printout NIL ,
FNHEADER NIL)) NIL) T)))) (TERPRI)) (PROGN (V\PRINTSTK (IPLUS FRAME 4)) (PROGN (PROG ((NEXTBLOCK (
VGETBASE (VVAG2 23 FRAME) 4))) (DECLARE (LOCALVARS NEXTBLOCK)) (COND (T (PRIN1 (QUOTE "[next, pc]")) (
SELECTQ (CONSTANT (NTHCHAR (QUOTE "[next, pc]") -1)) (= (printout NIL , NEXTBLOCK NIL)) NIL) T)))) (
TERPRI)) (PROGN (V\PRINTSTK (IPLUS FRAME 6)) (PROGN (PROG ((NAMETABLE (COND ((NOT (ZEROP (LOGAND (LRSH
(VGETBASE (VVAG2 23 FRAME) 0) 9) 1))) (VVAG2 (LOGAND (VGETBASE (VVAG2 23 FRAME) 7) 255) (VGETBASE (
VVAG2 23 FRAME) 6))) (T (VVAG2 (LOGAND (VGETBASE (VVAG2 23 FRAME) 3) 255) (VGETBASE (VVAG2 23 FRAME) 2
)))))) (DECLARE (LOCALVARS NAMETABLE)) (COND (T (PRIN1 (QUOTE "[nametable]")) (SELECTQ (CONSTANT (
NTHCHAR (QUOTE "[nametable]") -1)) (= (printout NIL , NAMETABLE NIL)) NIL) T)))) (TERPRI)) (PROGN (
V\PRINTSTK (IPLUS FRAME 8)) (PROGN (PROG ((BLINK (COND ((EVENP (VGETBASE (VVAG2 23 FRAME) 1) 2) (
IDIFFERENCE FRAME 2)) (T (VGETBASE (VVAG2 23 FRAME) 8))))) (DECLARE (LOCALVARS BLINK)) (COND (T (PRIN1
(QUOTE "[blink, clink]")) (SELECTQ (CONSTANT (NTHCHAR (QUOTE "[blink, clink]") -1)) (= (printout NIL
, BLINK NIL)) NIL) T)))) (TERPRI)))) (SETQ NLOCALS (LRSH (VGETBASE NMT 7) 8)) (for old I from (IPLUS
FRAME (PROGN 10)) by 2 while (ILESSP I FT) as J from 0 do (OR VARSONLY (V\PRINTSTK I)) (COND ((ILESSP
J NLOCALS) (COND ((OR (SETQ TMP (V\SCANFORNTENTRY NMT (IPLUS 32768 J))) (AND (NEQ VARSONLY T) (SETQ
TMP (QUOTE *local*)))) (COND ((ZEROP (LRSH (VGETBASE (PROGN (VVAG2 23 I)) 0) 8)) (AND VARSONLY (SPACES
3)) (PRIN2 TMP) (SPACES 1) (APPLY* PRINTFN (VGETBASEPTR (VVAG2 23 0) I))) ((NOT VARSONLY) (printout
NIL TMP " [unbound]" T)))))) ((NOT VARSONLY) (COND ((SETQ TMP (V\SCANFORNTENTRY NMT (IPLUS 49152 J)))
(printout NIL "[fvar " .P2 TMP " " (COND ((EVENP (VGETBASE (PROGN (VVAG2 23 I)) 0)) (COND ((EQ (SETQ
TMP (VHILOC ((LAMBDA ($$1) (VVAG2 (LRSH (VGETBASE (PROGN $$1) 1) 8) (VGETBASE $$1 0))) (VVAG2 23 I))))
23) " on stack]") ((NEQ TMP (VHILOC (VVAG2 18 0))) " non-stack binding]") (T " top value]"))) (T
" not looked up]")) T)) (T (printout NIL "[padding]" T)))))) (COND ((NOT VARSONLY) (SETQ FT (VGETBASE
(VVAG2 23 FRAME) 4)) (for old I by 2 while (ILESSP I FT) do (V\PRINTSTK I) (COND ((ZEROP (LRSH (
VGETBASE (PROGN (VVAG2 23 I)) 0) 8)) (APPLY* PRINTFN (VGETBASEPTR (VVAG2 23 0) I))) (T (TERPRI))))))))
)
(V\SCANFORNTENTRY
(LAMBDA (NMT NTENTRY) (*) (bind NM for NT1 from (PROGN 8) as NT2 from (IPLUS (PROGN 8) (VGETBASE NMT 6
)) do (COND ((ZEROP (SETQ NM (VGETBASE NMT NT1))) (RETURN))) (COND ((IEQ NTENTRY (VGETBASE NMT NT2)) (
RETURN (VATOM NM)))))))
(V\PRINTSTK
(LAMBDA (I) (*) (PRINTNUM .I7 I) (PRIN1 ": ") (PRINTNUM .I7 (VGETBASE (VVAG2 23 0) I)) (PRINTNUM .I7 (
VGETBASE (VVAG2 23 0) (ADD1 I))) (SPACES 1)))
)
(DEFINEQ
(VDPRINTCODE
(LAMBDA (FN LVFLG RADIX OUTF FIRSTBYTE) (*) (*) (DECLARE (GLOBALVARS \INITSUBRS FVA STKA) (SPECVARS
OUTF)) (OR RADIX (SETQ RADIX 8)) (PROG ((CA (OR (VGETDEFN FN) (AND (LITATOM FN) (VGETDEFN (GETPROP FN
(QUOTE CODE)))) (ERROR FN "not compiled code"))) PVARS FVARS IVARS NTSIZE STARTPC TAG TEMP OP# (
REMOTEFLG T) (I4 (NUMFORMATCODE (LIST (QUOTE FIX) 4 RADIX))) (I6 (NUMFORMATCODE (LIST (QUOTE FIX) 6
RADIX)))) (DECLARE (SPECVARS CA IVARS PVARS FVARS I4 I6)) (PROGN (PRIN1 " stkmin: " OUTF) (PRINTNUM I6
(LOGOR (LLSH (VGETBASEBYTE CA 0) 8) (VGETBASEBYTE CA (ADD1 0))) OUTF) (PRIN1 " na: " OUTF) (PRINTNUM
I4 (SIGNED (LOGOR (LLSH (VGETBASEBYTE CA 2) 8) (VGETBASEBYTE CA (ADD1 2))) 16) OUTF) (PRIN1 " pv: "
OUTF) (PRINTNUM I4 (SIGNED (LOGOR (LLSH (VGETBASEBYTE CA 4) 8) (VGETBASEBYTE CA (ADD1 4))) 16) OUTF) (
PRIN1 " startpc: " OUTF) (PRINTNUM I4 (SETQ STARTPC (LOGOR (LLSH (VGETBASEBYTE CA 6) 8) (VGETBASEBYTE
CA (ADD1 6)))) OUTF) (PRIN1 " argtype: " OUTF) (PRIN1 (LOGAND (LRSH (VGETBASEBYTE CA 8) 4) 3) OUTF) (
PRIN1 " framename: " OUTF) (PRIN1 (V\UNCOPY (VVAG2 (VGETBASEBYTE CA 9) (LOGOR (LLSH (VGETBASEBYTE CA
10) 8) (VGETBASEBYTE CA (ADD1 10))))) OUTF) (PRIN1 " ntsize: " OUTF) (PRINTNUM I4 (SETQ NTSIZE (LOGOR
(LLSH (VGETBASEBYTE CA 12) 8) (VGETBASEBYTE CA (ADD1 12)))) OUTF) (PRIN1 " nlocals: " OUTF) (PRINTNUM
I4 (VGETBASEBYTE CA 14) OUTF) (TERPRI OUTF)) (for I from 0 by 2 while (ILESSP I (LLSH (PROGN 8) 1)) do
(PRINTNUM I4 I OUTF) (PRIN1 ": " OUTF) (PRINTNUM I6 (LOGOR (LLSH (VGETBASEBYTE CA I) 8) (VGETBASEBYTE
CA (ADD1 I))) OUTF) (TERPRI OUTF)) (VPRINTCODENT "name table: " (LLSH (PROGN 8) 1) (LLSH NTSIZE 1)) (
VPRINTCODENT "Local args: " (SETQ TEMP (IPLUS (LLSH (PROGN 8) 1) (COND ((ZEROP NTSIZE) (*) 8) (T (LLSH
NTSIZE 2))))) (LRSH (IDIFFERENCE STARTPC TEMP) 1)) (printout OUTF T "----" T) (PROG ((CODELOC STARTPC
) B B1 B2 B3 FN LEN LEVADJ STK (LEVEL (AND LVFLG 0))) (COND (LEVEL (SETUPHASHARRAY (QUOTE FVA)) (
SETUPHASHARRAY (QUOTE STKA)) (CLRHASH FVA) (CLRHASH STKA))) LP (COND ((OR (NULL FIRSTBYTE) (IGEQ
CODELOC FIRSTBYTE)) (PRINTNUM I4 CODELOC OUTF) (PRIN1 ": " OUTF) (COND (LVFLG (SETQ TEMP (GETHASH
CODELOC FVA)) (COND (LEVEL (COND ((AND TEMP (OR (NEQ LEVEL TEMP) (NOT (EQUAL STK (GETHASH CODELOC STKA
))))) (PRIN1 "*" OUTF)))) (T (SETQ LEVEL TEMP) (SETQ STK (GETHASH CODELOC STKA)))) (COND (LEVEL (TAB 7
NIL OUTF) (PRINTNUM I4 LEVEL OUTF))))) (TAB 12 NIL OUTF)) (T (*) (SETQ TAG (V\FINDOP (VGETBASEBYTE CA
(PROG1 CODELOC (SETQ CODELOC (IPLUS CODELOC 1)))))) (SELECTQ (OR (fetch OPPRINT of TAG) (fetch
OPCODENAME of TAG)) (-X- (TERPRI OUTF) (RETURN)) (BIND (COND (LEVEL (push STK (SETQ LEVEL (ADD1 (
IDIFFERENCE LEVEL (LOGAND (CODELT CA CODELOC) 15)))))))) (UNBIND (AND LEVEL (SETQ LEVEL (pop STK)))) (
DUNBIND (AND LEVEL (SETQ LEVEL (SUB1 (pop STK))))) (RETURN (SETQ LEVEL)) (SUBRCALL (AND LEVEL (SETQ
LEVEL (ADD1 (IDIFFERENCE LEVEL (VGETBASEBYTE CA (ADD1 CODELOC))))))) NIL) (COND ((AND LEVEL (SETQ
LEVADJ (fetch LEVADJ of TAG))) (SELECTQ LEVADJ (FNX (SETQ LEVEL (IPLUS LEVEL (IDIFFERENCE 1 (
VGETBASEBYTE CA CODELOC))))) (JUMP (SETQ LEVEL)) ((CJUMP NCJUMP) (SETQ LEVEL (IPLUS LEVEL -1))) (COND
((NUMBERP LEVADJ) (SETQ LEVEL (IPLUS LEVEL LEVADJ))))))) (add CODELOC (fetch OPNARGS of TAG)) (GO LP))
) (SETQ LEN (fetch OPNARGS of (SETQ TAG (V\FINDOP (SETQ B (VGETBASEBYTE CA (PROG1 CODELOC (SETQ
CODELOC (IPLUS CODELOC 1))))))))) (PRINTNUM I4 B OUTF) (COND ((IGREATERP LEN 0) (PRINTNUM I4 (SETQ B1
(VGETBASEBYTE CA (PROG1 CODELOC (SETQ CODELOC (IPLUS CODELOC 1))))) OUTF))) (COND ((IGREATERP LEN 1) (
PRINTNUM I4 (SETQ B2 (VGETBASEBYTE CA (PROG1 CODELOC (SETQ CODELOC (IPLUS CODELOC 1))))) OUTF))) (AND
(IGREATERP LEN 2) (PRINTNUM I4 (SETQ B3 (VGETBASEBYTE CA (PROG1 CODELOC (SETQ CODELOC (IPLUS CODELOC 1
))))) OUTF)) (PROGN (printout OUTF 30 (fetch OPCODENAME of TAG)) (SETQ OP# (fetch OP# of TAG)) (SETQ
LEVADJ (fetch LEVADJ of TAG))) (SELECTQ (SETQ TAG (OR (fetch OPPRINT of TAG) (fetch OPCODENAME of TAG)
)) (-X- (TERPRI OUTF) (RETURN)) (IVAR (TAB 40 NIL OUTF) (PROGN (*) (PROG NIL (PRIN2 (CADR (OR (ASSOC (
SELECTQ LEN (0 (IDIFFERENCE B OP#)) (LRSH B1 1)) IVARS) (RETURN (printout OUTF "[" (QUOTE ivar) (
SELECTQ LEN (0 (IDIFFERENCE B OP#)) (LRSH B1 1)) "]")))) OUTF)))) (PVAR (TAB 40 NIL OUTF) (PROGN (*) (
PROG NIL (PRIN2 (CADR (OR (ASSOC (SELECTQ LEN (0 (IDIFFERENCE B OP#)) (LRSH B1 1)) PVARS) (RETURN (
printout OUTF "[" (QUOTE pvar) (SELECTQ LEN (0 (IDIFFERENCE B OP#)) (LRSH B1 1)) "]")))) OUTF)))) (
FVAR (TAB 40 NIL OUTF) (PROGN (*) (PROG NIL (PRIN2 (CADR (OR (ASSOC (SELECTQ LEN (0 (IDIFFERENCE B OP#
)) (LRSH B1 1)) FVARS) (RETURN (printout OUTF "[" (QUOTE fvar) (SELECTQ LEN (0 (IDIFFERENCE B OP#)) (
LRSH B1 1)) "]")))) OUTF)))) (JUMP ((LAMBDA (N) (PRIN1 "->" OUTF) (PRINTNUM I4 (SETQ N (IPLUS N (
IDIFFERENCE CODELOC (ADD1 LEN)))) OUTF) (COND (LEVEL (PUTHASH N (SELECTQ LEVADJ ((NCJUMP JUMP) LEVEL)
(SUB1 LEVEL)) FVA) (PUTHASH N STK STKA)))) (IPLUS (IDIFFERENCE B OP#) 2))) (SIC (printout OUTF 40 .P2
B1)) (SNIC (printout OUTF 40 .P2 (IDIFFERENCE B1 256))) (SICX (printout OUTF 40 .P2 (IPLUS (LLSH B1 8)
B2))) (JUMPX ((LAMBDA (N) (PRIN1 "->" OUTF) (PRINTNUM I4 (SETQ N (IPLUS N (IDIFFERENCE CODELOC (ADD1
LEN)))) OUTF) (COND (LEVEL (PUTHASH N (SELECTQ LEVADJ ((NCJUMP JUMP) LEVEL) (SUB1 LEVEL)) FVA) (
PUTHASH N STK STKA)))) (COND ((IGEQ B1 128) (IDIFFERENCE B1 256)) (T B1)))) (FN (SETQ B (IPLUS (LLSH
B1 8) B2)) (printout OUTF 40 (VATOM B))) (BIND (TAB 40 NIL OUTF) (PROG ((NNILS (LRSH B1 4)) (NVALS (
LOGAND B1 15))) (for I from (ADD1 (IDIFFERENCE B2 (IPLUS NNILS NVALS))) to (IDIFFERENCE B2 NNILS) do (
SPACES 1 OUTF) (PCVAR I PVARS (QUOTE pvar))) (PRIN1 (QUOTE ;) OUTF) (for I from (ADD1 (IDIFFERENCE B2
NNILS)) to B2 do (SPACES 1 OUTF) (PCVAR I PVARS (QUOTE pvar))) (COND (LEVEL (push STK (SETQ LEVEL (
ADD1 (IDIFFERENCE LEVEL NVALS)))))))) (JUMPXX ((LAMBDA (N) (PRIN1 "->" OUTF) (PRINTNUM I4 (SETQ N (
IPLUS N (IDIFFERENCE CODELOC (ADD1 LEN)))) OUTF) (COND (LEVEL (PUTHASH N (SELECTQ LEVADJ ((NCJUMP JUMP
) LEVEL) (SUB1 LEVEL)) FVA) (PUTHASH N STK STKA)))) (IPLUS (LLSH B1 8) B2 (COND ((IGREATERP B1 127)
-65536) (T 0))))) (ATOM (printout OUTF 40 .P2 (VATOM (IPLUS (LLSH B1 8) B2)))) (GCONST (printout OUTF
40 .P2 (V\UNCOPY (VVAG2 B1 (IPLUS (LLSH B2 8) B3))))) (FNX (printout OUTF "(" B1 ")" 40 (VATOM (IPLUS
(LLSH B2 8) B3)))) (TYPEP (printout OUTF "(" (COND ((EQ B1 6) (QUOTE ARRAYP)) ((EQ B1 7) (QUOTE
STRINGP)) ((EQ B1 3) (QUOTE FLOATP)) ((EQ B1 1) (QUOTE SMALLP)) ((EQ B1 8) (QUOTE STACKP)) ((EQ B1 2)
(QUOTE 2)) ((EQ B1 4) (QUOTE 4)) (T (QUOTE ?))) ")")) (UNBIND (AND LEVEL (SETQ LEVEL (pop STK)))) (
DUNBIND (AND LEVEL (SETQ LEVEL (SUB1 (pop STK))))) (RETURN (SETQ LEVEL)) (SUBRCALL (printout OUTF 40
.P2 (CAR (NTH \INITSUBRS (ADD1 B1)))) (AND LEVEL (SETQ LEVEL (ADD1 (IDIFFERENCE LEVEL B2))))) (COND ((
LISTP TAG) (printout OUTF 40 (CAR (NTH TAG (ADD1 B1))))))) (TERPRI OUTF) (COND ((AND LEVEL LEVADJ) (
SELECTQ LEVADJ (FNX (SETQ LEVEL (IPLUS LEVEL (IDIFFERENCE 1 B1)))) (JUMP (SETQ LEVEL)) ((CJUMP NCJUMP)
(SETQ LEVEL (IPLUS LEVEL -1))) (COND ((NUMBERP LEVADJ) (SETQ LEVEL (IPLUS LEVEL LEVADJ))))))) (GO LP)
))))
(VPRINTCODENT
(LAMBDA (STR START1 START2) (DECLARE (USEDFREE CA IVARS PVARS FVARS I4 I6 OUTF)) (*) (PROG (NAME TAG)
(COND ((ILESSP START1 (SETQ START2 (IPLUS START2 START1))) (printout OUTF STR T) (for NT1 from START1
by 2 while (ILESSP NT1 START2) as NT2 from START2 by 2 do (PRINTNUM I4 NT1 OUTF) (PRIN1 ": " OUTF) (
PRINTNUM I6 (LOGOR (LLSH (VGETBASEBYTE CA NT1) 8) (VGETBASEBYTE CA (ADD1 NT1))) OUTF) (SPACES 3 OUTF)
(PRINTNUM I4 NT2 OUTF) (PRIN1 ": " OUTF) (PRINTNUM I6 (LOGOR (LLSH (VGETBASEBYTE CA NT2) 8) (
VGETBASEBYTE CA (ADD1 NT2))) OUTF) (COND ((SETQ NAME (VATOM (LOGOR (LLSH (VGETBASEBYTE CA NT1) 8) (
VGETBASEBYTE CA (ADD1 NT1))))) (SETQ TAG (VGETBASEBYTE CA (ADD1 NT2))) (printout OUTF .SP 5 (SELECTC (
VGETBASEBYTE CA NT2) ((LRSH 0 8) (push IVARS (LIST TAG NAME)) (QUOTE IVAR)) ((LRSH 32768 8) (push
PVARS (LIST TAG NAME)) (QUOTE PVAR)) (PROGN (push FVARS (LIST TAG NAME)) (QUOTE FVAR))) " " TAG ": "
NAME))) (TERPRI OUTF)))))))
(VBROKENDEF
(LAMBDA (CA WHEN) (*) (PROG (BEFORE AFTER SIZE FB OP OFFSET NEWCA OPCODE TAG) (PROGN (SETQ FB ((LAMBDA
(DEFA0004) (DECLARE (LOCALVARS DEFA0004)) (LOGOR (LLSH (VGETBASEBYTE DEFA0004 6) 8) (VGETBASEBYTE
DEFA0004 (ADD1 6)))) (PROGN (SETQ NEWCA (SETQ CA (VGETDEFN CA)))))) (SETQ BEFORE) (SETQ AFTER T) (SETQ
OFFSET 0) (GO DOCOPY)) (SELECTQ WHEN (BEFORE (SETQ BEFORE T)) (AFTER (SETQ AFTER T)) ((NIL BOTH) (
SETQ BEFORE T) (SETQ AFTER T)) (LISPERROR "ILLEGAL ARG" WHEN)) (SETQ SIZE (ARRAYSIZE CA)) (SETQ OFFSET
(COND (BEFORE 3) (T 0))) (SETQ FB (LOGOR (LLSH (VGETBASEBYTE CA 6) 8) (VGETBASEBYTE CA (ADD1 6)))) (
SETQ NEWCA (\CODEARRAY (COND (BEFORE (IPLUS OFFSET SIZE)) (T SIZE)) (LOGAND (IPLUS (ADD1 (LRSH (IPLUS
FB 3) 2)) (CONSTANT (SUB1 2))) (CONSTANT (LOGXOR (SUB1 2) -1))))) DOCOPY (for I from 0 to (SUB1 FB) do
(VPUTBASEBYTE NEWCA I (VGETBASEBYTE CA I))) (*) (COND (BEFORE (*) (VPUTBASEBYTE NEWCA FB (V\CAR.UFN (
V\FINDOP (QUOTE 'NIL)))) (VPUTBASEBYTE NEWCA (ADD1 FB) (V\CAR.UFN (V\FINDOP (QUOTE HELP)))) (
VPUTBASEBYTE NEWCA (IPLUS FB 2) (V\CAR.UFN (V\FINDOP (QUOTE POP)))))) (do (SETQ OP (VGETBASEBYTE CA FB
)) (SETQ TAG (V\FINDOP OP)) (VPUTBASEBYTE NEWCA (IPLUS FB OFFSET) (SELECTQ (CADR TAG) (-X- (RETURN)) (
RETURN (COND (AFTER (V\CAR.UFN (V\FINDOP (QUOTE \RETURN)))) (T OP))) OP)) (FRPTQ (CADDR TAG) (
VPUTBASEBYTE NEWCA (IPLUS (SETQ FB (IPLUS FB 1)) OFFSET) (VGETBASEBYTE CA FB))) (SETQ FB (IPLUS FB 1))
) (RETURN NEWCA))))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS PCVAR MACRO ((IND LST NAME) (* lmm "11-AUG-81 22:27") (ALLOCAL (PROG NIL (PRIN2 (CADR (OR (
ASSOC IND LST) (RETURN (printout OUTF "[" NAME IND "]")))) OUTF)))))
)
(DEFINEQ
(V\CAR.UFN
(LAMBDA (X) (*) (*) (\CALLME (QUOTE V\CAR.UFN)) (COND ((VLISTP X) (COND ((ZEROP 1) (VGETBASEPTR X 0))
(T (COND ((EQ (LRSH (VGETBASE X 0) 8) 0) (VGETBASEPTR (VGETBASEPTR X 0) 0)) (T (VGETBASEPTR X 0))))))
((NULL X) NIL) (T (SELECTQ CAR/CDRERR (T (LISPERROR "ARG NOT LIST" X)) ((NIL V\CDR.UFN) (COND ((EQ X T
) T) ((LITATOM X) NIL) (T (QUOTE "{car of non-list}")))) (COND ((EQ X T) T) ((STRINGP X) (LISPERROR
"ARG NOT LIST" X)) (T (QUOTE "{car of non-list}"))))))))
(V\CDR.UFN
(LAMBDA (X) (*) (*) (\CALLME (QUOTE V\CDR.UFN)) (COND ((VLISTP X) (COND ((ZEROP 1) (VGETBASEPTR X 2))
(T (PROG ((Q (LRSH (VGETBASE X 0) 8))) (RETURN (COND ((EQ Q 128) NIL) ((IGREATERP Q 128) (VADDBASE (
VVAG2 (VHILOC X) (LOGAND (VLOLOC X) 65280)) (LLSH (IDIFFERENCE Q 128) 1))) ((EQ Q 0) (V\CDR.UFN (
VGETBASEPTR X 0))) (T (VGETBASEPTR (VADDBASE (VVAG2 (VHILOC X) (LOGAND (VLOLOC X) 65280)) (LLSH Q 1))
0)))))))) ((NULL X) NIL) (T (SELECTQ CAR/CDRERR ((T V\CDR.UFN) (LISPERROR "ARG NOT LIST" X)) (NIL (
COND ((LITATOM X) (VGETPROPLIST X)) (T "{cdr of non-list}"))) (COND ((STRINGP X) (LISPERROR
"ARG NOT LIST" X)) (T "{cdr of non-list}")))))))
)
(DEFINEQ
(V\COPY
(LAMBDA (X) (*) (*) (SELECTQ (TYPENAME X) (LITATOM (VATOMNUMBER X T)) (VLISTP (PROG ((R (REVERSE X)) (
V (V\COPY (CDR (LAST X))))) LP (COND ((LISTP R) (SETQ V (VCONS (V\COPY (CAR R)) V)) (SETQ R (CDR R)) (
GO LP))) (RETURN V))) ((FIXP SMALLP) (PROG (V) (COND ((IGREATERP 0 X) (*) (COND ((IGREATERP X -65537)
(*) (RETURN (VADDBASE (VVAG2 15 0) (LOGAND X 65535)))))) ((ILESSP X 65536) (*) (RETURN (VADDBASE (
VVAG2 14 0) X)))) (*) (SETQ V (VCREATECELL 2)) (VPUTBASE V 0 (LOGOR (COND ((IGREATERP 0 X) 32768) (T 0
)) (LOGAND (LRSH X 16) 32767))) (VPUTBASE V 1 (LOGAND X 65535)) (RETURN V))) (STRINGP (VCOPYSTRING X))
(FLOATP (PROG ((VAL (VCREATECELL 3))) (SELECTQ (SYSTEMTYPE) ((ALTO D) (VPUTBASE VAL 0 (\GETBASE X 0))
(VPUTBASE VAL 1 (\GETBASE X 1))) (MKI.IEEE X VAL)) (RETURN VAL))) (ERROR X (QUOTE (can't be copied to
remote file))))))
(V\UNCOPY
(LAMBDA (X) (*) (PROG ((TYP (VNTYPX X))) (RETURN (COND ((EQ TYP 1) (COND ((EQ (VHILOC X) (CONSTANT 14)
) (VLOLOC X)) (T (IPLUS (VLOLOC X) -65536)))) ((EQ TYP 2) (*) (IPLUS (LLSH (VGETBASE X 0) 16) (
VGETBASE X 1))) ((EQ TYP 4) (VATOM (VLOLOC X))) ((EQ TYP 7) (PROG (STR (OFFST (VGETBASE X 3)) (I 1) (
PTR (VGETBASEPTR X 0)) (LENGTH (VGETBASE X 2))) (SETQ STR (ALLOCSTRING LENGTH)) (FRPTQ LENGTH (
RPLSTRING STR I (FCHARACTER (V\GETBASEBYTE PTR OFFST))) (SETQ I (IPLUS I 1)) (SETQ OFFST (IPLUS OFFST
1))) (RETURN STR))) ((EQ TYP 5) (CONS (V\UNCOPY (V\CAR.UFN X)) (V\UNCOPY (V\CDR.UFN X)))) ((ZEROP TYP)
(LIST (QUOTE #) (VHILOC X) (VLOLOC X))) (T (LIST (VTYPENAME X) (VHILOC X) (VLOLOC X))))))))
)
(DEFINEQ
(V\GETBASEBYTE
(LAMBDA (PTR N) (*) (*) (COND ((ZEROP (LOGAND N 1)) (LRSH (PROGN (VGETBASE PTR (LRSH N 1))) 8)) (T (
LOGAND (PROGN (VGETBASE PTR (LRSH N 1))) 255)))))
(V\PUTBASEBYTE
(LAMBDA (PTR DISP BYTE) (*) (*) (SETQ BYTE (PROG1 BYTE)) (VPUTBASE PTR (LRSH (SETQ DISP (\DTEST DISP (
QUOTE SMALLP))) 1) (COND ((EVENP DISP 2) ((LAMBDA ($$1) (IPLUS (LLSH BYTE 8) (LOGAND $$1 255))) (
VGETBASE PTR (LRSH DISP 1)))) (T ((LAMBDA ($$1) (IPLUS (LLSH (LRSH $$1 8) 8) BYTE)) (VGETBASE PTR (
LRSH DISP 1)))))) BYTE))
)
(DEFINEQ
(VNTYPX
(LAMBDA (X) (*) (*) (LOGAND (VGETBASE (VVAG2 22 32768) (LRSH (IPLUS (LLSH (VHILOC X) 8) (LRSH (VLOLOC
X) 8)) 1)) 255)))
(VTYPENAME
(LAMBDA (DATUM) (*) (PROG ((N (VNTYPX DATUM))) (RETURN (SELECTC N (6 ((LAMBDA (X) (QUOTE ARRAYP))
DATUM)) (VATOM (VGETBASE (VADDBASE (VVAG2 22 43008) (LLSH N 4)) 0)))))))
)
(DEFINEQ
(VCOPYATOM
(LAMBDA (X) (*) (*) (PROG ((N (NCHARS X)) (BASE (VGETBASEPTR \SCRATCHSTRING 0)) (OFFST (VGETBASE
\SCRATCHSTRING 3))) (for I from 1 to N do (V\PUTBASEBYTE BASE (IPLUS OFFST I -1) (NTHCHARCODE X I))) (
RETURN (VATOMNUMBER (V\MKATOM BASE OFFST N))))))
(VUNCOPYATOM
(LAMBDA (N) (*) (*) (PROG ((ADDR (VGETBASEPTR (VVAG2 16 0) (LLSH N 1))) LEN (STR (OR COPYATOMSTR (SETQ
COPYATOMSTR (ALLOCSTRING 255))))) (SETQ LEN (V\GETBASEBYTE ADDR 0)) (for I from 1 to LEN do (
RPLSTRING COPYATOMSTR I (FCHARACTER (V\GETBASEBYTE ADDR I)))) (RETURN (SUBATOM COPYATOMSTR 1 LEN)))))
(V\MKATOM
(LAMBDA (BASE OFFST LEN) (*) (PROG ((L 1) (H 0) H1 P Q C) (COND ((EQ 0 LEN) (GO LP))) (SETQ C (
NTHCHARCODE BASE OFFST)) (PROGN NIL NIL) (*) (SETQ H C) HASH (COND ((NEQ L LEN) (SETQ H (LOGAND (IPLUS
(IPLUS (LOGAND (SETQ H1 (IPLUS H (LLSH (LOGAND H 4095) 2))) 32767) (LLSH (LOGAND H1 127) 8)) (
NTHCHARCODE BASE (IPLUS OFFST L))) 32767)) (SETQ L (ADD1 L)) (GO HASH))) (*) LP (COND ((NEQ 0 (SETQ P
(VGETBASE (VVAG2 20 0) H))) (COND ((EQ (VATOM (SETQ Q (SUB1 P))) BASE) (RETURN Q)) (T (SETQ H (LOGAND
(IPLUS H 19) 32767)) (GO LP))))) (*) (RETURN (ERROR! BASE OFFST LEN H)))))
(VGETTOPVAL
(LAMBDA (X) (*) (VGETBASEPTR (VADDBASE (VVAG2 18 0) (LLSH (PROGN (VATOMNUMBER (PROGN (\DTEST X (QUOTE
LITATOM))))) 1)) 0)))
(VGETPROPLIST
(LAMBDA (ATM) (*) (VGETBASEPTR (VADDBASE (VVAG2 19 0) (LLSH (VATOMNUMBER (PROGN (\DTEST ATM (QUOTE
LITATOM)))) 1)) 0)))
(VSETTOPVAL
(LAMBDA (ATM VAL) (*) (SELECTQ (\DTEST ATM (QUOTE LITATOM)) (NIL (AND VAL (LISPERROR
"ATTEMPT TO SET NIL OR T" VAL))) (T (OR (EQ VAL T) (LISPERROR "ATTEMPT TO SET NIL OR T" VAL))) (
VPUTBASEPTR (VADDBASE (VVAG2 18 0) (LLSH (PROGN (VATOMNUMBER ATM)) 1)) 0 (V\COPY VAL)))))
(VGETDEFN
(LAMBDA (A) (*) (VGETBASEPTR (VADDBASE (VVAG2 17 0) (LLSH (VATOMNUMBER A) 1)) 0)))
(V\SMASHATOM
(LAMBDA (A) (*) (LRSH ((LAMBDA ($$PUTBITS) (VPUTBASE $$PUTBITS 0 (LOGOR (LOGAND (VGETBASE $$PUTBITS 0)
255) (LLSH 0 8)))) (VGETBASEPTR (VADDBASE (VVAG2 16 0) (LLSH (VATOMNUMBER A) 1)) 0)) 8)))
)
(DEFINEQ
(VLISTP
(LAMBDA (X) (*) (*) (AND (EQ (VNTYPX X) 5) X)))
)
(RPAQQ COPYATOMSTR NIL)
(DEFINEQ
(V\FINDOP
(LAMBDA (OPNAME FLG) (*) (PROGN (OR \OPCODEARRAY (PROGN (SETQ \OPCODEARRAY (ARRAY 256)) (for X in
\OPCODES do (PUTPROP (fetch OPCODENAME of X) (QUOTE DOPCODE) X) (for I from (fetch OP# of X) to (OR (
fetch OPLAST of X) (fetch OP# of X)) by 1 do (SETA \OPCODEARRAY (ADD1 I) X))))) (OR (COND ((LITATOM
OPNAME) (GETPROP OPNAME (QUOTE DOPCODE))) ((FIXP OPNAME) (ELT \OPCODEARRAY (ADD1 OPNAME)))) (AND FLG (
ERROR OPNAME FLG))))))
)
(RPAQQ \OPCODES ((0 -X- 0) (1 CAR 0 T 0 NIL \CAR.UFN) (2 CDR 0 T 0 NIL \CDR.UFN) (3 LISTP 0 T 0 NIL
LISTP) (4 NTYPX 0 T 0 NIL NTYPX) (5 TYPEP 1 TYPEP 0) (6 DTEST 2 ATOM 0 NIL \DTESTFAIL) (7 CDDR 0 T 0
NIL CDDR) (8 FN0 2 FN 1) (9 FN1 2 FN 0) (10 FN2 2 FN -1) (11 FN3 2 FN -2) (12 FN4 2 FN -3) (13 FNX 3
FNX FNX) (14 APPLYFN 0 T -1) (15 CHECKAPPLY* 0 T 0 NIL \CHECKAPPLY*) (16 RETURN 0 T 0 NIL \HARDRETURN)
(17 BIND 2) (18 UNBIND 0) (19 DUNBIND 0) (20 RPLPTR.N 1 T -1 NIL \RPLPTR.UFN) (21 GCREF 1 T 0 NIL
\HTFIND) (22 was.htfind 0 T) (23 GVAR← 2 ATOM 0 NIL \SETGLOBALVAL.UFN) (24 RPLACA 0 T -1 NIL
\RPLACA.UFN) (25 RPLACD 0 T -1 NIL \RPLACD.UFN) (26 CONS 0 T -1 NIL \CONS.UFN) (27 GETP 0 T -1 NIL
GETPROP) (28 FMEMB 0 T -1 NIL FMEMB) (29 GETHASH 0 T -1 NIL GETHASH) (30 PUTHASH 0 T -2 NIL PUTHASH) (
31 CREATECELL 0 T 0 NIL \CREATECELL) (32 BIN 0 T 0 NIL \BIN) (33 BOUT 0 T -1 NIL \BOUT) (34 BITBLT 0 T
-1 NIL BitBltSUBR) (35 LIST1 0 T 0 NIL CONS) (36 DOCOLLECT 0 T -1 NIL DOCOLLECT) (37 ENDCOLLECT 0 T
-1 NIL ENDCOLLECT) (38 RPLCONS 0 T -1 NIL \RPLCONS) (39 unused) (40 ELT 0 T -1 NIL ELT) (41 NTHCHC 0 T
-1 NIL NTHCHARCODE) (42 SETA 0 T -2 NIL SETA) (43 RPLCHARCODE 0 T -2 NIL RPLCHARCODE) (44 EVAL 0 T 0
NIL \EVAL) (45 EVALV 0 T 0 NIL \EVALV1) (46 unused) (47 STKSCAN 0 T 0 NIL \STKSCAN) (48 unused NIL NIL
NIL 48) (49 IBLT2 0 T -7 NIL \IBLT2.UFN) (50 unused NIL NIL NIL 58) (59 \MU.DRAWLINE 0 T -8 NIL
\DRAWLINE.UFN) (60 STORE.N 1 T 0) (61 COPY.N 1 T 1) (62 RAID 0 T 0 NIL RAID) (63 \RETURN 0 T 0 NIL
\RETURN) (64 IVAR 0 IVAR 1 70) (71 IVARX 1 IVAR 1) (72 PVAR 0 PVAR 1 78) (79 PVARX 1 PVAR 1) (80 FVAR
0 FVAR 1 86) (87 FVARX 1 FVAR 1) (88 PVAR← 0 PVAR 0 94) (95 PVARX← 1 PVAR 0) (96 GVAR 2 ATOM 1) (97
ARG0 0 T 0 NIL \ARG0) (98 IVARX← 1 IVAR 0) (99 FVARX← 1 FVAR 0) (100 COPY 0 T 1) (101 MYARGCOUNT 0 T 1
NIL \MYARGCOUNT) (102 MYALINK 0 T 1) (103 ACONST 2 ATOM 1) (104 'NIL 0 T 1) (105 'T 0 T 1) (106 '0 0
T 1) (107 '1 0 T 1) (108 SIC 1 SIC 1) (109 SNIC 1 SNIC 1) (110 SICX 2 SICX 1) (111 GCONST 3 GCONST 1)
(112 ATOMNUMBER 2 ATOM 1) (113 READFLAGS 0 T 0 NIL \READFLAGS) (114 READRP 0 T 0 NIL \READRP) (115
WRITEMAP 0 T -2 NIL \WRITEMAP) (116 READPRINTERPORT 0 T 1 NIL NILL) (117 WRITEPRINTERPORT 0 T 0 NIL
NILL) (118 PILOTBITBLT 0 T -1 NIL \PILOTBITBLT) (119 RCLK 0 T 0 NIL \RCLKSUBR) (120 MISC1 1 T 0 NIL
\MISC1.UFN) (121 MISC2 1 T -1 NIL \MISC2.UFN) (122 RECLAIMCELL 0 T 0 NIL \GCRECLAIMCELL) (123 GCSCAN1
0 T 0 NIL \GCSCAN1) (124 GCSCAN2 0 T 0 NIL \GCSCAN2) (125 SUBRCALL 2) (126 CONTEXTSWITCH 0 T 0 NIL
\CONTEXTSWITCH) (127 AUDIO 0 T 0 NIL NILL) (128 JUMP 0 JUMP JUMP 143) (144 FJUMP 0 JUMP CJUMP 159) (
160 TJUMP 0 JUMP CJUMP 175) (176 JUMPX 1 JUMPX JUMP) (177 JUMPXX 2 JUMPXX JUMP) (178 FJUMPX 1 JUMPX
CJUMP) (179 TJUMPX 1 JUMPX CJUMP) (180 NFJUMPX 1 JUMPX NCJUMP) (181 NTJUMPX 1 JUMPX NCJUMP) (182 jeq)
(183 jlistp) (184 PVAR←↑ 0 PVAR -1 190) (191 POP 0 T -1) (192 was.getbase) (193 was.getbaseptr) (194
GETBASEBYTE 0 T -1 NIL \GETBASEBYTE) (195 was.scanbase) (196 BLT 0 T -2 NIL \BLT) (197 was.putbase) (
198 was.putbaseptr) (199 PUTBASEBYTE 0 T -2 NIL \PUTBASEBYTE) (200 GETBASE.N 1 T 0) (201 GETBASEPTR.N
1 T 0) (202 GETBITS.N.FD 2 T 0) (203 unused) (204 unused) (205 PUTBASE.N 1 T -1 NIL \PUTBASE.UFN) (206
PUTBASEPTR.N 1 T -1 NIL \PUTBASEPTR.UFN) (207 PUTBITS.N.FD 2 T -1 NIL \PUTBITS.UFN) (208 ADDBASE 0 T
-1 NIL \ADDBASE) (209 VAG2 0 T -1 NIL \VAG2) (210 HILOC 0 T 0) (211 LOLOC 0 T 0) (212 PLUS2 0 T -1 NIL
\SLOWPLUS2) (213 DIFFERENCE 0 T -1 NIL \SLOWDIFFERENCE) (214 TIMES2 0 T -1 NIL \SLOWTIMES2) (215
QUOTIENT 0 T -1 NIL \SLOWQUOTIENT) (216 IPLUS2 0 T -1 NIL \SLOWIPLUS2) (217 IDIFFERENCE 0 T -1 NIL
\SLOWIDIFFERENCE) (218 ITIMES2 0 T -1 NIL \SLOWITIMES2) (219 IQUOTIENT 0 T -1 NIL \SLOWIQUOTIENT) (220
IREMAINDER 0 T -1 NIL IREMAINDER) (221 IPLUS.N 1 T 0 NIL \SLOWIPLUS2) (222 IDIFFERENCE.N 1 T 0 NIL
\SLOWIDIFFERENCE) (223 IBLT1 0 T -7 NIL \IBLT1.UFN) (224 LLSH1 0 T 0 NIL \SLOWLLSH1) (225 LLSH8 0 T 0
NIL \SLOWLLSH8) (226 LRSH1 0 T 0 NIL \SLOWLRSH1) (227 LRSH8 0 T 0 NIL \SLOWLRSH8) (228 LOGOR2 0 T -1
NIL \SLOWLOGOR2) (229 LOGAND2 0 T -1 NIL \SLOWLOGAND2) (230 LOGXOR2 0 T -1 NIL \SLOWLOGXOR2) (231
unused) (232 FPLUS2 0 T -1 NIL \BOXFPLUSDIF) (233 FDIFFERENCE 0 T -1 NIL \FDIFFERENCE.UFN) (234
FTIMES2 0 T -1 NIL \BOXFTIMES2) (235 FQUOTIENT 0 T -1 NIL \BOXFQUOTIENT) (236 UBFLOAT2 1 (UFADD UFSUB
UFISUB UFMULT UFDIV UFGREAT UFMAX UFMIN) -1 NIL \UNBOXFLOAT2) (237 UBFLOAT1 1 (BOX UNBOX UFABS
UFNEGATE) 0 NIL \UNBOXFLOAT1) (238 unused) (239 unused) (240 EQ 0 T -1) (241 IGREATERP 0 T -1 NIL
\SLOWIGREATERP) (242 FGREATERP 0 T -1 NIL FGREATERP) (243 GREATERP 0 T -1 NIL GREATERP) (244 unused) (
245 MAKENUMBER 0 T -1 NIL \MAKENUMBER) (246 BOXIPLUS 0 T -1 NIL \BOXIPLUS) (247 BOXIDIFFERENCE 0 T -1
NIL \BOXIDIFFERENCE) (248 FLOATBLT 0 T -4 NIL \FLOATBLT) (249 FFTSTEP 0 T -1 NIL \FFTSTEP) (250
FLOATBLT1 1 (EXP MAG FLOAT COMP) -3 NIL \FLOATBLT1.UFN) (251 FLOATBLT2 1 (TIMES PERM PLUS DIFF SEP) -2
NIL \FLOATBLT2.UFN) (252 unused) (253 SWAP 0 T 0) (254 NOP 0 T 0) (255 UPCTRACE 0 T 0 NIL NILL)))
(RPAQQ \OPCODEARRAY NIL)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \OPCODEARRAY \OPCODES)
)
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(RECORD OPCODE (OP# OPCODENAME OPNARGS OPPRINT LEVADJ OPLAST UFNFN))
]
)
(FILESLOAD VMEM)
(RPAQQ RDVALS ((\AtomFrLst)))
(RPAQQ RDPTRS NIL)
(DECLARE: EVAL@COMPILE DONTCOPY
(FILESLOAD (LOADCOMP) VMEM)
)
STOP