From 3156b7c1f4bf927a3e4a7718a0e056ffcaf663a4 Mon Sep 17 00:00:00 2001 From: Larry Masinter Date: Tue, 9 Mar 2021 19:01:26 -0800 Subject: [PATCH 1/2] Save RDSYS for reading sysouts. Made by loadup-init --- library/RDSYS | 322 +---------------------------------------- library/RDSYS.LCOM | Bin 43052 -> 43454 bytes scripts/release-all.sh | 2 +- 3 files changed, 2 insertions(+), 322 deletions(-) diff --git a/library/RDSYS b/library/RDSYS index 68737d31..34077f89 100644 --- a/library/RDSYS +++ b/library/RDSYS @@ -1,321 +1 @@ -(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") -(FILECREATED "20-Dec-98 14:54:54" |{DSK}disk3>lispcore3.0>library>RDSYS.;17| 56574 ) - - -(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\\STKNAME V\\PRINTBF V\\PRINTFRAME V\\SCANFORNTENTRY V\\PRINTSTK) (FNS V\\CHECKARRAYBLOCK V\\PARSEARRAYSPACE V\\PARSEARRAYSPACE1) (FNS VPRINTCODE VPRINTCODENT VBROKENDEF) (FNS V\\CAR.UFN V\\CDR.UFN) (FNS V\\COPY V\\UNCOPY) (FNS V\\GETBASEBYTE V\\PUTBASEBYTE) (FNS VNTYPX VTYPENAME V\\TYPENAMEFROMNUMBER) (FNS VUNCOPYATOM VMAKE.LOCAL.ATOM VSYMBOL.VALUE VSYMBOL.PNAME VSYMBOL.PACKAGE VOLD.FIND.SYMBOL VLOOKUP-SYMBOL VFIND.PACKAGE VFIND.SYMBOL VPACKAGE.NAME V\\MKATOM VGETTOPVAL VGETPROPLIST VSETTOPVAL VGETDEFN V\\ATOMCELL) (FNS VLISTP) (VARS (COPYATOMSTR)) (FNS V\\GET-COMPILED-CODE-BASE) (* |;;| "YOU MUST REMAKE THIS FILE using (DORENAME 'R) (after CONNing to library) whenever the SYSOUT layout changes in LLPARAMS (e.g., if MDSTypeTable moves)") (FILES VMEM) (VARS RDVALS RDPTRS) (DECLARE\: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) VMEM))) -) -(DEFINEQ - -(VREADPAGEMAP -(LAMBDA NIL (*) (*) (PROG (D) (MAPVMPAGE (IPLUS (LLSH (VHILOC (VVAG2 20 0)) 8) (LRSH (VLOLOC (VVAG2 20 0)) 8)) 1) (*) (*) (MAPVMPAGE (IPLUS (LLSH (VHILOC (VVAG2 5 0)) 8) (LRSH (VLOLOC (VVAG2 5 0)) 8)) (SUB1 (VGETBASE (VVAG2 20 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 20 0) 23)) |do| (*) (MAPVMPAGE (IPLUS (IPLUS (LLSH (VHILOC (VVAG2 20 512)) 8) (LRSH (VLOLOC (VVAG2 20 512)) 8)) J) FP)) (|for| I |from| 0 |to| (SUB1 (LLSH 8 8)) |do| (COND ((IEQ (SETQ D (VGETBASE (VVAG2 20 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 20 0) 15))) (|printout| T "Warning: " "Interface page key" "= " (PROGN 5603) ", but \\InterfacePage says " (VGETBASE (VVAG2 20 0) 15) T)))) -) - -(V\\LOCKEDPAGEP -(LAMBDA (VP TEMP) (*) (*) (OR (NEQ 0 (LOGAND (LLSH 1 (IMOD VP 16)) (VGETBASE (VADDBASE (VVAG2 20 28672) (LRSH VP 4)) 0))) NIL)) -) - -(V\\LOOKUPPAGEMAP -(LAMBDA (VP) (*) (*) (LET ((PRIMENTRY (VGETBASE (VVAG2 20 512) (LRSH VP 5)))) (COND ((EQ PRIMENTRY 65535) 0) (T (VGETBASE (VVAG2 5 0) (IPLUS PRIMENTRY (LOGAND VP 31))))))) -) - -(VCHECKPAGEMAP -(LAMBDA NIL (*) (LET ((*PRINT-BASE* 8) (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 (VADDBASE VREALPAGETABLE (LLSH RPTINDEX 1)) 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 (\\GETBASEFIXP (SETQ FPBASE (VADDBASE (VVAG2 2 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 (\\GETBASEFIXP 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 20 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 (VADDBASE VREALPAGETABLE (LLSH RP 1)) 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| (\\GETBASEFIXP (VVAG2 20 0) 82) |as| (FPBASE _ (VADDBASE (VVAG2 2 0) 1)) |by| (VADDBASE FPBASE 1) |when| (NEQ (VGETBASE FPBASE 0) 65535) |do| (VCHECKFPTOVP1 FP (\\GETBASEFIXP 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) (*) (PROG ((*PRINT-BASE* 8) (OUTSTREAM (GETSTREAM FILE (QUOTE OUTPUT))) (RPTR VREALPAGETABLE) (RP 0) FLAGS VP STATE FIRSTONE LASTONE) (|printout| OUTSTREAM " 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 (VADDBASE VREALPAGETABLE (LLSH RP 1)) RP)) (SETQ VP (VGETBASE RPTR 1)) (COND ((AND (NULL MODE) (EQ VP STATE)) (SETQ LASTONE RP)) (T (COND (LASTONE (|printout| OUTSTREAM "ditto thru " LASTONE T) (SETQ LASTONE NIL))) (SETQ FIRSTONE RP) (SETQ STATE VP) (|printout| OUTSTREAM .I7.8 (RPFROMRPT RP)) (COND ((EQ (VGETBASE RPTR 1) 65534) (PRIN1 " Empty" OUTSTREAM)) ((NOT (ILESSP (VGETBASE RPTR 1) 65534)) (PRIN1 " Unavailable" OUTSTREAM)) (T (|printout| OUTSTREAM .I8.8 VP \,) (\\PRINTVP VP OUTSTREAM) (|printout| OUTSTREAM 28 .I6.8 (VGETBASE RPTR 2) |,,|) (COND ((NEQ 0 (LRSH (VGETBASE RPTR 0) 15)) (COND ((NOT (V\\LOCKEDPAGEP VP)) (*) (PRIN1 "Temp" OUTSTREAM))) (PRIN1 "Locked " OUTSTREAM))) NIL)) (TERPRI OUTSTREAM)))))) -) - -(V\\PRINTFPTOVP -(LAMBDA (FIRSTPAGE NWORDS TYPEFLG STREAM VPRAWFLG) (*) (SETQ STREAM (GETSTREAM STREAM (QUOTE OUTPUT))) (OR FIRSTPAGE (SETQ FIRSTPAGE 1)) (OR NWORDS (SETQ NWORDS (\\GETBASEFIXP (VVAG2 20 0) 82))) (LET ((BASE (VADDBASE (VVAG2 2 0) (SUB1 FIRSTPAGE))) (*PRINT-BASE* 8) (LASTVP -2) (NEXTFP (SUB1 FIRSTPAGE)) FIRSTFP FIRSTVP NEXTVP LOCKEDP TYPE NEXTLOCKED NEXTTYPE) (|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)) (|if| TYPEFLG |then| (SETQ NEXTTYPE (VTYPENAME ((LAMBDA ($$1) (VVAG2 (LRSH (SETQ $$1 NEXTVP) 8) (LLSH (LOGAND $$1 255) 8))) NIL))) (|if| (NULL NEXTTYPE) |then| (SETQ NEXTTYPE (SELECTC (LRSH NEXTVP 8) ((LIST 8 (CL:1+ 8)) "Pnames") ((LIST 10 (CL:1+ 10)) "Definitions") ((LIST 12 (CL:1+ 12)) "Value cells") ((LIST 2 (CL:1+ 2)) "Property lists") ((VHILOC (VVAG2 2 0)) "\\FPTOVP") (1 "Stack") ((VHILOC (VVAG2 22 0)) "GC Main table") ((VHILOC (VVAG2 23 0)) "GC Overflow table") NIL)))))) (COND ((COND ((EQ NEXTVP 65535) (NEQ LASTVP 65535)) (T (OR (NEQ NEXTVP (ADD1 LASTVP)) (NEQ NEXTLOCKED LOCKEDP) (NEQ TYPE NEXTTYPE)))) (COND ((IGEQ LASTVP 0) (COND (FIRSTFP (|printout| STREAM FIRSTFP "-"))) (|printout| STREAM (SUB1 NEXTFP) 12) (COND ((EQ LASTVP 65535) (|printout| STREAM "empty")) (T (COND (FIRSTFP (|if| VPRAWFLG |then| (PRIN1 FIRSTVP STREAM) |else| (\\PRINTVP FIRSTVP STREAM)) (PRIN1 "-" STREAM))) (|if| VPRAWFLG |then| (PRIN1 LASTVP STREAM) |else| (\\PRINTVP LASTVP STREAM)) (COND (LOCKEDP (PRIN1 (QUOTE *) STREAM))) (|if| TYPE |then| (|printout| STREAM 32 TYPE)))))) (SETQ FIRSTFP) (TERPRI STREAM) (SETQ FIRSTVP NEXTVP)) (T (*) (OR FIRSTFP (SETQ FIRSTFP (SUB1 NEXTFP))))) (SETQ LASTVP NEXTVP) (SETQ LOCKEDP NEXTLOCKED) (SETQ TYPE NEXTTYPE) (SETQ NWORDS (PLUS NWORDS -1))))) -) -) -(DEFINEQ - -(VRAIDCOMMAND -(LAMBDA NIL (*) (DECLARE (USEDFREE ROOTFRAME ALINKS? RAIDIX FRAME# VPRINTLEVEL)) (FRESHLINE T) (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)) (Z "Zap Print level to: ") (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 (VPRINCOPY (VGETTOPVAL (VREADATOM)))) (P (VPRINCOPY (VGETPROPLIST (VREADATOM)))) (C (VPRINTCODE (VREADATOM) T RAIDIX)) (V (VPRINCOPY (VREADVA))) (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 (PRINTNUM .I2 (VATOMNUMBER (VREADATOM)) 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))) (Z (LET ((A (PROG1 (READ T T) (READC T))) (D (PROG1 (READ T T) (READC T)))) (COND ((AND (FIXP A) (FIXP D)) (SETQ VPRINTLEVEL (CONS A D))) (T (PRINTOUT T "Must be two integers, car level then cdr level" T) (ERROR!))))) (W (VSHOWSTACKBLOCKS (COND ((EQ (PEEKC T) (QUOTE \ -)) (READC T) (VGETBASE (VVAG2 20 0) 30)) (T (VREADOCT))))) (^X (V\\PRINTFRAME (VREADOCT) (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 (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 20 0) 6)) (G (VGETBASE (VVAG2 20 0) 5)) (K (VGETBASE (VVAG2 20 0) 3)) (H (VGETBASE (VVAG2 20 0) 4)) (S (VGETBASE (VVAG2 20 0) 2)) (R (VGETBASE (VVAG2 20 0) 1)) (M (VGETBASE (VVAG2 20 0) 14)) (COND ((AND (ILESSP (SETQ FRAME (VREADOCT)) 256) (ILESSP (VGETBASE (VVAG2 20 0) FRAME) (VGETBASE (VVAG2 20 0) 7)) (IEQ (LRSH (VGETBASE (VVAG2 1 (PROGN (PROGN (VGETBASE (VVAG2 20 0) FRAME)))) 0) 13) 6)) (VGETBASE (VVAG2 20 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 20 0) 24)) (T (VGETBASE (VVAG2 20 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 (HANDLER-BIND ((XCL:MISSING-EXTERNAL-SYMBOL (CL:FUNCTION (LAMBDA (CONDITION) (* |;;| "MAKE AN INTERNAL SYMBOL INSTEAD") (CL:INTERN (XCL:MISSING-EXTERNAL-SYMBOL-NAME CONDITION) (XCL:MISSING-EXTERNAL-SYMBOL-PACKAGE CONDITION))))) (XCL:MISSING-PACKAGE (CL:FUNCTION (LAMBDA (CONDITION) (* |;;| "FAKE A PACKAGE BY THIS NAME AND MAKE THE SYMBOL IN IT") (CL:INTERN (XCL:MISSING-PACKAGE-SYMBOL-NAME CONDITION) (CL:MAKE-PACKAGE (XCL:MISSING-PACKAGE-PACKAGE-NAME CONDITION) :USE NIL)))))) (CL:READ T)) (READC T))) -) - -(VSHOWSTACKBLOCKS -(LAMBDA (SCANPTR WAITFLG) (*) (*) (PROG ((EASP (VGETBASE (VVAG2 20 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)) (VGETBASEPTR (VVAG2 1 SCANPTR) 6)) (T (VGETBASEPTR (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 (CAR VPRINTLEVEL) (CDR VPRINTLEVEL)) T T))) - -(VNOSUCHATOM -(LAMBDA (ATM) (*) (*) (|printout| T "No such atom: " ATM T) (ERROR "No such atom: "))) -) -(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 (V\\STKNAME IPOS)) (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)) (VGETBASEPTR (VVAG2 1 IPOS) 6)) (T (VGETBASEPTR (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)) (VGETBASEPTR (VVAG2 1 IPOS) 6)) (T (VGETBASEPTR (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\\STKNAME -(LAMBDA (POS) (*) (*) (LET ((NAME (VGETBASEPTR (PROGN (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE (VVAG2 1 POS) 0) 9) 1)) (VGETBASEPTR (VVAG2 1 POS) 6)) (T (VGETBASEPTR (VVAG2 1 POS) 2)))) 4))) (|if| (EQ NAME (QUOTE \\INTERPRETER)) |then| (VGETBASEPTR (VVAG2 1 0) (LET ((BFLINK (COND ((NOT (NEQ 0 (LOGAND (VGETBASE (VVAG2 1 POS) 1) 1))) (IDIFFERENCE POS 2)) (T (VGETBASE (VVAG2 1 POS) 8))))) (+ (VGETBASE (VVAG2 1 BFLINK) 1) (TIMES (CL:1- (IDIFFERENCE (LRSH (IDIFFERENCE BFLINK (VGETBASE (VVAG2 1 BFLINK) 1)) 1) (LOGAND (LRSH (VGETBASE (VVAG2 1 BFLINK) 0) 8) 1))) 2)))) |else| NAME))) -) - -(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)))) (MAKE-NTENTRY 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)) (VGETBASEPTR (VVAG2 1 FRAME) 6)) (T (VGETBASEPTR (VVAG2 1 FRAME) 2)))) (I 0) (FT (IPLUS (IPLUS FRAME (PROGN 10)) (LLSH (ADD1 (SIGNED (VGETBASE (PROGN (VGETBASEPTR (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 (VGETBASEPTR (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)) (VGETBASEPTR (VVAG2 1 FRAME) 6)) (T (VGETBASEPTR (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 (MAKE-NTENTRY 32768 J))) (AND (NEQ VARSONLY T) (SETQ TMP "local"))) (COND ((EQ (LRSH (VGETBASE (PROGN (VVAG2 1 I)) 0) 12) 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 (MAKE-NTENTRY 49152 J))) (|printout| NIL "[fvar " .P2 TMP " " (COND ((EVENP (VGETBASE (PROGN (VVAG2 1 I)) 0)) (COND ((EQ (SETQ TMP (VHILOC ((LAMBDA ($$1) (VVAG2 (VGETBASE (PROGN $$1) 1) (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) 12) 0) (APPLY* PRINTFN (VGETBASEPTR (VVAG2 1 I) 0))) (T (TERPRI)))))))) -) - -(V\\SCANFORNTENTRY -(LAMBDA (NMT NTENTRY) (*) (*) (|bind| NM |for| NT1 |from| (PROGN 8) |by| (CONSTANT (PROGN 2)) |as| NT2 |from| (IPLUS (PROGN 8) (VGETBASE NMT 6)) |by| (CONSTANT (WORDSPERNTOFFSETENTRY)) |do| (COND ((NULL-NTENTRY (SETQ NM (GETSTKNAMEENTRY NMT NT1))) (RETURN))) (COND ((IEQP NTENTRY (GETSTKNTOFFSETENTRY 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 |VArrayFrLst2| (VVAG2 64 0)) (*) (V\\PARSEARRAYSPACE1 FN (VVAG2 46 0) |VArrayFrLst2|) (V\\PARSEARRAYSPACE1 FN (VVAG2 64 0) |VArrayFrLst|)) (T (V\\PARSEARRAYSPACE1 FN (VVAG2 46 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 - -(VPRINTCODE -(LAMBDA (FN LVFLG RADIX OUTF FIRSTBYTE PC FN.IS.CODEBASE) (*) (*) (*) (*) (*) (*) (DECLARE (SPECVARS OUTF)) (OR RADIX (SETQ RADIX 8)) (LET ((CODEBASE (COND (FN.IS.CODEBASE FN) (T (OR (V\\GET-COMPILED-CODE-BASE FN) (AND (LITATOM FN) (V\\GET-COMPILED-CODE-BASE (GET FN (QUOTE CODE)))) (ERROR FN "not compiled code"))))) (I4 (NUMFORMATCODE (LIST (QUOTE FIX) 4 RADIX))) (I6 (NUMFORMATCODE (LIST (QUOTE FIX) 6 RADIX))) NTSIZE STARTPC TAG TEMP OP# PVARS FVARS IVARS) (DECLARE (SPECVARS CODEBASE IVARS PVARS FVARS I4 I6)) (*) (LET ((*PRINT-BASE* RADIX)) (|for| I |from| 0 |by| 2 |while| (ILESSP I (LLSH (PROGN 8) 1)) |do| (PRINTNUM I4 I OUTF) (PRIN1 ": " OUTF) (PRINTNUM I6 (LOGOR (LLSH (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1)) (V\\GETBASEBYTE CODEBASE (LOGXOR I 3))) (T (V\\GETBASEBYTE CODEBASE I))) 8) ((LAMBDA (CODEBASE OFFSET) (DECLARE (LOCALVARS CODEBASE OFFSET)) (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1)) (V\\GETBASEBYTE CODEBASE (LOGXOR OFFSET 3))) (T (V\\GETBASEBYTE CODEBASE OFFSET)))) CODEBASE (ADD1 I))) OUTF) (SELECTQ I (0 (PRIN1 " stkmin" OUTF)) (2 (PRIN1 " na" OUTF)) (4 (PRIN1 " pv" OUTF)) (6 (PRIN1 " startpc" OUTF)) (8 (AND (NEQ 0 (LRSH (VGETBASE CODEBASE 4) 15)) (PRIN1 "[CLOSUREP]" OUTF)) (|printout| OUTF " byteswapped: " (NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1))) (|printout| OUTF " argtype: " (LOGAND (LRSH (VGETBASE CODEBASE 4) 12) 3))) (10 (|printout| OUTF " frame name: " .P2 (V\\UNCOPY (VGETBASEPTR CODEBASE 4)))) (12 (PRIN1 " ntsize" OUTF)) (14 (|printout| OUTF " nlocals: " (LRSH (VGETBASE CODEBASE 7) 8)) (|printout| OUTF " fvaroffset: " (LOGAND (VGETBASE CODEBASE 7) 255))) NIL) (*) (TERPRI OUTF))) (SETQ NTSIZE (VGETBASE CODEBASE 6)) (VPRINTCODENT "name table: " (LLSH (PROGN 8) 1) (LLSH NTSIZE 1)) (SETQ STARTPC (VGETBASE CODEBASE 3)) (COND ((GREATERP (SETQ NTSIZE (IDIFFERENCE (COND ((PROGN NIL) (*) (- STARTPC 4)) (T STARTPC)) (SETQ TEMP (IPLUS (LLSH (PROGN 8) 1) (COND ((EQ NTSIZE 0) (*) 8) (T (LLSH NTSIZE 2))))))) 4) (VPRINTCODENT "Local args: " TEMP (LRSH NTSIZE 1))) ((EQ NTSIZE 4) (*) (|printout| OUTF T "Info: " .P2 (VGETBASEPTR CODEBASE (LRSH TEMP 1)) T))) (|printout| OUTF T "----" T) (PROG ((CODELOC STARTPC) (LEVEL (AND LVFLG 0)) B B1 B2 B3 B4 B5 FN LEN LEVADJ STK) (COND (LEVEL (SETUPHASHARRAY (QUOTE \\PRINTCODE.LEVEL)) (SETUPHASHARRAY (QUOTE \\PRINTCODE.STKSTATE)) (CLRHASH \\PRINTCODE.LEVEL) (CLRHASH \\PRINTCODE.STKSTATE))) LP (COND ((AND PC (IGEQ CODELOC PC)) (*) (COND ((NOT (IEQP CODELOC PC)) (PRINTOUT OUTF "(PC ") (PRINTNUM I4 PC OUTF) (PRINTOUT OUTF " not found)"))) (|printout| OUTF "------------------------------" T) (SETQ PC))) (COND ((OR (NULL FIRSTBYTE) (IGEQ CODELOC FIRSTBYTE)) (PRINTNUM I4 CODELOC OUTF) (PRIN1 ": " OUTF) (COND (LVFLG (SETQ TEMP (GETHASH CODELOC \\PRINTCODE.LEVEL)) (COND (LEVEL (COND ((AND TEMP (OR (NEQ LEVEL TEMP) (NOT (EQUAL STK (GETHASH CODELOC \\PRINTCODE.STKSTATE))))) (PRIN1 "*" OUTF)))) (T (SETQ LEVEL TEMP) (SETQ STK (GETHASH CODELOC \\PRINTCODE.STKSTATE)))) (COND (LEVEL (TAB 7 NIL OUTF) (PRINTNUM I4 LEVEL OUTF))))) (TAB 12 NIL OUTF)) (T (*) (SETQ TAG (\\FINDOP ((LAMBDA (CODEBASE OFFSET) (DECLARE (LOCALVARS CODEBASE OFFSET)) (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1)) (V\\GETBASEBYTE CODEBASE (LOGXOR OFFSET 3))) (T (V\\GETBASEBYTE CODEBASE OFFSET)))) CODEBASE (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 (CODEBASELT CODEBASE 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 ((LAMBDA (CODEBASE OFFSET) (DECLARE (LOCALVARS CODEBASE OFFSET)) (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1)) (V\\GETBASEBYTE CODEBASE (LOGXOR OFFSET 3))) (T (V\\GETBASEBYTE CODEBASE OFFSET)))) CODEBASE (ADD1 CODELOC))))))) (MISCN (AND LEVEL (SETQ LEVEL (ADD1 (IDIFFERENCE LEVEL ((LAMBDA (CODEBASE OFFSET) (DECLARE (LOCALVARS CODEBASE OFFSET)) (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1)) (V\\GETBASEBYTE CODEBASE (LOGXOR OFFSET 3))) (T (V\\GETBASEBYTE CODEBASE OFFSET)))) CODEBASE (IPLUS 2 CODELOC))))))) NIL) (COND ((AND LEVEL (SETQ LEVADJ (|fetch| LEVADJ |of| TAG))) (COND ((LISTP LEVADJ) (SETQ LEVADJ (CAR LEVADJ)))) (SELECTQ LEVADJ (FNX (SETQ LEVEL (PLUS LEVEL (IDIFFERENCE 1 (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1)) (V\\GETBASEBYTE CODEBASE (LOGXOR CODELOC 3))) (T (V\\GETBASEBYTE CODEBASE CODELOC))))))) (POP.N (SETQ LEVEL (IDIFFERENCE LEVEL (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1)) (V\\GETBASEBYTE CODEBASE (LOGXOR CODELOC 3))) (T (V\\GETBASEBYTE CODEBASE CODELOC)))))) ((JUMP UNWIND) (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 ((LAMBDA (CODEBASE OFFSET) (DECLARE (LOCALVARS CODEBASE OFFSET)) (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1)) (V\\GETBASEBYTE CODEBASE (LOGXOR OFFSET 3))) (T (V\\GETBASEBYTE CODEBASE OFFSET)))) CODEBASE (PROG1 CODELOC (SETQ CODELOC (PLUS CODELOC 1))))))))) (PRINTNUM I4 B OUTF) (COND ((IGREATERP LEN 0) (PRINTNUM I4 (SETQ B1 ((LAMBDA (CODEBASE OFFSET) (DECLARE (LOCALVARS CODEBASE OFFSET)) (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1)) (V\\GETBASEBYTE CODEBASE (LOGXOR OFFSET 3))) (T (V\\GETBASEBYTE CODEBASE OFFSET)))) CODEBASE (PROG1 CODELOC (SETQ CODELOC (PLUS CODELOC 1))))) OUTF))) (COND ((IGREATERP LEN 1) (PRINTNUM I4 (SETQ B2 ((LAMBDA (CODEBASE OFFSET) (DECLARE (LOCALVARS CODEBASE OFFSET)) (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1)) (V\\GETBASEBYTE CODEBASE (LOGXOR OFFSET 3))) (T (V\\GETBASEBYTE CODEBASE OFFSET)))) CODEBASE (PROG1 CODELOC (SETQ CODELOC (PLUS CODELOC 1))))) OUTF))) (COND ((IGREATERP LEN 2) (PRINTNUM I4 (SETQ B3 ((LAMBDA (CODEBASE OFFSET) (DECLARE (LOCALVARS CODEBASE OFFSET)) (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1)) (V\\GETBASEBYTE CODEBASE (LOGXOR OFFSET 3))) (T (V\\GETBASEBYTE CODEBASE OFFSET)))) CODEBASE (PROG1 CODELOC (SETQ CODELOC (PLUS CODELOC 1))))) OUTF))) (COND ((IGREATERP LEN 3) (PRINTNUM I4 (SETQ B4 ((LAMBDA (CODEBASE OFFSET) (DECLARE (LOCALVARS CODEBASE OFFSET)) (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1)) (V\\GETBASEBYTE CODEBASE (LOGXOR OFFSET 3))) (T (V\\GETBASEBYTE CODEBASE OFFSET)))) CODEBASE (PROG1 CODELOC (SETQ CODELOC (PLUS CODELOC 1))))) OUTF))) (COND ((IGREATERP LEN 4) (PRINTNUM I4 (SETQ B5 ((LAMBDA (CODEBASE OFFSET) (DECLARE (LOCALVARS CODEBASE OFFSET)) (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1)) (V\\GETBASEBYTE CODEBASE (LOGXOR OFFSET 3))) (T (V\\GETBASEBYTE CODEBASE OFFSET)))) CODEBASE (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))) (COND ((LISTP OP#) (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)) \\PRINTCODE.LEVEL) (PUTHASH N STK \\PRINTCODE.STKSTATE)))) (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)) \\PRINTCODE.LEVEL) (PUTHASH N STK \\PRINTCODE.STKSTATE)))) (COND ((IGEQ B1 128) (IDIFFERENCE B1 256)) (T B1)))) (FN (*) (NEW-SYMBOL-CODE (BIG-VMEM-HOST (SETQ B (IPLUS (LLSH (IPLUS (LLSH (IPLUS (LLSH B1 8) B2) 8) B3) 8) B4)) (SETQ B (IPLUS (LLSH (IPLUS (LLSH B1 8) B2) 8) B3))) (SETQ B (IPLUS (LLSH B1 8) B2))) (|printout| OUTF 40 .P2 (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)) \\PRINTCODE.LEVEL) (PUTHASH N STK \\PRINTCODE.STKSTATE)))) (IPLUS (LLSH B1 8) B2 (COND ((IGREATERP B1 127) -65536) (T 0))))) (ATOM (|printout| OUTF 40 .P2 (VATOM (NEW-SYMBOL-CODE (BIG-VMEM-HOST (IPLUS (LLSH (IPLUS (LLSH (IPLUS (LLSH B1 8) B2) 8) B3) 8) B4) (IPLUS (LLSH (IPLUS (LLSH B1 8) B2) 8) B3)) (IPLUS (LLSH B1 8) B2))))) (GCONST (|printout| OUTF 40 .P2 (V\\UNCOPY (BIG-VMEM-HOST (VVAG2 (IPLUS (LLSH B1 8) B2) (IPLUS (LLSH B3 8) B4)) (VVAG2 B1 (IPLUS (LLSH B2 8) B3)))))) (FNX (|printout| OUTF "(" B1 ")" 40 .P2 (VATOM (NEW-SYMBOL-CODE (BIG-VMEM-HOST (IPLUS (LLSH (IPLUS (LLSH (IPLUS (LLSH B2 8) B3) 8) B4) 8) B5) (IPLUS (LLSH (IPLUS (LLSH B2 8) B3) 8) B4)) (IPLUS (LLSH B2 8) B3))))) (TYPEP (|printout| OUTF "(" .P2 (OR (V\\TYPENAMEFROMNUMBER B1) (QUOTE ?)) ")")) (UNBIND (AND LEVEL (SETQ LEVEL (|pop| STK)))) (DUNBIND (AND LEVEL (SETQ LEVEL (SUB1 (|pop| STK))))) (RETURN (SETQ LEVEL)) (SUBRCALL (|printout| OUTF 40 (|for| X |in| \\INITSUBRS |when| (EQ B1 (CADR X)) |do| (RETURN (CAR X)) |finally| (RETURN "?"))) (AND LEVEL (SETQ LEVEL (ADD1 (IDIFFERENCE LEVEL B2))))) (MISCN (|printout| OUTF 40 (|for| X |in| \\USER-SUBR-LIST |when| (EQ B1 (CADR X)) |do| (RETURN (CAR X)) |finally| (RETURN "?"))) (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 UNWIND) (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 CODEBASE IVARS PVARS FVARS I4 I6 OUTF)) (*) (*) (LET (NAME TAG) (COND ((ILESSP START1 (SETQ START2 (IPLUS START2 START1))) (|printout| OUTF STR T) (|for| NT1 |from| START1 |by| (LLSH (CONSTANT (PROGN 2)) 1) |while| (ILESSP NT1 START2) |as| NT2 |from| START2 |by| (LLSH (PROGN 2) 1) |do| (PRINTNUM I4 NT1 OUTF) (PRIN1 ": " OUTF) (PRINTNUM I6 (GETNAMEENTRY CODEBASE NT1) OUTF) (SPACES 3 OUTF) (PRINTNUM I4 NT2 OUTF) (PRIN1 ": " OUTF) (PRINTNUM I6 (GETNTOFFSETENTRY CODEBASE NT2) OUTF) (COND ((SETQ NAME (VATOM (CODEBASEGETNAME CODEBASE NT1))) (SETQ TAG (GETNTOFFSET CODEBASE NT2)) (|printout| OUTF .SP 5 (SELECTC (NTSLOT-VARTYPE (GETNTOFFSETENTRY CODEBASE NT2)) (0 (|push| IVARS (LIST TAG NAME)) (QUOTE IVAR)) (32768 (|push| PVARS (LIST TAG NAME)) (QUOTE PVAR)) (PROGN (|push| FVARS (LIST TAG NAME)) (QUOTE FVAR))) " " TAG ": " .P2 NAME))) (TERPRI OUTF)))))) -) - -(VBROKENDEF -(LAMBDA (DEF WHEN) (*) (PROG ((CA (V\\GET-COMPILED-CODE-BASE DEF)) BEFORE AFTER SIZE FIRSTBYTE NEWCA) (SETQ FIRSTBYTE (VGETBASE CA 3)) NIL (*) (PROGN (*) (PROGN (*) (SETQ NEWCA CA) (SETQ AFTER T) (GO DOSCAN)) (COND (AFTER (*) (|bind| OP |do| (SELECTQ (CADR (SETQ OP (\\FINDOP (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE NEWCA 4) 14) 1)) (V\\GETBASEBYTE NEWCA (LOGXOR FIRSTBYTE 3))) (T (V\\GETBASEBYTE NEWCA FIRSTBYTE)))))) (-X- (RETURN)) (GCONST NIL) (RETURN ((LAMBDA (CODEBASE OFFSET NEWVALUE) (DECLARE (LOCALVARS CODEBASE OFFSET NEWVALUE)) (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1)) (V\\PUTBASEBYTE CODEBASE (LOGXOR OFFSET 3) NEWVALUE)) (T (V\\PUTBASEBYTE CODEBASE OFFSET NEWVALUE)))) NEWCA FIRSTBYTE (V\\CAR.UFN (\\FINDOP (QUOTE \\RETURN))))) NIL) (SETQ FIRSTBYTE (PLUS FIRSTBYTE 1 (CADDR OP))))))) (RETURN NEWCA))) -) -) -(DEFINEQ - -(V\\CAR.UFN -(LAMBDA (X) (*) (*) (*) (COND ((VLISTP X) (COND ((ZEROP 1) (VGETBASEPTR X 0)) (T (COND ((EQ (LRSH (VGETBASE X 0) 12) 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) 12))) (RETURN (COND ((EQ Q 8) NIL) ((IGREATERP Q 8) (VADDBASE (VVAG2 (VHILOC X) (LOGAND (VLOLOC X) 65280)) (LLSH (IDIFFERENCE Q 8) 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 NEW-ATOM) (VATOMNUMBER X T)) (VLISTP (PROG ((R (REVERSE X)) (V (V\\COPY (CDR (LAST X))))) LP (COND ((LISTP R) (SETQ V (CONS (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 (CREATECELL 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))) (ONED-ARRAY (%COPY-ONED-ARRAY X)) (STRINGP (*) (%COPY-STRING-TO-ARRAY X)) (FLOATP (PROG ((VAL (CREATECELL 3))) (SELECTQ (SYSTEMTYPE) ((ALTO D) (VPUTBASE VAL 0 (\\GETBASE X 0)) (VPUTBASE VAL 1 (\\GETBASE X 1))) (MKI.IEEE X VAL)) (RETURN VAL))) (CHARACTER (VVAG2 7 (CL:CHAR-CODE X))) (ERROR X "can't be copied to remote file"))) -) - -(V\\UNCOPY -(LAMBDA (X CARLVL CDRLVL) (*) (SELECTC (VNTYPX X) (1 (COND ((EQ (VHILOC X) 14) (*) (VLOLOC X)) (T (IPLUS (VLOLOC X) -65536)))) (2 (*) (|create| FIXP HINUM _ (VGETBASE X 0) LONUM _ (VGETBASE X 1))) (3 (|create| FLOATP HIWORD _ (VGETBASE X 0) LOWORD _ (VGETBASE X 1))) (4 (VATOM (VLOLOC X))) (7 (PROG ((PTR (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE X 2) 14) 1)) (%ARRAY-BASE X)) (T (VGETBASEPTR X 0)))) (OFFST (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE X 2) 14) 1)) (%ARRAY-OFFSET X)) (T (VGETBASE X 3)))) (LENGTH (\\GETBASEFIXP X 4)) (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))) (9 (\\VAG2 7 (VLOLOC X))) (%ONED-ARRAY (LET ((SIZE (\\GETBASEFIXP X 6)) (BASE (VGETBASEPTR X 0)) (OFFSET (VGETBASE X 3)) (TYPENUMBER (LOGAND (VGETBASE X 2) 255)) NCELLS LOCAL-ARRAY LOCAL-BASE) (|if| (EQ (%TYPENUMBER-TO-GC-TYPE TYPENUMBER) 1) |then| (VTYPEDPOINTER (VTYPENAME X) X) |else| (SETQ NCELLS (LRSH (IPLUS (ITIMES (IPLUS SIZE OFFSET) (%TYPENUMBER-TO-BITS-PER-ELEMENT TYPENUMBER)) 31) 5)) (SETQ LOCAL-ARRAY (|create| ONED-ARRAY)) (SETQ LOCAL-BASE (\\ALLOCBLOCK NCELLS)) (|freplace| (ONED-ARRAY BASE) |of| LOCAL-ARRAY |with| LOCAL-BASE) (|freplace| (ONED-ARRAY STRING-P) |of| LOCAL-ARRAY |with| (%CHAR-TYPE-P TYPENUMBER)) (|freplace| (ONED-ARRAY FILL-POINTER-P) |of| LOCAL-ARRAY |with| (NEQ 0 (LOGAND (LRSH (VGETBASE X 2) 9) 1))) (|freplace| (ONED-ARRAY TYPE-NUMBER) |of| LOCAL-ARRAY |with| TYPENUMBER) (|freplace| (ONED-ARRAY FILL-POINTER) |of| LOCAL-ARRAY |with| (\\GETBASEFIXP X 4)) (|if| (NEQ OFFSET 0) |then| (|freplace| (ONED-ARRAY OFFSET) |of| LOCAL-ARRAY |with| OFFSET) (|freplace| (ONED-ARRAY DISPLACED-P) |of| LOCAL-ARRAY |with| T)) (|freplace| (ONED-ARRAY TOTAL-SIZE) |of| LOCAL-ARRAY |with| SIZE) (|for| I |from| 0 |to| (SUB1 (LLSH NCELLS 1)) |do| (\\PUTBASE LOCAL-BASE I (VGETBASE BASE I))) LOCAL-ARRAY))) (5 (COND ((VLISTP X) (COND ((EQ CDRLVL 0) (*) (QUOTE (--))) (T (CONS (COND ((OR (EQ CARLVL 0) (AND (OR (EQ CARLVL 1) (EQ CDRLVL 1)) (VLISTP (V\\CAR.UFN X)))) (QUOTE &)) (T (V\\UNCOPY (V\\CAR.UFN X) (AND CARLVL (SUB1 CARLVL)) (AND CDRLVL (SUB1 CDRLVL))))) (V\\UNCOPY (V\\CDR.UFN X) CARLVL (AND CDRLVL (SUB1 CDRLVL))))))) (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 24 0) (LRSH (IPLUS (LLSH (VHILOC X) 8) (LRSH (VLOLOC X) 8)) 1)) 2047)) -) - -(VTYPENAME -(LAMBDA (DATUM) (*) (LET ((N (VNTYPX DATUM))) (COND ((EQ N 6) ((LAMBDA (X) (QUOTE ARRAYP)) DATUM)) ((%STRINGP DATUM) (*) (QUOTE STRINGP)) (T (VATOM (VGETBASEPTR (VADDBASE (VVAG2 20 4096) (ITIMES N 18)) 0)))))) -) - -(V\\TYPENAMEFROMNUMBER -(LAMBDA (N) (*) (COND ((ILESSP N (ADD1 |VMaxTypeNumber|)) (VATOM (VGETBASEPTR (VADDBASE (VVAG2 20 4096) (ITIMES N 18)) 0))))) -) -) -(DEFINEQ - -(VUNCOPYATOM -(LAMBDA (N) (*) (*) (PROG (ATOM.NAME VPACKAGE.NAME) (*) (SETQ ATOM.NAME (VSYMBOL.PNAME N)) (*) (SETQ VPACKAGE.NAME (IF (READSYS.HAS.PACKAGES) THEN (VPACKAGE.NAME (VSYMBOL.PACKAGE N)) ELSE "INTERLISP")) (RETURN (VMAKE.LOCAL.ATOM VPACKAGE.NAME ATOM.NAME)))) -) - -(VMAKE.LOCAL.ATOM -(LAMBDA (PKG.NAME ATM.NAME) (*) (*) (CL:INTERN ATM.NAME (OR (CL:FIND-PACKAGE PKG.NAME) (CL:MAKE-PACKAGE PKG.NAME :USES NIL)))) -) - -(VSYMBOL.VALUE -(LAMBDA (SYMBOL) (*) (*) (LET ((LOC (VOLD.FIND.SYMBOL SYMBOL 1 (NCHARS SYMBOL)))) (COND (NIL (*) (VGETBASEPTR (VADDBASE (VVAG2 12 LOC) LOC) 0)) (T (*) (VGETBASEPTR (VADDBASE (VVAG2 44 0) (IPLUS (ITIMES (LOGAND LOC 65535) 10) 2)) 0))))) -) - -(VSYMBOL.PNAME -(LAMBDA (N BUFFER) (*) (*) (SETQ BUFFER (OR BUFFER (ALLOCSTRING \\PNAMELIMIT))) (PROG (ADDR LEN) (*) (COND (NIL (SETQ ADDR (VGETBASEPTR (VADDBASE (VADDBASE (VVAG2 8 0) N) N) 0))) (T (SETQ ADDR (VGETBASEPTR (VADDBASE (VVAG2 44 0) (IPLUS (ITIMES (LOGAND N 65535) 10) 0)) 0)))) (SETQ LEN (V\\GETBASEBYTE ADDR 0)) (|for| I |from| 1 |to| LEN |do| (RPLSTRING BUFFER I (FCHARACTER (V\\GETBASEBYTE ADDR I)))) (RETURN (SUBSTRING BUFFER 1 LEN)))) -) - -(VSYMBOL.PACKAGE -(LAMBDA (N) (*) (*) (PROG ((INDEX (COND (NIL (*) (LRSH (VGETBASE (VADDBASE (VADDBASE (VVAG2 8 0) N) N) 0) 8)) (NIL (T (LRSH (VGETBASE (VADDBASE (VVAG2 44 0) (IPLUS (ITIMES 10 N) 0 8)) 0) 8))) (T (LRSH (VGETBASE (V\\ATOMCELL N 8) 8) 8))))) (RETURN (COND ((EQ INDEX *UNINTERNED-PACKAGE-INDEX*) NIL) (T (VGETBASEPTR (VGETBASEPTR READSYS.PACKAGE.FROM.INDEX 0) (LLSH INDEX 1))))))) -) - -(VOLD.FIND.SYMBOL -(LAMBDA (BASE OFFST LEN FATP NONNUMERICP) (*) (PROG ((FATCHARSEENP (AND FATP (NOT (NULL (|for| I |from| OFFST |to| (SUB1 (IPLUS OFFST LEN)) |suchthat| (IGREATERP (VGETBASE BASE I) 255)))))) HASH HASHENT ATM# PNBASE FIRSTCHAR FIRSTBYTE REPROBE) (*) (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 21 0) HASH))) (*) (COND ((STREQUAL (CL:SYMBOL-NAME BASE) (VSYMBOL.PNAME (SETQ ATM# (SUB1 HASHENT)))) (RETURN ATM#)) (T (*) (SETQ HASH (IPLUS16 HASH (OR REPROBE (SETQ REPROBE (LOGAND 63 (LOGOR 1 (LOGXOR FIRSTBYTE HASH))))))) (GO LP))))) (*) (RETURN (PROGN (LET ((NEWATOM (VNOSUCHATOM BASE OFFST LEN FATP FATCHARSEENP))) NIL NEWATOM))))) -) - -(VLOOKUP-SYMBOL -(LAMBDA (TABLE STRING SXHASH ENTRY-HASH) (*) (*) (LET* ((VEC (VGETBASEPTR TABLE 0)) (*) (HASH (VGETBASEPTR TABLE 2)) (*) (LEN (\\GETBASEFIXP VEC 6)) (*) (H2 (ADD1 (IREMAINDER SXHASH (IDIFFERENCE LEN 2)))) (*)) (DECLARE (TYPE (CL:SIMPLE-ARRAY (CL:UNSIGNED-BYTE 8)) HASH) (TYPE (CL:SIMPLE-ARRAY (CL:UNSIGNED-BYTE 16)) VEC)) (PROG ((INDEX-VAR (IREMAINDER SXHASH LEN)) SYMBOL-NUMBER EHASH) (IF NIL THEN (CL:FORMAT T "Probe @ ~s~%" INDEX-VAR)) LOOP (SETQ EHASH (V\\GETBASEBYTE (VGETBASEPTR HASH 0) INDEX-VAR)) (*) (COND ((EQL EHASH ENTRY-HASH) (IF NIL THEN (CL:FORMAT T "Entry hash MATCHES~%")) (LET ((SYMBOL-NAME (VSYMBOL.PNAME (SETQ SYMBOL-NUMBER (VGETBASE (VGETBASEPTR VEC 0) INDEX-VAR))))) (*) (IF NIL THEN (CL:FORMAT T "Got symbol index~%")) (*) (COND ((STREQUAL SYMBOL-NAME STRING) (IF NIL THEN (CL:FORMAT T " found~%")) (GO DOIT)) (T (IF NIL THEN (CL:FORMAT T "Didn't match~%")))))) ((EQL 0 EHASH) (IF NIL THEN (CL:FORMAT T "Hit deleted entry (no match)~%")) (SETQ INDEX-VAR NIL) (GO DOIT)) (T (IF NIL THEN (CL:FORMAT T "Entry hash does not match~%")))) (SETQ INDEX-VAR (IREMAINDER (IPLUS INDEX-VAR H2) LEN)) (*) (IF NIL THEN (CL:FORMAT T "Reprobe @ ~s~%" INDEX-VAR)) (GO LOOP) DOIT (RETURN SYMBOL-NUMBER)))) -) - -(VFIND.PACKAGE -(LAMBDA (NAME) (*) (*) (PROG ((ITEM (MKSTRING NAME)) (HA READSYS.PACKAGE.FROM.NAME) BITS INDEX SLOT SKEY FIRSTINDEX REPROBE LIMIT ABASE VALUE) (SETQ BITS (STRINGHASHBITS ITEM)) (SETQ INDEX (LOGAND BITS (VGETBASE HA 1))) (*) (SETQ ABASE (VGETBASEPTR HA 2)) (SETQ FIRSTINDEX INDEX) (SETQ REPROBE (LOGOR (LOGAND (LOGXOR BITS (LRSH BITS 8)) (IMIN 63 (VGETBASE HA 1))) 1)) (*) (SETQ LIMIT (VGETBASE HA 1)) LP (SETQ SLOT ((LAMBDA (BASEA0294) (DECLARE (LOCALVARS BASEA0294)) (VADDBASE (VADDBASE BASEA0294 INDEX) INDEX)) (VADDBASE (VADDBASE ABASE INDEX) INDEX))) (*) (COND ((SETQ VALUE (VGETBASEPTR SLOT 2)) (*) (SETQ SKEY (V\\UNCOPY (VGETBASEPTR SLOT 0))) (COND ((STREQUAL ITEM SKEY) (*) (GO FOUND)))) ((NULL (VGETBASEPTR SLOT 0)) (*) (RETURN NIL))) (SETQ INDEX (LOGAND (IPLUS16 INDEX REPROBE) LIMIT)) (*) (COND ((EQ INDEX FIRSTINDEX) (*) (SHOULDNT "Hashing in full hash table"))) (GO LP) FOUND (RETURN (AND (NEQ VALUE \\HASH.NULL.VALUE) VALUE)))) -) - -(VFIND.SYMBOL -(LAMBDA (STRING PACKAGE) (*) (*) (LET* ((LENGTH (FFETCH (STRINGP LENGTH) OF STRING)) (HASH (COND ((EQL 0 LENGTH) 0) (T (PROG* ((TERMINUS LENGTH) (HASH (LLSH (NTHCHARCODE STRING 1) 8)) (CHAR# 2)) A0355 (COND ((IGREATERP CHAR# TERMINUS) (RETURN (PROGN HASH)))) (PROGN) (SETQ HASH (IPLUS16 (IPLUS16 (SETQ HASH (IPLUS16 HASH (LLSH (LOGAND HASH 4095) 2))) (LLSH (LOGAND HASH 255) 8)) (NTHCHARCODE STRING CHAR#))) (SETQ CHAR# (ADD1 CHAR#)) (GO A0355))))) (*) (EHASH (IPLUS (IREMAINDER (LOGXOR LENGTH HASH (RSH HASH 8) (RSH HASH 16) (RSH HASH 19)) 254) 2)) (*) (SYM) (WHERE) (DONE)) (COND ((NOT (VGETBASEPTR PACKAGE 14)) (*) (IF NIL THEN (PRINT "Checking INTERNAL symbols")) (LET ((INDEX (VLOOKUP-SYMBOL (VGETBASEPTR PACKAGE 16) STRING HASH EHASH))) (*) (COND (INDEX (SETQ SYM INDEX) (SETQ WHERE :INTERNAL) (SETQ DONE T)))))) (COND ((NOT DONE) (IF NIL THEN (PRINT "Checking EXTERNAL symbols")) (LET ((INDEX (VLOOKUP-SYMBOL (VGETBASEPTR PACKAGE 18) STRING HASH EHASH))) (*) (COND (INDEX (SETQ SYM INDEX) (SETQ WHERE :EXTERNAL) (SETQ DONE T)))))) (COND ((NOT DONE) (IF NIL THEN (CL:FORMAT T "Checking USE'd packages~%")) (LET ((HEAD (VGETBASEPTR PACKAGE 2)) (*)) (PROG ((PREV HEAD) (TABLE (V\\CDR.UFN HEAD))) USED-PACKAGE-LOOP (COND ((OR DONE (NULL TABLE)) (RETURN (PROGN (CL:VALUES NIL NIL))))) (PROGN (LET ((INDEX (VLOOKUP-SYMBOL (V\\CAR.UFN TABLE) STRING HASH EHASH))) (*) (COND (INDEX (COND ((NEQ PREV HEAD) (LET* ((A0347 PREV) (A0346 (V\\CDR.UFN A0347)) (A0349 TABLE) (A0348 (V\\CDR.UFN A0349)) (A0351 HEAD) (A0350 (V\\CDR.UFN A0351))) (V\\CDR.UFN (RPLACD A0347 A0348)) (V\\CDR.UFN (RPLACD A0349 A0350)) (V\\CDR.UFN (RPLACD A0351 TABLE)) A0346))) (SETQ SYM INDEX) (SETQ WHERE :INHERITED) (SETQ DONE T)) (T)))) (PROGN (SETQ PREV (PROG1 TABLE (PROGN (SETQ TABLE (V\\CDR.UFN TABLE)) NIL))) NIL) (GO USED-PACKAGE-LOOP))))) (CL:VALUES SYM WHERE))) -) - -(VPACKAGE.NAME -(LAMBDA (RMPKG) (*) (AND RMPKG (V\\UNCOPY (VGETBASEPTR RMPKG 4))))) - -(V\\MKATOM -(LAMBDA (BASE OFFST LEN FATP NONNUMERICP) (*) (PROG ((FATCHARSEENP (AND FATP (NOT (NULL (|for| I |from| OFFST |to| (SUB1 (IPLUS OFFST LEN)) |suchthat| (IGREATERP (VGETBASE BASE I) 255)))))) HASH HASHENT ATM# PNBASE FIRSTCHAR FIRSTBYTE REPROBE) (*) (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 21 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 (PROGN (LET ((NEWATOM (VNOSUCHATOM BASE OFFST LEN FATP FATCHARSEENP))) NIL NEWATOM))))) -) - -(VGETTOPVAL -(LAMBDA (X) (*) (VGETBASEPTR (V\\ATOMCELL X 12) 0))) - -(VGETPROPLIST -(LAMBDA (ATM) (*) (VGETBASEPTR (V\\ATOMCELL ATM (CONSTANT 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 ((ATOMNO (VATOMNUMBER X))) (COND (NIL (*) (EQ (VHILOC ATOMNO) 0) (*) (LET ((LOC (SELECTC N (10 (VATOMNUMBER ATOMNO)) (12 (VATOMNUMBER ATOMNO)) (2 (VATOMNUMBER ATOMNO)) (8 (\\ATOMPNAMEINDEX ATOMNO)) (SHOULDNT)))) (VADDBASE (VVAG2 N LOC) LOC))) ((FIXP ATOMNO) (*) (LET ((LOC (SELECTC N (10 4) (12 2) (2 6) (8 0) (SHOULDNT)))) (VADDBASE (VVAG2 44 0) (IPLUS LOC (ITIMES 10 ATOMNO))))) (T (*) (LET ((OFFSET (SELECTC N (10 4) (12 2) (2 6) (8 0) (SHOULDNT)))) (VADDBASE ATOMNO OFFSET)))))) -) -) -(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) -(DEFINEQ - -(V\\GET-COMPILED-CODE-BASE -(LAMBDA (X) (*) (*) (PROG NIL (COND ((LITATOM X) (COND ((PROG1 (NEQ 0 (LRSH (VGETBASE (V\\ATOMCELL X 10) 0) 15)) (SETQ X (VGETBASEPTR (V\\ATOMCELL X 10) 0))) (RETURN X))))) (RETURN (AND (EQ (VNTYPX X) 13) (VGETBASEPTR (\\DTEST X (QUOTE COMPILED-CLOSURE)) 0))))) -) -) - - - -(* |;;| -"YOU MUST REMAKE THIS FILE using (DORENAME 'R) (after CONNing to library) whenever the SYSOUT layout changes in LLPARAMS (e.g., if MDSTypeTable moves)" -) - - -(FILESLOAD VMEM) - -(RPAQQ RDVALS ((\\RPTSIZE) (|\\ArrayFrLst|) (|\\ArrayFrLst2|) (|\\MaxTypeNumber|) (|\\AtomFrLst|)) -) - -(RPAQQ RDPTRS ((\\REALPAGETABLE) (\\FREEBLOCKBUCKETS))) -(DECLARE\: EVAL@COMPILE DONTCOPY - -(FILESLOAD (LOADCOMP) VMEM) -) -(DECLARE\: DONTCOPY - (FILEMAP (NIL (1392 8231 (VREADPAGEMAP 1402 . 2230) (VREADPAGEMAPBLOCK 2232 . 2378) (VCHECKIFPAGE 2380 - . 2596) (V\\LOCKEDPAGEP 2598 . 2747) (V\\LOOKUPPAGEMAP 2749 . 2944) (VCHECKPAGEMAP 2946 . 4630) ( -VCHECKFPTOVP 4632 . 4879) (VCHECKFPTOVP1 4881 . 5217) (V\\SHOWPAGETABLE 5219 . 6359) (V\\PRINTFPTOVP -6361 . 8229)) (8232 17921 (VRAIDCOMMAND 8242 . 11844) (VRAIDSHOWFRAME 11846 . 12375) (VRAIDSTACKCMD -12377 . 13457) (VRAIDROOTFRAME 13459 . 13648) (VPRINTADDRS 13650 . 14198) (VPRINTVA 14200 . 14320) ( -VREADVA 14322 . 14382) (VREADOCT 14384 . 15010) (VREADATOM 15012 . 15555) (VSHOWSTACKBLOCKS 15557 . -17590) (VSHOWSTACKBLOCK1 17592 . 17718) (VPRINCOPY 17720 . 17814) (VNOSUCHATOM 17816 . 17919)) (17922 -26243 (V\\BACKTRACE 17932 . 19569) (V\\STKNAME 19571 . 20167) (V\\PRINTBF 20169 . 21087) ( -V\\PRINTFRAME 21089 . 25715) (V\\SCANFORNTENTRY 25717 . 26076) (V\\PRINTSTK 26078 . 26241)) (26244 -28463 (V\\CHECKARRAYBLOCK 26254 . 27713) (V\\PARSEARRAYSPACE 27715 . 27966) (V\\PARSEARRAYSPACE1 27968 - . 28461)) (28464 41387 (VPRINTCODE 28474 . 39613) (VPRINTCODENT 39615 . 40538) (VBROKENDEF 40540 . -41385)) (41388 42471 (V\\CAR.UFN 41398 . 41846) (V\\CDR.UFN 41848 . 42469)) (42472 45791 (V\\COPY -42482 . 43417) (V\\UNCOPY 43419 . 45789)) (45792 46309 (V\\GETBASEBYTE 45802 . 45961) (V\\PUTBASEBYTE -45963 . 46307)) (46310 46835 (VNTYPX 46320 . 46449) (VTYPENAME 46451 . 46677) (V\\TYPENAMEFROMNUMBER -46679 . 46833)) (46836 55661 (VUNCOPYATOM 46846 . 47120) (VMAKE.LOCAL.ATOM 47122 . 47272) ( -VSYMBOL.VALUE 47274 . 47530) (VSYMBOL.PNAME 47532 . 47989) (VSYMBOL.PACKAGE 47991 . 48390) ( -VOLD.FIND.SYMBOL 48392 . 49471) (VLOOKUP-SYMBOL 49473 . 50705) (VFIND.PACKAGE 50707 . 51668) ( -VFIND.SYMBOL 51670 . 53528) (VPACKAGE.NAME 53530 . 53616) (V\\MKATOM 53618 . 54682) (VGETTOPVAL 54684 - . 54752) (VGETPROPLIST 54754 . 54838) (VSETTOPVAL 54840 . 55065) (VGETDEFN 55067 . 55133) ( -V\\ATOMCELL 55135 . 55659)) (55662 55794 (VLISTP 55672 . 55792)) (55824 56130 ( -V\\GET-COMPILED-CODE-BASE 55834 . 56128))))) -STOP +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED " 9-Mar-2021 16:55:14" |{DSK}larry>ilisp>medley>tmp>RDSYS.;1|) (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\\STKNAME V\\PRINTBF V\\PRINTFRAME V\\SCANFORNTENTRY V\\PRINTSTK) (FNS V\\CHECKARRAYBLOCK V\\PARSEARRAYSPACE V\\PARSEARRAYSPACE1) (FNS VPRINTCODE VPRINTCODENT VBROKENDEF) (FNS V\\CAR.UFN V\\CDR.UFN) (FNS V\\COPY V\\UNCOPY) (FNS V\\GETBASEBYTE V\\PUTBASEBYTE) (FNS VNTYPX VTYPENAME V\\TYPENAMEFROMNUMBER) (FNS VUNCOPYATOM VMAKE.LOCAL.ATOM VSYMBOL.VALUE VSYMBOL.PNAME VSYMBOL.PACKAGE VOLD.FIND.SYMBOL VLOOKUP-SYMBOL VFIND.PACKAGE VFIND.SYMBOL VPACKAGE.NAME V\\MKATOM VGETTOPVAL VGETPROPLIST VSETTOPVAL VGETDEFN V\\ATOMCELL) (FNS VLISTP) (VARS (COPYATOMSTR)) (FNS V\\GET-COMPILED-CODE-BASE) (* |;;| "YOU MUST REMAKE THIS FILE using (DORENAME 'R) (after CONNing to library) whenever the SYSOUT layout changes in LLPARAMS (e.g., if MDSTypeTable moves)") (FILES VMEM) (VARS RDVALS RDPTRS) (DECLARE\: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) VMEM)))) (DEFINEQ (VREADPAGEMAP (LAMBDA NIL (*) (*) (PROG (D) (MAPVMPAGE (IPLUS (LLSH (VHILOC (VVAG2 20 0)) 8) (LRSH (VLOLOC (VVAG2 20 0)) 8)) 1) (*) (*) (MAPVMPAGE (IPLUS (LLSH (VHILOC (VVAG2 5 0)) 8) (LRSH (VLOLOC (VVAG2 5 0)) 8)) (SUB1 (VGETBASE (VVAG2 20 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 20 0) 23)) |do| (*) (MAPVMPAGE (IPLUS (IPLUS (LLSH (VHILOC (VVAG2 20 512)) 8) (LRSH (VLOLOC (VVAG2 20 512)) 8)) J) FP)) (|for| I |from| 0 |to| (SUB1 (LLSH 8 8)) |do| (COND ((IEQ (SETQ D (VGETBASE (VVAG2 20 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 20 0) 15))) (|printout| T "Warning: " "Interface page key" "= " (PROGN 5603) ", but \\InterfacePage says " (VGETBASE (VVAG2 20 0) 15) T)))) ) (V\\LOCKEDPAGEP (LAMBDA (VP TEMP) (*) (*) (OR (NEQ 0 (LOGAND (LLSH 1 (IMOD VP 16)) (VGETBASE (VADDBASE (VVAG2 20 28672) (LRSH VP 4)) 0))) NIL)) ) (V\\LOOKUPPAGEMAP (LAMBDA (VP) (*) (*) (LET ((PRIMENTRY (VGETBASE (VVAG2 20 512) (LRSH VP 5)))) (COND ((EQ PRIMENTRY 65535) 0) (T (VGETBASE (VVAG2 5 0) (IPLUS PRIMENTRY (LOGAND VP 31))))))) ) (VCHECKPAGEMAP (LAMBDA NIL (*) (LET ((*PRINT-BASE* 8) (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 (VADDBASE VREALPAGETABLE (LLSH RPTINDEX 1)) 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 (\\GETBASEFIXP (SETQ FPBASE (VADDBASE (VVAG2 2 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 (\\GETBASEFIXP 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 20 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 (VADDBASE VREALPAGETABLE (LLSH RP 1)) 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| (\\GETBASEFIXP (VVAG2 20 0) 82) |as| (FPBASE _ (VADDBASE (VVAG2 2 0) 1)) |by| (VADDBASE FPBASE 1) |when| (NEQ (VGETBASE FPBASE 0) 65535) |do| (VCHECKFPTOVP1 FP (\\GETBASEFIXP 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) (*) (PROG ((*PRINT-BASE* 8) (OUTSTREAM (GETSTREAM FILE (QUOTE OUTPUT))) (RPTR VREALPAGETABLE) (RP 0) FLAGS VP STATE FIRSTONE LASTONE) (|printout| OUTSTREAM " 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 (VADDBASE VREALPAGETABLE (LLSH RP 1)) RP)) (SETQ VP (VGETBASE RPTR 1)) (COND ((AND (NULL MODE) (EQ VP STATE)) (SETQ LASTONE RP)) (T (COND (LASTONE (|printout| OUTSTREAM "ditto thru " LASTONE T) (SETQ LASTONE NIL))) (SETQ FIRSTONE RP) (SETQ STATE VP) (|printout| OUTSTREAM .I7.8 (RPFROMRPT RP)) (COND ((EQ (VGETBASE RPTR 1) 65534) (PRIN1 " Empty" OUTSTREAM)) ((NOT (ILESSP (VGETBASE RPTR 1) 65534)) (PRIN1 " Unavailable" OUTSTREAM)) (T (|printout| OUTSTREAM .I8.8 VP \,) (\\PRINTVP VP OUTSTREAM) (|printout| OUTSTREAM 28 .I6.8 (VGETBASE RPTR 2) |,,|) (COND ((NEQ 0 (LRSH (VGETBASE RPTR 0) 15)) (COND ((NOT (V\\LOCKEDPAGEP VP)) (*) (PRIN1 "Temp" OUTSTREAM))) (PRIN1 "Locked " OUTSTREAM))) NIL)) (TERPRI OUTSTREAM)))))) ) (V\\PRINTFPTOVP (LAMBDA (FIRSTPAGE NWORDS TYPEFLG STREAM VPRAWFLG) (*) (SETQ STREAM (GETSTREAM STREAM (QUOTE OUTPUT))) (OR FIRSTPAGE (SETQ FIRSTPAGE 1)) (OR NWORDS (SETQ NWORDS (\\GETBASEFIXP (VVAG2 20 0) 82))) (LET ((BASE (VADDBASE (VVAG2 2 0) (SUB1 FIRSTPAGE))) (*PRINT-BASE* 8) (LASTVP -2) (NEXTFP (SUB1 FIRSTPAGE)) FIRSTFP FIRSTVP NEXTVP LOCKEDP TYPE NEXTLOCKED NEXTTYPE) (|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)) (|if| TYPEFLG |then| (SETQ NEXTTYPE (VTYPENAME ((LAMBDA ($$1) (VVAG2 (LRSH (SETQ $$1 NEXTVP) 8) (LLSH (LOGAND $$1 255) 8))) NIL))) (|if| (NULL NEXTTYPE) |then| (SETQ NEXTTYPE (SELECTC (LRSH NEXTVP 8) ((LIST 8 (CL:1+ 8)) "Pnames") ((LIST 10 (CL:1+ 10)) "Definitions") ((LIST 12 (CL:1+ 12)) "Value cells") ((LIST 2 (CL:1+ 2)) "Property lists") ((VHILOC (VVAG2 2 0)) "\\FPTOVP") (1 "Stack") ((VHILOC (VVAG2 22 0)) "GC Main table") ((VHILOC (VVAG2 23 0)) "GC Overflow table") NIL)))))) (COND ((COND ((EQ NEXTVP 65535) (NEQ LASTVP 65535)) (T (OR (NEQ NEXTVP (ADD1 LASTVP)) (NEQ NEXTLOCKED LOCKEDP) (NEQ TYPE NEXTTYPE)))) (COND ((IGEQ LASTVP 0) (COND (FIRSTFP (|printout| STREAM FIRSTFP "-"))) (|printout| STREAM (SUB1 NEXTFP) 12) (COND ((EQ LASTVP 65535) (|printout| STREAM "empty")) (T (COND (FIRSTFP (|if| VPRAWFLG |then| (PRIN1 FIRSTVP STREAM) |else| (\\PRINTVP FIRSTVP STREAM)) (PRIN1 "-" STREAM))) (|if| VPRAWFLG |then| (PRIN1 LASTVP STREAM) |else| (\\PRINTVP LASTVP STREAM)) (COND (LOCKEDP (PRIN1 (QUOTE *) STREAM))) (|if| TYPE |then| (|printout| STREAM 32 TYPE)))))) (SETQ FIRSTFP) (TERPRI STREAM) (SETQ FIRSTVP NEXTVP)) (T (*) (OR FIRSTFP (SETQ FIRSTFP (SUB1 NEXTFP))))) (SETQ LASTVP NEXTVP) (SETQ LOCKEDP NEXTLOCKED) (SETQ TYPE NEXTTYPE) (SETQ NWORDS (PLUS NWORDS -1))))) ) ) (DEFINEQ (VRAIDCOMMAND (LAMBDA NIL (*) (DECLARE (USEDFREE ROOTFRAME ALINKS? RAIDIX FRAME# VPRINTLEVEL)) (FRESHLINE T) (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)) (Z "Zap Print level to: ") (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 (VPRINCOPY (VGETTOPVAL (VREADATOM)))) (P (VPRINCOPY (VGETPROPLIST (VREADATOM)))) (C (VPRINTCODE (VREADATOM) T RAIDIX)) (V (VPRINCOPY (VREADVA))) (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 (PRINTNUM .I2 (VATOMNUMBER (VREADATOM)) 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))) (Z (LET ((A (PROG1 (READ T T) (READC T))) (D (PROG1 (READ T T) (READC T)))) (COND ((AND (FIXP A) (FIXP D)) (SETQ VPRINTLEVEL (CONS A D))) (T (PRINTOUT T "Must be two integers, car level then cdr level" T) (ERROR!))))) (W (VSHOWSTACKBLOCKS (COND ((EQ (PEEKC T) (QUOTE \ )) (READC T) (VGETBASE (VVAG2 20 0) 30)) (T (VREADOCT))))) (^X (V\\PRINTFRAME (VREADOCT) (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 (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 20 0) 6)) (G (VGETBASE (VVAG2 20 0) 5)) (K (VGETBASE (VVAG2 20 0) 3)) (H (VGETBASE (VVAG2 20 0) 4)) (S (VGETBASE (VVAG2 20 0) 2)) (R (VGETBASE (VVAG2 20 0) 1)) (M (VGETBASE (VVAG2 20 0) 14)) (COND ((AND (ILESSP (SETQ FRAME (VREADOCT)) 256) (ILESSP (VGETBASE (VVAG2 20 0) FRAME) (VGETBASE (VVAG2 20 0) 7)) (IEQ (LRSH (VGETBASE (VVAG2 1 (PROGN (PROGN (VGETBASE (VVAG2 20 0) FRAME)))) 0) 13) 6)) (VGETBASE (VVAG2 20 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 20 0) 24)) (T (VGETBASE (VVAG2 20 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 (HANDLER-BIND ((XCL:MISSING-EXTERNAL-SYMBOL (CL:FUNCTION (LAMBDA (CONDITION) (* |;;| "MAKE AN INTERNAL SYMBOL INSTEAD") (CL:INTERN (XCL:MISSING-EXTERNAL-SYMBOL-NAME CONDITION) (XCL:MISSING-EXTERNAL-SYMBOL-PACKAGE CONDITION))))) (XCL:MISSING-PACKAGE (CL:FUNCTION (LAMBDA (CONDITION) (* |;;| "FAKE A PACKAGE BY THIS NAME AND MAKE THE SYMBOL IN IT") (CL:INTERN (XCL:MISSING-PACKAGE-SYMBOL-NAME CONDITION) (CL:MAKE-PACKAGE (XCL:MISSING-PACKAGE-PACKAGE-NAME CONDITION) :USE NIL)))))) (CL:READ T)) (READC T))) ) (VSHOWSTACKBLOCKS (LAMBDA (SCANPTR WAITFLG) (*) (*) (PROG ((EASP (VGETBASE (VVAG2 20 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)) (VGETBASEPTR (VVAG2 1 SCANPTR) 6)) (T (VGETBASEPTR (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 (CAR VPRINTLEVEL) (CDR VPRINTLEVEL)) T T))) (VNOSUCHATOM (LAMBDA (ATM) (*) (*) (|printout| T "No such atom: " ATM T) (ERROR "No such atom: "))) ) (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 (V\\STKNAME IPOS)) (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)) (VGETBASEPTR (VVAG2 1 IPOS) 6)) (T (VGETBASEPTR (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)) (VGETBASEPTR (VVAG2 1 IPOS) 6)) (T (VGETBASEPTR (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\\STKNAME (LAMBDA (POS) (*) (*) (LET ((NAME (VGETBASEPTR (PROGN (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE (VVAG2 1 POS) 0) 9) 1)) (VGETBASEPTR (VVAG2 1 POS) 6)) (T (VGETBASEPTR (VVAG2 1 POS) 2)))) 4))) (|if| (EQ NAME (QUOTE \\INTERPRETER)) |then| (VGETBASEPTR (VVAG2 1 0) (LET ((BFLINK (COND ((NOT (NEQ 0 (LOGAND (VGETBASE (VVAG2 1 POS) 1) 1))) (IDIFFERENCE POS 2)) (T (VGETBASE (VVAG2 1 POS) 8))))) (+ (VGETBASE (VVAG2 1 BFLINK) 1) (TIMES (CL:1- (IDIFFERENCE (LRSH (IDIFFERENCE BFLINK (VGETBASE (VVAG2 1 BFLINK) 1)) 1) (LOGAND (LRSH (VGETBASE (VVAG2 1 BFLINK) 0) 8) 1))) 2)))) |else| NAME))) ) (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)))) (MAKE-NTENTRY 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)) (VGETBASEPTR (VVAG2 1 FRAME) 6)) (T (VGETBASEPTR (VVAG2 1 FRAME) 2)))) (I 0) (FT (IPLUS (IPLUS FRAME (PROGN 10)) (LLSH (ADD1 (SIGNED (VGETBASE (PROGN (VGETBASEPTR (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 (VGETBASEPTR (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)) (VGETBASEPTR (VVAG2 1 FRAME) 6)) (T (VGETBASEPTR (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 (MAKE-NTENTRY 32768 J))) (AND (NEQ VARSONLY T) (SETQ TMP "local"))) (COND ((EQ (LRSH (VGETBASE (PROGN (VVAG2 1 I)) 0) 12) 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 (MAKE-NTENTRY 49152 J))) (|printout| NIL "[fvar " .P2 TMP " " (COND ((EVENP (VGETBASE (PROGN (VVAG2 1 I)) 0)) (COND ((EQ (SETQ TMP (VHILOC ((LAMBDA ($$1) (VVAG2 (VGETBASE (PROGN $$1) 1) (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) 12) 0) (APPLY* PRINTFN (VGETBASEPTR (VVAG2 1 I) 0))) (T (TERPRI)))))))) ) (V\\SCANFORNTENTRY (LAMBDA (NMT NTENTRY) (*) (*) (|bind| NM |for| NT1 |from| (PROGN 8) |by| (CONSTANT (PROGN 2)) |as| NT2 |from| (IPLUS (PROGN 8) (VGETBASE NMT 6)) |by| (CONSTANT (WORDSPERNTOFFSETENTRY)) |do| (COND ((NULL-NTENTRY (SETQ NM (GETSTKNAMEENTRY NMT NT1))) (RETURN))) (COND ((IEQP NTENTRY (GETSTKNTOFFSETENTRY 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 |VArrayFrLst2| (VVAG2 64 0)) (*) (V\\PARSEARRAYSPACE1 FN (VVAG2 46 0) |VArrayFrLst2|) (V\\PARSEARRAYSPACE1 FN (VVAG2 64 0) |VArrayFrLst|)) (T (V\\PARSEARRAYSPACE1 FN (VVAG2 46 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 (VPRINTCODE (LAMBDA (FN LVFLG RADIX OUTF FIRSTBYTE PC FN.IS.CODEBASE) (*) (*) (*) (*) (*) (*) (DECLARE (SPECVARS OUTF)) (OR RADIX (SETQ RADIX 8)) (LET ((CODEBASE (COND (FN.IS.CODEBASE FN) (T (OR (V\\GET-COMPILED-CODE-BASE FN) (AND (LITATOM FN) (V\\GET-COMPILED-CODE-BASE (GET FN (QUOTE CODE)))) (ERROR FN "not compiled code"))))) (I4 (NUMFORMATCODE (LIST (QUOTE FIX) 4 RADIX))) (I6 (NUMFORMATCODE (LIST (QUOTE FIX) 6 RADIX))) NTSIZE STARTPC TAG TEMP OP# PVARS FVARS IVARS) (DECLARE (SPECVARS CODEBASE IVARS PVARS FVARS I4 I6)) (*) (LET ((*PRINT-BASE* RADIX)) (|for| I |from| 0 |by| 2 |while| (ILESSP I (LLSH (PROGN 8) 1)) |do| (PRINTNUM I4 I OUTF) (PRIN1 ": " OUTF) (PRINTNUM I6 (LOGOR (LLSH (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1)) (V\\GETBASEBYTE CODEBASE (LOGXOR I 3))) (T (V\\GETBASEBYTE CODEBASE I))) 8) ((LAMBDA (CODEBASE OFFSET) (DECLARE (LOCALVARS CODEBASE OFFSET)) (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1)) (V\\GETBASEBYTE CODEBASE (LOGXOR OFFSET 3))) (T (V\\GETBASEBYTE CODEBASE OFFSET)))) CODEBASE (ADD1 I))) OUTF) (SELECTQ I (0 (PRIN1 " stkmin" OUTF)) (2 (PRIN1 " na" OUTF)) (4 (PRIN1 " pv" OUTF)) (6 (PRIN1 " startpc" OUTF)) (8 (AND (NEQ 0 (LRSH (VGETBASE CODEBASE 4) 15)) (PRIN1 "[CLOSUREP]" OUTF)) (|printout| OUTF " byteswapped: " (NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1))) (|printout| OUTF " argtype: " (LOGAND (LRSH (VGETBASE CODEBASE 4) 12) 3))) (10 (|printout| OUTF " frame name: " .P2 (V\\UNCOPY (VGETBASEPTR CODEBASE 4)))) (12 (PRIN1 " ntsize" OUTF)) (14 (|printout| OUTF " nlocals: " (LRSH (VGETBASE CODEBASE 7) 8)) (|printout| OUTF " fvaroffset: " (LOGAND (VGETBASE CODEBASE 7) 255))) NIL) (*) (TERPRI OUTF))) (SETQ NTSIZE (VGETBASE CODEBASE 6)) (VPRINTCODENT "name table: " (LLSH (PROGN 8) 1) (LLSH NTSIZE 1)) (SETQ STARTPC (VGETBASE CODEBASE 3)) (COND ((GREATERP (SETQ NTSIZE (IDIFFERENCE (COND ((PROGN NIL) (*) (- STARTPC 4)) (T STARTPC)) (SETQ TEMP (IPLUS (LLSH (PROGN 8) 1) (COND ((EQ NTSIZE 0) (*) 8) (T (LLSH NTSIZE 2))))))) 4) (VPRINTCODENT "Local args: " TEMP (LRSH NTSIZE 1))) ((EQ NTSIZE 4) (*) (|printout| OUTF T "Info: " .P2 (VGETBASEPTR CODEBASE (LRSH TEMP 1)) T))) (|printout| OUTF T "----" T) (PROG ((CODELOC STARTPC) (LEVEL (AND LVFLG 0)) B B1 B2 B3 B4 B5 FN LEN LEVADJ STK) (COND (LEVEL (SETUPHASHARRAY (QUOTE \\PRINTCODE.LEVEL)) (SETUPHASHARRAY (QUOTE \\PRINTCODE.STKSTATE)) (CLRHASH \\PRINTCODE.LEVEL) (CLRHASH \\PRINTCODE.STKSTATE))) LP (COND ((AND PC (IGEQ CODELOC PC)) (*) (COND ((NOT (IEQP CODELOC PC)) (PRINTOUT OUTF "(PC ") (PRINTNUM I4 PC OUTF) (PRINTOUT OUTF " not found)"))) (|printout| OUTF "------------------------------" T) (SETQ PC))) (COND ((OR (NULL FIRSTBYTE) (IGEQ CODELOC FIRSTBYTE)) (PRINTNUM I4 CODELOC OUTF) (PRIN1 ": " OUTF) (COND (LVFLG (SETQ TEMP (GETHASH CODELOC \\PRINTCODE.LEVEL)) (COND (LEVEL (COND ((AND TEMP (OR (NEQ LEVEL TEMP) (NOT (EQUAL STK (GETHASH CODELOC \\PRINTCODE.STKSTATE))))) (PRIN1 "*" OUTF)))) (T (SETQ LEVEL TEMP) (SETQ STK (GETHASH CODELOC \\PRINTCODE.STKSTATE)))) (COND (LEVEL (TAB 7 NIL OUTF) (PRINTNUM I4 LEVEL OUTF))))) (TAB 12 NIL OUTF)) (T (*) (SETQ TAG (\\FINDOP ((LAMBDA (CODEBASE OFFSET) (DECLARE (LOCALVARS CODEBASE OFFSET)) (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1)) (V\\GETBASEBYTE CODEBASE (LOGXOR OFFSET 3))) (T (V\\GETBASEBYTE CODEBASE OFFSET)))) CODEBASE (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 (CODEBASELT CODEBASE 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 ((LAMBDA (CODEBASE OFFSET) (DECLARE (LOCALVARS CODEBASE OFFSET)) (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1)) (V\\GETBASEBYTE CODEBASE (LOGXOR OFFSET 3))) (T (V\\GETBASEBYTE CODEBASE OFFSET)))) CODEBASE (ADD1 CODELOC))))))) (MISCN (AND LEVEL (SETQ LEVEL (ADD1 (IDIFFERENCE LEVEL ((LAMBDA (CODEBASE OFFSET) (DECLARE (LOCALVARS CODEBASE OFFSET)) (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1)) (V\\GETBASEBYTE CODEBASE (LOGXOR OFFSET 3))) (T (V\\GETBASEBYTE CODEBASE OFFSET)))) CODEBASE (IPLUS 2 CODELOC))))))) NIL) (COND ((AND LEVEL (SETQ LEVADJ (|fetch| LEVADJ |of| TAG))) (COND ((LISTP LEVADJ) (SETQ LEVADJ (CAR LEVADJ)))) (SELECTQ LEVADJ (FNX (SETQ LEVEL (PLUS LEVEL (IDIFFERENCE 1 (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1)) (V\\GETBASEBYTE CODEBASE (LOGXOR CODELOC 3))) (T (V\\GETBASEBYTE CODEBASE CODELOC))))))) (POP.N (SETQ LEVEL (IDIFFERENCE LEVEL (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1)) (V\\GETBASEBYTE CODEBASE (LOGXOR CODELOC 3))) (T (V\\GETBASEBYTE CODEBASE CODELOC)))))) ((JUMP UNWIND) (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 ((LAMBDA (CODEBASE OFFSET) (DECLARE (LOCALVARS CODEBASE OFFSET)) (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1)) (V\\GETBASEBYTE CODEBASE (LOGXOR OFFSET 3))) (T (V\\GETBASEBYTE CODEBASE OFFSET)))) CODEBASE (PROG1 CODELOC (SETQ CODELOC (PLUS CODELOC 1))))))))) (PRINTNUM I4 B OUTF) (COND ((IGREATERP LEN 0) (PRINTNUM I4 (SETQ B1 ((LAMBDA (CODEBASE OFFSET) (DECLARE (LOCALVARS CODEBASE OFFSET)) (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1)) (V\\GETBASEBYTE CODEBASE (LOGXOR OFFSET 3))) (T (V\\GETBASEBYTE CODEBASE OFFSET)))) CODEBASE (PROG1 CODELOC (SETQ CODELOC (PLUS CODELOC 1))))) OUTF))) (COND ((IGREATERP LEN 1) (PRINTNUM I4 (SETQ B2 ((LAMBDA (CODEBASE OFFSET) (DECLARE (LOCALVARS CODEBASE OFFSET)) (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1)) (V\\GETBASEBYTE CODEBASE (LOGXOR OFFSET 3))) (T (V\\GETBASEBYTE CODEBASE OFFSET)))) CODEBASE (PROG1 CODELOC (SETQ CODELOC (PLUS CODELOC 1))))) OUTF))) (COND ((IGREATERP LEN 2) (PRINTNUM I4 (SETQ B3 ((LAMBDA (CODEBASE OFFSET) (DECLARE (LOCALVARS CODEBASE OFFSET)) (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1)) (V\\GETBASEBYTE CODEBASE (LOGXOR OFFSET 3))) (T (V\\GETBASEBYTE CODEBASE OFFSET)))) CODEBASE (PROG1 CODELOC (SETQ CODELOC (PLUS CODELOC 1))))) OUTF))) (COND ((IGREATERP LEN 3) (PRINTNUM I4 (SETQ B4 ((LAMBDA (CODEBASE OFFSET) (DECLARE (LOCALVARS CODEBASE OFFSET)) (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1)) (V\\GETBASEBYTE CODEBASE (LOGXOR OFFSET 3))) (T (V\\GETBASEBYTE CODEBASE OFFSET)))) CODEBASE (PROG1 CODELOC (SETQ CODELOC (PLUS CODELOC 1))))) OUTF))) (COND ((IGREATERP LEN 4) (PRINTNUM I4 (SETQ B5 ((LAMBDA (CODEBASE OFFSET) (DECLARE (LOCALVARS CODEBASE OFFSET)) (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1)) (V\\GETBASEBYTE CODEBASE (LOGXOR OFFSET 3))) (T (V\\GETBASEBYTE CODEBASE OFFSET)))) CODEBASE (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))) (COND ((LISTP OP#) (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)) \\PRINTCODE.LEVEL) (PUTHASH N STK \\PRINTCODE.STKSTATE)))) (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)) \\PRINTCODE.LEVEL) (PUTHASH N STK \\PRINTCODE.STKSTATE)))) (COND ((IGEQ B1 128) (IDIFFERENCE B1 256)) (T B1)))) (FN (*) (NEW-SYMBOL-CODE (BIG-VMEM-HOST (SETQ B (IPLUS (LLSH (IPLUS (LLSH (IPLUS (LLSH B1 8) B2) 8) B3) 8) B4)) (SETQ B (IPLUS (LLSH (IPLUS (LLSH B1 8) B2) 8) B3))) (SETQ B (IPLUS (LLSH B1 8) B2))) (|printout| OUTF 40 .P2 (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)) \\PRINTCODE.LEVEL) (PUTHASH N STK \\PRINTCODE.STKSTATE)))) (IPLUS (LLSH B1 8) B2 (COND ((IGREATERP B1 127) -65536) (T 0))))) (ATOM (|printout| OUTF 40 .P2 (VATOM (NEW-SYMBOL-CODE (BIG-VMEM-HOST (IPLUS (LLSH (IPLUS (LLSH (IPLUS (LLSH B1 8) B2) 8) B3) 8) B4) (IPLUS (LLSH (IPLUS (LLSH B1 8) B2) 8) B3)) (IPLUS (LLSH B1 8) B2))))) (GCONST (|printout| OUTF 40 .P2 (V\\UNCOPY (BIG-VMEM-HOST (VVAG2 (IPLUS (LLSH B1 8) B2) (IPLUS (LLSH B3 8) B4)) (VVAG2 B1 (IPLUS (LLSH B2 8) B3)))))) (FNX (|printout| OUTF "(" B1 ")" 40 .P2 (VATOM (NEW-SYMBOL-CODE (BIG-VMEM-HOST (IPLUS (LLSH (IPLUS (LLSH (IPLUS (LLSH B2 8) B3) 8) B4) 8) B5) (IPLUS (LLSH (IPLUS (LLSH B2 8) B3) 8) B4)) (IPLUS (LLSH B2 8) B3))))) (TYPEP (|printout| OUTF "(" .P2 (OR (V\\TYPENAMEFROMNUMBER B1) (QUOTE ?)) ")")) (UNBIND (AND LEVEL (SETQ LEVEL (|pop| STK)))) (DUNBIND (AND LEVEL (SETQ LEVEL (SUB1 (|pop| STK))))) (RETURN (SETQ LEVEL)) (SUBRCALL (|printout| OUTF 40 (|for| X |in| \\INITSUBRS |when| (EQ B1 (CADR X)) |do| (RETURN (CAR X)) |finally| (RETURN "?"))) (AND LEVEL (SETQ LEVEL (ADD1 (IDIFFERENCE LEVEL B2))))) (MISCN (|printout| OUTF 40 (|for| X |in| \\USER-SUBR-LIST |when| (EQ B1 (CADR X)) |do| (RETURN (CAR X)) |finally| (RETURN "?"))) (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 UNWIND) (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 CODEBASE IVARS PVARS FVARS I4 I6 OUTF)) (*) (*) (LET (NAME TAG) (COND ((ILESSP START1 (SETQ START2 (IPLUS START2 START1))) (|printout| OUTF STR T) (|for| NT1 |from| START1 |by| (LLSH (CONSTANT (PROGN 2)) 1) |while| (ILESSP NT1 START2) |as| NT2 |from| START2 |by| (LLSH (PROGN 2) 1) |do| (PRINTNUM I4 NT1 OUTF) (PRIN1 ": " OUTF) (PRINTNUM I6 (GETNAMEENTRY CODEBASE NT1) OUTF) (SPACES 3 OUTF) (PRINTNUM I4 NT2 OUTF) (PRIN1 ": " OUTF) (PRINTNUM I6 (GETNTOFFSETENTRY CODEBASE NT2) OUTF) (COND ((SETQ NAME (VATOM (CODEBASEGETNAME CODEBASE NT1))) (SETQ TAG (GETNTOFFSET CODEBASE NT2)) (|printout| OUTF .SP 5 (SELECTC (NTSLOT-VARTYPE (GETNTOFFSETENTRY CODEBASE NT2)) (0 (|push| IVARS (LIST TAG NAME)) (QUOTE IVAR)) (32768 (|push| PVARS (LIST TAG NAME)) (QUOTE PVAR)) (PROGN (|push| FVARS (LIST TAG NAME)) (QUOTE FVAR))) " " TAG ": " .P2 NAME))) (TERPRI OUTF)))))) ) (VBROKENDEF (LAMBDA (DEF WHEN) (*) (PROG ((CA (V\\GET-COMPILED-CODE-BASE DEF)) BEFORE AFTER SIZE FIRSTBYTE NEWCA) (SETQ FIRSTBYTE (VGETBASE CA 3)) NIL (*) (PROGN (*) (PROGN (*) (SETQ NEWCA CA) (SETQ AFTER T)) (*) (COND (AFTER (*) (|bind| OP |do| (SELECTQ (CADR (SETQ OP (\\FINDOP (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE NEWCA 4) 14) 1)) (V\\GETBASEBYTE NEWCA (LOGXOR FIRSTBYTE 3))) (T (V\\GETBASEBYTE NEWCA FIRSTBYTE)))))) (-X- (RETURN)) (GCONST NIL) (RETURN ((LAMBDA (CODEBASE OFFSET NEWVALUE) (DECLARE (LOCALVARS CODEBASE OFFSET NEWVALUE)) (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1)) (V\\PUTBASEBYTE CODEBASE (LOGXOR OFFSET 3) NEWVALUE)) (T (V\\PUTBASEBYTE CODEBASE OFFSET NEWVALUE)))) NEWCA FIRSTBYTE (V\\CAR.UFN (\\FINDOP (QUOTE \\RETURN))))) NIL) (SETQ FIRSTBYTE (PLUS FIRSTBYTE 1 (CADDR OP))))))) (RETURN NEWCA))) ) ) (DEFINEQ (V\\CAR.UFN (LAMBDA (X) (*) (*) (*) (COND ((VLISTP X) (COND ((ZEROP 1) (VGETBASEPTR X 0)) (T (COND ((EQ (LRSH (VGETBASE X 0) 12) 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) 12))) (RETURN (COND ((EQ Q 8) NIL) ((IGREATERP Q 8) (VADDBASE (VVAG2 (VHILOC X) (LOGAND (VLOLOC X) 65280)) (LLSH (IDIFFERENCE Q 8) 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 NEW-ATOM) (VATOMNUMBER X T)) (VLISTP (PROG ((R (REVERSE X)) (V (V\\COPY (CDR (LAST X))))) LP (COND ((LISTP R) (SETQ V (CONS (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 (CREATECELL 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))) (ONED-ARRAY (%COPY-ONED-ARRAY X)) (STRINGP (*) (%COPY-STRING-TO-ARRAY X)) (FLOATP (PROG ((VAL (CREATECELL 3))) (SELECTQ (SYSTEMTYPE) ((ALTO D) (VPUTBASE VAL 0 (\\GETBASE X 0)) (VPUTBASE VAL 1 (\\GETBASE X 1))) (MKI.IEEE X VAL)) (RETURN VAL))) (CHARACTER (VVAG2 7 (CL:CHAR-CODE X))) (ERROR X "can't be copied to remote file"))) ) (V\\UNCOPY (LAMBDA (X CARLVL CDRLVL) (*) (SELECTC (VNTYPX X) (1 (COND ((EQ (VHILOC X) 14) (*) (VLOLOC X)) (T (IPLUS (VLOLOC X) -65536)))) (2 (*) (|create| FIXP HINUM _ (VGETBASE X 0) LONUM _ (VGETBASE X 1))) (3 (|create| FLOATP HIWORD _ (VGETBASE X 0) LOWORD _ (VGETBASE X 1))) (4 (VATOM (VLOLOC X))) (7 (PROG ((PTR (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE X 2) 14) 1)) (%ARRAY-BASE X)) (T (VGETBASEPTR X 0)))) (OFFST (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE X 2) 14) 1)) (%ARRAY-OFFSET X)) (T (VGETBASE X 3)))) (LENGTH (\\GETBASEFIXP X 4)) (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))) (9 (\\VAG2 7 (VLOLOC X))) (%ONED-ARRAY (LET ((SIZE (\\GETBASEFIXP X 6)) (BASE (VGETBASEPTR X 0)) (OFFSET (VGETBASE X 3)) (TYPENUMBER (LOGAND (VGETBASE X 2) 255)) NCELLS LOCAL-ARRAY LOCAL-BASE) (|if| (EQ (%TYPENUMBER-TO-GC-TYPE TYPENUMBER) 1) |then| (VTYPEDPOINTER (VTYPENAME X) X) |else| (SETQ NCELLS (LRSH (IPLUS (ITIMES (IPLUS SIZE OFFSET) (%TYPENUMBER-TO-BITS-PER-ELEMENT TYPENUMBER)) 31) 5)) (SETQ LOCAL-ARRAY (|create| ONED-ARRAY)) (SETQ LOCAL-BASE (\\ALLOCBLOCK NCELLS)) (|freplace| (ONED-ARRAY BASE) |of| LOCAL-ARRAY |with| LOCAL-BASE) (|freplace| (ONED-ARRAY STRING-P) |of| LOCAL-ARRAY |with| (%CHAR-TYPE-P TYPENUMBER)) (|freplace| (ONED-ARRAY FILL-POINTER-P) |of| LOCAL-ARRAY |with| (NEQ 0 (LOGAND (LRSH (VGETBASE X 2) 9) 1))) (|freplace| (ONED-ARRAY TYPE-NUMBER) |of| LOCAL-ARRAY |with| TYPENUMBER) (|freplace| (ONED-ARRAY FILL-POINTER) |of| LOCAL-ARRAY |with| (\\GETBASEFIXP X 4)) (|if| (NEQ OFFSET 0) |then| (|freplace| (ONED-ARRAY OFFSET) |of| LOCAL-ARRAY |with| OFFSET) (|freplace| (ONED-ARRAY DISPLACED-P) |of| LOCAL-ARRAY |with| T)) (|freplace| (ONED-ARRAY TOTAL-SIZE) |of| LOCAL-ARRAY |with| SIZE) (|for| I |from| 0 |to| (SUB1 (LLSH NCELLS 1)) |do| (\\PUTBASE LOCAL-BASE I (VGETBASE BASE I))) LOCAL-ARRAY))) (5 (COND ((VLISTP X) (COND ((EQ CDRLVL 0) (*) (QUOTE (--))) (T (CONS (COND ((OR (EQ CARLVL 0) (AND (OR (EQ CARLVL 1) (EQ CDRLVL 1)) (VLISTP (V\\CAR.UFN X)))) (QUOTE &)) (T (V\\UNCOPY (V\\CAR.UFN X) (AND CARLVL (SUB1 CARLVL)) (AND CDRLVL (SUB1 CDRLVL))))) (V\\UNCOPY (V\\CDR.UFN X) CARLVL (AND CDRLVL (SUB1 CDRLVL))))))) (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 24 0) (LRSH (IPLUS (LLSH (VHILOC X) 8) (LRSH (VLOLOC X) 8)) 1)) 2047)) ) (VTYPENAME (LAMBDA (X) (*) (*) (*) (LET ((N (VNTYPX X))) (COND ((EQ N 6) ((LAMBDA (X) (QUOTE ARRAYP)) X)) ((%STRINGP X) (*) (QUOTE STRINGP)) ((EQ (QUOTE NEW-ATOM) (SETQ N (VATOM (VGETBASEPTR (VADDBASE (VVAG2 20 4096) (ITIMES N 18)) 0)))) (*) (QUOTE LITATOM)) (T N)))) ) (V\\TYPENAMEFROMNUMBER (LAMBDA (N) (*) (COND ((ILESSP N (ADD1 |VMaxTypeNumber|)) (VATOM (VGETBASEPTR (VADDBASE (VVAG2 20 4096) (ITIMES N 18)) 0))))) ) ) (DEFINEQ (VUNCOPYATOM (LAMBDA (N) (*) (*) (PROG (ATOM.NAME VPACKAGE.NAME) (*) (SETQ ATOM.NAME (VSYMBOL.PNAME N)) (*) (SETQ VPACKAGE.NAME (IF (READSYS.HAS.PACKAGES) THEN (VPACKAGE.NAME (VSYMBOL.PACKAGE N)) ELSE "INTERLISP")) (RETURN (VMAKE.LOCAL.ATOM VPACKAGE.NAME ATOM.NAME)))) ) (VMAKE.LOCAL.ATOM (LAMBDA (PKG.NAME ATM.NAME) (*) (*) (CL:INTERN ATM.NAME (OR (CL:FIND-PACKAGE PKG.NAME) (CL:MAKE-PACKAGE PKG.NAME :USES NIL)))) ) (VSYMBOL.VALUE (LAMBDA (SYMBOL) (*) (*) (LET ((LOC (VOLD.FIND.SYMBOL SYMBOL 1 (NCHARS SYMBOL)))) (COND (NIL (*) (VGETBASEPTR (VADDBASE (VVAG2 12 LOC) LOC) 0)) (T (*) (VGETBASEPTR (VADDBASE (VVAG2 44 0) (IPLUS (ITIMES (LOGAND LOC 65535) 10) 2)) 0))))) ) (VSYMBOL.PNAME (LAMBDA (N BUFFER) (*) (*) (SETQ BUFFER (OR BUFFER (ALLOCSTRING \\PNAMELIMIT))) (PROG (ADDR LEN) (*) (COND (NIL (SETQ ADDR (VGETBASEPTR (VADDBASE (VADDBASE (VVAG2 8 0) N) N) 0))) (T (SETQ ADDR (VGETBASEPTR (VADDBASE (VVAG2 44 0) (IPLUS (ITIMES (LOGAND N 65535) 10) 0)) 0)))) (SETQ LEN (V\\GETBASEBYTE ADDR 0)) (|for| I |from| 1 |to| LEN |do| (RPLSTRING BUFFER I (FCHARACTER (V\\GETBASEBYTE ADDR I)))) (RETURN (SUBSTRING BUFFER 1 LEN)))) ) (VSYMBOL.PACKAGE (LAMBDA (N) (*) (*) (PROG ((INDEX (COND (NIL (*) (LRSH (VGETBASE (VADDBASE (VADDBASE (VVAG2 8 0) N) N) 0) 8)) (NIL (T (LRSH (VGETBASE (VADDBASE (VVAG2 44 0) (IPLUS (ITIMES 10 N) 0 8)) 0) 8))) (T (LRSH (VGETBASE (V\\ATOMCELL N 8) 8) 8))))) (RETURN (COND ((EQ INDEX *UNINTERNED-PACKAGE-INDEX*) NIL) (T (VGETBASEPTR (VGETBASEPTR READSYS.PACKAGE.FROM.INDEX 0) (LLSH INDEX 1))))))) ) (VOLD.FIND.SYMBOL (LAMBDA (BASE OFFST LEN FATP NONNUMERICP) (*) (PROG ((FATCHARSEENP (AND FATP (NOT (NULL (|for| I |from| OFFST |to| (SUB1 (IPLUS OFFST LEN)) |suchthat| (IGREATERP (VGETBASE BASE I) 255)))))) HASH HASHENT ATM# PNBASE FIRSTCHAR FIRSTBYTE REPROBE) (*) (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 21 0) HASH))) (*) (COND ((STREQUAL (CL:SYMBOL-NAME BASE) (VSYMBOL.PNAME (SETQ ATM# (SUB1 HASHENT)))) (RETURN ATM#)) (T (*) (SETQ HASH (IPLUS16 HASH (OR REPROBE (SETQ REPROBE (LOGAND 63 (LOGOR 1 (LOGXOR FIRSTBYTE HASH))))))) (GO LP))))) (*) (RETURN (PROGN (LET ((NEWATOM (VNOSUCHATOM BASE OFFST LEN FATP FATCHARSEENP))) NIL NEWATOM))))) ) (VLOOKUP-SYMBOL (LAMBDA (TABLE STRING SXHASH ENTRY-HASH) (*) (*) (LET* ((VEC (VGETBASEPTR TABLE 0)) (*) (HASH (VGETBASEPTR TABLE 2)) (*) (LEN (\\GETBASEFIXP VEC 6)) (*) (H2 (ADD1 (IREMAINDER SXHASH (IDIFFERENCE LEN 2)))) (*)) (DECLARE (TYPE (CL:SIMPLE-ARRAY (CL:UNSIGNED-BYTE 8)) HASH) (TYPE (CL:SIMPLE-ARRAY (CL:UNSIGNED-BYTE 16)) VEC)) (PROG ((INDEX-VAR (IREMAINDER SXHASH LEN)) SYMBOL-NUMBER EHASH) (IF NIL THEN (CL:FORMAT T "Probe @ ~s~%" INDEX-VAR)) LOOP (SETQ EHASH (V\\GETBASEBYTE (VGETBASEPTR HASH 0) INDEX-VAR)) (*) (COND ((EQL EHASH ENTRY-HASH) (IF NIL THEN (CL:FORMAT T "Entry hash MATCHES~%")) (LET ((SYMBOL-NAME (VSYMBOL.PNAME (SETQ SYMBOL-NUMBER (VGETBASE (VGETBASEPTR VEC 0) INDEX-VAR))))) (*) (IF NIL THEN (CL:FORMAT T "Got symbol index~%")) (*) (COND ((STREQUAL SYMBOL-NAME STRING) (IF NIL THEN (CL:FORMAT T " found~%")) (GO DOIT)) (T (IF NIL THEN (CL:FORMAT T "Didn't match~%")))))) ((EQL 0 EHASH) (IF NIL THEN (CL:FORMAT T "Hit deleted entry (no match)~%")) (SETQ INDEX-VAR NIL) (GO DOIT)) (T (IF NIL THEN (CL:FORMAT T "Entry hash does not match~%")))) (SETQ INDEX-VAR (IREMAINDER (IPLUS INDEX-VAR H2) LEN)) (*) (IF NIL THEN (CL:FORMAT T "Reprobe @ ~s~%" INDEX-VAR)) (GO LOOP) DOIT (RETURN SYMBOL-NUMBER)))) ) (VFIND.PACKAGE (LAMBDA (NAME) (*) (*) (PROG ((ITEM (MKSTRING NAME)) (HA READSYS.PACKAGE.FROM.NAME) BITS INDEX SLOT SKEY FIRSTINDEX REPROBE LIMIT ABASE VALUE) (SETQ BITS (STRINGHASHBITS ITEM)) (SETQ INDEX (LOGAND BITS (VGETBASE HA 1))) (*) (SETQ ABASE (VGETBASEPTR HA 2)) (SETQ FIRSTINDEX INDEX) (SETQ REPROBE (LOGOR (LOGAND (LOGXOR BITS (LRSH BITS 8)) (IMIN 63 (VGETBASE HA 1))) 1)) (*) (SETQ LIMIT (VGETBASE HA 1)) LP (SETQ SLOT ((LAMBDA (BASEA0200) (DECLARE (LOCALVARS BASEA0200)) (VADDBASE (VADDBASE BASEA0200 INDEX) INDEX)) (VADDBASE (VADDBASE ABASE INDEX) INDEX))) (*) (COND ((SETQ VALUE (VGETBASEPTR SLOT 2)) (*) (SETQ SKEY (V\\UNCOPY (VGETBASEPTR SLOT 0))) (COND ((STREQUAL ITEM SKEY) (*) (GO FOUND)))) ((NULL (VGETBASEPTR SLOT 0)) (*) (RETURN NIL))) (SETQ INDEX (LOGAND (IPLUS16 INDEX REPROBE) LIMIT)) (*) (COND ((EQ INDEX FIRSTINDEX) (*) (SHOULDNT "Hashing in full hash table"))) (GO LP) FOUND (RETURN (AND (NEQ VALUE \\HASH.NULL.VALUE) VALUE)))) ) (VFIND.SYMBOL (LAMBDA (STRING PACKAGE) (*) (*) (LET* ((LENGTH (FFETCH (STRINGP LENGTH) OF STRING)) (HASH (COND ((EQL 0 LENGTH) 0) (T (PROG* ((TERMINUS LENGTH) (HASH (LLSH (NTHCHARCODE STRING 1) 8)) (CHAR# 2)) A0355 (COND ((IGREATERP CHAR# TERMINUS) (RETURN (PROGN HASH)))) (PROGN) (SETQ HASH (IPLUS16 (IPLUS16 (SETQ HASH (IPLUS16 HASH (LLSH (LOGAND HASH 4095) 2))) (LLSH (LOGAND HASH 255) 8)) (NTHCHARCODE STRING CHAR#))) (SETQ CHAR# (ADD1 CHAR#)) (GO A0355))))) (*) (EHASH (IPLUS (IREMAINDER (LOGXOR LENGTH HASH (RSH HASH 8) (RSH HASH 16) (RSH HASH 19)) 254) 2)) (*) (SYM) (WHERE) (DONE)) (COND ((NOT (VGETBASEPTR PACKAGE 14)) (*) (IF NIL THEN (PRINT "Checking INTERNAL symbols")) (LET ((INDEX (VLOOKUP-SYMBOL (VGETBASEPTR PACKAGE 16) STRING HASH EHASH))) (*) (COND (INDEX (SETQ SYM INDEX) (SETQ WHERE :INTERNAL) (SETQ DONE T)))))) (COND ((NOT DONE) (IF NIL THEN (PRINT "Checking EXTERNAL symbols")) (LET ((INDEX (VLOOKUP-SYMBOL (VGETBASEPTR PACKAGE 18) STRING HASH EHASH))) (*) (COND (INDEX (SETQ SYM INDEX) (SETQ WHERE :EXTERNAL) (SETQ DONE T)))))) (COND ((NOT DONE) (IF NIL THEN (CL:FORMAT T "Checking USE'd packages~%")) (LET ((HEAD (VGETBASEPTR PACKAGE 2)) (*)) (PROG ((PREV HEAD) (TABLE (V\\CDR.UFN HEAD))) USED-PACKAGE-LOOP (COND ((OR DONE (NULL TABLE)) (RETURN (PROGN (CL:VALUES NIL NIL))))) (PROGN (LET ((INDEX (VLOOKUP-SYMBOL (V\\CAR.UFN TABLE) STRING HASH EHASH))) (*) (COND (INDEX (COND ((NEQ PREV HEAD) (LET* ((A0347 PREV) (A0346 (V\\CDR.UFN A0347)) (A0349 TABLE) (A0348 (V\\CDR.UFN A0349)) (A0351 HEAD) (A0350 (V\\CDR.UFN A0351))) (V\\CDR.UFN (RPLACD A0347 A0348)) (V\\CDR.UFN (RPLACD A0349 A0350)) (V\\CDR.UFN (RPLACD A0351 TABLE)) A0346))) (SETQ SYM INDEX) (SETQ WHERE :INHERITED) (SETQ DONE T)) (T)))) (PROGN (SETQ PREV (PROG1 TABLE (PROGN (SETQ TABLE (V\\CDR.UFN TABLE)) NIL))) NIL) (GO USED-PACKAGE-LOOP))))) (CL:VALUES SYM WHERE))) ) (VPACKAGE.NAME (LAMBDA (RMPKG) (*) (AND RMPKG (V\\UNCOPY (VGETBASEPTR RMPKG 4))))) (V\\MKATOM (LAMBDA (BASE OFFST LEN FATP NONNUMERICP) (*) (PROG ((FATCHARSEENP (AND FATP (NOT (NULL (|for| I |from| OFFST |to| (SUB1 (IPLUS OFFST LEN)) |suchthat| (IGREATERP (VGETBASE BASE I) 255)))))) HASH HASHENT ATM# PNBASE FIRSTCHAR FIRSTBYTE REPROBE) (*) (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 21 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 (PROGN (LET ((NEWATOM (VNOSUCHATOM BASE OFFST LEN FATP FATCHARSEENP))) NIL NEWATOM))))) ) (VGETTOPVAL (LAMBDA (X) (*) (VGETBASEPTR (V\\ATOMCELL X 12) 0))) (VGETPROPLIST (LAMBDA (ATM) (*) (VGETBASEPTR (V\\ATOMCELL ATM (CONSTANT 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 ((ATOMNO (VATOMNUMBER X))) (COND (NIL (*) (EQ (VHILOC ATOMNO) 0) (*) (LET ((LOC (SELECTC N (10 (VATOMNUMBER ATOMNO)) (12 (VATOMNUMBER ATOMNO)) (2 (VATOMNUMBER ATOMNO)) (8 (\\ATOMPNAMEINDEX ATOMNO)) (SHOULDNT)))) (VADDBASE (VVAG2 N LOC) LOC))) ((FIXP ATOMNO) (*) (LET ((LOC (SELECTC N (10 4) (12 2) (2 6) (8 0) (SHOULDNT)))) (VADDBASE (VVAG2 44 0) (IPLUS LOC (ITIMES 10 ATOMNO))))) (T (*) (LET ((OFFSET (SELECTC N (10 4) (12 2) (2 6) (8 0) (SHOULDNT)))) (VADDBASE ATOMNO OFFSET)))))) ) ) (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) (DEFINEQ (V\\GET-COMPILED-CODE-BASE (LAMBDA (X) (*) (*) (PROG NIL (COND ((LITATOM X) (COND ((PROG1 (NEQ 0 (LRSH (VGETBASE (V\\ATOMCELL X 10) 0) 15)) (SETQ X (VGETBASEPTR (V\\ATOMCELL X 10) 0))) (RETURN X))))) (RETURN (AND (EQ (VNTYPX X) 13) (VGETBASEPTR (\\DTEST X (QUOTE COMPILED-CLOSURE)) 0))))) ) ) (* |;;| "YOU MUST REMAKE THIS FILE using (DORENAME 'R) (after CONNing to library) whenever the SYSOUT layout changes in LLPARAMS (e.g., if MDSTypeTable moves)" ) (FILESLOAD VMEM) (RPAQQ RDVALS ((\\RPTSIZE) (|\\MaxTypeNumber|) (|\\AtomFrLst|) (|\\ArrayFrLst|) (|\\ArrayFrLst2|))) (RPAQQ RDPTRS ((\\REALPAGETABLE) (\\FREEBLOCKBUCKETS))) (DECLARE\: EVAL@COMPILE DONTCOPY (FILESLOAD (LOADCOMP) VMEM) ) STOP \ No newline at end of file diff --git a/library/RDSYS.LCOM b/library/RDSYS.LCOM index d1743b3488f2b0bbbbb12836342e81717e817ae8..55d054a9e7cb65e88cb7043e057ca1225d55f373 100644 GIT binary patch delta 4173 zcmaJ@Z){uD6}O$Vw2%ZRF;1F<=F}}E5lZm$`=50oFZOfd_}R}qzc^{}nx&1Qv0s`h zq-Yf#W*P_>Luz{0PH^U?6mQdFkAuRak)K zvk-!dPsXyz?;ks}yi^#q=2uoOj4oP>kDnV|DlAxq3!|$`=SGcK_IP&qTg=5lXbl0o zODi|R$|Ib(wtlD#@$;4i*$a;^pI?RDhlYoT(aOU7YGL8x?d9drVCz6Up{Y?rRZKO8 zUftI9|L3az>%MNzc>fVB^N>*{RLB4aIR!r~#PB}?gl0f7Q}_)-G!=t52oN`vlzJFR z5ey{}OUxoE!EhpiUm3q5ewi@jGDae8YHCi^2m|$KiF7ji&>%EFymzn1v$)@bzjnXp zjJ@_ikNsKqp;F7_!efM4+Xz24Spa16A2z01VF;+@n?VsU{I z^sjT>_l2YFS9P)1s*~ zhxbT z!cV7?J*NY9vG-o@CHwi_Z}%Cl0p}6u!im7TSF}Ir?e})s-oDWN!RorF*0_dRk6H6> zZ)Q3)d#bO8)r#9R;%@9bZ#pJ^x$b$EQuJ;c%e&}V`_;aC?|9I+`hGr%2iV>KiGC8JJWxOy97~L3UD~G1Qc9s#z=^HH}ks zI-60WCN4M;^7(OGBh891p_*9}YcGY%hyYpD%%w7>K~@apaM#o`IYq;Dm@PvtrDSMT z$s!Ae8r5_?39`VT%9t8Yq}5mkWYn6=Oq=6MRt@7S0y)$l)6u#dVO^(WEFD@(>FE^6 zVV;_DBqY3>)c>&JWQ(5K&NPvWSK8M*MBCbnp7?PL|0*vHGK*EPQc^pK%CAm;k&)@=2 zpPa?#6d>OUA|~Ms2oVuZfWWX0xYKjIEWyb*@ZqpMA9}(k2=?{R;SeKYdsSHw|HVhZ1?X?S%0WGa#^F_mp!TfcYI#j0s5VCTNMQ z8M4on!TY4WRz7rS?Tp{r_ti$v*wv=ujT@hQLcV8jdOqKtwDw*9c-uc|e^ee0T-m%; zHG`RH-}CfzCx(Ojn)1!!)Bo|6vFu2S2%ts@lt(aXxa8~0uuPT_Kp0iDArfe^X56)6 z7|L(0d%7gvs4^`hgo%Y}}Z+V}$ zuRUWv7}%4fiSeD}Lh-AOP)bWo?WC78)L>$~J5}2Hed&7TZ}x>}d%a)SKY4Zl6R4xz zd$)dY!HU-GYO!+4iq&2&RvsaoqsS>$GFFao5`-hrGowYqkO-rRGKQ>X!Z}Jf0m|vM zg0(Aqij_{9x%xpGVcM`eO0}OkMMK`Q?D6>1x__H^;n#t9@k-U&S1FNQTiDA~`^K0mAcF`iM7sQPgz@8t#-m9e=UdEwO^xR|N9R$RrO%$nlFPNYj4`w4SZa>UTpVu z=tuO>KR5gIZvDsydYgX4G4;NusvjwB%^j)S(1Z4q&;6*(VnvhuiDh(bPnbb6i;zt- z3P*RGEwEH?-6vIlD<_P7DxaTrnt?=GBBDafK?Mm5cGsqeEocWaB)*L5N#$j***J18 znn(;f=In?v>TdvqNarGV5<l|mXgYIZ&aTwgSVsR#ME#n9n1{V8i!?|wi zT?7XaBctKSm`G1R1d%Onzxu*g#}EwM;NXmP6z3TnEp}?1L*~vBfsnT9fuW&6ybfb` zz1Z&)(a__0?c2x`aVx zaad4HQ^f%uOr6Z~fE%D2V1@_~|If|MwqLw{hyCZv{q}D!-)&#L9I(H<{Lp^^NeNB1 delta 3721 zcma)9YitwQ6}Fua64<0pFj?n8a^kQdQ8&?y=bh4!i9IHcA7gCCfvlHohy%nP$ST09 zs8oiP3fk_9E=;>BZIPB;`U9yCCtg~$rM3Ey+NxRsDpEuHqYDVBs#?kER#ktMo;x$K zgWyN4Xy)AS-h0lu=brPO$%q|T|9C)c=h8d>VOUpfZ znjMr+9U49iqqV%R~TkR&p=~;AQ)DBaYarle(*fw6N~%5=ud>c zwEO>dtPVJy6WHRc{hzIQ0b=rA1!BNMO2!uletfb(WCrA91m6_+B7O*f2!Xg9QF>97 zAT9^}!Tl)G6buEuM4(X+h~R}(EFO#|!%9jC696@ZgV9i8&j8eF^>sGeLW2!|&6M4t z-*xY{@6wyvIvut3`pa$Y-hYf|j*!{%imOylgoUY=t>j%=uDNT@Ts3e*2ZFcsFSL2= zSM+bSy<|V3|Dvr&-DfFqPr0fq7uJ<96$AaIfo6NnqG4!@VJ5VYF$CkWZMmjKr`y{j zf3-#+ z*stqvb$s4`*fP7_h>|fdL$GWQRZinBS@w;2%VYazt*t$Hf!p*Qott;HmzM3dm0iku zXzMomJk=W2L!IqhG`nh;v_fqAk*V#2W!sgi6&$@;9j#>bZ*=b1ENff3o9&zRTb=D) z)0jy%+wZoRuaO^5s7=}94x3gRY$~Zu`oqrQyjO&AB^<-#^wN+RSEu4iL`^CQtSBXl zD8)fiiDR~69%H4Gw53rL1qenHF~yg}0n5W)C7DQK5k_#xaF9@vsYomtCnE|{IGa>s zDLIT|lKc@lW>l3V=DiSCd|_1$fy9fDPWzQWFsk@tAh9e~$z*a&PAC*ej07pv?^n^H zggQ+}B-(T-8J&!PL{y_GYX?PJi$rwR*oy@$auUdi&}2f1gNSF(6G_>x_&}tE^^*z` z7JE8vl&DeBAc%;pn-_TWg@h`RlzpMGu<8pXK;Y5c$_h^0;EBMJL&|<12xu{;C?S+6 z0hD-L&BuFCrq?a=5^Filqds#JkIIMyJV&iV7#kDvaurX<0>IN7oZwJbim(uI)jS4= z$FOdb6C`5k2;L^gBgqjuB0=QX^-Ja$rn1<}TW+z>DrKumSyL(MWH;($S*iGT_wVid zX!LIqb3pV$FkoZ==9dHkzmh_f^Fk$uSQ@iLi4bnb89e2gbUJwaz)Cq70FGjGpXUvS#OOcu z^m@E3c;MtB9Gb_sh#k!XzEev}^T$tWrwPJ&FZXua1s!?^8?lcvG$o)~UKI7|UUouY zz%$?hj$;Aa+Egd7_K(`qKOx3yY^tz~QCYWAh$htvxKqRratfQ(W!+ z^|U*k_Q~;~$v_l_{bFN(5IfiY0kDne7tiu7nU#NOwFcifZT)yF>9oFjHl>fA1N&)x z_FPX-abHHOUt8%Yjoz%uK6>=v0eK&PVtc$guGQcFWYwvEcy7pbv-YU7s)xpap`yp< zCX10b|Kq?*3Sz^=Qd4}St{Ds(4*ALu)1P!htSLD>ND7&Zz1CQc$K?YApdsp0!r=sw zDM%iODVVxrSkg!vpaud+KPZY|DG(qLoFU-N!x73=*i=|h%}WyShoMIG^*7ZCPuTX4f?AWI*xosbv4_a zDr7WYSubS^hctira<=daLHZEM6=GV7AVGrg#+s2V0Yn1S7{H)bOOQT-xD2F2Yb}4Y zDO=cP^avI7zg+0Zt4(UlDzVqBdWgNRm9+Xo77gl}vv7!DeFTF-3Qg+xjuMPFu`x87 zE9@pnjk%LTt7KPHWAkF(`#WI@+$$7?0E%Uqzk zZaXfhZmo9I%0T00)Rt`dd#JeOdxJE#7elRPHi%$TR+L&&o(=@seS6sPm7&u zyV`e0b*g=)t&eRbwJ&#Xrmyfwb?fX~U&)JD_ax{1F%?M@vrZC_X^kwzuRrW#*lwPl z=dgP`jj#;i?Mah6BnBH7)~4UAO$pg{!z5-qnY0R5l<<=@6%HnnnBbDRZ+(hK$E+Eo zt7FGr z3HYf)a!9Myuy9z`M$wzg8RWvMc82uViY*4|dwql-5fm`kaVyTfXn4oa_=z10W5WnW z_kvfXK~KEBreTXTBOp->^Z}2J(zqCt9yrozt8Bp_vtVCQkI(y#&MwI(7mtn2p1{uH z#kf8P$Nx33dC<^5I5>c(r}b;^bk%T_SiJVmNA?E4oScjxnJW79#l8CXFYYS-{oFNnYc9W(uMLMjEh5*AhYd=YelF`wn5;9gc73A4 zIuljaNf&;$P0j_4WJc=7CIX4cF)K1O&25Mi2G%z&$7LT$Tb>6!e|ePZ$A Date: Tue, 9 Mar 2021 19:26:55 -0800 Subject: [PATCH 2/2] We might revisit this, but it looks like new was all written in spring of 1995 --- {library => obsolete/library}/new/PCTREE | 0 {library => obsolete/library}/new/TEDIT | 0 {library => obsolete/library}/new/TEDIT.LCOM | Bin {library => obsolete/library}/new/TEDITABBREV.LCOM | Bin {library => obsolete/library}/new/TEDITCOMMAND.LCOM | Bin {library => obsolete/library}/new/TEDITDCL | 0 {library => obsolete/library}/new/TEDITDCL.LCOM | 0 {library => obsolete/library}/new/TEDITFILE | 0 {library => obsolete/library}/new/TEDITFILE.LCOM | Bin {library => obsolete/library}/new/TEDITFIND.LCOM | Bin {library => obsolete/library}/new/TEDITFNKEYS.LCOM | Bin {library => obsolete/library}/new/TEDITHCPY.LCOM | Bin {library => obsolete/library}/new/TEDITHISTORY | 0 {library => obsolete/library}/new/TEDITHISTORY.LCOM | Bin {library => obsolete/library}/new/TEDITLOOKS.LCOM | Bin {library => obsolete/library}/new/TEDITMENU | 0 {library => obsolete/library}/new/TEDITMENU.LCOM | Bin {library => obsolete/library}/new/TEDITPAGE.LCOM | Bin {library => obsolete/library}/new/TEDITSCREEN.LCOM | Bin .../library}/new/TEDITSELECTION.LCOM | Bin {library => obsolete/library}/new/TEDITWINDOW.LCOM | Bin {library => obsolete/library}/new/TEXTOFD | 0 {library => obsolete/library}/new/TEXTOFD.LCOM | Bin 23 files changed, 0 insertions(+), 0 deletions(-) rename {library => obsolete/library}/new/PCTREE (100%) rename {library => obsolete/library}/new/TEDIT (100%) rename {library => obsolete/library}/new/TEDIT.LCOM (100%) rename {library => obsolete/library}/new/TEDITABBREV.LCOM (100%) rename {library => obsolete/library}/new/TEDITCOMMAND.LCOM (100%) rename {library => obsolete/library}/new/TEDITDCL (100%) rename {library => obsolete/library}/new/TEDITDCL.LCOM (100%) rename {library => obsolete/library}/new/TEDITFILE (100%) rename {library => obsolete/library}/new/TEDITFILE.LCOM (100%) rename {library => obsolete/library}/new/TEDITFIND.LCOM (100%) rename {library => obsolete/library}/new/TEDITFNKEYS.LCOM (100%) rename {library => obsolete/library}/new/TEDITHCPY.LCOM (100%) rename {library => obsolete/library}/new/TEDITHISTORY (100%) rename {library => obsolete/library}/new/TEDITHISTORY.LCOM (100%) rename {library => obsolete/library}/new/TEDITLOOKS.LCOM (100%) rename {library => obsolete/library}/new/TEDITMENU (100%) rename {library => obsolete/library}/new/TEDITMENU.LCOM (100%) rename {library => obsolete/library}/new/TEDITPAGE.LCOM (100%) rename {library => obsolete/library}/new/TEDITSCREEN.LCOM (100%) rename {library => obsolete/library}/new/TEDITSELECTION.LCOM (100%) rename {library => obsolete/library}/new/TEDITWINDOW.LCOM (100%) rename {library => obsolete/library}/new/TEXTOFD (100%) rename {library => obsolete/library}/new/TEXTOFD.LCOM (100%) diff --git a/library/new/PCTREE b/obsolete/library/new/PCTREE similarity index 100% rename from library/new/PCTREE rename to obsolete/library/new/PCTREE diff --git a/library/new/TEDIT b/obsolete/library/new/TEDIT similarity index 100% rename from library/new/TEDIT rename to obsolete/library/new/TEDIT diff --git a/library/new/TEDIT.LCOM b/obsolete/library/new/TEDIT.LCOM similarity index 100% rename from library/new/TEDIT.LCOM rename to obsolete/library/new/TEDIT.LCOM diff --git a/library/new/TEDITABBREV.LCOM b/obsolete/library/new/TEDITABBREV.LCOM similarity index 100% rename from library/new/TEDITABBREV.LCOM rename to obsolete/library/new/TEDITABBREV.LCOM diff --git a/library/new/TEDITCOMMAND.LCOM b/obsolete/library/new/TEDITCOMMAND.LCOM similarity index 100% rename from library/new/TEDITCOMMAND.LCOM rename to obsolete/library/new/TEDITCOMMAND.LCOM diff --git a/library/new/TEDITDCL b/obsolete/library/new/TEDITDCL similarity index 100% rename from library/new/TEDITDCL rename to obsolete/library/new/TEDITDCL diff --git a/library/new/TEDITDCL.LCOM b/obsolete/library/new/TEDITDCL.LCOM similarity index 100% rename from library/new/TEDITDCL.LCOM rename to obsolete/library/new/TEDITDCL.LCOM diff --git a/library/new/TEDITFILE b/obsolete/library/new/TEDITFILE similarity index 100% rename from library/new/TEDITFILE rename to obsolete/library/new/TEDITFILE diff --git a/library/new/TEDITFILE.LCOM b/obsolete/library/new/TEDITFILE.LCOM similarity index 100% rename from library/new/TEDITFILE.LCOM rename to obsolete/library/new/TEDITFILE.LCOM diff --git a/library/new/TEDITFIND.LCOM b/obsolete/library/new/TEDITFIND.LCOM similarity index 100% rename from library/new/TEDITFIND.LCOM rename to obsolete/library/new/TEDITFIND.LCOM diff --git a/library/new/TEDITFNKEYS.LCOM b/obsolete/library/new/TEDITFNKEYS.LCOM similarity index 100% rename from library/new/TEDITFNKEYS.LCOM rename to obsolete/library/new/TEDITFNKEYS.LCOM diff --git a/library/new/TEDITHCPY.LCOM b/obsolete/library/new/TEDITHCPY.LCOM similarity index 100% rename from library/new/TEDITHCPY.LCOM rename to obsolete/library/new/TEDITHCPY.LCOM diff --git a/library/new/TEDITHISTORY b/obsolete/library/new/TEDITHISTORY similarity index 100% rename from library/new/TEDITHISTORY rename to obsolete/library/new/TEDITHISTORY diff --git a/library/new/TEDITHISTORY.LCOM b/obsolete/library/new/TEDITHISTORY.LCOM similarity index 100% rename from library/new/TEDITHISTORY.LCOM rename to obsolete/library/new/TEDITHISTORY.LCOM diff --git a/library/new/TEDITLOOKS.LCOM b/obsolete/library/new/TEDITLOOKS.LCOM similarity index 100% rename from library/new/TEDITLOOKS.LCOM rename to obsolete/library/new/TEDITLOOKS.LCOM diff --git a/library/new/TEDITMENU b/obsolete/library/new/TEDITMENU similarity index 100% rename from library/new/TEDITMENU rename to obsolete/library/new/TEDITMENU diff --git a/library/new/TEDITMENU.LCOM b/obsolete/library/new/TEDITMENU.LCOM similarity index 100% rename from library/new/TEDITMENU.LCOM rename to obsolete/library/new/TEDITMENU.LCOM diff --git a/library/new/TEDITPAGE.LCOM b/obsolete/library/new/TEDITPAGE.LCOM similarity index 100% rename from library/new/TEDITPAGE.LCOM rename to obsolete/library/new/TEDITPAGE.LCOM diff --git a/library/new/TEDITSCREEN.LCOM b/obsolete/library/new/TEDITSCREEN.LCOM similarity index 100% rename from library/new/TEDITSCREEN.LCOM rename to obsolete/library/new/TEDITSCREEN.LCOM diff --git a/library/new/TEDITSELECTION.LCOM b/obsolete/library/new/TEDITSELECTION.LCOM similarity index 100% rename from library/new/TEDITSELECTION.LCOM rename to obsolete/library/new/TEDITSELECTION.LCOM diff --git a/library/new/TEDITWINDOW.LCOM b/obsolete/library/new/TEDITWINDOW.LCOM similarity index 100% rename from library/new/TEDITWINDOW.LCOM rename to obsolete/library/new/TEDITWINDOW.LCOM diff --git a/library/new/TEXTOFD b/obsolete/library/new/TEXTOFD similarity index 100% rename from library/new/TEXTOFD rename to obsolete/library/new/TEXTOFD diff --git a/library/new/TEXTOFD.LCOM b/obsolete/library/new/TEXTOFD.LCOM similarity index 100% rename from library/new/TEXTOFD.LCOM rename to obsolete/library/new/TEXTOFD.LCOM