(FILECREATED " 8-Aug-85 23:08:13" {ERIS}<LISPCORE>LIBRARY>READSYS.;20 12486
changes to: (FNS VLOADFNS)
previous date: " 8-Aug-85 19:42:24" {ERIS}<LISPCORE>LIBRARY>READSYS.;19)
(* Copyright (c) 1982, 1983, 1984, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT READSYSCOMS)
(RPAQQ READSYSCOMS ((FNS PRINTSYSOUT READSYS TELERAID VLISTGET VLOADFNS VLOADVAR VLOADVARS VRAID
VSAVEWORK SHOWREMOTESCREEN VGETVAL VINSPECT VUNSAVEDEF VCADR VPUTDEFN
VYANKDEF)
(INITVARS (RDSYSINIT)
(ATOMPAGELST NIL)
(ATOMCACHE NIL)
(NEWATOMARRAY (HASHARRAY 30)))
(FNS VATOM VATOMNUMBER)
(DECLARE: EVAL@COMPILE DONTCOPY (PROP (DMACRO MACRO)
IEQ)
DONTEVAL@LOAD
(FILES (LOADCOMP)
VMEM))
(FILES VMEM)))
(DEFINEQ
(PRINTSYSOUT
[LAMBDA (OUTF RADIX SHORTFLG) (* lmm "16-JUN-82 17:50")
(RESETLST (OR RADIX (SETQ RADIX 20Q))
(PROG (MAP (LINECOUNT 0)
(PAGECOUNT 0)
(LINESPERPAGE LINESPERPAGE)
CURFN
(VDEFSPACE (VGETTOPVAL (QUOTE \DEFSPACE)))
(INUM 0)
(.I6 (NUMFORMATCODE (LIST (QUOTE FIX)
6 RADIX)))
D FN ILIST MX)
[OUTFILE (OR OUTF (PACKFILENAME (QUOTE EXTENSION)
(QUOTE LISTING)
(QUOTE NAME)
(FILENAMEFIELD VMEMFILE (QUOTE NAME]
(RESETSAVE NIL (LIST (QUOTE CLOSEF?)
(OUTPUT)))
(RESETSAVE (LINELENGTH 1750Q))
(RESETSAVE (RADIX 12Q))
[SETQ MX (SUB1 (V\UNCOPY (VGETTOPVAL (QUOTE \AtomFrLst]
(SETQ ILIST (for I from 0 to MX when (SETQ D (VGETBASEPTR VDEFSPACE
(LLSH I 1)))
collect (LIST (V\UNCOPY I)
D)))
(printout NIL "code listing for " VMEMFILE " created " (GETFILEINFO VMEMFILE
(QUOTE
CREATIONDATE))
T)
[SORT ILIST (FUNCTION (LAMBDA (X Y)
(ILESSP (CADR X)
(CADR Y]
(for X in ILIST do (PRINTNUM .I6 (VHILOC (CADR X)))
(SPACES 1)
(PRINTNUM .I6 (VLOLOC (CADR X)))
(SPACES 12Q)
(PRINT (CAR X)))
(PRINTOUT NIL .PAGE)
(SORT ILIST (FUNCTION FILEINDEXALPHORDER))
[for X in ILIST do (printout NIL (CAR X)
": " 62Q)
(PRINTNUM .I6 (VHILOC (CADR X)))
(SPACES 1)
(PRINTNUM .I6 (VLOLOC (CADR X)))
(TERPRI)
(COND
((NOT SHORTFLG)
(VDPRINTCODE (CAR X)
NIL RADIX)
(TERPRI)
(TERPRI]
(RETURN OUTF])
(READSYS
[LAMBDA (FILE WRITEABLE) (* lmm " 6-Aug-84 13:22")
(COND
[FILE (INITVMEM FILE WRITEABLE)
(* * clear atom cache)
(for X in ATOMPAGELST do (for I from 0 to 255 do (FASTSETA (CDR X)
I 0)))
(* * initialize those variables which are renamed "pointers", e.g., the array free list)
[for X in RDPTRS do (SET (PACK* (QUOTE V)
(SUBATOM (CAR X)
2 -1))
(VGETTOPVAL (CAR X]
(* * Initialize those variables which are renamed "values", e.g., \AtomFrLst = # of allocated atoms)
(for X in RDVALS do (SET (PACK* (QUOTE V)
(SUBATOM (CAR X)
2 -1))
(VGETVAL (CAR X]
((LISTP VMEMFILE)
(CLOSEREMOTEVMEMFILE))
(T (CLOSEVMEMFILE])
(TELERAID
[LAMBDA (HOST RAIDIX) (* bvm: "13-Jul-84 17:24")
(RESETLST [COND
(HOST (RESETSAVE NIL (QUOTE (CLOSEVMEMFILE)))
(READSYS (LIST HOST]
(COND
((LISTP VMEMFILE)
(VRAID RAIDIX])
(VLISTGET
[LAMBDA (LST TOKEN) (* edited: "11-Jun-85 04:24")
(AND LST (if (EQ TOKEN (V\UNCOPY (V\CAR.UFN LST)))
then (V\UNCOPY (V\CAR.UFN (V\CDR.UFN LST)))
else (VLISTGET (V\CDR.UFN (V\CDR.UFN LST))
TOKEN])
(VLOADFNS
[LAMBDA (FNS) (* mpl " 8-Aug-85 23:05")
(for FN inside FNS
do (PRINTOUT T "Reading function " FN)
[SAVEPUT FN (QUOTE EXPR)
(LET [(DEFN (V\UNCOPY (VGETDEFN FN]
(COND
[(NLISTP DEFN)
(* * Hmm, must have been a compiled function. Let's try to get its proplist and save the defn from the EXPR prop)
(LET [(PLIST (V\UNCOPY (VGETPROPLIST FN]
(COND
([AND (LISTP PLIST)
(LISTP (LISTGET PLIST (QUOTE EXPR]
(LISTGET PLIST (QUOTE EXPR]
(T DEFN]
(TERPRI T])
(VLOADVAR
[LAMBDA (VAR) (* edited: "11-Jun-85 03:09")
(SAVESET VAR (VGETVAL VAR)
T])
(VLOADVARS
[LAMBDA (VARS) (* lmm " 7-Aug-85 18:44")
(for VAR inside VARS
do (PRINTOUT T "Reading variable: " VAR)
(SAVEPUT VAR (QUOTE VALUE)
(VGETVAL VAR))
(TERPRI T])
(VRAID
[LAMBDA (RAIDIX) (* bvm: "18-AUG-83 13:10")
(DECLARE (SPECVARS RAIDIX ROOTFRAME ALINKS? FRAME# REMOTESCREEN))
(printout T "virtual RAID" T)
(OR RAIDIX (SETQ RAIDIX 10Q))
(PROG ((ROOTFRAME)
(ALINKS? T)
(FRAME#)
(REMOTESCREEN))
(RESETLST (RESETSAVE (OUTPUT T))
(RESETSAVE (INTCHAR (CHARCODE ↑G)))
(SETQ .I2 (NUMFORMATCODE (LIST (QUOTE FIX)
2 RAIDIX)))
(SETQ .I5 (NUMFORMATCODE (LIST (QUOTE FIX)
5 RAIDIX)))
(SETQ .I6 (NUMFORMATCODE (LIST (QUOTE FIX)
6 RAIDIX)))
(SETQ .I7 (NUMFORMATCODE (LIST (QUOTE FIX)
7 RAIDIX)))
(bind RESULT until [SETQ RESULT (ERSETQ (when (SETQ $$VAL (VRAIDCOMMAND))
do (RETURN $$VAL]
finally (COND
((AND (LISTP VMEMFILE)
(EQ (CAR RESULT)
(QUOTE RETURN)))
(CLEARPAGECACHE)
(REMOTERETURN])
(VSAVEWORK
[LAMBDA NIL (* lmm " 7-Aug-85 18:47")
(LET (FNS VARS FILES CHANGES)
(PRINTOUT T "Functions on CHANGEDFNSLST: " (SETQ FNS (VGETVAL (QUOTE CHANGEDFNSLST)))
T)
(PRINTOUT T "Variables on CHANGEDVARSLST: " (SETQ VARS (VGETVAL (QUOTE CHANGEDVARSLST)))
T)
(PRINTOUT T "Files on FILELST: " (SETQ FILES (VGETVAL (QUOTE FILELST)))
T)
(for FILE in FILES
do [SETQ CHANGES (CDR (VLISTGET (VGETPROPLIST FILE)
(QUOTE FILE]
(IF CHANGES
THEN (PRINTOUT T FILE " has changes " CHANGES T)
(for TYPEPAIR in CHANGES do (SELECTQ (CAR TYPEPAIR)
[FNS (SETQ FNS (UNION FNS (CDR TYPEPAIR]
[VARS (SETQ VARS (UNION VARS
(CDR TYPEPAIR]
(PRINTOUT T "can't save " TYPEPAIR
" changes from "
FILE)))
ELSE (PRINTOUT T FILE " has no changes recorded." T)))
(for FN in (INTERSECTION FNS FNS) when (EQ (QUOTE Y)
(ASKUSER DWIMWAIT (QUOTE Y)
(LIST "save function" FN)
NIL T))
do (VLOADFNS FN))
(for VAR in (INTERSECTION VARS VARS) when (EQ (QUOTE Y)
(ASKUSER DWIMWAIT (QUOTE Y)
(LIST "save variable" VAR)
NIL T))
do (VLOADVARS VAR])
(SHOWREMOTESCREEN
[LAMBDA NIL (* bvm: "18-AUG-83 13:12")
(DECLARE (USEDFREE REMOTESCREEN))
(PROG ((WINDOW REMOTESCREEN)
BITMAPBASE)
(COND
((NOT WINDOW)
(SETQ WINDOW (CREATEW WHOLEDISPLAY NIL 0 T))
(SETQ BITMAPBASE (fetch BITMAPBASE of (fetch (WINDOW SAVE) of WINDOW)))
(COND
([NOT (IEQP (UNFOLD \NP.DISPLAY BYTESPERPAGE)
(TIMES SCREENHEIGHT (QUOTIENT SCREENWIDTH BITSPERBYTE]
(ERROR "Confused about screen size")))
[COND
[(LISTP VMEMFILE)
(for I from \VP.DISPLAY to (IPLUS \VP.DISPLAY \NP.DISPLAY -1)
do (REMOTEPMAP VMEMFILE I BITMAPBASE)
(SETQ BITMAPBASE (\ADDBASE BITMAPBASE WORDSPERPAGE]
(T (SETVMPTR (UNFOLD \VP.DISPLAY WORDSPERPAGE))
(\BINS (GETSTREAM VMEMFILE)
BITMAPBASE 0 (UNFOLD \NP.DISPLAY BYTESPERPAGE)
(TIMES SCREENHEIGHT (QUOTIENT SCREENWIDTH BITSPERBYTE]
(SETQ REMOTESCREEN WINDOW)))
(OPENW WINDOW)
(until (OR (READP T)
(NOT (OPENWP WINDOW)))
do (TOTOPW WINDOW)
(BLOCK))
(COND
((OPENWP WINDOW)
(CLOSEW WINDOW])
(VGETVAL
[LAMBDA (X) (* lmm "20-AUG-81 12:51")
(V\UNCOPY (VGETTOPVAL X])
(VINSPECT
(LAMBDA (HI LO ASTYPE) (* kbr: " 8-Aug-85 19:05")
(* Virtual inspector. *)
(PROG (PTR OBJECT D FIELDSPEC WINDOW) (* TBW: This is not completely generalized.
*)
(SETQ PTR (VVAG2 HI LO))
(SETQ OBJECT (NCREATE ASTYPE))
(FOR DESCRIPTOR IN (GETDESCRIPTORS ASTYPE)
DO (SETQ D (CADR DESCRIPTOR))
(SETQ FIELDSPEC (CADDR DESCRIPTOR))
(COND
((EQ FIELDSPEC (QUOTE POINTER))
(\PUTBASEPTR OBJECT D (V\UNCOPY (VGETBASEPTR PTR D))))
((EQUAL FIELDSPEC (QUOTE (BITS . 15)))
(\PUTBASE OBJECT D (VGETBASE PTR D)))))
(SETQ WINDOW (INSPECT OBJECT ASTYPE))
(WINDOWPROP WINDOW (QUOTE TITLE)
(CONCAT (V\UNCOPY PTR)
" Inspector"))
(RETURN WINDOW))))
(VUNSAVEDEF
[LAMBDA (SYMBOL) (* gbn " 8-Aug-85 15:37")
(for (X ←(VGETPROPLIST SYMBOL)) by (V\CDR.UFN (V\CDR.UFN X)) while X
do (SELECTQ (V\UNCOPY (V\CAR.UFN X))
(CODE (PRINTOUT T "Found a CODE property, doing UNSAVEDEF" T)
(VPUTDEFN SYMBOL (LOGOR (VGETBASEPTR0 (VCADR X))
(LLSH 1 37Q)))
(RETURN))
[BROKEN (PRINTOUT T "Found a BROKEN property, unbreaking" T)
(RETURN (VYANKDEF SYMBOL (VCADR X]
[ADVISED (PRINTOUT T "Found a ADVISED property, unbreaking" T)
(RETURN (VYANKDEF SYMBOL (VCADR X]
NIL)
finally (PRINTOUT T "No CODE property found" T])
(VCADR
[LAMBDA (X)
(V\CAR.UFN (V\CDR.UFN X])
(VPUTDEFN
[LAMBDA (SYMBOL VDEF CODEP) (* gbn " 8-Aug-85 15:40")
(LET ((CELL (V\ATOMCELL SYMBOL 12Q)))
(VPUTBASE0 CELL (LRSH VDEF 20Q))
(VPUTBASE0 (ADD1 CELL)
(LOGAND VDEF 177777Q])
(VYANKDEF
[LAMBDA (NEWSYMBOL OLDSYMBOL)
(VPUTDEFN NEWSYMBOL (VGETDEFN OLDSYMBOL])
)
(RPAQ? RDSYSINIT )
(RPAQ? ATOMPAGELST NIL)
(RPAQ? ATOMCACHE NIL)
(RPAQ? NEWATOMARRAY (HASHARRAY 30))
(DEFINEQ
(VATOM
[LAMBDA (N) (* lmm " 6-Aug-84 13:20")
(* Converts a VM atom number into a Lisp atom.)
(PROG ((PAGE (FASSOC (LRSH N 8)
ATOMPAGELST))
ATM FPTR)
(COND
((AND PAGE (NEQ (SETQ ATM (FASTELT (CDR PAGE)
(LOGAND N 255)))
0))
(RETURN ATM)))
(SETQ ATM (VUNCOPYATOM N))
[COND
((NULL PAGE)
(SETQ PAGE (CONS (LRSH N 8)
(POINTERARRAY 256 0)))
(COND
(ATOMCACHE (ATTACH PAGE ATOMCACHE))
(T (SETQ ATOMPAGELST (NCONC ATOMPAGELST (SETQ ATOMCACHE (LIST PAGE]
(FASTSETA (CDR PAGE)
(LOGAND N 255)
ATM)
(RETURN ATM])
(VATOMNUMBER
[LAMBDA (AT NEWOK) (* lmm " 6-Aug-84 13:21")
(V\MKATOM AT 1 (NCHARS AT])
)
(DECLARE: EVAL@COMPILE DONTCOPY
(PUTPROPS IEQ DMACRO (= . EQ))
(PUTPROPS IEQ MACRO ((X Y)
(IEQP X Y)))
DONTEVAL@LOAD
(FILESLOAD (LOADCOMP)
VMEM)
)
(FILESLOAD VMEM)
(PUTPROPS READSYS COPYRIGHT ("Xerox Corporation" 1982 1983 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (769 11169 (PRINTSYSOUT 779 . 2524) (READSYS 2526 . 3402) (TELERAID 3404 . 3667) (
VLISTGET 3669 . 3999) (VLOADFNS 4001 . 4690) (VLOADVAR 4692 . 4849) (VLOADVARS 4851 . 5126) (VRAID
5128 . 6096) (VSAVEWORK 6098 . 7635) (SHOWREMOTESCREEN 7637 . 8827) (VGETVAL 8829 . 8962) (VINSPECT
8964 . 9971) (VUNSAVEDEF 9973 . 10727) (VCADR 10729 . 10791) (VPUTDEFN 10793 . 11066) (VYANKDEF 11068
. 11167)) (11291 12202 (VATOM 11301 . 12059) (VATOMNUMBER 12061 . 12200)))))
STOP