(FILECREATED " 8-Oct-85 13:16:50" {PHYLUM}<TAMARIN>LISP>PCODE.;2 13693
changes to: (VARS PCODECOMS)
(FNS pcum NPRINTCODE psizes)
previous date: " 1-Apr-85 17:52:27" {IVY}<ABELL>LISP>PCODE.;1)
(PRETTYCOMPRINT PCODECOMS)
(RPAQQ PCODECOMS ((FNS NPRINTCODE pcum psizes CntVars mapargs mapfn pcumargs)))
(DEFINEQ
(NPRINTCODE
[LAMBDA (FN LVFLG RADIX OUTF FIRSTBYTE) (* edited: " 2-Apr-85 10:00")
(* * 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 inn "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 hopefully works again, but seems that frequently when
modifying any part of PRINTCODE it stops, so *BEWARE* and make sure you test it after a DORENAME
(R) as well as in "normal" mode.)
(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# fname (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 (SETQ fname (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
((EQ NTSIZE 0)
(* 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))
InStarList
(MAXLEVEL 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]
[COND
((NOT InStarList)
(SETQ InStarList T)
(SETQ starlist (CONS fname starlist]
(PRIN1 "*" OUTF)
(PRIN1 TEMP OUTF)
(* COND ((ILESSP TEMP LEVEL) (PRIN1 "#" OUTF) (PRIN1 LEVEL OUTF) (SETQ LEVEL TEMP) (SETQ STK
(GETHASH CODELOC STKA))))
]
(T (SETQ LEVEL TEMP)
(SETQ STK (GETHASH CODELOC STKA]
(COND
(LEVEL (TAB 7 NIL OUTF)
(PRINTNUM I4 LEVEL OUTF)
(COND
((IGREATERP LEVEL MAXLEVEL)
(SETQ MAXLEVEL LEVEL]
(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- (PRIN1 "Maxlevel: " OUTF)
(PRIN1 MAXLEVEL)
(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]
(if (LISTP LEVADJ)
then (SETQ LEVADJ (CAR LEVADJ)))
(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 [SETQ TAG (ALLOCAL (COND
((EQ (QUOTE RETURN)
(fetch OPCODENAME of TAG))
(QUOTE RETURN))
(T (OR (fetch OPPRINT of TAG)
(fetch OPCODENAME of TAG]
(-X- (TERPRI OUTF)
[SETA cntArray (MIN MAXLEVEL 100)
(CONS fname (ELT cntArray (MIN MAXLEVEL 100]
(* PRINT (LIST fname MAXLEVEL))
(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]
(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)))
(JUMP (SETQ LEVEL))
((CJUMP NCJUMP)
(add LEVEL -1))
(COND
((NUMBERP LEVADJ)
(add LEVEL LEVADJ]
(GO LP])
(pcum
[LAMBDA NIL (* edited: " 2-Apr-85 12:31")
[SETQ total (for i from 0 to 100 sum (LENGTH (ELT cntArray i]
(SETQ cum 0)
(PRINT total)
(for i from 0 to 100 when (ELT cntArray i)
do (PRIN1 i)
(SETQ zz (LENGTH (ELT cntArray i)))
(PRIN1 " ")
(PRIN1 zz)
(PRIN1 " ")
(PRIN1 (FQUOTIENT (FTIMES 100.0 zz)
total))
(SETQ cum (PLUS cum zz))
(PRIN1 " ")
(PRIN1 (FQUOTIENT (FTIMES 100.0 cum)
total))
(TERPRI])
(psizes
[LAMBDA NIL (* edited: " 1-Apr-85 18:14")
(for iiii from 0 to 100 do (if (ELT cntArray iiii)
then (PRIN1 iiii)
(PRIN1 ": ")
(PRIN1 (LENGTH (ELT cntArray iiii)))
(PRIN1 ", "])
(CntVars
[LAMBDA (FN) (* edited: " 2-Apr-85 14:56")
(PROG (CA vars pvars total)
[SETQ CA (OR (MCODEP FN)
(AND (LITATOM FN)
(MCODEP (GETPROP FN (QUOTE CODE]
(SETQ vars (fetch (CODEARRAY NA) of CA))
(SETQ pvars (fetch (CODEARRAY PV) of CA))
[SETQ total (IPLUS (MAX 0 vars)
(ITIMES 2 (ADD1 pvars]
(SETA argArray total (ADD1 (ELT argArray total)))
[COND
((IGREATERP total 25)
(SETQ longones (CONS (LIST FN total)
longones]
(RETURN total])
(mapargs
[LAMBDA NIL (* edited: " 2-Apr-85 14:42")
(MAPATOMS (FUNCTION (LAMBDA (x)
(COND
((CCODEP x)
(CntVars x])
(mapfn
[LAMBDA NIL (* edited: " 2-Apr-85 10:20")
(MAPATOMS (FUNCTION (LAMBDA (x)
(COND
((CCODEP x)
(NPRINTCODE x T NIL null])
(pcumargs
[LAMBDA NIL (* edited: " 2-Apr-85 14:51")
(SETQ total (for i from 0 to 199 sum (ELT argArray i)))
(SETQ cum 0)
(PRINT total)
(for i from 0 to 199 when (NEQ 0 (ELT argArray i))
do (PRIN1 i)
(SETQ zz (ELT argArray i))
(PRIN1 " ")
(PRIN1 zz)
(PRIN1 " ")
(PRIN1 (FQUOTIENT (FTIMES 100.0 zz)
total))
(SETQ cum (PLUS cum zz))
(PRIN1 " ")
(PRIN1 (FQUOTIENT (FTIMES 100.0 cum)
total))
(TERPRI])
)
(PUTPROPS PCODE COPYRIGHT (NONE))
(DECLARE: DONTCOPY
(FILEMAP (NIL (334 13637 (NPRINTCODE 344 . 10850) (pcum 10852 . 11508) (psizes 11510 . 11827) (CntVars
11829 . 12544) (mapargs 12546 . 12758) (mapfn 12760 . 12984) (pcumargs 12986 . 13635)))))
STOP