(FILECREATED "13-FEB-83 16:36:54" <BLISP>ACODE.;141 22782
changes to: (FNS DPRINTCODE DCHANGECCODE CCCSCAN)
previous date: "13-FEB-83 14:32:05" <BLISP>ACODE.;140)
(* Copyright (c) 1982, 1983 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? 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))
(FNS LLBREAK BROKENDEF)
(FNS SUBFNDEF)
(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)
(* lmm "13-FEB-83 16:29")
(DECLARE (GLOBALVARS \INITSUBRS FVA STKA)
(SPECVARS OUTF))
(OR RADIX (SETQ RADIX 10Q))
(PROG [(CA (OR (MCODEP FN)
(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 14Q 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)
17Q]
[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 36Q (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 50Q NIL OUTF)
(PCVAR (SELECTQ LEN
(0 (IDIFFERENCE B OP#))
(LRSH B1 1))
IVARS
(QUOTE ivar)))
(PVAR (TAB 50Q NIL OUTF)
(PCVAR (SELECTQ LEN
(0 (IDIFFERENCE B OP#))
(LRSH B1 1))
PVARS
(QUOTE pvar)))
(FVAR (TAB 50Q 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 50Q .P2 B1))
(SNIC (printout OUTF 50Q .P2 (IDIFFERENCE B1 400Q)))
(SICX (printout OUTF 50Q .P2 (IPLUS (LLSH B1 10Q)
B2)))
[JUMPX (PRINJUMP (COND
((IGEQ B1 200Q)
(IDIFFERENCE B1 400Q))
(T B1]
(FN (SETQ B (IPLUS (LLSH B1 10Q)
B2))
(printout OUTF 50Q (\INDEXATOMDEF B)))
[BIND (TAB 50Q NIL OUTF)
(ALLOCAL (PROG ((NNILS (LRSH B1 4))
(NVALS (LOGAND B1 17Q)))
(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 10Q)
B2
(COND
((IGREATERP B1 177Q)
-200000Q)
(T 0]
[ATOM (printout OUTF 50Q .P2 (\INDEXATOMPNAME (IPLUS (LLSH B1 10Q)
B2]
[GCONST (printout OUTF 50Q .P2 (1ST (\VAG2 B1 (IPLUS (LLSH B2 10Q)
B3]
[FNX (printout OUTF "(" B1 ")" 50Q (\INDEXATOMDEF (IPLUS (LLSH B2 10Q)
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 50Q .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)))
(* lmm "13-FEB-83 14:28")
(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 BYTESPERWORD as NT2 from (UNFOLD (IPLUS (fetch (CODEARRAY OVERHEADWORDS)
of T)
NTSIZE)
BYTESPERWORD)
by BYTESPERWORD
do (OR (SETQ NAME (\INDEXATOMVAL (CODELT2 CA NT1)))
(RETURN))
(SELECTQ (CODELT CA NT2)
(0 (pushnew BOUND NAME))
(200Q (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 10Q)
B2)))
(GO FN))
(FNX (SETQ NAME (\INDEXATOMDEF (IPLUS (LLSH B2 10Q)
B3)))
(GO FN))
[(GVAR GVAR←)
(pushnew GLOBALS (\INDEXATOMVAL (IPLUS (LLSH B1 10Q)
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) (* lmm " 2-AUG-80 21:25")
(* 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])
(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))
]
)
(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])
)
(DEFINEQ
(SUBFNDEF
[LAMBDA (X) (* lmm " 2-MAY-80 11:58")
(AND (LITATOM X)
(EQ (NTHCHAR X -5)
(QUOTE A))
(EQ (NTHCHAR X -4)
0)
(MCODEP X])
)
(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 " #" 11Q "name" 30Q "len-1" 42Q "format" 53Q "stk effect" 67Q "UFN table entry" T
T)
(OR LAST (SETQ LAST 377Q))
(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]
11Q
(fetch OPCODENAME of X))
[COND
((NEQ (fetch OPCODENAME of X)
(QUOTE unused))
(printout NIL 32Q (OR (fetch OPNARGS of X)
(QUOTE ?))
43Q
(OR (fetch OPPRINT of X)
(QUOTE ?))
54Q
(OR (fetch LEVADJ of X)
(QUOTE ?))
67Q
(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" 3676Q 3677Q))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1453 10462 (DPRINTCODE 1463 . 9347) (PRINTCODENT 9349 . 10460)) (11177 13874 (DCALLSCCODE 11187 . 13637) (RUNION
13639 . 13872)) (13875 18051 (DCHANGECCODE 13885 . 15847) (CCCSUBFN? 15849 . 16311) (CCCSCAN 16313 . 18049)) (18522 20948 (LLBREAK
18532 . 19097) (BROKENDEF 19099 . 20946)) (20949 21144 (SUBFNDEF 20959 . 21142)) (21424 22479 (PRINTOPCODES 21434 . 22477)))))
STOP
INTOPCODES
53102Q . 55165Q)))))
STOP