(FILECREATED " 5-Jan-84 06:48:26" {PHYLUM}<LISPCORE>SOURCES>ACODE.;25 23459
changes to: (FNS BROKENDEF PRINTOPCODES)
previous date: "31-Dec-83 17:50:07" {PHYLUM}<LISPCORE>SOURCES>ACODE.;24)
(* Copyright (c) 1982, 1983, 1984 by Xerox Corporation)
(PRETTYCOMPRINT ACODECOMS)
(RPAQQ ACODECOMS ((* Printing compiled code)
(FNS DPRINTCODE PRINTCODENT)
(DECLARE: DONTCOPY (MACROS PCVAR PRINJUMP NEXTBYTE))
(* Analyzing compiled code)
(FNS DCALLSCCODE RUNION)
(FNS DCHANGECCODE CCCSUBFN? \SUBFNDEF CCCSCAN)
(P (SELECTQ (SYSTEMTYPE)
(D (MOVD (QUOTE DCALLSCCODE)
(QUOTE CALLSCCODE))
(MOVD (QUOTE DPRINTCODE)
(QUOTE PRINTCODE))
(MOVD (QUOTE DCHANGECCODE)
(QUOTE CHANGECCODE)))
NIL))
(BLOCKS (DCALLSCCODE DCALLSCCODE RUNION (NOLINKFNS . T))
(DCHANGECCODE DCHANGECCODE CCCSUBFN? CCCSCAN))
(DECLARE: DONTCOPY (RECORDS REFMAP))
(ADDVARS (IGNOREFNS))
(FNS LLBREAK BROKENDEF)
(DECLARE: DONTCOPY (ADDVARS (RDCOMS (FNS DPRINTCODE PRINTCODENT BROKENDEF)
(MACROS PCVAR))
(RD.SUBFNS (MCODEP . VGETDEFN)
(CODELT . VGETBASEBYTE))
(EXPANDMACROFNS NEXTBYTE PCVAR PRINJUMP)))
(* reference to opcodes symbolically)
(FNS PRINTOPCODES)
(GLOBALVARS \OPCODES)
(DECLARE: EVAL@COMPILE DONTCOPY (P (CHECKIMPORTS (QUOTE (LLCODE RENAMEMACROS
MODARITH))
T))
(LOCALVARS . T))))
(* Printing compiled code)
(DEFINEQ
(DPRINTCODE
(LAMBDA (FN LVFLG RADIX OUTF FIRSTBYTE) (* JonL "16-Dec-83 22:30")
(DECLARE (GLOBALVARS \INITSUBRS FVA STKA)
(SPECVARS OUTF))
(OR RADIX (SETQ RADIX 8))
(PROG ((CA (OR (MCODEP FN)
(AND (LITATOM FN)
(MCODEP (GETPROP FN (QUOTE CODE))))
(ERROR FN "not compiled code")))
PVARS FVARS IVARS NTSIZE STARTPC TAG TEMP OP# (REMOTEFLG (UNLESSRDSYS NIL T))
(I4 (NUMFORMATCODE (LIST (QUOTE FIX)
4 RADIX)))
(I6 (NUMFORMATCODE (LIST (QUOTE FIX)
6 RADIX))))
(DECLARE (SPECVARS CA IVARS PVARS FVARS I4 I6))
(PROGN (PRIN1 " stkmin: " OUTF)
(PRINTNUM I6 (fetch (CODEARRAY STKMIN) of CA)
OUTF)
(PRIN1 " na: " OUTF)
(PRINTNUM I4 (fetch (CODEARRAY NA) of CA)
OUTF)
(PRIN1 " pv: " OUTF)
(PRINTNUM I4 (fetch (CODEARRAY PV) of CA)
OUTF)
(PRIN1 " startpc: " OUTF)
(PRINTNUM I4 (SETQ STARTPC (fetch (CODEARRAY STARTPC) of CA))
OUTF)
(PRIN1 " argtype: " OUTF)
(PRIN1 (fetch (CODEARRAY ARGTYPE) of CA)
OUTF)
(PRIN1 " framename: " OUTF)
(PRIN1 (1ST (fetch (CODEARRAY FRAMENAME) of CA))
OUTF)
(PRIN1 " ntsize: " OUTF)
(PRINTNUM I4 (SETQ NTSIZE (fetch (CODEARRAY NTSIZE) of CA))
OUTF)
(PRIN1 " nlocals: " OUTF)
(PRINTNUM I4 (fetch (CODEARRAY NLOCALS) of CA)
OUTF)
(TERPRI OUTF))
(for I from 0 by BYTESPERWORD while (ILESSP I (UNFOLD (fetch (CODEARRAY OVERHEADWORDS)
of T)
BYTESPERWORD))
do (PRINTNUM I4 I OUTF)
(PRIN1 ": " OUTF)
(PRINTNUM I6 (CODELT2 CA I)
OUTF)
(TERPRI OUTF))
(PRINTCODENT "name table: " (UNFOLD (fetch (CODEARRAY OVERHEADWORDS) of T)
BYTESPERWORD)
(UNFOLD NTSIZE BYTESPERWORD))
(PRINTCODENT "Local args: " (SETQ TEMP (IPLUS (UNFOLD (fetch (CODEARRAY OVERHEADWORDS)
of T)
BYTESPERWORD)
(COND
((ZEROP NTSIZE)
(* No nametable, but there's a quad of zeros there
anyway)
BYTESPERQUAD)
(T (UNFOLD NTSIZE (ITIMES 2 BYTESPERWORD))))
))
(FOLDLO (IDIFFERENCE STARTPC TEMP)
2))
(printout OUTF T "----" T)
(PROG ((CODELOC STARTPC)
B B1 B2 B3 FN LEN LEVADJ STK (LEVEL (AND LVFLG 0)))
(ALLOCAL (COND
(LEVEL (SETUPHASHARRAY (QUOTE FVA))
(SETUPHASHARRAY (QUOTE STKA))
(CLRHASH FVA)
(CLRHASH STKA))))
LP (COND
((OR (NULL FIRSTBYTE)
(IGEQ CODELOC FIRSTBYTE))
(PRINTNUM I4 CODELOC OUTF)
(PRIN1 ": " OUTF)
(COND
(LVFLG (SETQ TEMP (GETHASH CODELOC FVA))
(COND
(LEVEL (COND
((AND TEMP (OR (NEQ LEVEL TEMP)
(NOT (EQUAL STK (GETHASH CODELOC STKA)))))
(PRIN1 "*" OUTF))))
(T (SETQ LEVEL TEMP)
(SETQ STK (GETHASH CODELOC STKA))))
(COND
(LEVEL (TAB 7 NIL OUTF)
(PRINTNUM I4 LEVEL OUTF)))))
(TAB 12 NIL OUTF))
(T (* 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
(CODELT CA 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
(CODELT CA (ADD1 CODELOC)))))))
NIL)
(COND
((AND LEVEL (ALLOCAL (SETQ LEVADJ (fetch LEVADJ of TAG))))
(SELECTQ LEVADJ
(FNX (add LEVEL (IDIFFERENCE 1 (CODELT CA 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))))
(SELECTQ (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 "(" (COND
((EQ B1 \ARRAYP)
(QUOTE ARRAYP))
((EQ B1 \STRINGP)
(QUOTE STRINGP))
((EQ B1 \FLOATP)
(QUOTE FLOATP))
((EQ B1 \SMALLP)
(QUOTE SMALLP))
((EQ B1 \STACKP)
(QUOTE STACKP))
((EQ B1 \FIXP)
(QUOTE \FIXP))
((EQ B1 \LITATOM)
(QUOTE \LITATOM))
(T (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)))))
NIL)
(TERPRI OUTF)
(COND
((AND LEVEL LEVADJ)
(SELECTQ LEVADJ
(FNX (add LEVEL (IDIFFERENCE 1 B1)))
(JUMP (SETQ LEVEL))
((CJUMP NCJUMP)
(add LEVEL -1))
(COND
((NUMBERP LEVADJ)
(add LEVEL LEVADJ))))))
(GO LP)))))
(PRINTCODENT
[LAMBDA (STR START1 START2) (* lmm "13-FEB-83 14:27")
(DECLARE (USEDFREE CA IVARS PVARS FVARS I4 I6 OUTF))
(PROG (NAME TAG)
(COND
((ILESSP START1 (SETQ START2 (IPLUS START2 START1)))
(printout OUTF STR T)
(for NT1 from START1 by BYTESPERWORD while (ILESSP NT1 START2) as NT2 from START2
by BYTESPERWORD
do (PRINTNUM I4 NT1 OUTF)
(PRIN1 ": " OUTF)
(PRINTNUM I6 (CODELT2 CA NT1)
OUTF)
(SPACES 3 OUTF)
(PRINTNUM I4 NT2 OUTF)
(PRIN1 ": " OUTF)
(PRINTNUM I6 (CODELT2 CA NT2)
OUTF)
(COND
((SETQ NAME (\INDEXATOMVAL (CODELT2 CA NT1)))
(SETQ TAG (CODELT CA (ADD1 NT2)))
(printout OUTF .SP 5 (SELECTC (CODELT CA NT2)
((LRSH IVARCODE 10Q)
(push IVARS (LIST TAG NAME))
(QUOTE IVAR))
((LRSH PVARCODE 10Q)
(push PVARS (LIST TAG NAME))
(QUOTE PVAR))
(PROGN (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")
(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))
FVA)
(PUTHASH N STK STKA)))))
(PUTPROPS NEXTBYTE MACRO (NIL
(CODELT CA (PROG1 CODELOC (add CODELOC 1)))))
)
)
(* Analyzing compiled code)
(DEFINEQ
(DCALLSCCODE
(LAMBDA (DEF VARSFLG) (* DECLARATIONS: (RECORD RESULT
(LNCALLED CALLED BOUND USEDFREE GLOBALS)))
(* JonL "31-Dec-83 17:35")
(PROG ((CA (OR (MCODEP DEF)
(ERROR DEF "not compiled code")))
USEDFREE BOUND GLOBALS CALLED LNCALLED NTSIZE STARTPC NAME TAG)
(SETQ STARTPC (fetch (CODEARRAY STARTPC) of CA))
(SETQ NTSIZE (fetch (CODEARRAY NTSIZE) of CA))
(for NT1 from (UNFOLD (fetch (CODEARRAY OVERHEADWORDS) of T)
BYTESPERWORD)
by (PROG1 BYTESPERWORD (* Comment PPLossage)) as NT2
from (UNFOLD (IPLUS (fetch (CODEARRAY OVERHEADWORDS) of T)
NTSIZE)
BYTESPERWORD)
by (PROG1 BYTESPERWORD (* Comment PPLossage))
do (OR (SETQ NAME (\INDEXATOMVAL (CODELT2 CA NT1)))
(RETURN))
(SELECTQ (CODELT CA NT2)
(0 (pushnew BOUND NAME))
(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←)
(pushnew GLOBALS (\INDEXATOMVAL (IPLUS (LLSH B1 8)
B2))))
NIL)
(GO LP)
FN (COND
((NOT (FMEMB NAME IGNOREFNS))
(COND
((SETQ B (\SUBFNDEF NAME))
(SETQ B (DCALLSCCODE B))
(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)))
(T (pushnew CALLED NAME)))))
(GO LP))
(RETURN (create RESULT
LNCALLED ←(REVERSE LNCALLED)
CALLED ←(REVERSE CALLED)
BOUND ←(REVERSE BOUND)
USEDFREE ←(REVERSE USEDFREE)
GLOBALS ←(REVERSE GLOBALS))))))
(RUNION
[LAMBDA (L1 L2) (* lmm "11-MAR-81 23:07")
(COND
((NULL L1)
L2)
((FMEMB (CAR L1)
L2)
(RUNION (CDR L1)
L2))
(T (RUNION (CDR L1)
(CONS (CAR L1)
L2])
)
(DEFINEQ
(DCHANGECCODE
[LAMBDA (NEWREF OLDREF FN) (* lmm "13-FEB-83 16:29")
(* 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 (DEF (SEAL (QUOTE "refmap"))
MAP)
(SETQ DEF (OR (MCODEP 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]
((NOT (EQP (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))
(for LC in (fetch NAMELOCS of MAP) do (CODESETA2 DEF LC (\ATOMVALINDEX NEWREF)))
(for LC in (fetch CONSTLOCS of MAP) do (CODESETA2 DEF LC (\ATOMPNAMEINDEX NEWREF)))
(for LC in (fetch DEFLOCS of MAP) do (CODESETA2 DEF LC (\ATOMDEFINDEX NEWREF)))
(for LC in (fetch PTRLOCS of MAP) do (UNINTERRUPTABLY
[\DELREF (\VAG2 (CODELT DEF LC)
(CODELT2 DEF (ADD1 LC]
(\ADDREF NEWREF)
(CODESETA DEF LC (\HILOC NEWREF))
(CODESETA2 DEF (ADD1 LC)
(\LOLOC NEWREF)))]
(RETURN OLDREF])
(CCCSUBFN?
(LAMBDA (X) (* JonL "31-Dec-83 13:32")
(* 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))
(OR (find Y in SUBMAPS suchthat (EQUAL (fetch (REFMAP CODEARRAY) of Y)
X))
(SETQ SUBMAPS (NCONC SUBMAPS (CCCSCAN X OLDREF))))))))
(\SUBFNDEF
(LAMBDA (X) (* JonL "15-Dec-83 20:48")
(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)))))
(MCODEP X))))
(CCCSCAN
[LAMBDA (DEF OLDREF)
(DECLARE (SPECVARS SUBMAPS OLDREF))
(* lmm "13-FEB-83 16:29")
(PROG (NAMELOCS CONSTLOCS DEFLOCS PTRLOCS SUBMAPS (CA (OR (MCODEP DEF)
(ERROR DEF "not compiled code")))
TAG B NAME CODELOC)
(SETQ CODELOC (fetch (CODEARRAY STARTPC) of CA))
[COND
((LITATOM OLDREF)
(for NT1 from (UNFOLD (fetch (CODEARRAY OVERHEADWORDS) of T)
BYTESPERWORD)
by BYTESPERWORD
do (OR (SETQ NAME (\INDEXATOMVAL (CODELT2 CA NT1)))
(RETURN))
(AND (EQ NAME OLDREF)
(push NAMELOCS NT1]
LP (SETQ B (CODELT 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)
[COND
((EQ (SETQ NAME (CODELT2 CA (IDIFFERENCE CODELOC 2)))
(\ATOMDEFINDEX OLDREF))
(push DEFLOCS (IDIFFERENCE CODELOC 2]
(CCCSUBFN? (\INDEXATOMDEF NAME)))
[ATOM (COND
((AND (LITATOM OLDREF)
(EQ (CODELT2 CA (IDIFFERENCE CODELOC 2))
(\ATOMPNAMEINDEX OLDREF)))
(push CONSTLOCS (IDIFFERENCE CODELOC 2]
[GCONST (COND
((EQUAL [SETQ NAME (\VAG2 (CODELT CA (IDIFFERENCE CODELOC 3))
(CODELT2 CA (IDIFFERENCE CODELOC 2]
OLDREF)
(push PTRLOCS (IDIFFERENCE CODELOC 3]
NIL)
(GO LP])
)
(SELECTQ (SYSTEMTYPE)
(D (MOVD (QUOTE DCALLSCCODE)
(QUOTE CALLSCCODE))
(MOVD (QUOTE DPRINTCODE)
(QUOTE PRINTCODE))
(MOVD (QUOTE DCHANGECCODE)
(QUOTE CHANGECCODE)))
NIL)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: DCALLSCCODE DCALLSCCODE RUNION (NOLINKFNS . T))
(BLOCK: DCHANGECCODE DCHANGECCODE CCCSUBFN? CCCSCAN)
]
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(RECORD REFMAP (CODEARRAY NAMELOCS CONSTLOCS DEFLOCS PTRLOCS))
]
)
(ADDTOVAR IGNOREFNS )
(DEFINEQ
(LLBREAK
[LAMBDA (FN WHEN)
(DECLARE (GLOBALVARS BROKENFNS)) (* lmm "21-JAN-82 08:00")
(PROG (NUFN DEF)
[COND
((GETPROP FN (QUOTE BROKEN))
(RESTORE FN (QUOTE BROKEN]
(OR (SETQ DEF (MCODEP FN))
(ERROR FN "is not compiled code"))
(/SETATOMVAL (QUOTE BROKENFNS)
(CONS FN BROKENFNS))
(/PUTD [SETQ NUFN (PACK* FN (GENSYM (QUOTE L]
DEF)
(/PUTPROP FN (QUOTE BROKEN)
NUFN)
(/PUTD FN (BROKENDEF DEF WHEN))
(RETURN FN])
(BROKENDEF
(LAMBDA (CA WHEN) (* lmm " 5-SEP-81 13:03")
(PROG (BEFORE AFTER SIZE FB OP OFFSET NEWCA OPCODE TAG)
(UNLESSRDSYS NIL (PROGN (SETQ FB (fetch (CODEARRAY STARTPC) of (SETQ NEWCA (SETQ CA
(MCODEP CA)))))
(SETQ BEFORE)
(SETQ AFTER T)
(SETQ OFFSET 0)
(GO DOCOPY)))
(SELECTQ WHEN
(BEFORE (SETQ BEFORE T))
(AFTER (SETQ AFTER T))
((NIL BOTH)
(SETQ BEFORE T)
(SETQ AFTER T))
(LISPERROR "ILLEGAL ARG" WHEN))
(SETQ SIZE (ARRAYSIZE CA))
(SETQ OFFSET (COND
(BEFORE 3)
(T 0)))
(SETQ FB (fetch (CODEARRAY STARTPC) of CA))
(SETQ NEWCA (\CODEARRAY (COND
(BEFORE (IPLUS OFFSET SIZE))
(T SIZE))
(CEIL (ADD1 (FOLDHI FB BYTESPERCELL))
CELLSPERQUAD)))
DOCOPY
(for I from 0 to (SUB1 FB) do (CODESETA NEWCA I (CODELT CA I)))
(* copy over header)
(COND
(BEFORE (* insert call to RAID followed by a POP)
(CODESETA NEWCA FB (CAR (\FINDOP (QUOTE 'NIL))))
(CODESETA NEWCA (ADD1 FB)
(CAR (\FINDOP (QUOTE RAID))))
(CODESETA NEWCA (IPLUS FB 2)
(CAR (\FINDOP (QUOTE POP))))))
(do (SETQ OP (CODELT CA FB))
(SETQ TAG (\FINDOP OP))
(CODESETA NEWCA (IPLUS FB OFFSET)
(SELECTQ (fetch (OPCODE OPCODENAME) of TAG)
(-X- (RETURN))
(RETURN (COND
(AFTER (CAR (\FINDOP (QUOTE \RETURN))))
(T OP)))
OP))
(FRPTQ (fetch (OPCODE OPNARGS) of TAG)
(CODESETA NEWCA (IPLUS (add FB 1)
OFFSET)
(CODELT CA FB)))
(add FB 1))
(RETURN NEWCA))))
)
(DECLARE: DONTCOPY
(ADDTOVAR RDCOMS (FNS DPRINTCODE PRINTCODENT BROKENDEF)
(MACROS PCVAR))
(ADDTOVAR RD.SUBFNS (MCODEP . VGETDEFN)
(CODELT . VGETBASEBYTE))
(ADDTOVAR EXPANDMACROFNS NEXTBYTE PCVAR PRINJUMP)
)
(* reference to opcodes symbolically)
(DEFINEQ
(PRINTOPCODES
(LAMBDA (START LAST) (* bvm: " 7-JUL-82 17:09")
(printout NIL " #" 9 "name" 24 "len-1" 34 "format" 43 "stk effect" 55 "UFN table entry" T T)
(OR LAST (SETQ LAST 255))
(for X in (COND
(START (find TAIL on \OPCODES suchthat (IGEQ (fetch OP# of (CAR TAIL))
START)))
(T \OPCODES))
until (IGREATERP (fetch OP# of X)
LAST)
do (printout NIL .I3.8 (fetch OP# of X)
#
(COND
((fetch OPLAST of X)
(printout NIL "-" .I3.8 (fetch OPLAST of X))))
9
(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
(ADDTOVAR GLOBALVARS \OPCODES)
)
(DECLARE: EVAL@COMPILE DONTCOPY
(CHECKIMPORTS (QUOTE (LLCODE RENAMEMACROS MODARITH))
T)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
)
(PUTPROPS ACODE COPYRIGHT ("Xerox Corporation" 1982 1983 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1503 10722 (DPRINTCODE 1513 . 9607) (PRINTCODENT 9609 . 10720)) (11443 14329 (
DCALLSCCODE 11453 . 14092) (RUNION 14094 . 14327)) (14330 18888 (DCHANGECCODE 14340 . 16302) (
CCCSUBFN? 16304 . 16800) (\SUBFNDEF 16802 . 17148) (CCCSCAN 17150 . 18886)) (19386 21832 (LLBREAK
19396 . 19961) (BROKENDEF 19963 . 21830)) (22112 23153 (PRINTOPCODES 22122 . 23151)))))
STOP