(FILECREATED " 6-Jun-85 12:33:17" {ERIS}<LISPCORE>LIBRARY>RDSYS.;2
previous date: "14-Apr-85 18:05:01" {ERIS}<LISPCORE>LIBRARY>RDSYS.;16)
(PRETTYCOMPRINT RDSYSCOMS)
(RPAQQ RDSYSCOMS ((FNS VREADPAGEMAP VREADPAGEMAPBLOCK VCHECKIFPAGE V\LOCKEDPAGEP V\LOOKUPPAGEMAP
VCHECKPAGEMAP VCHECKFPTOVP VCHECKFPTOVP1 V\SHOWPAGETABLE V\PRINTFPTOVP) (FNS VRAIDCOMMAND
VRAIDSHOWFRAME VRAIDSTACKCMD VRAIDROOTFRAME VPRINTADDRS VPRINTVA VREADVA VREADOCT VREADATOM
VSHOWSTACKBLOCKS VSHOWSTACKBLOCK1 VPRINCOPY VNOSUCHATOM) (FNS V\BACKTRACE V\PRINTBF V\PRINTFRAME
V\SCANFORNTENTRY V\PRINTSTK) (FNS V\CHECKARRAYBLOCK V\PARSEARRAYSPACE V\PARSEARRAYSPACE1) (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\ATOMCELL) (FNS VLISTP) (VARS (COPYATOMSTR)) (FILES VMEM) (VARS
RDVALS RDPTRS) (DECLARE: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) VMEM))))
(DEFINEQ
(VREADPAGEMAP
(LAMBDA NIL (*) (*) (PROG (D) (MAPVMPAGE (IPLUS (LLSH (VHILOC (VVAG2 6 0)) 8) (LRSH (VLOLOC (VVAG2 6 0
)) 8)) 1) (*) (*) (MAPVMPAGE (IPLUS (LLSH (VHILOC (VVAG2 5 0)) 8) (LRSH (VLOLOC (VVAG2 5 0)) 8)) (SUB1
(VGETBASE (VVAG2 6 0) 22))) (*) (SETVMPTR (VVAG2 5 0)) (for I from 0 to (SUB1 (LRSH (IPLUS 256 31) 5)
) as VP from (IPLUS (LLSH (VHILOC (VVAG2 5 0)) 8) (LRSH (VLOLOC (VVAG2 5 0)) 8)) by 32 do (*) (
VREADPAGEMAPBLOCK VP)) (for J from 0 to (SUB1 8) as FP from (SUB1 (VGETBASE (VVAG2 6 0) 23)) do (*) (
MAPVMPAGE (IPLUS (IPLUS (LLSH (VHILOC (VVAG2 6 512)) 8) (LRSH (VLOLOC (VVAG2 6 512)) 8)) J) FP)) (for
I from 0 to (SUB1 (LLSH 8 8)) do (COND ((IEQ (SETQ D (VGETBASE (VVAG2 6 512) I)) 65535)) (T (SETVMPTR
(VADDBASE (VVAG2 5 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 6 0) 15))) (printout T "Warning: "
"Interface page key" "= " (PROGN 5603) ", but \InterfacePage says " (VGETBASE (VVAG2 6 0) 15) T)))))
(V\LOCKEDPAGEP
(LAMBDA (VP TEMP) (*) (*) (OR (NEQ 0 (LOGAND (LLSH 1 (IMOD VP 16)) (VGETBASE (VADDBASE (VVAG2 6 28672)
(LRSH VP 4)) 0))) NIL)))
(V\LOOKUPPAGEMAP
(LAMBDA (VP) (*) (*) (PROG ((PRIMENTRY (VGETBASE (VVAG2 6 512) (LRSH VP 5)))) (RETURN (COND ((EQ
PRIMENTRY 65535) 0) (T (VGETBASE (VVAG2 5 0) (IPLUS PRIMENTRY (LOGAND VP 31)))))))))
(VCHECKPAGEMAP
(LAMBDA NIL (*) (RESETFORM (RADIX 8) (PROG ((NUMOCCUPIED 0) (NUMLOCKED 0) (CHAINOCCUPIED 0) (
CHAINLOCKED 0) RPTR FPBASE FP VP RP) (VCHECKFPTOVP) (for RPTINDEX from 1 to (SUB1 VRPTSIZE) when (
ILESSP (VGETBASE (PROGN (SETQ RPTR (VADDBASE VREALPAGETABLE (TIMES3 RPTINDEX)))) 1) 65534) do (SETQ
NUMOCCUPIED (PLUS NUMOCCUPIED 1)) (SETQ VP (VGETBASE RPTR 1)) (SETQ FP (VGETBASE RPTR 2)) (COND ((
VCHECKFPTOVP1 FP VP RPTINDEX)) ((NEQ VP (VGETBASE (SETQ FPBASE (VADDBASE (VVAG2 4 0) FP)) 0)) (
printout T "RPT for RP " (RPFROMRPT RPTINDEX) " says VP ") (\PRINTVP VP T) (printout T " lives in FP "
FP "; but FP Map says that FP contains ") (\PRINTVP (VGETBASE FPBASE 0) T) (printout T T)) ((
V\LOCKEDPAGEP VP) (SETQ NUMLOCKED (PLUS NUMLOCKED 1)) (COND ((NOT (NEQ 0 (LRSH (VGETBASE RPTR 0) 15)))
(printout T "VP " VP ", living in RP " (RPFROMRPT RPTINDEX) " should be locked but isn't." T)) ((
IGREATERP FP (DLRPFROMFP (VGETBASE (VVAG2 6 0) 57))) (printout T "VP " VP
" is locked, but living in FP " FP ", which is not in the locked page area" T)))))) (PROGN (SETQ RPTR
VREALPAGETABLE) (*) (while (NEQ (SETQ RP (LOGAND (VGETBASE RPTR 0) 32767)) 0) when (ILESSP (VGETBASE (
PROGN (SETQ RPTR (VADDBASE VREALPAGETABLE (TIMES3 RP)))) 1) 65534) do (SETQ CHAINOCCUPIED (PLUS
CHAINOCCUPIED 1)) (COND ((NEQ 0 (LRSH (VGETBASE RPTR 0) 15)) (SETQ CHAINLOCKED (PLUS CHAINLOCKED 1))))
) (COND ((ILESSP CHAINOCCUPIED NUMOCCUPIED) (printout T NUMOCCUPIED " occupied pages, but only "
CHAINOCCUPIED " are on page chain. " NUMLOCKED " pages are permanently locked; " CHAINLOCKED
" pages on chain are locked somehow." T))))))))
(VCHECKFPTOVP
(LAMBDA NIL (*) (for FP from 1 to (VGETBASE (VVAG2 6 0) 20) as (FPBASE ← (VADDBASE (VVAG2 4 0) 1)) by
(VADDBASE FPBASE 1) when (NEQ (VGETBASE FPBASE 0) 65535) do (VCHECKFPTOVP1 FP (VGETBASE FPBASE 0)))))
(VCHECKFPTOVP1
(LAMBDA (FP VP RPTINDEX) (*) (PROG ((FP2 (V\LOOKUPPAGEMAP VP))) (RETURN (COND ((NEQ FP2 FP) (COND (NIL
(printout T "RPT for RP " (RPFROMRPT RPTINDEX))) (T (printout T "FP map"))) (printout T " says FP "
FP " contains VP ") (\PRINTVP VP T) (printout T "; but PageMap says that page is in FP " FP2 T) T)))))
)
(V\SHOWPAGETABLE
(LAMBDA (MODE FILE) (*) (RESETLST (RESETSAVE (OUTPUT FILE)) (RESETSAVE (RADIX 8)) (PROG ((RPTR
VREALPAGETABLE) (RP 0) FLAGS VP STATE FIRSTONE LASTONE) (printout NIL
" RP VP FilePage Status" T) (until (SELECTQ MODE (CHAIN (EQ (SETQ RP (LOGAND (
VGETBASE RPTR 0) 32767)) 0)) (NIL (SETQ RP (PLUS RP 1)) (IGEQ RP VRPTSIZE)) (\ILLEGAL.ARG MODE)) do (
SETQ RPTR (VADDBASE VREALPAGETABLE (TIMES3 RP))) (SETQ VP (VGETBASE RPTR 1)) (COND ((AND (NULL MODE) (
EQ VP STATE)) (SETQ LASTONE RP)) (T (COND (LASTONE (printout NIL "ditto thru " LASTONE T) (SETQ
LASTONE NIL))) (SETQ FIRSTONE RP) (SETQ STATE VP) (printout NIL .I7.8 (RPFROMRPT RP)) (COND ((EQ (
VGETBASE RPTR 1) 65534) (PRIN1 " Empty")) ((NOT (ILESSP (VGETBASE RPTR 1) 65534)) (PRIN1
" Unavailable")) (T (printout NIL .I8.8 VP , # (\PRINTVP VP) 28 .I6.8 (VGETBASE RPTR 2) ,,) (COND ((
NEQ 0 (LRSH (VGETBASE RPTR 0) 15)) (COND ((NOT (V\LOCKEDPAGEP VP)) (*) (PRIN1 "Temp"))) (PRIN1
"Locked "))) NIL)) (TERPRI))))))))
(V\PRINTFPTOVP
(LAMBDA (BASE NWORDS STREAM) (*) (SETQ STREAM (GETSTREAM STREAM (QUOTE OUTPUT))) (OR BASE (SETQ BASE (
VVAG2 4 0))) (OR NWORDS (SETQ NWORDS (VGETBASE (VVAG2 6 0) 20))) (RESETFORM (RADIX 8) (PROG ((LASTVP
-2) (NEXTFP 0) FIRSTFP FIRSTVP NEXTVP LOCKEDP NEXTLOCKED) (while (IGEQ NWORDS 0) do (SETQ NEXTFP (PLUS
NEXTFP 1)) (COND ((EQ NWORDS 0) (SETQ NEXTVP -1)) ((NEQ (SETQ NEXTVP (VGETBASE (SETQ BASE (VADDBASE
BASE 1)) 0)) 65535) (SETQ NEXTLOCKED (V\LOCKEDPAGEP NEXTVP)))) (COND ((COND ((EQ NEXTVP 65535) (NEQ
LASTVP 65535)) (T (OR (NEQ NEXTVP (ADD1 LASTVP)) (NEQ NEXTLOCKED LOCKEDP)))) (COND ((IGEQ LASTVP 0) (
COND (FIRSTFP (printout STREAM FIRSTFP "-"))) (printout STREAM (SUB1 NEXTFP) 12) (COND ((EQ LASTVP
65535) (printout STREAM "empty")) (T (COND (FIRSTFP (\PRINTVP FIRSTVP STREAM) (PRIN1 "-" STREAM))) (
\PRINTVP LASTVP STREAM) (COND (LOCKEDP (PRIN1 (QUOTE *) STREAM))))))) (SETQ FIRSTFP) (TERPRI STREAM) (
SETQ FIRSTVP NEXTVP)) (T (*) (OR FIRSTFP (SETQ FIRSTFP (SUB1 NEXTFP))))) (SETQ LASTVP NEXTVP) (SETQ
LOCKEDP NEXTLOCKED) (SETQ NWORDS (PLUS NWORDS -1)))))))
)
(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]"
NOECHOFLG T CONFIRMFLG T RETURN (QUOTE ↑N)) (L "isp stack ") (% "Lisp stack " NOECHOFLG T
EXPLAINSTRING "↑L -- Lisp stack from arbitrary frame or context" RETURN (QUOTE ↑L)) (F "rame ") (%
"Next frame " EXPLAINSTRING "LF - next frame" RETURN (QUOTE LF)) (↑ " Previous frame ") (A
"tom top-level value of atom: ") (D "efinition for atom: ") (P "roperty list for atom: ") (V
" -- show object at Virtual address: ") (B "lock of storage starting at address: ") (S
"how raw stack from address: ") (C "ode for function:") (% "Basic frame at: " EXPLAINSTRING
"↑F - print basic frame at octal address" RETURN (QUOTE ↑F)) (% "frame extension at: " EXPLAINSTRING
"↑X - print frame extension at octal address" RETURN (QUOTE ↑X)) (W "alk stack blocks starting at: ")
(K "" EXPLAINSTRING "K -- Set linKtype for stack ops") (← " Set word at address: ") (%
" Set value of atom " EXPLAINSTRING "↑V -- Set value of atom" RETURN (QUOTE ↑V)) (%
"atom number for atom: " EXPLAINSTRING "↑O - look up atom" RETURN (QUOTE ↑O)) (I
"nspect InterfacePage [confirm]" CONFIRMFLG T) (U " -- Show remote screen [confirm]" CONFIRMFLG T) (
"
" "" RETURN NIL) (% " Enter Lisp " EXPLAINSTRING "↑Y -- Enter Lisp" RETURN (QUOTE ↑Y)))) T)) (↑N (
RETURN (QUOTE RETURN))) (Q (TERPRI T) (RETURN (QUOTE QUIT))) (NIL) (A (PRINT (V\UNCOPY (VGETTOPVAL (
VREADATOM))) T T)) (P (PRINT (V\UNCOPY (VGETPROPLIST (VREADATOM))) T T)) (C (VDPRINTCODE (VREADATOM) T
RAIDIX)) (V (PRINT (V\UNCOPY (VREADVA)) T T)) (B (VPRINTADDRS (VREADVA) (VREADOCT
" for (number of words): "))) (S (VPRINTADDRS (VVAG2 1 (VREADOCT)) (VREADOCT
" for (number of words): "))) (D (VPRINTADDRS (V\ATOMCELL (PROGN (VREADATOM)) 10) 2)) (↑O (PRINT (
VATOMNUMBER (VREADATOM)) T T)) (↑V (PROG ((ATM (VREADATOM))) (printout T " to be ") (VSETTOPVAL ATM (
READ T T)))) ((L ↑L) (VRAIDSTACKCMD CMD)) (F (VRAIDSHOWFRAME (SETQ FRAME# (PROG1 (READ T T) (READC T))
))) (LF (OR FRAME# (SETQ FRAME# 0)) (printout T "(" .I1 (SETQ FRAME# (PLUS FRAME# 1)) ")" T) (
VRAIDSHOWFRAME FRAME#)) (↑ (COND ((OR (NULL FRAME#) (ILEQ FRAME# 1)) (printout T "No previous frame" T
)) (T (printout T "(" .I1 (SETQ FRAME# (PLUS 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 T " Currently ") (PRINTNUM .I7 (VGETBASE VA 0
) T) (printout T " 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 (VRAIDROOTFRAME)))) (FRPTQ (SUB1 N) (COND ((EQ (PROGN (
SETQ FRAME (COND (ALINKS? (IDIFFERENCE (LOGAND (VGETBASE (VVAG2 1 FRAME) 1) (CONSTANT (LOGXOR (SUB1 2)
-1))) 10)) (T (IDIFFERENCE (COND ((NOT (NEQ 0 (LOGAND (VGETBASE (VVAG2 1 FRAME) 1) 1))) (VGETBASE (
VVAG2 1 FRAME) 1)) (T (VGETBASE (VVAG2 1 FRAME) 9))) 10))))) 0) (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))))
(VRAIDSTACKCMD
(LAMBDA (CMD) (*) (DECLARE (USEDFREE FRAME# ROOTFRAME)) (PROG (FRAME) (SETQ FRAME# 0) (COND ((EQ CMD (
QUOTE L)) (VRAIDROOTFRAME)) (T (SETQ ROOTFRAME (SELECTQ (SETQ FRAME (ASKUSER NIL NIL
"in context (? for help): " (QUOTE ((P "age fault") (G "arbage collection") (K "eyboard handler") (H
"ard Return") (S "tack manipulator") (R "eset") (M "iscellaneous") (F "rame at location: "))) T)) (P (
VGETBASE (VVAG2 6 0) 6)) (G (VGETBASE (VVAG2 6 0) 5)) (K (VGETBASE (VVAG2 6 0) 3)) (H (VGETBASE (VVAG2
6 0) 4)) (S (VGETBASE (VVAG2 6 0) 2)) (R (VGETBASE (VVAG2 6 0) 1)) (M (VGETBASE (VVAG2 6 0) 14)) (
COND ((AND (ILESSP (SETQ FRAME (VREADOCT)) 256) (ILESSP (VGETBASE (VVAG2 6 0) FRAME) (VGETBASE (VVAG2
6 0) 7)) (IEQ (LRSH (VGETBASE (VVAG2 1 (PROGN (PROGN (VGETBASE (VVAG2 6 0) FRAME)))) 0) 13) 6)) (
VGETBASE (VVAG2 6 0) FRAME)) ((IEQ (LRSH (VGETBASE (VVAG2 1 FRAME) 0) 13) 6) FRAME) (T (PRINTNUM .I7
FRAME) (printout T " not a valid frame." T) (RETURN))))))) (FRESHLINE T) (V\BACKTRACE ROOTFRAME NIL T
NIL NIL NIL ALINKS? (FUNCTION VPRINCOPY) 1 RAIDIX))))
(VRAIDROOTFRAME
(LAMBDA NIL (*) (SETQ ROOTFRAME (PROG1 (COND ((LISTP VMEMFILE) (PRIN1 "in TeleRaid Context" T) (
VGETBASE (VVAG2 6 0) 24)) (T (VGETBASE (VVAG2 6 0) 0))) (TERPRI T)))))
(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 ((EVENP
(VLOLOC NB) 8) (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 .I2 (VLOLOC X)) (PRIN1 "}"
)))
(VREADVA
(LAMBDA NIL (*) (VVAG2 (VREADOCT) (VREADOCT))))
(VREADOCT
(LAMBDA (PROMPT) (*) (DECLARE (USEDFREE RAIDIX)) (COND ((AND PROMPT (NOT (READP T))) (printout T
PROMPT))) (bind STR while (EQUAL (SETQ STR (RSTRING T T)) "") do (READC T) finally (RETURN (PROG1 (OR
(FIXP (SELECTQ RAIDIX (8 (MKATOM (CONCAT STR "Q"))) (16 (bind (N ← 0) CHAR while (SETQ CHAR (GNC STR))
do (SETQ N (IPLUS (ITIMES N 16) (COND ((FIXP CHAR) CHAR) ((AND (IGEQ (SETQ CHAR (CHCON1 CHAR)) (
CHARCODE A)) (ILEQ CHAR (CHARCODE F))) (IPLUS (IDIFFERENCE CHAR (CHARCODE A)) 10)) (T (ERROR CHAR (
QUOTE ?) T))))) finally (RETURN N))) (SHOULDNT))) (PROGN (PRIN1 "?" T) (ERROR!))) (READC T))))))
(VREADATOM
(LAMBDA NIL (*) (PROG1 (READ T T) (READC T))))
(VSHOWSTACKBLOCKS
(LAMBDA (SCANPTR WAITFLG) (*) (*) (PROG ((EASP (VGETBASE (VVAG2 6 0) 7))) SCAN (SELECTC (LRSH (
VGETBASE (VVAG2 1 SCANPTR) 0) 13) (5 (VSHOWSTACKBLOCK1 SCANPTR "free block" (IEQ (VGETBASE (VVAG2 1
SCANPTR) 0) 40960)) (SETQ SCANPTR (PLUS SCANPTR (VGETBASE (VVAG2 1 SCANPTR) 1)))) (7 (VSHOWSTACKBLOCK1
SCANPTR "guard block" T) (SETQ SCANPTR (PLUS SCANPTR (VGETBASE (VVAG2 1 SCANPTR) 1)))) (6 (*) (
VSHOWSTACKBLOCK1 SCANPTR "Frame extn = " (AND (IEQ (LRSH (VGETBASE (VVAG2 1 SCANPTR) 0) 13) 6) (OR (
IEQ (IDIFFERENCE SCANPTR 2) (COND ((NOT (NEQ 0 (LOGAND (VGETBASE (VVAG2 1 SCANPTR) 1) 1))) (
IDIFFERENCE SCANPTR 2)) (T (VGETBASE (VVAG2 1 SCANPTR) 8)))) (AND (NEQ 0 (LOGAND (LRSH (VGETBASE (
VVAG2 1 (PROGN (IDIFFERENCE SCANPTR 2))) 0) 9) 1)) (IEQ (VGETBASE (VVAG2 1 (PROGN (IDIFFERENCE SCANPTR
2))) 1) (VGETBASE (VVAG2 1 (PROGN (COND ((NOT (NEQ 0 (LOGAND (VGETBASE (VVAG2 1 SCANPTR) 1) 1))) (
IDIFFERENCE SCANPTR 2)) (T (VGETBASE (VVAG2 1 SCANPTR) 8))))) 1)))))) (PRIN2 (V\UNCOPY (VGETBASEPTR (
PROGN (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE (VVAG2 1 SCANPTR) 0) 9) 1)) (VVAG2 (LOGAND (VGETBASE (
VVAG2 1 SCANPTR) 7) 255) (VGETBASE (VVAG2 1 SCANPTR) 6))) (T (VVAG2 (LOGAND (VGETBASE (VVAG2 1 SCANPTR
) 3) 255) (VGETBASE (VVAG2 1 SCANPTR) 2))))) 4))) (SETQ SCANPTR (VGETBASE (VVAG2 1 SCANPTR) 4))) (PROG
((ORIG SCANPTR) IVAR) (*) (while (EQ (LRSH (VGETBASE (VVAG2 1 SCANPTR) 0) 13) 0) do (SETQ SCANPTR (
PLUS SCANPTR 2))) (COND ((NOT (IEQ (LRSH (VGETBASE (VVAG2 1 SCANPTR) 0) 13) 4)) (VSHOWSTACKBLOCK1 ORIG
"Garbage" T)) (T (SETQ IVAR (VGETBASE (VVAG2 1 SCANPTR) 1)) (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE (
VVAG2 1 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 1 SCANPTR) 0) 13) 4) (for I from (VGETBASE (VVAG2 1 SCANPTR) 1) to (
IDIFFERENCE SCANPTR 2) by 2 always (IEQ 0 (LRSH (VGETBASE (VVAG2 1 I) 0) 13)))))))) (SETQ SCANPTR (
PLUS 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))))
(VNOSUCHATOM
(LAMBDA (ATM) (*) (*) (printout T "No such atom: " ATM T) (ERROR!)))
)
(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 (PLUS CNT 1)))) (SETQ NAME (
VGETBASEPTR (PROGN (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE (VVAG2 1 IPOS) 0) 9) 1)) (VVAG2 (LOGAND (
VGETBASE (VVAG2 1 IPOS) 7) 255) (VGETBASE (VVAG2 1 IPOS) 6))) (T (VVAG2 (LOGAND (VGETBASE (VVAG2 1
IPOS) 3) 255) (VGETBASE (VVAG2 1 IPOS) 2))))) 4)) (COND (JUNK (TERPRI) (TERPRI) (PRIN1
"Basic frame at ") (PRINTNUM .I7 (SETQ BLINK (COND ((NOT (NEQ 0 (LOGAND (VGETBASE (VVAG2 1 IPOS) 1) 1)
)) (IDIFFERENCE IPOS 2)) (T (VGETBASE (VVAG2 1 IPOS) 8))))) (TERPRI) (V\PRINTBF BLINK (COND ((NEQ 0 (
LOGAND (LRSH (VGETBASE (VVAG2 1 IPOS) 0) 9) 1)) (VVAG2 (LOGAND (VGETBASE (VVAG2 1 IPOS) 7) 255) (
VGETBASE (VVAG2 1 IPOS) 6))) (T (VVAG2 (LOGAND (VGETBASE (VVAG2 1 IPOS) 3) 255) (VGETBASE (VVAG2 1
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 ((NOT (NEQ 0 (LOGAND (VGETBASE (VVAG2 1 IPOS) 1) 1))) (IDIFFERENCE IPOS 2)) (T (VGETBASE (VVAG2 1
IPOS) 8))) (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE (VVAG2 1 IPOS) 0) 9) 1)) (VVAG2 (LOGAND (VGETBASE (
VVAG2 1 IPOS) 7) 255) (VGETBASE (VVAG2 1 IPOS) 6))) (T (VVAG2 (LOGAND (VGETBASE (VVAG2 1 IPOS) 3) 255)
(VGETBASE (VVAG2 1 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 (EQ (PROGN (SETQ IPOS (COND (ALINKS (
IDIFFERENCE (LOGAND (VGETBASE (VVAG2 1 IPOS) 1) (CONSTANT (LOGXOR (SUB1 2) -1))) 10)) (T (IDIFFERENCE
(COND ((NOT (NEQ 0 (LOGAND (VGETBASE (VVAG2 1 IPOS) 1) 1))) (VGETBASE (VVAG2 1 IPOS) 1)) (T (VGETBASE
(VVAG2 1 IPOS) 9))) 10))))) 0))) (GO POSLP))) (RETURN T))))
(V\PRINTBF
(LAMBDA (BL NMT PRINTFN VARSONLY) (*) (bind NM for I from (VGETBASE (VVAG2 1 BL) 1) by 2 as J from 0
to (SUB1 (IDIFFERENCE (LRSH (IDIFFERENCE BL (VGETBASE (VVAG2 1 BL) 1)) 1) (LOGAND (LRSH (VGETBASE (
VVAG2 1 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 1 0) I)))) finally (OR
VARSONLY (while (ILESSP I BL) do (V\PRINTSTK I) (printout NIL "[padding]" T) (SETQ I (PLUS I 2))))) (
COND ((NOT VARSONLY) (V\PRINTSTK BL) (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE (VVAG2 1 BL) 0) 9) 1)) (
PRIN1 "residual "))) (COND ((NEQ (LOGAND (VGETBASE (VVAG2 1 BL) 0) 255) 0) (printout NIL "usecnt= " (
LOGAND (VGETBASE (VVAG2 1 BL) 0) 255) ,))) (TERPRI)))))
(V\PRINTFRAME
(LAMBDA (FRAME PRINTFN VARSONLY) (*) (PROG ((NMT (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE (VVAG2 1 FRAME)
0) 9) 1)) (VVAG2 (LOGAND (VGETBASE (VVAG2 1 FRAME) 7) 255) (VGETBASE (VVAG2 1 FRAME) 6))) (T (VVAG2 (
LOGAND (VGETBASE (VVAG2 1 FRAME) 3) 255) (VGETBASE (VVAG2 1 FRAME) 2))))) (I 0) (FT (IPLUS (IPLUS
FRAME (PROGN 10)) (LLSH (ADD1 (SIGNED (VGETBASE (PROGN (VVAG2 (LOGAND (VGETBASE (VVAG2 1 FRAME) 3) 255
) (VGETBASE (VVAG2 1 FRAME) 2))) 2) 16)) 2) (PROGN 4))) TMP NLOCALS) (COND ((NOT VARSONLY) (V\PRINTSTK
FRAME) (PRIN1 "[") (PROGN (PROG ((FAST (NEQ 0 (LOGAND (LRSH (VGETBASE (VVAG2 1 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 (NEQ 0 (LOGAND (LRSH (VGETBASE (VVAG2 1
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
(NEQ 0 (LOGAND (LRSH (VGETBASE (VVAG2 1 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 (NEQ 0 (LOGAND (LRSH (VGETBASE (VVAG2 1 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 1
FRAME) 0) 255))) (DECLARE (LOCALVARS USECNT)) (COND ((NEQ USECNT 0) (PRIN1 (QUOTE "USE=")) (SELECTQ (
CONSTANT (NTHCHAR (QUOTE "USE=") -1)) (= (printout NIL , USECNT ", ")) NIL) T))) (PROG ((SLOWP (NEQ 0
(LOGAND (VGETBASE (VVAG2 1 FRAME) 1) 1)))) (DECLARE (LOCALVARS SLOWP)) (COND (SLOWP (PRIN1 (QUOTE
"X, ")) (SELECTQ (CONSTANT (NTHCHAR (QUOTE "X, ") -1)) (= (printout NIL , SLOWP NIL)) NIL) T))) (PROG
((ALINK (IDIFFERENCE (LOGAND (VGETBASE (VVAG2 1 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 1 FRAME) 3) 255) (VGETBASE (VVAG2 1 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 1 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 ((NEQ 0 (LOGAND (LRSH (VGETBASE (VVAG2 1 FRAME) 0) 9) 1)) (VVAG2 (LOGAND (VGETBASE (
VVAG2 1 FRAME) 7) 255) (VGETBASE (VVAG2 1 FRAME) 6))) (T (VVAG2 (LOGAND (VGETBASE (VVAG2 1 FRAME) 3)
255) (VGETBASE (VVAG2 1 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 ((NOT (NEQ 0
(LOGAND (VGETBASE (VVAG2 1 FRAME) 1) 1))) (IDIFFERENCE FRAME 2)) (T (VGETBASE (VVAG2 1 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 ((EQ (LRSH (VGETBASE (PROGN
(VVAG2 1 I)) 0) 8) 0) (AND VARSONLY (SPACES 3)) (PRIN2 TMP) (SPACES 1) (APPLY* PRINTFN (VGETBASEPTR (
VVAG2 1 I) 0))) ((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 1 I)) 0)) (COND ((EQ (SETQ TMP (VHILOC ((LAMBDA ($$1) (VVAG2 (LRSH (VGETBASE (PROGN $$1
) 1) 8) (VGETBASE $$1 0))) (VVAG2 1 I)))) 1) " on stack]") ((NEQ (LOGAND TMP (CONSTANT (LOGXOR (SUB1 2
) -1))) (VHILOC (VVAG2 12 0))) (*) " non-stack binding]") (T " top value]"))) (T " not looked up]")) T
)) (T (printout NIL "[padding]" T)))))) (COND ((NOT VARSONLY) (SETQ FT (VGETBASE (VVAG2 1 FRAME) 4)) (
for old I by 2 while (ILESSP I FT) do (*) (V\PRINTSTK I) (COND ((EQ (LRSH (VGETBASE (PROGN (VVAG2 1 I)
) 0) 8) 0) (APPLY* PRINTFN (VGETBASEPTR (VVAG2 1 I) 0))) (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 ((EQ (SETQ NM (VGETBASE NMT NT1)) 0) (RETURN))) (COND ((IEQ NTENTRY (VGETBASE NMT NT2)) (
RETURN (VATOM NM)))))))
(V\PRINTSTK
(LAMBDA (I) (*) (PRINTNUM .I7 I) (PRIN1 ": ") (PRINTNUM .I7 (VGETBASE (VVAG2 1 0) I)) (PRINTNUM .I7 (
VGETBASE (VVAG2 1 0) (ADD1 I))) (SPACES 1)))
)
(DEFINEQ
(V\CHECKARRAYBLOCK
(LAMBDA (BASE FREE ONFREELIST) (*) (COND (T (PROG (ERROR TRAILER) (COND ((NEQ (LRSH (VGETBASE BASE 0)
3) 5461) (SETQ ERROR "ARRAYBLOCK Password wrong")) ((NEQ (NEQ 0 (LOGAND (VGETBASE BASE 0) 1)) (NOT
FREE)) (SETQ ERROR "ARRAYBLOCK INUSE bit set wrong")) (NIL (SETQ ERROR
"Free ARRAYBLOCK with RefCnt not 1")) ((NEQ (LRSH (VGETBASE (SETQ TRAILER ((LAMBDA (BASE N) (DECLARE (
LOCALVARS BASE N)) (VADDBASE (VADDBASE BASE N) N)) BASE (IDIFFERENCE (VGETBASE BASE 1) 1))) 0) 3) 5461
) (SETQ ERROR "ARRAYBLOCK Trailer password wrong")) ((NEQ (VGETBASE BASE 1) (VGETBASE TRAILER 1)) (
SETQ ERROR "ARRAYBLOCK Header and Trailer length don't match")) ((NEQ (NEQ 0 (LOGAND (VGETBASE BASE 0)
1)) (NOT FREE)) (SETQ ERROR "ARRAYBLOCK Trailer INUSE bit set wrong")) ((OR (NOT ONFREELIST) (ILESSP
(VGETBASE BASE 1) 4)) (*) (RETURN)) ((OR (NOT (EQUAL (VGETBASEPTR (VGETBASEPTR BASE 4) 2) BASE)) (NOT
(EQUAL (VGETBASEPTR (VGETBASEPTR BASE 2) 4) BASE))) (SETQ ERROR "ARRAYBLOCK links fouled")) ((bind (
FBL ← ((LAMBDA (BASE N) (DECLARE (LOCALVARS BASE N)) (VADDBASE (VADDBASE BASE N) N)) VFREEBLOCKBUCKETS
(IMIN (INTEGERLENGTH (VGETBASE BASE 1)) 30))) ROVER first (OR (SETQ ROVER (VGETBASEPTR FBL 0)) (
RETURN (SETQ ERROR "Free block's bucket empty"))) do (AND (EQUAL ROVER BASE) (RETURN)) (
V\CHECKARRAYBLOCK ROVER T) repeatuntil (EQ (SETQ ROVER (VGETBASEPTR ROVER 2)) (VGETBASEPTR FBL 0)))) (
T (*) (RETURN))) (ERROR BASE ERROR) (RETURN ERROR))))))
(V\PARSEARRAYSPACE
(LAMBDA (FN) (*) (COND ((NEQ 0 (VGETBASE (VVAG2 6 0) 65)) (*) (V\PARSEARRAYSPACE1 FN (VVAG2 19 0)
VArrayFrLst2) (V\PARSEARRAYSPACE1 FN (VVAG2 64 0) VArrayFrLst)) (T (V\PARSEARRAYSPACE1 FN (VVAG2 19 0)
VArrayFrLst)))))
(V\PARSEARRAYSPACE1
(LAMBDA (FN START END) (*) (for (ROVER ← START) repeatuntil (EQUAL END (SETQ ROVER ((LAMBDA (BASE N) (
DECLARE (LOCALVARS BASE N)) (VADDBASE (VADDBASE BASE N) N)) ROVER (VGETBASE ROVER 1)))) do (
V\CHECKARRAYBLOCK ROVER (NOT (NEQ 0 (LOGAND (VGETBASE ROVER 0) 1))) (AND (NOT (NEQ 0 (LOGAND (VGETBASE
ROVER 0) 1))) (VGETBASEPTR ROVER 2))) (AND FN (APPLY* FN ROVER (VGETBASE ROVER 1) (NEQ 0 (LOGAND (
VGETBASE ROVER 0) 1)) (LOGAND (LRSH (VGETBASE ROVER 0) 1) 3))))))
)
(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 ((EQ NTSIZE 0) (*) 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 (\FINDOP (VGETBASEBYTE CA
(PROG1 CODELOC (SETQ CODELOC (PLUS 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))) (if (LISTP LEVADJ) then (SETQ LEVADJ (CAR LEVADJ))) (SELECTQ LEVADJ (
FNX (SETQ LEVEL (PLUS LEVEL (IDIFFERENCE 1 (VGETBASEBYTE CA CODELOC))))) (POP.N (SETQ LEVEL (
IDIFFERENCE LEVEL (VGETBASEBYTE CA CODELOC)))) (JUMP (SETQ LEVEL)) ((CJUMP NCJUMP) (SETQ LEVEL (PLUS
LEVEL -1))) (COND ((NUMBERP LEVADJ) (SETQ LEVEL (PLUS LEVEL LEVADJ))))))) (add CODELOC (fetch OPNARGS
of TAG)) (GO LP))) (SETQ LEN (fetch OPNARGS of (SETQ TAG (\FINDOP (SETQ B (VGETBASEBYTE CA (PROG1
CODELOC (SETQ CODELOC (PLUS CODELOC 1))))))))) (PRINTNUM I4 B OUTF) (COND ((IGREATERP LEN 0) (PRINTNUM
I4 (SETQ B1 (VGETBASEBYTE CA (PROG1 CODELOC (SETQ CODELOC (PLUS CODELOC 1))))) OUTF))) (COND ((
IGREATERP LEN 1) (PRINTNUM I4 (SETQ B2 (VGETBASEBYTE CA (PROG1 CODELOC (SETQ CODELOC (PLUS CODELOC 1))
))) OUTF))) (AND (IGREATERP LEN 2) (PRINTNUM I4 (SETQ B3 (VGETBASEBYTE CA (PROG1 CODELOC (SETQ CODELOC
(PLUS CODELOC 1))))) OUTF)) (PROGN (printout OUTF 30 (fetch OPCODENAME of TAG)) (SETQ OP# (fetch OP#
of TAG)) (SETQ LEVADJ (fetch LEVADJ of TAG))) (if (LISTP OP#) then (SETQ OP# (CAR OP#))) (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 (PLUS LEVEL (IDIFFERENCE 1 B1)))) (POP.N (SETQ LEVEL (IDIFFERENCE LEVEL B1))) (JUMP (SETQ LEVEL)
) ((CJUMP NCJUMP) (SETQ LEVEL (PLUS LEVEL -1))) (COND ((NUMBERP LEVADJ) (SETQ LEVEL (PLUS 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
(DEFA0005) (DECLARE (LOCALVARS DEFA0005)) (LOGOR (LLSH (VGETBASEBYTE DEFA0005 6) 8) (VGETBASEBYTE
DEFA0005 (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 (
\FINDOP (QUOTE 'NIL)))) (VPUTBASEBYTE NEWCA (ADD1 FB) (V\CAR.UFN (\FINDOP (QUOTE HELP)))) (
VPUTBASEBYTE NEWCA (IPLUS FB 2) (V\CAR.UFN (\FINDOP (QUOTE POP)))))) (do (SETQ OP (VGETBASEBYTE CA FB)
) (SETQ TAG (\FINDOP OP)) (VPUTBASEBYTE NEWCA (IPLUS FB OFFSET) (SELECTQ (CADR TAG) (-X- (RETURN)) (
RETURN (COND (AFTER (V\CAR.UFN (\FINDOP (QUOTE \RETURN)))) (T OP))) OP)) (FRPTQ (CADDR TAG) (
VPUTBASEBYTE NEWCA (IPLUS (SETQ FB (PLUS FB 1)) OFFSET) (VGETBASEBYTE CA FB))) (SETQ FB (PLUS 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) (*) (*) (*) (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 T (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) (*) (*) (*) (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 T ((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) (*) (SELECTC (VNTYPX X) (1 (COND ((EQ (VHILOC X) 14) (*) (VLOLOC X)) (T (IPLUS (VLOLOC X)
-65536)))) (2 (*) (IPLUS (LLSH (VGETBASE X 0) 16) (VGETBASE X 1))) (4 (VATOM (VLOLOC X))) (7 (PROG ((
PTR (VGETBASEPTR X 0)) (OFFST (VGETBASE X 3)) (LENGTH (VGETBASE X 2)) (I 1) STR) (*) (SETQ STR (
ALLOCSTRING LENGTH)) (FRPTQ LENGTH (RPLSTRING STR I (FCHARACTER (V\GETBASEBYTE PTR OFFST))) (SETQ I (
PLUS I 1)) (SETQ OFFST (PLUS OFFST 1))) (RETURN STR))) (5 (COND ((VLISTP X) (CONS (V\UNCOPY (V\CAR.UFN
X)) (V\UNCOPY (V\CDR.UFN X)))) (T (*) (VTYPEDPOINTER (QUOTE LISTP) X)))) (0 (VTYPEDPOINTER NIL X)) (
VTYPEDPOINTER (VTYPENAME X) X))))
)
(DEFINEQ
(V\GETBASEBYTE
(LAMBDA (PTR N) (*) (*) (COND ((EVENP N) (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 6 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 6 4096) (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 (VADDBASE (VADDBASE (VVAG2 8 0) N) N) 0)) (STR (OR
COPYATOMSTR (SETQ COPYATOMSTR (ALLOCSTRING 255)))) LEN) (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 FATP) (*) (PROG (HASH HASHENT ATM# PNBASE FIRSTCHAR FIRSTBYTE REPROBE (
FATCHARSEENP (AND FATP (NOT (NULL (for I from OFFST to (SUB1 (IPLUS OFFST LEN)) suchthat (IGREATERP (
VGETBASE BASE I) 255))))))) (*) (COND ((EQ LEN 0) (*) (SETQ HASH 0) (SETQ FIRSTBYTE 255) (GO LP))) (
SETQ FIRSTCHAR (NTHCHARCODE BASE OFFST)) (*) NIL (*) (SETQ FIRSTBYTE (LOGAND FIRSTCHAR 255)) (*) (
PROGN (*) (SETQ HASH (LLSH FIRSTBYTE 8)) (for CHAR# from (ADD1 OFFST) to (SUB1 (IPLUS OFFST LEN)) do (
SETQ HASH (IPLUS16 (IPLUS16 (SETQ HASH (IPLUS16 HASH (LLSH (LOGAND HASH 4095) 2))) (LLSH (LOGAND HASH
255) 8)) (NTHCHARCODE BASE CHAR#))))) (*) LP (*) (COND ((NEQ 0 (SETQ HASHENT (VGETBASE (VVAG2 7 0)
HASH))) (*) (COND ((EQ (VATOM (SETQ ATM# (SUB1 HASHENT))) BASE) (RETURN (VADDBASE (VVAG2 0 0) ATM#)))
(T (*) (SETQ HASH (IPLUS16 HASH (OR REPROBE (SETQ REPROBE (LOGAND 63 (LOGOR 1 (LOGXOR FIRSTBYTE HASH))
))))) (GO LP))))) (*) (RETURN (VNOSUCHATOM BASE OFFST LEN HASH FATP FATCHARSEENP)))))
(VGETTOPVAL
(LAMBDA (X) (*) (VGETBASEPTR (V\ATOMCELL X 12) 0)))
(VGETPROPLIST
(LAMBDA (ATM) (*) (VGETBASEPTR (V\ATOMCELL ATM 2) 0)))
(VSETTOPVAL
(LAMBDA (ATM VAL) (*) (SELECTQ ATM (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 (V\ATOMCELL ATM 12) 0 (V\COPY VAL))
)))
(VGETDEFN
(LAMBDA (A) (*) (VGETBASEPTR (V\ATOMCELL A 10) 0)))
(V\ATOMCELL
(LAMBDA (X N) (*) (LET ((LOC (SELECTC N (10 (VATOMNUMBER X)) (12 (VATOMNUMBER X)) (2 (VATOMNUMBER X))
(8 (\ATOMPNAMEINDEX X)) (SHOULDNT)))) (VADDBASE (VVAG2 N LOC) LOC))))
)
(DEFINEQ
(VLISTP
(LAMBDA (X) (*) (*) (AND (EQ (VNTYPX X) 5) (COND ((EQ 1 0) T) (T (*) (NEQ (LOGAND (VLOLOC X) 255) 0)))
X)))
)
(RPAQQ COPYATOMSTR NIL)
(FILESLOAD VMEM)
(RPAQQ RDVALS ((\RPTSIZE) (\ArrayFrLst2) (\ArrayFrLst) (\AtomFrLst)))
(RPAQQ RDPTRS ((\REALPAGETABLE) (\FREEBLOCKBUCKETS)))
(DECLARE: EVAL@COMPILE DONTCOPY
(FILESLOAD (LOADCOMP) VMEM)
)
STOP