(FILECREATED "18-Jun-86 23:02:26" {ERIS}<LISPCORE>LIBRARY>READSYS.;24 21728
changes to: (FNS VSAVEWORK VLOADFUNCTIONS)
(VARS READSYSCOMS)
previous date: "21-Feb-86 19:39:54" {ERIS}<LISPCORE>LIBRARY>READSYS.;23)
(* Copyright (c) 1982, 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT READSYSCOMS)
(RPAQQ READSYSCOMS
((FNS PRINTSYSOUT READSYS TELERAID VLISTGET VLOADFNS VLOADFUNCTIONS VLOADVAR VLOADVARS VRAID
VSAVEWORK SHOWREMOTESCREEN VGETVAL VINSPECT VUNSAVEDEF VCADR VPUTDEFN VYANKDEF)
[INITVARS (RDSYSINIT)
(ATOMPAGELST NIL)
(ATOMCACHE NIL)
(NEWATOMARRAY (HASHARRAY 30))
(TELERAIDPRINTLEVEL (QUOTE (2 . 20]
(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])
(VLOADFUNCTIONS
[LAMBDA (FUNCTIONS) (* gbn "18-Jun-86 22:48")
(for FUNCTION inside FUNCTIONS do (PRINTOUT T "Reading function " FUNCTION)
[SAVEPUT FUNCTION (QUOTE FUNCTIONS)
(LET [(PLIST (V\UNCOPY (VGETPROPLIST FUNCTION]
(COND
([AND (LISTP PLIST)
(LISTP (LISTGET PLIST (QUOTE FUNCTIONS]
(LISTGET PLIST (QUOTE FUNCTIONS]
(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:
"23-Jan-86 18:44")
(DECLARE (SPECVARS RAIDIX ROOTFRAME ALINKS? FRAME# REMOTESCREEN VPRINTLEVEL))
(printout T "virtual RAID" T)
(OR RAIDIX (SETQ RAIDIX 8))
(PROG ((ROOTFRAME)
(ALINKS? T)
(FRAME#)
(REMOTESCREEN)
(VPRINTLEVEL TELERAIDPRINTLEVEL))
(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 (* gbn "18-Jun-86 22:54")
(LET (FNS VARS FUNCTIONS 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))))
(FUNCTIONS (SETQ FUNCTIONS
(UNION FUNCTIONS (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 FUNCTION in (INTERSECTION FUNCTIONS FUNCTIONS)
when (EQ (QUOTE Y)
(ASKUSER DWIMWAIT (QUOTE Y)
(LIST "save function" FUNCTION)
NIL T)) do (VLOADFUNCTIONS FUNCTION))
(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:
"21-Feb-86 19:38")
(DECLARE (USEDFREE REMOTESCREEN))
(RESETLST (PROG ((WINDOW REMOTESCREEN)
HEIGHT WIDTH BITMAPBASE LASTPAGE NWORDS POS NEWPOS MINBOTTOM MINLEFT DELTAX
DELTAY REG X Y)
(COND
((NOT WINDOW)
(SETQ WINDOW (CREATEW [CREATEREGION 0 0 (SETQ WIDTH (VGETVAL (QUOTE
SCREENWIDTH
)))
(SETQ HEIGHT (VGETVAL (QUOTE SCREENHEIGHT]
NIL 0 T)) (* WINDOW has the
dimensions of the remote
screen)
(SETQ BITMAPBASE (fetch BITMAPBASE of (fetch (WINDOW SAVE) of WINDOW)))
(SETQ NWORDS (TIMES HEIGHT (QUOTIENT WIDTH BITSPERWORD)))
(* * Now fetch remote display to local window.
Display memory is contiguous bitmap, and its virtual address is known
constant)
[COND
[(LISTP VMEMFILE) (* Remote machine.
Get it a page at a time
with REMOTEPMAP then
finish any leftover
specially)
(for I from \VP.DISPLAY to [SUB1 (SETQ LASTPAGE (IPLUS \VP.DISPLAY
(FOLDLO NWORDS
WORDSPERPAGE
]
do (REMOTEPMAP VMEMFILE I BITMAPBASE)
(SETQ BITMAPBASE (\ADDBASE BITMAPBASE WORDSPERPAGE)))
(COND
((NEQ (SETQ NWORDS (IMOD NWORDS WORDSPERPAGE))
0) (* Screen bitmap not an
integral number of
pages, so have to get
the rest of it more
carefully)
(LET [(BUF (NCREATE (QUOTE VMEMPAGEP]
(REMOTEPMAP VMEMFILE LASTPAGE BUF)
(\BLT BITMAPBASE BUF NWORDS]
(T (SETVMPTR (UNFOLD \VP.DISPLAY WORDSPERPAGE))
(\BINS (GETSTREAM VMEMFILE)
BITMAPBASE 0 (UNFOLD \NP.DISPLAY BYTESPERPAGE)
(UNFOLD NWORDS BYTESPERWORD]
(SETQ REMOTESCREEN WINDOW))
(T (SETQ WIDTH (WINDOWPROP WINDOW (QUOTE WIDTH)))
(SETQ HEIGHT (WINDOWPROP WINDOW (QUOTE HEIGHT)))
(MOVEW WINDOW 0 0)))
(RESETSAVE NIL (LIST (QUOTE CLOSEW)
WINDOW))
(OPENW WINDOW)
[COND
((OR (GREATERP HEIGHT SCREENHEIGHT)
(GREATERP WIDTH SCREENWIDTH)) (* Remote screen is
bigger than local, so
allow user to move
window around)
(SETQ MINLEFT (IMIN 0 (IDIFFERENCE SCREENWIDTH WIDTH)))
(SETQ MINBOTTOM (IMIN 0 (IDIFFERENCE SCREENHEIGHT HEIGHT)))
(SETQ POS (CURSORPOSITION]
(until (OR (READP T)
(NOT (OPENWP WINDOW)))
do (* Keep window on top
until user types
something or explicitly
closes the window)
(COND
((AND POS (NOT (EQUAL (SETQ NEWPOS (CURSORPOSITION NIL NIL NEWPOS))
POS))) (* Track mouse while
button down)
[COND
((LASTMOUSESTATE (OR LEFT MIDDLE))
(SETQ REG (WINDOWPROP WINDOW (QUOTE REGION)))
(SETQ X (fetch (REGION LEFT) of REG))
(SETQ Y (fetch (REGION BOTTOM) of REG))
(SETQ DELTAX
(IDIFFERENCE [IMAX MINLEFT
(IMIN 0 (IPLUS X (IDIFFERENCE (fetch XCOORD
of NEWPOS)
(fetch XCOORD
of POS]
X))
(SETQ DELTAY
(IDIFFERENCE [IMAX MINBOTTOM
(IMIN 0 (IPLUS Y (IDIFFERENCE (fetch YCOORD
of NEWPOS)
(fetch YCOORD
of POS]
Y))
(COND
((OR (NEQ DELTAX 0)
(NEQ DELTAY 0)) (* Bound the movement so
that window always
covers our screen.
Don't call MOVEW if no
actual movement, so as
to avoid excess flashing)
(RELMOVEW WINDOW (create POSITION
XCOORD ← DELTAX
YCOORD ← DELTAY]
(swap POS NEWPOS)))
(TOTOPW WINDOW)
(BLOCK])
(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))
(RPAQ? TELERAIDPRINTLEVEL (QUOTE (2 . 20)))
(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 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1042 20344 (PRINTSYSOUT 1052 . 2797) (READSYS 2799 . 3675) (TELERAID 3677 . 3940) (
VLISTGET 3942 . 4272) (VLOADFNS 4274 . 4963) (VLOADFUNCTIONS 4965 . 5702) (VLOADVAR 5704 . 5861) (
VLOADVARS 5863 . 6138) (VRAID 6140 . 7649) (VSAVEWORK 7651 . 10111) (SHOWREMOTESCREEN 10113 . 18002) (
VGETVAL 18004 . 18137) (VINSPECT 18139 . 19146) (VUNSAVEDEF 19148 . 19902) (VCADR 19904 . 19966) (
VPUTDEFN 19968 . 20241) (VYANKDEF 20243 . 20342)) (20515 21426 (VATOM 20525 . 21283) (VATOMNUMBER
21285 . 21424)))))
STOP