(FILECREATED "16-Jul-86 23:22:17" {ERIS}<LISPCORE>SOURCES>ACODE.;22 41645
changes to: (FNS CALLSCCODE CCCSUBFN? BROKENDEF PRINTCODE PRINTCODENT CHANGECCODE CCCSCAN
LLBREAK \ALLOC.CODE.BLOCK \SUBFNDEF)
(VARS ACODECOMS)
(MACROS NEXTBYTE CODEBASESETA2 CODEBASELT2 CODEBASESETA CODEBASELT)
previous date: "30-Jun-86 17:36:26" {ERIS}<LISPCORE>SOURCES>ACODE.;21)
(* Copyright (c) 1982, 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT ACODECOMS)
(RPAQQ ACODECOMS ((COMS (* Printing compiled code)
(FNS PRINTCODE PRINTCODENT)
(DECLARE: DONTCOPY (MACROS PCVAR PRINJUMP NEXTBYTE)
(GLOBALVARS \INITSUBRS \PRINTCODE.LEVEL \PRINTCODE.STKSTATE)))
(COMS (* Analyzing compiled code)
(FNS CALLSCCODE RUNION WHOCALLS WHOCALLS1)
(FNS CHANGECCODE CCCSUBFN? \SUBFNDEF CCCSCAN)
(BLOCKS (CALLSCCODE CALLSCCODE RUNION)
(CHANGECCODE CHANGECCODE CCCSUBFN? CCCSCAN))
(DECLARE: DONTCOPY (RECORDS REFMAP)
(MACROS CODEBASELT CODEBASELT2 CODEBASESETA CODEBASESETA2))
(ADDVARS (IGNOREFNS)))
(COMS (* Low-level break)
(FNS LLBREAK BROKENDEF))
[COMS (* for TELERAID)
(DECLARE: DONTCOPY (ADDVARS (RDCOMS (FNS PRINTCODE PRINTCODENT BROKENDEF)
(MACROS PCVAR)
(MACROS CODEBASELT CODEBASELT2
CODEBASESETA CODEBASESETA2))
(EXPANDMACROFNS NEXTBYTE PCVAR PRINJUMP CODEBASELT
CODEBASELT2 CODEBASESETA CODEBASESETA2]
(COMS (* reference to opcodes symbolically)
(FNS PRINTOPCODES)
(GLOBALVARS \OPCODES))
(DECLARE: EVAL@COMPILE DONTCOPY (LOCALVARS . T))))
(* Printing compiled code)
(DEFINEQ
(PRINTCODE
[LAMBDA (FN LVFLG RADIX OUTF FIRSTBYTE PC FN.IS.CODEBASE) (* bvm: " 8-Jul-86 16:54")
(* * "WARNING: this code must run `renamed' for TeleRaid Printcode to work. However, it is pretty tricky to get it to run renamed because some of the constructs run in local space (e.g., the CARs and CADRs of the code list) and many run in remote space (e.g., the bytes of the code).
It seems that frequently when modifying any part of PRINTCODE the renamed version stops working, so *BEWARE* and make sure you test any edits by doing a (DORENAME 'R) and checking TeleRaid's CodePrint command, as well as in normal PRINTCODE mode.")
(* * "All the CODEARRAY accesses are equivalent to FNHEADER accesses indirected thru the CCODEP object. The reason it is done this awful crufty way, instead of fetching the code base, is so this works in Interlisp-10 as well. Might want to punt that now.")
(DECLARE (SPECVARS OUTF))
(OR RADIX (SETQ RADIX 8))
(LET
([CODEBASE (COND
(FN.IS.CODEBASE FN)
(T (OR (\GET-COMPILED-CODE-BASE FN)
[AND (LITATOM FN)
(\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)) (* "Used by PRINTCODENT")
(PROGN (PRIN1 " stkmin: " OUTF)
(PRINTNUM I6 (fetch (FNHEADER STKMIN) of CODEBASE)
OUTF)
(PRIN1 " na: " OUTF)
(PRINTNUM I4 (fetch (FNHEADER NA) of CODEBASE)
OUTF)
(PRIN1 " pv: " OUTF)
(PRINTNUM I4 (fetch (FNHEADER PV) of CODEBASE)
OUTF)
(PRIN1 " startpc: " OUTF)
(PRINTNUM I4 (SETQ STARTPC (fetch (FNHEADER STARTPC) of CODEBASE))
OUTF)
(PRIN1 " argtype: " OUTF)
(PRIN1 (fetch (FNHEADER ARGTYPE) of CODEBASE)
OUTF)
(PRIN1 " framename: " OUTF)
(PRIN1 (1ST (fetch (FNHEADER FRAMENAME) of CODEBASE))
OUTF)
(PRIN1 " ntsize: " OUTF)
(PRINTNUM I4 (SETQ NTSIZE (fetch (FNHEADER NTSIZE) of CODEBASE))
OUTF)
(PRIN1 " nlocals: " OUTF)
(PRINTNUM I4 (fetch (FNHEADER NLOCALS) of CODEBASE)
OUTF)
(TERPRI OUTF))
(for I from 0 by BYTESPERWORD while (ILESSP I (UNFOLD (fetch (FNHEADER OVERHEADWORDS)
of T)
BYTESPERWORD))
do (PRINTNUM I4 I OUTF)
(PRIN1 ": " OUTF)
(PRINTNUM I6 (CODEBASELT2 CODEBASE I)
OUTF)
(TERPRI OUTF))
(PRINTCODENT "name table: " (UNFOLD (fetch (FNHEADER OVERHEADWORDS) of T)
BYTESPERWORD)
(UNFOLD NTSIZE BYTESPERWORD))
[COND
((GREATERP [SETQ NTSIZE (IDIFFERENCE STARTPC (SETQ TEMP
(IPLUS (UNFOLD (fetch (FNHEADER OVERHEADWORDS)
of T)
BYTESPERWORD)
(COND
((EQ NTSIZE 0)
(*
"No nametable, but there's a quad of zeros there anyway")
BYTESPERQUAD)
(T (UNFOLD NTSIZE (ITIMES 2
BYTESPERWORD
]
WORDSPERCELL)
(PRINTCODENT "Local args: " TEMP (FOLDLO NTSIZE 2]
(printout OUTF T "----" T)
(PROG ((CODELOC STARTPC)
(LEVEL (AND LVFLG 0))
B B1 B2 B3 FN LEN LEVADJ STK)
[ALLOCAL (COND
(LEVEL (SETUPHASHARRAY (QUOTE \PRINTCODE.LEVEL))
(SETUPHASHARRAY (QUOTE \PRINTCODE.STKSTATE))
(CLRHASH \PRINTCODE.LEVEL)
(CLRHASH \PRINTCODE.STKSTATE]
LP (COND
((AND PC (IGEQ CODELOC PC)) (* "Caller asked to highlight this spot")
(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 (*
"Don't print code, but quietly process LEVEL etc")
(SETQ TAG (\FINDOP (NEXTBYTE)))
(SELECTQ (ALLOCAL (OR (fetch OPPRINT of TAG)
(fetch OPCODENAME of TAG)))
(-X- (TERPRI OUTF)
(RETURN))
(BIND [ALLOCAL (COND
(LEVEL (push STK (SETQ LEVEL
(ADD1 (IDIFFERENCE LEVEL
(LOGAND (CODEBASELT CODEBASE
CODELOC)
15])
(UNBIND [ALLOCAL (AND LEVEL (SETQ LEVEL (pop STK])
(DUNBIND [ALLOCAL (AND LEVEL (SETQ LEVEL (SUB1 (pop STK])
(RETURN (SETQ LEVEL))
(SUBRCALL [AND LEVEL (SETQ LEVEL (ADD1 (IDIFFERENCE LEVEL (CODEBASELT
CODEBASE
(ADD1 CODELOC])
NIL)
[COND
([AND LEVEL (ALLOCAL (SETQ LEVADJ (fetch LEVADJ of TAG]
[ALLOCAL (COND
((LISTP LEVADJ)
(SETQ LEVADJ (CAR LEVADJ]
(SELECTQ LEVADJ
(FNX (add LEVEL (IDIFFERENCE 1 (CODEBASELT CODEBASE CODELOC))))
(POP.N (SETQ LEVEL (IDIFFERENCE LEVEL (CODEBASELT CODEBASE CODELOC))))
(JUMP (SETQ LEVEL))
((CJUMP NCJUMP)
(add LEVEL -1))
(COND
((NUMBERP LEVADJ)
(add LEVEL LEVADJ]
(ALLOCAL (add CODELOC (fetch OPNARGS of TAG)))
(GO LP)))
[SETQ LEN (LOCAL (fetch OPNARGS of (SETQ TAG (\FINDOP (SETQ B (NEXTBYTE]
(PRINTNUM I4 B OUTF)
(COND
((IGREATERP LEN 0)
(PRINTNUM I4 (SETQ B1 (NEXTBYTE))
OUTF)))
(COND
((IGREATERP LEN 1)
(PRINTNUM I4 (SETQ B2 (NEXTBYTE))
OUTF)))
(AND (IGREATERP LEN 2)
(PRINTNUM I4 (SETQ B3 (NEXTBYTE))
OUTF))
[ALLOCAL (PROGN (printout OUTF 30 (fetch OPCODENAME of TAG))
(SETQ OP# (fetch OP# of TAG))
(SETQ LEVADJ (fetch LEVADJ of TAG]
[ALLOCAL (COND
((LISTP OP#)
(SETQ OP# (CAR OP#]
[SELECTQ [SETQ TAG (ALLOCAL (OR (fetch OPPRINT of TAG)
(fetch OPCODENAME of TAG]
(-X- (TERPRI OUTF)
(RETURN))
(IVAR (TAB 40 NIL OUTF)
(PCVAR (SELECTQ LEN
(0 (IDIFFERENCE B OP#))
(LRSH B1 1))
IVARS
(QUOTE ivar)))
(PVAR (TAB 40 NIL OUTF)
(PCVAR (SELECTQ LEN
(0 (IDIFFERENCE B OP#))
(LRSH B1 1))
PVARS
(QUOTE pvar)))
(FVAR (TAB 40 NIL OUTF)
(PCVAR (SELECTQ LEN
(0 (IDIFFERENCE B OP#))
(LRSH B1 1))
FVARS
(QUOTE fvar)))
(JUMP (PRINJUMP (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 (PRINJUMP (COND
((IGEQ B1 128)
(IDIFFERENCE B1 256))
(T B1))))
(FN (SETQ B (IPLUS (LLSH B1 8)
B2))
(printout OUTF 40 (\INDEXATOMDEF B)))
(BIND (TAB 40 NIL OUTF)
[ALLOCAL (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 [PRINJUMP (IPLUS (LLSH B1 8)
B2
(COND
((IGREATERP B1 127)
-65536)
(T 0])
(ATOM (printout OUTF 40 .P2 (\INDEXATOMPNAME (IPLUS (LLSH B1 8)
B2))))
(GCONST [printout OUTF 40 .P2 (1ST (\VAG2 B1 (IPLUS (LLSH B2 8)
B3])
(FNX (printout OUTF "(" B1 ")" 40 (\INDEXATOMDEF (IPLUS (LLSH B2 8)
B3))))
(TYPEP (printout OUTF "(" (OR (\TYPENAMEFROMNUMBER B1)
(QUOTE ?))
")"))
(UNBIND [ALLOCAL (AND LEVEL (SETQ LEVEL (pop STK])
(DUNBIND [ALLOCAL (AND LEVEL (SETQ LEVEL (SUB1 (pop STK])
(RETURN (SETQ LEVEL))
(SUBRCALL [ALLOCAL (printout OUTF 40 .P2 (CAR (NTH \INITSUBRS (ADD1 B1]
[AND LEVEL (SETQ LEVEL (ADD1 (IDIFFERENCE LEVEL B2])
(ALLOCAL (COND
((LISTP TAG)
(printout OUTF 40 (CAR (NTH TAG (ADD1 B1]
(TERPRI OUTF)
[COND
((AND LEVEL LEVADJ)
(SELECTQ LEVADJ
(FNX (add LEVEL (IDIFFERENCE 1 B1)))
(POP.N (SETQ LEVEL (IDIFFERENCE LEVEL B1)))
(JUMP (SETQ LEVEL))
((CJUMP NCJUMP)
(add LEVEL -1))
(COND
((NUMBERP LEVADJ)
(add LEVEL LEVADJ]
(GO LP])
(PRINTCODENT
[LAMBDA (STR START1 START2)
(DECLARE (USEDFREE CODEBASE IVARS PVARS FVARS I4 I6 OUTF))
(* bvm: " 8-Jul-86 16:53")
(LET (NAME TAG)
(COND
((ILESSP START1 (SETQ START2 (IPLUS START2 START1)))
(printout OUTF STR T)
(for NT1 from START1 by BYTESPERWORD while (ILESSP NT1 START2) as NT2 from START2
by BYTESPERWORD do (PRINTNUM I4 NT1 OUTF)
(PRIN1 ": " OUTF)
(PRINTNUM I6 (CODEBASELT2 CODEBASE NT1)
OUTF)
(SPACES 3 OUTF)
(PRINTNUM I4 NT2 OUTF)
(PRIN1 ": " OUTF)
(PRINTNUM I6 (CODEBASELT2 CODEBASE NT2)
OUTF)
(COND
((SETQ NAME (\INDEXATOMVAL (CODEBASELT2 CODEBASE NT1)))
(SETQ TAG (CODEBASELT CODEBASE (ADD1 NT2)))
(printout OUTF .SP 5
(SELECTC (CODEBASELT CODEBASE NT2)
((LRSH IVARCODE 8)
(ALLOCAL (push IVARS (LIST TAG NAME)))
(QUOTE IVAR))
((LRSH PVARCODE 8)
(ALLOCAL (push PVARS (LIST TAG NAME)))
(QUOTE PVAR))
(PROGN (ALLOCAL (push FVARS (LIST TAG NAME)))
(QUOTE FVAR)))
" " TAG ": " NAME)))
(TERPRI OUTF])
)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
[PUTPROPS PCVAR MACRO ((IND LST NAME)
(* lmm "11-AUG-81 22:27")
(ALLOCAL (PROG NIL (PRIN2 [CADR (OR (ASSOC IND LST)
(RETURN (printout OUTF "[" NAME IND "]"]
OUTF]
[PUTPROPS PRINJUMP MACRO (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]
[PUTPROPS NEXTBYTE MACRO (NIL (CODEBASELT CODEBASE (PROG1 CODELOC (add CODELOC 1]
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \INITSUBRS \PRINTCODE.LEVEL \PRINTCODE.STKSTATE)
)
)
(* Analyzing compiled code)
(DEFINEQ
(CALLSCCODE
[LAMBDA (DEF OPTION FNAPPLY) (* DECLARATIONS: (RECORD RESULT
(LNCALLED CALLED BOUND USEDFREE
GLOBALS)))
(* bvm: "11-Jul-86 16:45")
(* * "Analyze DEF for function calls and variable references. Action depends on OPTION and FNAPPLY as follows:
OPTION = NIL means return value of CALLSCCODE as described in IRM
OPTION = T means return list of free variable references
OPTION = FNAPPLY means apply FNAPPLY to each function called and a flag BOUND, USEDFREE or GLOBALS and return nothing
OPTION = VARAPPLY means apply FNAPPLY to each variable references and return nothing")
(PROG ((CODEBASE (OR (\GET-COMPILED-CODE-BASE DEF)
(ERROR DEF "not compiled code")))
USEDFREE BOUND GLOBALS CALLED LNCALLED NTSIZE STARTPC NAME TAG)
(SETQ STARTPC (fetch (FNHEADER STARTPC) of CODEBASE))
[COND
((NEQ OPTION (QUOTE FNAPPLY)) (* "Get variables out of name table")
(SETQ NTSIZE (fetch (FNHEADER NTSIZE) of CODEBASE))
(for NT1 from (UNFOLD (fetch (FNHEADER OVERHEADWORDS) of T)
BYTESPERWORD) by BYTESPERWORD as NT2
from (UNFOLD (IPLUS (fetch (FNHEADER OVERHEADWORDS) of T)
NTSIZE)
BYTESPERWORD) by BYTESPERWORD
do (OR (SETQ NAME (\INDEXATOMVAL (CODEBASELT2 CODEBASE NT1)))
(RETURN)) (*
"Top two bits of the entry indicate kind of name: 00 = IVAR, 10 = PVAR, 11 = FVAR")
(SELECTQ OPTION
(VARAPPLY (SPREADAPPLY* FNAPPLY NAME (SELECTQ (CODEBASELT CODEBASE NT2)
((0 128)
(QUOTE BOUND))
(QUOTE USEDFREE))))
(SELECTQ (CODEBASELT CODEBASE NT2)
((0 128)
(pushnew BOUND NAME))
(pushnew USEDFREE NAME]
(PROG ((CODELOC STARTPC)
B B1 B2 B3 FN LEN)
LP (SETQ B (NEXTBYTE))
(SETQ B1 (AND [ILESSP 0 (SETQ LEN (fetch OPNARGS of (SETQ TAG (\FINDOP B]
(NEXTBYTE)))
(SETQ B2 (AND (ILESSP 1 LEN)
(NEXTBYTE)))
(SETQ B3 (AND (ILESSP 2 LEN)
(NEXTBYTE)))
(SELECTQ (fetch OPCODENAME of TAG)
(-X- (RETURN))
((FN0 FN1 FN2 FN3 FN4)
(SETQ NAME (\INDEXATOMDEF (IPLUS (LLSH B1 8)
B2)))
(GO FN))
(FNX (SETQ NAME (\INDEXATOMDEF (IPLUS (LLSH B2 8)
B3)))
(GO FN))
((GVAR GVAR←)
[SELECTQ OPTION
(FNAPPLY)
(VARAPPLY (APPLY* FNAPPLY (\INDEXATOMVAL (IPLUS (LLSH B1 8)
B2))
(QUOTE GLOBALS)))
(pushnew GLOBALS (\INDEXATOMVAL (IPLUS (LLSH B1 8)
B2])
NIL)
(GO LP)
FN [SELECTQ OPTION
(FNAPPLY (APPLY* FNAPPLY NAME (QUOTE CALLED)))
(VARAPPLY)
(COND
((FMEMB NAME IGNOREFNS) (* "Don't show calls to these")
)
[(SETQ B (\SUBFNDEF NAME)) (*
"Compiled subfunction, recursively analyze it")
(COND
((SETQ B (CALLSCCODE B OPTION))
(COND
((EQ OPTION T) (* "Just got free variables back")
(SETQ USEDFREE (RUNION B USEDFREE)))
(T (SETQ LNCALLED (RUNION (fetch LNCALLED of B)
LNCALLED))
(SETQ BOUND (RUNION (fetch BOUND of B)
BOUND))
(SETQ USEDFREE (RUNION (fetch USEDFREE of B)
USEDFREE))
(SETQ GLOBALS (RUNION (fetch GLOBALS of B)
GLOBALS))
(SETQ CALLED (RUNION (fetch CALLED of B)
CALLED]
((EQ OPTION T) (* "Only look at vars")
)
(T (pushnew CALLED NAME]
(GO LP))
(RETURN (SELECTQ OPTION
((FNAPPLY VARAPPLY)
NIL)
(T (* "All free var references")
(RUNION USEDFREE GLOBALS))
(create RESULT
LNCALLED ← (REVERSE LNCALLED)
CALLED ← (REVERSE CALLED)
BOUND ← (REVERSE BOUND)
USEDFREE ← (REVERSE USEDFREE)
GLOBALS ← (REVERSE GLOBALS])
(RUNION
[LAMBDA (L1 L2) (* bvm: "14-Mar-86 14:27")
(* * Fast UNION using EQ)
(for X in L1 unless (FMEMB X L2) do (push L2 X))
L2])
(WHOCALLS
[LAMBDA (CALLEE USAGE)
(DECLARE (SPECVARS CALLEE CALLTYPE VAL)) (* bvm: "14-Mar-86 10:44")
(PROG ((CALLTYPE (SELECTQ USAGE
((USES VAR VARS)
(QUOTE VARAPPLY))
(QUOTE FNAPPLY)))
VAL)
(MAPATOMS (FUNCTION WHOCALLS1))
(RETURN VAL])
(WHOCALLS1
[LAMBDA (FN)
(DECLARE (USEDFREE VAL CALLEE CALLTYPE)) (* bvm: "14-Mar-86 10:43")
(* * If FN uses CALLEE in the CALLTYPE manner, add FN to the list VAL)
(COND
((CCODEP FN)
[CALLSCCODE FN CALLTYPE (FUNCTION (LAMBDA (CALLED FLG)
(COND
((COND
((LISTP CALLEE)
(MEMB CALLED CALLEE))
(T (EQ CALLED CALLEE)))
(printout T FN ", ")
(push VAL FN)
(RETFROM (QUOTE WHOCALLS1]
(BLOCK])
)
(DEFINEQ
(CHANGECCODE
[LAMBDA (NEWREF OLDREF FN) (* bvm: " 8-Jul-86 17:02")
(* * "A reference map is a list (`refmap' E1 ... EN), where each element E has the form (CODEARRAY NAMELOCS CONSTLOCS DEFLOCS PTRLOCS). The first element is for the main function, and further elements are for compiler-generated subfunctions. Each LOCS list is a list of byte locations in the code to be fixed up in the indicated way (i.e. VALINDEX, LOLOC, DEFINDEX, and full 24-bit pointer in GCONST format respectively).")
(PROG ((SEAL (QUOTE "refmap"))
DEF MAP)
(SETQ DEF (OR (\GET-COMPILED-CODE-BASE FN)
(RETURN)))
[COND
[(NEQ (CAR (LISTP OLDREF))
SEAL) (*
"Construct a reference map for OLDREF in DEF")
(COND
((EQ [PROG1 OLDREF (SETQ OLDREF (CONS SEAL (CCCSCAN DEF OLDREF]
NEWREF) (*
"No change, just return reference map")
(RETURN OLDREF]
((NEQ (fetch (REFMAP CODEARRAY) of (CADR OLDREF))
DEF)
(ERROR (QUOTE "Inconsistent reference map")
(CONS OLDREF FN] (*
"Change all references in the map OLDREF to refer to NEWREF")
[for MAP in (CDR OLDREF) do (SETQ DEF (fetch CODEARRAY of MAP))
[COND
((OR (fetch NAMELOCS of MAP)
(fetch CONSTLOCS of MAP)
(fetch DEFLOCS of MAP))
(OR (LITATOM NEWREF)
(ERROR
"Can't changename a symbol to a non-symbol in compiled code"
NEWREF]
(for LC in (fetch NAMELOCS of MAP)
do (CODEBASESETA2 DEF LC (\ATOMVALINDEX NEWREF)))
(for LC in (fetch CONSTLOCS of MAP)
do (CODEBASESETA2 DEF LC (\ATOMPNAMEINDEX NEWREF)))
(for LC in (fetch DEFLOCS of MAP)
do (CODEBASESETA2 DEF LC (\ATOMDEFINDEX NEWREF)))
(for LC in (fetch PTRLOCS of MAP)
do (UNINTERRUPTABLY
(* "should do (\DELREF (\VAG2 (CODELT DEF LC) (CODELT2 DEF (ADD1 LC)))) but can't because references aren't incremented by MOVD")
(\ADDREF NEWREF)
(CODEBASESETA DEF LC (\HILOC NEWREF))
(CODEBASESETA2 DEF (ADD1 LC)
(\LOLOC NEWREF)))]
(RETURN OLDREF])
(CCCSUBFN?
[LAMBDA (X) (* bvm: "11-Jul-86 16:47")
(* Tests if X is fnA0nnn or (fnA0nnn)%, the latter being a possible ERRORSET
form. If so, and X is a compiled function, adds X's analysis to SUBMAPS)
(COND
((SETQ X (\SUBFNDEF X))
(SETQ X (\GET-COMPILED-CODE-BASE X))
(OR (find Y in SUBMAPS suchthat (EQ (fetch (REFMAP CODEARRAY) of Y)
X))
(SETQ SUBMAPS (NCONC SUBMAPS (CCCSCAN X OLDREF])
(\SUBFNDEF
[LAMBDA (X) (* bvm: " 7-Jul-86 16:31")
(AND (LITATOM X)
(EQ (NTHCHARCODE X -5)
(CHARCODE A))
[NOT (find I C from -4 to -1 suchthat (OR (ILESSP (SETQ C (NTHCHARCODE X I))
(CHARCODE 0))
(IGREATERP C (CHARCODE 9]
(\GET-COMPILED-DEFINITION X])
(CCCSCAN
[LAMBDA (DEF OLDREF)
(DECLARE (SPECVARS SUBMAPS OLDREF)) (* bvm: " 8-Jul-86 17:04")
(PROG ((CA DEF)
CONSTLOCS DEFLOCS PTRLOCS SUBMAPS NAMELOCS TAG B NAME CODELOC)
(SETQ CODELOC (fetch (FNHEADER STARTPC) of CA))
[COND
((LITATOM OLDREF)
(for NT1 from (UNFOLD (fetch (FNHEADER OVERHEADWORDS) of T)
BYTESPERWORD) by BYTESPERWORD
do (OR (SETQ NAME (\INDEXATOMVAL (CODEBASELT2 CA NT1)))
(RETURN))
(AND (EQ NAME OLDREF)
(push NAMELOCS NT1]
LP (SETQ B (CODEBASELT CA CODELOC))
(SETQ TAG (\FINDOP B))
(add CODELOC (fetch OPNARGS of TAG)
1)
(SELECTQ (OR (fetch OPPRINT of TAG)
(fetch OPCODENAME of TAG))
(-X- (RETURN (CONS (create REFMAP
CODEARRAY ← CA
NAMELOCS ← NAMELOCS
CONSTLOCS ← CONSTLOCS
DEFLOCS ← DEFLOCS
PTRLOCS ← PTRLOCS)
SUBMAPS)))
((FN FNX)
(SETQ NAME (CODEBASELT2 CA (IDIFFERENCE CODELOC 2)))
[COND
((AND (LITATOM OLDREF)
(EQ NAME (\ATOMDEFINDEX OLDREF)))
(push DEFLOCS (IDIFFERENCE CODELOC 2]
(CCCSUBFN? (\INDEXATOMDEF NAME)))
(ATOM [COND
((AND (LITATOM OLDREF)
(EQ (CODEBASELT2 CA (IDIFFERENCE CODELOC 2))
(\ATOMPNAMEINDEX OLDREF)))
(push CONSTLOCS (IDIFFERENCE CODELOC 2])
(GCONST [COND
((EQ [SETQ NAME (\VAG2 (CODEBASELT CA (IDIFFERENCE CODELOC 3))
(CODEBASELT2 CA (IDIFFERENCE CODELOC 2]
OLDREF)
(push PTRLOCS (IDIFFERENCE CODELOC 3])
NIL)
(GO LP])
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: CALLSCCODE CALLSCCODE RUNION)
(BLOCK: CHANGECCODE CHANGECCODE CCCSUBFN? CCCSCAN)
]
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(RECORD REFMAP (CODEARRAY NAMELOCS CONSTLOCS DEFLOCS PTRLOCS))
]
(DECLARE: EVAL@COMPILE
(PUTPROPS CODEBASELT MACRO (= . \GETBASEBYTE))
[PUTPROPS CODEBASELT2 MACRO (OPENLAMBDA (DEF LC)
(LOGOR (LLSH (CODEBASELT DEF LC)
BITSPERBYTE)
(CODEBASELT DEF (ADD1 LC]
(PUTPROPS CODEBASESETA MACRO (= . \PUTBASEBYTE))
[PUTPROPS CODEBASESETA2 MACRO (OPENLAMBDA (DEF LC VALUE)
(CODEBASESETA DEF LC (LRSH VALUE BITSPERBYTE))
(CODEBASESETA DEF (ADD1 LC)
(IMOD VALUE (CONSTANT (LLSH 1 BITSPERBYTE]
)
)
(ADDTOVAR IGNOREFNS )
(* Low-level break)
(DEFINEQ
(LLBREAK
[LAMBDA (FN WHEN)
(DECLARE (GLOBALVARS BROKENFNS)) (* bvm: " 8-Jul-86 17:11")
(PROG (NUFN DEF)
[COND
((GETPROP FN (QUOTE BROKEN))
(RESTORE FN (QUOTE BROKEN]
(OR (SETQ DEF (\GET-COMPILED-DEFINITION FN))
(ERROR FN "is not compiled code"))
(/SETATOMVAL (QUOTE BROKENFNS)
(CONS FN BROKENFNS))
(/PUTD [SETQ NUFN (PACK* FN (GENSYM (QUOTE L]
DEF T)
(/PUTPROP FN (QUOTE BROKEN)
NUFN)
(/PUTD FN (create COMPILED-CLOSURE using DEF FNHEADER ← (BROKENDEF DEF WHEN)))
(RETURN FN])
(BROKENDEF
[LAMBDA (DEF CA WHEN) (* bvm: "11-Jul-86 17:15")
(PROG ((CA (\GET-COMPILED-CODE-BASE DEF))
BEFORE AFTER SIZE FIRSTBYTE NEWCA)
(SETQ FIRSTBYTE (fetch (FNHEADER STARTPC) of CA))
(UNLESSRDSYS NIL (PROGN (* For Teleraid, can't create new code
blocks, so can only make break AFTER)
(SETQ NEWCA CA)
(SETQ BEFORE)
(SETQ AFTER T)
(GO DOSCAN)))
(SELECTQ WHEN
(BEFORE (SETQ BEFORE T))
(AFTER (SETQ AFTER T))
((NIL BOTH)
(SETQ BEFORE T)
(SETQ AFTER T))
(LISPERROR "ILLEGAL ARG" WHEN))
(SETQ SIZE (UNFOLD (\#BLOCKDATACELLS CA)
BYTESPERCELL))
(SETQ NEWCA (\ALLOC.CODE.BLOCK (IPLUS (COND
(BEFORE 3)
(T 0))
SIZE)
(CEIL (ADD1 (FOLDHI FIRSTBYTE BYTESPERCELL))
CELLSPERQUAD)))
(COND
(BEFORE (* Need to insert preamble code)
(\MOVEBYTES CA 0 NEWCA 0 FIRSTBYTE) (* Copy header)
[PROGN (* insert call to RAID followed by a
POP)
[CODEBASESETA NEWCA FIRSTBYTE (CAR (\FINDOP (QUOTE 'NIL]
[CODEBASESETA NEWCA (ADD1 FIRSTBYTE)
(CAR (\FINDOP (QUOTE RAID]
(CODEBASESETA NEWCA (IPLUS FIRSTBYTE 2)
(CAR (\FINDOP (QUOTE POP]
(\MOVEBYTES CA FIRSTBYTE NEWCA (IPLUS FIRSTBYTE 3)
(IDIFFERENCE SIZE FIRSTBYTE))
(add FIRSTBYTE 3))
(T (* Just copy verbatim)
(\MOVEBYTES CA 0 NEWCA 0 SIZE)))
(* * NOTE: Need to addref framename if we ever gc code blocks)
DOSCAN
[COND
(AFTER (* Change all RETURNs to \RETURN)
(bind OP do (SELECTQ [fetch (OPCODE OPCODENAME) of (SETQ OP
(\FINDOP (CODEBASELT NEWCA
FIRSTBYTE]
(-X- (RETURN))
(RETURN [CODEBASESETA NEWCA FIRSTBYTE (CAR (\FINDOP (QUOTE
\RETURN
])
NIL)
(add FIRSTBYTE 1 (fetch (OPCODE OPNARGS) of OP]
(RETURN NEWCA])
)
(* for TELERAID)
(DECLARE: DONTCOPY
(ADDTOVAR RDCOMS (FNS PRINTCODE PRINTCODENT BROKENDEF)
(MACROS PCVAR)
(MACROS CODEBASELT CODEBASELT2 CODEBASESETA CODEBASESETA2))
(ADDTOVAR EXPANDMACROFNS NEXTBYTE PCVAR PRINJUMP CODEBASELT CODEBASELT2 CODEBASESETA CODEBASESETA2)
)
(* reference to opcodes symbolically)
(DEFINEQ
(PRINTOPCODES
[LAMBDA (SINGLE) (* lmm "22-Mar-85 10:34")
(printout NIL " #" 9 "name" 24 "len-1" 34 "format" 43 "stk effect" 55 "UFN table entry" T T)
(for X in (COND
(SINGLE (LIST (\FINDOP SINGLE)))
(T \OPCODES)) do [LET ((OP (fetch OP# of X)))
(COND
((LISTP OP)
(printout NIL .I3.8 (CAR OP)
"-"
(CADR OP)))
(T (printout NIL .I3.8 OP]
(TAB 9)
(PRIN1 (fetch OPCODENAME of X))
[COND
((NEQ (fetch OPCODENAME of X)
(QUOTE unused))
(printout NIL 26 (OR (fetch OPNARGS of X)
(QUOTE ?))
35
(OR (fetch OPPRINT of X)
(QUOTE ?))
44
(OR (fetch LEVADJ of X)
(QUOTE ?))
55
(OR (fetch UFNFN of X)
""]
(TERPRI])
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \OPCODES)
)
(DECLARE: EVAL@COMPILE DONTCOPY
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
)
(PUTPROPS ACODE COPYRIGHT ("Xerox Corporation" 1982 1983 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2314 18285 (PRINTCODE 2324 . 16169) (PRINTCODENT 16171 . 18283)) (19490 27283 (
CALLSCCODE 19500 . 25774) (RUNION 25776 . 26017) (WHOCALLS 26019 . 26409) (WHOCALLS1 26411 . 27281)) (
27284 34182 (CHANGECCODE 27294 . 30762) (CCCSUBFN? 30764 . 31364) (\SUBFNDEF 31366 . 31846) (CCCSCAN
31848 . 34180)) (35156 39263 (LLBREAK 35166 . 35866) (BROKENDEF 35868 . 39261)) (39631 41402 (
PRINTOPCODES 39641 . 41400)))))
STOP