(FILECREATED "31-Jan-86 14:21:22" {ERINYES}<HERRING>COMPILER>DDISASM.;37 19523
changes to: (FNS DDISASM.EMITNAME&TYPE DDISASM.HELP DDISASM.DIGESTANAMETABLE
DDISASM.IVARLOOKUP)
previous date: "28-Jan-86 17:45:11" {ERINYES}<HERRING>COMPILER>DDISASM.;33)
(* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT DDISASMCOMS)
(RPAQQ DDISASMCOMS ((* * see associated doc: D2T.tedit)
(GLOBALVARS \DDISASM.LABELUSED)
(INITVARS \DDISASM.LABELUSED)
(FNS DDISASM)
(FNS DDISASM.DIGESTHEADER DDISASM.DIGESTBOTHNAMETABLES DDISASM.DIGESTANAMETABLE)
(FNS DDISASM.DIGESTCODE DDISASM.APPLYDOPCODE DDISASM.BIND DDISASM.GETSLOTNR
DDISASM.GETATOMARG DDISASM.GETTYPEPARG DDISASM.GETJUMPTOARG)
(FNS DDISASM.EMITPSEUDOOPS DDISASM.EMITNAME&TYPE DDISASM.EMITHEADER)
(FNS DDISASM.IVARLOOKUP DDISASM.PVARLOOKUP DDISASM.FVARLOOKUP DDISASM.PFVARLOOKUP
)
(FNS DDISASM.HELP)))
(* * see associated doc: D2T.tedit)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \DDISASM.LABELUSED)
)
(RPAQ? \DDISASM.LABELUSED NIL)
(DEFINEQ
(DDISASM
[LAMBDA (FN ERRFILE) (* jmh "23-Nov-85 16:12")
(* * returns (#errs . instrlist) -- error messages printed to <OR ERRFILE T> -- also see DDISASM.HELP)
(DECLARE (GLOBALVARS \DDISASM.LABELUSED))
(LET ((CA (OR (MCODEP FN)
[AND (LITATOM FN)
(MCODEP (GETPROP FN (QUOTE CODE]
(ERROR FN "not compiled code")))
(NERRS 0)
ERRS FNTYPE NTPVARS LTPVARS CGPVARS NTIVARS LTIVARS FVARS INTERMEDIATEINSTRS
OUTPUTINSTRSTCONC) (* e.g. NT/LT/CGPVARS are NameTable /LocalnameTable
/CompilerGenerated PVARS)
(DECLARE (SPECVARS NERRS ERRFILE ERRS CA FNTYPE NTPVARS LTPVARS CGPVARS NTIVARS LTIVARS
FVARS))
[OR \DDISASM.LABELUSED (SETQ \DDISASM.LABELUSED (HASHARRAY (fetch (ARRAYP LENGTH)
of CA]
(CLRHASH \DDISASM.LABELUSED)
(* * pass 1 -- digest)
(DDISASM.DIGESTHEADER)
(DDISASM.DIGESTBOTHNAMETABLES)
(SETQ INTERMEDIATEINSTRS (DDISASM.DIGESTCODE))
(* * pass 2 -- emit)
(SETQ OUTPUTINSTRSTCONC (DDISASM.EMITPSEUDOOPS))
(for I in INTERMEDIATEINSTRS
do (if (GETHASH (CAR I)
\DDISASM.LABELUSED)
then (TCONC OUTPUTINSTRSTCONC (CAR I)))
(TCONC OUTPUTINSTRSTCONC (CDR I)))
(CONS NERRS (CAR OUTPUTINSTRSTCONC])
)
(DEFINEQ
(DDISASM.DIGESTHEADER
[LAMBDA NIL
(DECLARE (USEDFREE CA FNTYPE)) (* jmh "12-Nov-85 14:10")
(SETQ FNTYPE (SELECTQ (fetch (CODEARRAY ARGTYPE) of CA)
(0 (QUOTE LAMBDA))
(1 (QUOTE NLAMBDA))
(2 (QUOTE LAMBDA*))
(3 (QUOTE NLAMBDA*))
(DDISASM.HELP "impossible argtype"])
(DDISASM.DIGESTBOTHNAMETABLES
[LAMBDA NIL (* jmh "12-Nov-85 14:10")
(* * digest name table and local-var table -- no value returned)
(DECLARE (USEDFREE CA NTPVARS LTPVARS CGPVARS NTIVARS LTIVARS FVARS))
(LET (TABLESTART TABLENELTS PIFVARS)
(* * global name table)
(SETQ TABLESTART (UNFOLD (fetch (CODEARRAY OVERHEADWORDS) of T)
BYTESPERWORD))
(SETQ TABLENELTS (fetch (CODEARRAY NTSIZE) of CA))
(SETQ PIFVARS (DDISASM.DIGESTANAMETABLE TABLESTART TABLENELTS))
(SETQ NTPVARS (CAR PIFVARS))
(SETQ NTIVARS (CADR PIFVARS))
(SETQ FVARS (CDDR PIFVARS))
(* * local name table)
[SETQ TABLESTART (IPLUS TABLESTART (IMAX BYTESPERQUAD (UNFOLD TABLENELTS
(ITIMES 2 BYTESPERWORD]
(SETQ TABLENELTS (FOLDLO (IDIFFERENCE (fetch (CODEARRAY STARTPC) of CA)
TABLESTART)
BYTESPERCELL))
(SETQ PIFVARS (DDISASM.DIGESTANAMETABLE TABLESTART TABLENELTS))
(SETQ LTPVARS (CAR PIFVARS))
(SETQ LTIVARS (CADR PIFVARS))
(if (CDDR PIFVARS)
then (DDISASM.HELP "local FVARs" (CDDR PIFVARS])
(DDISASM.DIGESTANAMETABLE
[LAMBDA (TABLESTART TABLENELTS) (* jmh
"29-Jan-86 12:49")
(* * digests a name table => (pvars ivars . fvars) each a list of
(name . slot#) in order of occurrence)
(DECLARE (USEDFREE CA))
(LET ((TABLESIZE (UNFOLD TABLENELTS BYTESPERWORD))
VARNAME NAME NR PVARS IVARS FVARS)
[for N from 1 to TABLENELTS as NTPTR from TABLESTART by BYTESPERWORD
while [NOT (ZEROP (SETQ VARNAME (CODELT2 CA NTPTR]
do (SETQ NAME (\INDEXATOMVAL VARNAME))
[SETQ NR (CODELT CA (ADD1 (IPLUS NTPTR TABLESIZE]
(SELECTC (CODELT CA (IPLUS NTPTR TABLESIZE))
((LRSH IVARCODE 8)
(push IVARS (LIST NAME (IDIFFERENCE -1 NR))))
((LRSH PVARCODE 8)
(push PVARS (LIST NAME NR)))
(push FVARS (LIST NAME NR]
(CONS (REVERSE PVARS)
(CONS (REVERSE IVARS)
(REVERSE FVARS])
)
(DEFINEQ
(DDISASM.DIGESTCODE
[LAMBDA NIL (* jmh "12-Nov-85 14:10")
(* * process the byte code -- collect list of (label=PC op . symbolic-args), noting what labels are jumped to or
are BINDs)
(DECLARE (USEDFREE CA))
(repeatuntil (ZEROP BO) bind PC BO DOPCODE first (SETQ PC (fetch (CODEARRAY STARTPC)
of CA))
collect (SETQ BO (CODELT CA PC))
(SETQ DOPCODE (if (\FINDOP BO)
else (DDISASM.HELP "no dopcode")))
(PROG1 (CONS PC (DDISASM.APPLYDOPCODE PC BO DOPCODE))
(add PC (ADD1 (fetch OPNARGS of DOPCODE])
(DDISASM.APPLYDOPCODE
[LAMBDA (PC B0 DOPCODE) (* jmh "28-Jan-86 14:12")
(* * returns an instr as (CONS opname (APPEND symbolic-args errs-if-any)))
(DECLARE (GLOBALVARS \DDISASM.LABELUSED)
(USEDFREE CA FNTYPE NERRS ERRS ERRFILE))
(LET* [(OPCODENAME (fetch (OPCODE OPCODENAME) of DOPCODE))
(OPNARGS (fetch (OPCODE OPNARGS) of DOPCODE))
(OPPRINT (fetch (OPCODE OPPRINT) of DOPCODE))
[B1 (if (IGEQ OPNARGS 1)
then (CODELT CA (IPLUS 1 PC]
[B2 (if (IGEQ OPNARGS 2)
then (CODELT CA (IPLUS 2 PC]
[B3 (if (IGEQ OPNARGS 3)
then (CODELT CA (IPLUS 3 PC]
(INSTR (SELECTQ OPPRINT
[NIL (SELECTQ OPCODENAME
(BIND (DDISASM.BIND B1 B2))
((-X- UNBIND DUNBIND)
(LIST OPCODENAME))
(PROGN (push ERRS "unimplemented NIL-opprint")
(LIST OPCODENAME]
[(T SUBRCALL)
(SELECTQ OPCODENAME
[(GETBITS.N.FD PUTBITS.N.FD)
(LIST OPCODENAME B1 (LOGAND 15 (LRSH B2 4))
(ADD1 (LOGAND 15 B2]
(if (LISTP (fetch (OPCODE OP#) of DOPCODE))
then (if (NOT (ZEROP OPNARGS))
then (push ERRS "op# list & opnargs>0"))
[LIST OPCODENAME (IDIFFERENCE
B0
(CAR (fetch (OPCODE OP#) of DOPCODE]
else (CONS OPCODENAME (for I from 1 to OPNARGS
collect (CODELT CA (IPLUS I PC]
((JUMP JUMPX JUMPXX)
(LET ((TARGET (DDISASM.GETJUMPTOARG PC B0 DOPCODE)))
(PUTHASH TARGET T \DDISASM.LABELUSED)
(LIST OPCODENAME TARGET)))
[IVAR (LIST OPCODENAME (if (NEQ FNTYPE (QUOTE LAMBDA*))
then (DDISASM.IVARLOOKUP (DDISASM.GETSLOTNR
PC B0 DOPCODE))
else (DDISASM.GETSLOTNR PC B0 DOPCODE]
[PVAR (LIST OPCODENAME (DDISASM.PVARLOOKUP (DDISASM.GETSLOTNR PC B0
DOPCODE]
[FVAR (LIST OPCODENAME (DDISASM.FVARLOOKUP (DDISASM.GETSLOTNR PC B0
DOPCODE]
(ATOM (LIST OPCODENAME (DDISASM.GETATOMARG B1 B2)))
(FN (LIST OPCODENAME (DDISASM.GETATOMARG B1 B2)))
(FNX (LIST OPCODENAME B1 (DDISASM.GETATOMARG B2 B3)))
(SIC (LIST (QUOTE SIC)
B1))
(SNIC (LIST (QUOTE SNIC)
(IPLUS B1 -256)))
(SICX (LIST (QUOTE SICX)
(LOGOR (LLSH B1 8)
B2)))
[GCONST (LIST (QUOTE GCONST)
(1ST (\VAG2 B1 (IPLUS (LLSH B2 8)
B3]
(TYPEP (LIST OPCODENAME (DDISASM.GETTYPEPARG B1)))
(if (LISTP OPPRINT)
then [if (NEQ OPNARGS 1)
then (push ERRS "opprint is listp but opnargs not 1")
(LIST OPCODENAME)
else (LIST OPCODENAME (LET [(X (NTH OPPRINT (ADD1 B1]
(if (LISTP X)
then (CAR X)
else B1]
else (PROGN (push ERRS "unimplemented opprint")
(LIST OPCODENAME]
(if ERRS
then (add NERRS (LENGTH ERRS))
(NCONC INSTR (CONS "*DDisAsm errs*" (REVERSE ERRS)))
(printout (OR ERRFILE T)
.PPV INSTR T))
INSTR])
(DDISASM.BIND
[LAMBDA (B1 B2) (* jmh "16-Oct-85 17:15")
(* * returns (BIND nonnil-vars nil-vars) with nonnil-vars in reverse the order in which the BIND will bind them by
popping values off the stack)
(DECLARE (USEDFREE CA))
(LET* [(NNVARS (LRSH B1 4))
(NVVARS (LOGAND B1 15))
[NVARS (REVERSE (for N from 1 to NNVARS as SLOT from B2 by -1
collect (DDISASM.PFVARLOOKUP SLOT]
(VVARS (REVERSE (for N from 1 to NVVARS as SLOT from (IDIFFERENCE B2 NNVARS)
by -1 collect (DDISASM.PFVARLOOKUP SLOT]
(LIST (QUOTE BIND)
VVARS NVARS])
(DDISASM.GETSLOTNR
[LAMBDA (PC B0 DOPCODE) (* jmh " 8-Dec-85 17:04")
(* * get slot-number argument from all of the byte code of a variable-reference instr -- an alpha-byte arg will be
divided by 2)
(DECLARE (USEDFREE CA ERRS))
(LET (OPNRRANGE)
(SELECTQ (fetch (OPCODE OPNARGS) of DOPCODE)
[0 (SETQ OPNRRANGE (fetch (OPCODE OP#) of DOPCODE))
(if (AND (LISTP OPNRRANGE)
(NUMBERP (CAR OPNRRANGE)))
then (IDIFFERENCE B0 (CAR OPNRRANGE))
else (PROG1 0 (push ERRS "no OP# range"]
(1 (LRSH (CODELT CA (ADD1 PC))
1))
(PROGN (push ERRS "opnargs>1")
0])
(DDISASM.GETATOMARG
[LAMBDA (B1 B2) (* jmh "29-Oct-85 15:29")
(DECLARE (USEDFREE ERRS))
(if (\INDEXATOMVAL (LOGOR (LLSH B1 8)
B2))
else (push ERRS "unknown atom")
(QUOTE ?])
(DDISASM.GETTYPEPARG
[LAMBDA (B1) (* jmh "16-Oct-85 16:07")
(if (EQ B1 \ARRAYP)
then (QUOTE ARRAYP)
elseif (EQ B1 \STRINGP)
then (QUOTE STRINGP)
elseif (EQ B1 \FLOATP)
then (QUOTE FLOATP)
elseif (EQ B1 \SMALLP)
then (QUOTE SMALLP)
elseif (EQ B1 \STACKP)
then (QUOTE STACKP)
elseif (EQ B1 \FIXP)
then (QUOTE FIXP)
elseif (EQ B1 \LITATOM)
then (QUOTE LITATOM)
else B1])
(DDISASM.GETJUMPTOARG
[LAMBDA (PC B0 DOPCODE)
(DECLARE (USEDFREE CA ERRS)) (* jmh "10-Nov-85 14:06")
(SELECTQ (fetch (OPCODE OPNARGS) of DOPCODE)
(0 (LET ((OP#RANGE (fetch (OPCODE OP#) of DOPCODE)))
(if (AND (LISTP OP#RANGE)
(NUMBERP (CAR OP#RANGE)))
then (IPLUS PC 2 (IDIFFERENCE B0 (CAR OP#RANGE)))
else (push ERRS "no k without OP# range")
0)))
[1 (LET [(D (CODELT CA (ADD1 PC]
(IPLUS PC (if (ILESSP D 128)
then D
else (IDIFFERENCE D 256]
[2 (LET [(D (LOGOR (LLSH (CODELT CA (ADD1 PC))
8)
(CODELT CA (IPLUS 2 PC]
(IPLUS PC (if (ILESSP D 32768)
then D
else (IDIFFERENCE D 65536]
(PROG1 0 (push ERRS "opnargs>2"])
)
(DEFINEQ
(DDISASM.EMITPSEUDOOPS
[LAMBDA NIL (* jmh " 8-Dec-85 14:57")
(* * returns a TCONC)
(DECLARE (USEDFREE NTIVARS LTIVARS NTPVARS LTPVARS CGPVARS FVARS))
(LET ((OUTPUTINSTRSTCONC (CONS)))
(TCONC OUTPUTINSTRSTCONC (DDISASM.EMITNAME&TYPE))
(TCONC OUTPUTINSTRSTCONC (DDISASM.EMITHEADER))
(if NTPVARS
then (TCONC OUTPUTINSTRSTCONC (CONS (QUOTE PVARS:)
NTPVARS)))
(if NTIVARS
then (TCONC OUTPUTINSTRSTCONC (CONS (QUOTE IVARS:)
NTIVARS)))
(if FVARS
then (TCONC OUTPUTINSTRSTCONC (CONS (QUOTE FVARS:)
FVARS)))
[if (OR LTIVARS LTPVARS CGPVARS)
then (TCONC OUTPUTINSTRSTCONC (QUOTE LOCAL:))
(if LTPVARS
then (TCONC OUTPUTINSTRSTCONC (CONS (QUOTE PVARS:)
NTPVARS)))
(if LTIVARS
then (TCONC OUTPUTINSTRSTCONC (CONS (QUOTE IVARS:)
LTIVARS)))
(if CGPVARS
then (TCONC OUTPUTINSTRSTCONC (CONS (QUOTE PVARS:)
CGPVARS]
(TCONC OUTPUTINSTRSTCONC (QUOTE CODE:))
OUTPUTINSTRSTCONC])
(DDISASM.EMITNAME&TYPE
[LAMBDA NIL (* jmh
"29-Jan-86 20:18")
(* * returns (N/LAMBDA: name arglist))
(DECLARE (USEDFREE CA FNTYPE NTIVARS LTIVARS))
(LET [(IVARS (APPEND NTIVARS (APPEND LTIVARS]
(LIST (SELECTQ FNTYPE
([LAMBDA LAMBDA*]
(QUOTE LAMBDA:))
([NLAMBDA NLAMBDA*]
(QUOTE NLAMBDA:))
(DDISASM.HELP "bad argtype" FNTYPE))
(fetch (CODEARRAY FRAMENAME) of CA)
(SELECTQ FNTYPE
([LAMBDA NLAMBDA]
[SORT IVARS (FUNCTION (LAMBDA (A B)
(ILESSP (CADR B)
(CADR A])
(NLAMBDA* (if (EQ 1 (LENGTH IVARS))
then (CAR IVARS)
else (DDISASM.HELP "nlambda* but #ivars not 1")))
(LAMBDA* (if [AND (NULL IVARS)
(LET ((X (DDISASM.PVARLOOKUP 0 T)))
(OR (NULL X)
(NOT (LITATOM (CAR X]
then (SETQ LTIVARS (LIST (LIST "dummy$ivar" 0)))
(SETQ IVARS LTIVARS))
(if IVARS
then (if (EQ 1 (LENGTH IVARS))
then (CAR IVARS)
else (DDISASM.HELP "lambda* but #ivars >1"))
else (DDISASM.PVARLOOKUP 0)))
(DDISASM.HELP "bad argtype" FNTYPE])
(DDISASM.EMITHEADER
[LAMBDA NIL (* jmh "30-Oct-85 18:22")
(* * returns (DFNHEADER: . property-list))
(DECLARE (USEDFREE CA))
(LIST (QUOTE DFNHEADER:)
(QUOTE STKMIN:)
(fetch (CODEARRAY STKMIN) of CA)
(QUOTE PV:)
(fetch (CODEARRAY PV) of CA)
(QUOTE STARTPC:)
(fetch (CODEARRAY STARTPC) of CA)
(QUOTE NTSIZE:)
(fetch (CODEARRAY NTSIZE) of CA)
(QUOTE NLOCALS:)
(fetch (CODEARRAY NLOCALS) of CA)
(QUOTE FVAROFFSET:)
(fetch (CODEARRAY FVAROFFSET) of CA])
)
(DEFINEQ
(DDISASM.IVARLOOKUP
[LAMBDA (NR) (* jmh
"29-Jan-86 12:51")
(* * returns <name canonical-ivar-nr> of the IVAR with slot NR --
canonical ivar nr is -1,-2,.. per ivar list in fn decl)
(DECLARE (USEDFREE ERRS NTIVARS LTIVARS))
(SETQ NR (IDIFFERENCE -1 NR))
(OR (for X in NTIVARS thereis (EQ NR (CADR X)))
(for X in LTIVARS thereis (EQ NR (CADR X)))
(PROGN (push ERRS "ivar lookup failed")
(QUOTE (? -1])
(DDISASM.PVARLOOKUP
[LAMBDA (NR DONTCREATE?) (* jmh "28-Jan-86 11:29")
(* * returns <name slot> of the PVAR with slot NR -- makes PVAR with name "pvar" if necessary unless DONTCREATE?)
(DECLARE (GLOBALVARS PRXFLG)
(USEDFREE NTPVARS LTPVARS CGPVARS))
(OR (for X in NTPVARS thereis (EQ NR (CADR X)))
(for X in LTPVARS thereis (EQ NR (CADR X)))
(for X in CGPVARS thereis (EQ NR (CADR X)))
(AND (NULL DONTCREATE?)
(LET ((X (LIST "pvar" NR)))
(push CGPVARS X)
X])
(DDISASM.FVARLOOKUP
[LAMBDA (NR ERROK) (* jmh " 8-Dec-85 13:40")
(* * returns <name slot> of the FVAR with slot NR -- or, if ERROK, then NIL='none')
(DECLARE (USEDFREE ERRS FVARS))
(OR (for X in FVARS thereis (EQ NR (CADR X)))
(if (NOT ERROK)
then (push ERRS "fvar lookup failed")
(QUOTE (? -1])
(DDISASM.PFVARLOOKUP
[LAMBDA (NR) (* jmh "15-Oct-85 15:38")
(if (DDISASM.FVARLOOKUP NR T)
else (DDISASM.PVARLOOKUP NR])
)
(DEFINEQ
(DDISASM.HELP
[LAMBDA (MSG1 MSG2) (* jmh
"29-Jan-86 18:58")
(DECLARE (USEDFREE ERRFILE))
(if (NULL ERRFILE)
then (HELP MSG1 MSG2)
else (ASM.HELP MSG1 MSG2])
)
(PUTPROPS DDISASM COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1273 2825 (DDISASM 1283 . 2823)) (2826 5740 (DDISASM.DIGESTHEADER 2836 . 3228) (
DDISASM.DIGESTBOTHNAMETABLES 3230 . 4593) (DDISASM.DIGESTANAMETABLE 4595 . 5738)) (5741 13337 (
DDISASM.DIGESTCODE 5751 . 6463) (DDISASM.APPLYDOPCODE 6465 . 9978) (DDISASM.BIND 9980 . 10724) (
DDISASM.GETSLOTNR 10726 . 11511) (DDISASM.GETATOMARG 11513 . 11797) (DDISASM.GETTYPEPARG 11799 . 12391
) (DDISASM.GETJUMPTOARG 12393 . 13335)) (13338 17189 (DDISASM.EMITPSEUDOOPS 13348 . 14651) (
DDISASM.EMITNAME&TYPE 14653 . 16507) (DDISASM.EMITHEADER 16509 . 17187)) (17190 19118 (
DDISASM.IVARLOOKUP 17200 . 17818) (DDISASM.PVARLOOKUP 17820 . 18472) (DDISASM.FVARLOOKUP 18474 . 18913
) (DDISASM.PFVARLOOKUP 18915 . 19116)) (19119 19440 (DDISASM.HELP 19129 . 19438)))))
STOP