(FILECREATED "27-Feb-86 11:00:46" {ERINYES}<HERRING>DT>D2DTEST.;3 16988
changes to: (FNS DD)
previous date: " 8-Feb-86 11:25:41" {ERINYES}<HERRING>DT>D2DTEST.;2)
(* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT D2DTESTCOMS)
(RPAQQ D2DTESTCOMS ((FILES DDISASM D2T T2D ASM DASM)
(DECLARE: (GLOBALVARS DDALL.FNS))
(INITVARS DDALL.FNS)
(VARS (SYSPRETTYFLG T))
(FNS DD SHOWOL)
(FNS PRINTCODELIST)
(FNS DESCRIBEFN)
(FNS DDI DDI.1 DDI.1A DDI.1B)
(FNS DDALL.INIT DDALL.OK DDALL.OK.LOCKEDP DDALL.1 DDALL.REPORT)
(FNS DDLIST COLLECT.FNS.OF COLLECT.D2D.FNS)
(FNS DDALL COLLECT.ALL.FNS)))
(FILESLOAD DDISASM D2T T2D ASM DASM)
(DECLARE:
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS DDALL.FNS)
)
)
(RPAQ? DDALL.FNS NIL)
(RPAQQ SYSPRETTYFLG T)
(DEFINEQ
(DD
[LAMBDA (FN OPTIONS)
(DECLARE (GLOBALVARS DDFN DDA D2T T2D DASM DASMFN)) (* jmh
"27-Feb-86 10:00")
(PROG NIL
(SETQ DDFN FN)
(SETQ DDA (QUOTE ??))
(SETQ D2T (QUOTE ??))
(SETQ T2D (QUOTE ??))
(SETQ DASM (QUOTE ??))
[PUTD (QUOTE DASMFN)
(FUNCTION (LAMBDA NIL
(QUOTE ??]
(printout T "DDA--" T)
(SETQ DDA (DDISASM FN))
(if (NOT (ZEROP (CAR DDA)))
then (RETURN))
(printout T "D2T--" T)
(SETQ D2T (D2T (CDR DDA)))
(if (NOT (ZEROP (CAR D2T)))
then (RETURN))
(printout T "T2D--" T)
(SETQ T2D (T2D (CDR D2T)))
(if (NOT (ZEROP (CAR T2D)))
then (RETURN))
(printout T "DASM--" T)
(SETQ DASM (DASM (CDR T2D)
OPTIONS))
(PUTD (QUOTE DASMFN)
(CDR DASM)
T)
(RETURN (if (ZEROP (CAR DASM))
then (CDR DASM)
else (LIST (CAR DASM)
(QUOTE errors])
(SHOWOL
[LAMBDA NIL
(DECLARE (GLOBALVARS \ASM.OUTPUTLISTING)) (* jmh " 2-Dec-85 12:17")
(for LINE in \ASM.OUTPUTLISTING do (printout T LINE T])
)
(DEFINEQ
(PRINTCODELIST
[LAMBDA (FNS FILE) (* jmh "25-Nov-85 16:01")
(* * PRINTCODE with stack modelling all the fns of list-of-atoms FNS to file FILE -- appends to FILE if open or
NIL, else opens and closes FILE -- each fn on new page -- beginning and end of each fn labelled with fn name and as
current date and time -- beginning of fn shows leading comments of fn)
(LET ([OPENEDHERE? (AND FILE (NOT (OPENP FILE]
(DATE+TIME (DATE)))
[if OPENEDHERE?
then (SETQ FILE (OPENFILE FILE (QUOTE OUTPUT]
(for FNTAIL on FNS bind FN
do (SETQ FN (CAR FNTAIL))
(printout FILE .TAB 50 DATE+TIME T T .PPV (DESCRIBEFN FN)
T T)
(PRINTCODE FN T 8 FILE)
(printout FILE T (QUOTE end)
, FN , DATE+TIME T)
(if (CDR FNTAIL)
then (printout FILE .PAGE)))
(if OPENEDHERE?
then (CLOSEF FILE])
)
(DEFINEQ
(DESCRIBEFN
[LAMBDA (FN) (* jmh "25-Nov-85 15:32")
(* * return list of the calling form and leading comments of the fn)
(LET ((FNDEF (VIRGINFN FN)))
(if (LISTP FNDEF)
then (LET ((LCS (LIST FN)))
(pop FNDEF)
(NCONC1 LCS (pop FNDEF))
(while (MEMB (CAAR FNDEF)
(QUOTE (DECLARE declare)))
do (pop FNDEF))
(while (EQ (CAAR FNDEF)
(QUOTE *))
do (NCONC1 LCS (pop FNDEF)))
LCS)
elseif FNDEF
then (LIST FN "virginfn not avail")
else (LIST FN "no defn"])
)
(DEFINEQ
(DDI
[LAMBDA (FN ERRFILE) (* jmh
"29-Jan-86 19:30")
(* * for applying to a function to D->D it, including error-trapping --
returns a CCODEP or NIL)
(DECLARE (SPECVARS ERRFILE))
(PROG (X)
(printout T FN ,)
(if [AND (SETQ X (DDI.1 (QUOTE DDISASM)
FN
(LIST FN ERRFILE)))
(SETQ X (DDI.1 (QUOTE D2T)
FN
(LIST X ERRFILE)))
(SETQ X (DDI.1 (QUOTE T2D)
FN
(LIST X ERRFILE)))
(SETQ X (DDI.1 (QUOTE DASM)
FN
(LIST X NIL ERRFILE]
then (printout T (QUOTE ok)
T)
(RETURN X])
(DDI.1
[LAMBDA (FNTOCALL SUBJECTFN ARGS) (* jmh
"29-Jan-86 17:08")
(* * report on results of an ERRORSET for DDI --
if ERRORSET caught an error, print error messages <mentioning FN> and
return NIL -- elseif CAR of result not 0, print error message <mentioning
FN> and return NIL -- else print nothing and return CDR of result)
(DECLARE (USEDFREE ERRFILE))
(LET [(X (ERRORSET (BQUOTE (APPLY (QUOTE (\, FNTOCALL))
(QUOTE (\, ARGS]
(BLOCK)
(if (NLISTP X)
then (LET ((ERRN (ERRORN)))
(DDI.1A FNTOCALL ERRN)
(if ERRFILE
then (printout ERRFILE SUBJECTFN "-- ")
(DDI.1A FNTOCALL ERRN ERRFILE)
(printout ERRFILE T))
NIL)
elseif (NOT (ZEROP (CAAR X)))
then (DDI.1B FNTOCALL (CAAR X))
(if ERRFILE
then (printout ERRFILE SUBJECTFN "-- ")
(DDI.1B FNTOCALL (CAAR X)
ERRFILE)
(printout ERRFILE T))
NIL
else (CDAR X])
(DDI.1A
[LAMBDA (FN ERRN FILE) (* jmh
"29-Jan-86 17:00")
(* * print system-error message for DDI)
(if (NULL FILE)
then (SETQ FILE T))
(printout FILE FN , (QUOTE had% error)
,
(CAR ERRN)
,
(QUOTE --)
,
(ERRORSTRING (CAR ERRN))
T)
(printout FILE (CADR ERRN)
T])
(DDI.1B
[LAMBDA (FN NERRS FILE) (* jmh "13-Jan-86 15:50")
(* * print vanilla-error message for DDI)
(if (NULL FILE)
then (SETQ FILE T))
(printout FILE FN , (QUOTE had)
, NERRS , (QUOTE errors)
T])
)
(DEFINEQ
(DDALL.INIT
[LAMBDA NIL (* jmh "27-Jan-86 16:17")
(* * init global variables in which DDALL stats are collected)
(DECLARE (GLOBALVARS DDALL.LASTFN DDALL.TOTAL DDALL.CANTDO DDALL.FAILED DDALL.7IVARS
DDALL.32FRAME DDALL.40FRAME))
(SETQ DDALL.TOTAL 0) (* count ccodeps)
(SETQ DDALL.CANTDO NIL) (* fns for which no attempt made)
(SETQ DDALL.FAILED NIL) (* fns for which failed)
(SETQ DDALL.7IVARS NIL) (* fns with .ge. 7 ivars)
(SETQ DDALL.32FRAME NIL) (* fns with framesize .ge. 32)
(SETQ DDALL.40FRAME NIL) (* fns with framesize .ge. 40)
NIL])
(DDALL.OK
[LAMBDA (FN ERRFILE QUIET?) (* jmh
" 8-Feb-86 11:19")
(* * say whether is ok to redefine this fn)
(LET ((WHYNOT (if (NOT (LITATOM FN))
then "not litatom"
elseif (NOT (CCODEP (GETD FN)))
then "not ccodep"
elseif (DDALL.OK.LOCKEDP FN)
then "locked down"
elseif (FMEMB FN UNSAFE.TO.MODIFY.FNS)
then "unsafe.to.modify.fn"
elseif (EQ (NTHCHAR FN 1)
(QUOTE \))
then "backslash"
else NIL)))
(if WHYNOT
then (if (NOT QUIET?)
then (printout T FN " skipped -- " WHYNOT T)
(if ERRFILE
then (printout ERRFILE FN " skipped -- " WHYNOT T T)))
NIL
else T])
(DDALL.OK.LOCKEDP
[LAMBDA (FN) (* jmh "14-Jan-86 16:42")
(* * crude, conservative test whether FN is locked down -- is the first page of its definition locked down?)
(PROG (DEF BASE)
(if (NULL (SETQ DEF (GETD FN)))
then (ERROR "unhappy DDALL.OK.LOCKEDP"))
(SETQ BASE (\GETBASEPTR DEF 0))
(RETURN (OR (\LOCKEDPAGEP (fetch (POINTER PAGE#) of BASE))
(\LOCKEDPAGEP (fetch (POINTER PAGE#) of BASE)
T])
(DDALL.1
[LAMBDA (FN SMASHDEF? ERRFILE) (* jmh
" 7-Feb-86 12:03")
(* * apply DDI to FN and collect statistics)
(DECLARE (GLOBALVARS DDALL.LASTFN DDALL.TOTAL DDALL.CANTDO DDALL.FAILED DDALL.7IVARS
DDALL.32FRAME DDALL.40FRAME))
(LET (NEWDEF)
(add DDALL.TOTAL 1)
(SETQ DDALL.LASTFN FN)
(if (NOT (DDALL.OK FN ERRFILE))
then (push DDALL.CANTDO FN)
elseif (NOT (SETQ NEWDEF (DDI FN ERRFILE)))
then (push DDALL.FAILED FN)
else (if SMASHDEF?
then (PUTD FN NEWDEF T))
(if (ILEQ 7 (CADR \ASM.STATS))
then (push DDALL.7IVARS FN))
(LET [(FRAMESIZE (PLUS 8 (CADR \ASM.STATS)
(CADDR \ASM.STATS)
(CADDDR \ASM.STATS)
(CAR (CDDDDR \ASM.STATS]
(if (ILEQ 32 FRAMESIZE)
then (push DDALL.32FRAME FN))
(if (ILEQ 40 FRAMESIZE)
then (push DDALL.40FRAME FN])
(DDALL.REPORT
[LAMBDA (FILE SKIP?) (* jmh
"29-Jan-86 16:54")
(* * report on statistics for DDALL, to FILE)
(DECLARE (GLOBALVARS DDALL.LASTFN DDALL.TOTAL DDALL.CANTDO DDALL.FAILED DDALL.7IVARS
DDALL.32FRAME DDALL.40FRAME))
(if (NULL FILE)
then (SETQ FILE T))
(printout FILE "summary for " DDALL.TOTAL " fns thru " DDALL.LASTFN " --" T)
(if SKIP?
then (printout FILE T))
(printout FILE (LENGTH DDALL.CANTDO)
" not attempted-- "
(REVERSE DDALL.CANTDO)
T)
(if SKIP?
then (printout FILE T))
(printout FILE (LENGTH DDALL.FAILED)
" failures-- "
(REVERSE DDALL.FAILED)
T)
(if SKIP?
then (printout FILE T))
(printout FILE (LENGTH DDALL.7IVARS)
" with .ge.7 ivars-- "
(REVERSE DDALL.7IVARS)
T)
(if SKIP?
then (printout FILE T))
(printout FILE (LENGTH DDALL.32FRAME)
" with framesize 32..39--"
(LDIFFERENCE (REVERSE DDALL.32FRAME)
DDALL.40FRAME)
T)
(if SKIP?
then (printout FILE T))
(printout FILE (LENGTH DDALL.40FRAME)
" with framesize .ge.40--"
(REVERSE DDALL.40FRAME)
T])
)
(DEFINEQ
(DDLIST
[LAMBDA (L SMASHDEF? ERRFILE) (* jmh
" 4-Feb-86 15:59")
(* * apply DDI to all appropriate atoms on list L and print summaries --
use file ERRFILE if specified, T in either case)
(DECLARE (GLOBALVARS DDALL.LASTFN))
(OR ERRFILE (SETQ ERRFILE (QUOTE DDLIST.OUT)))
(printout T [SETQ ERRFILE (FULLNAME (OPENSTREAM ERRFILE (QUOTE OUTPUT]
T)
(DDALL.INIT)
(RESETLST [RESETSAVE NIL (BQUOTE (CLOSEF (\, ERRFILE]
(RESETSAVE NIL (BQUOTE (DDALL.REPORT (\, ERRFILE)
T)))
(RESETSAVE NIL (BQUOTE (DDALL.REPORT)))
(for X in L do (if (KEYDOWNP (QUOTE STOP))
then (ERROR!)
else (DDALL.1 X SMASHDEF? ERRFILE)))
(SETQ DDALL.LASTFN "end"])
(COLLECT.FNS.OF
[LAMBDA (COMS) (* jmh "14-Jan-86 12:16")
(* * return list comprising all top-level FNS of COMS variable)
(for X in COMS when (EQ (CAR X)
(QUOTE FNS))
join (COPY (CDR X])
(COLLECT.D2D.FNS
[LAMBDA NIL (* jmh
"31-Jan-86 14:58")
(* * set D2D.FNS to a list of the names of all the fns in the D2D
packages, for applying D2D to -- for beginnings of crude attempt to
empirically solve the halting problem)
(DECLARE (GLOBALVARS D2D.FNS))
[SETQ D2D.FNS (APPEND (for X in (QUOTE (D2DTESTCOMS DDISASMCOMS D2TCOMS T2DCOMS DASMCOMS))
join (COLLECT.FNS.OF (EVAL X)))
(for X in ASMCOMS join (COLLECT.FNS.OF X]
T])
)
(DEFINEQ
(DDALL
[LAMBDA (STARTFROM SMASHDEF? ERRFILE) (* jmh
" 4-Feb-86 11:33")
(* * apply DDI to all atoms in DDALL.FNS .ge.
STARTFROM and print summaries -- use file ERRFILE if specified, T in
either case -- STOP key aborts cleanly --
SPACE key says where we are)
(DECLARE (GLOBALVARS DDALL.FNS DDALL.LASTFN))
(if (NULL DDALL.FNS)
then (printout T "building DDALL.FNS" T)
(printout T (COLLECT.ALL.FNS)
" fns" T))
(OR ERRFILE (SETQ ERRFILE (QUOTE DDALL.OUT)))
(printout T [SETQ ERRFILE (FULLNAME (OPENSTREAM ERRFILE (QUOTE OUTPUT]
T)
(DDALL.INIT)
(RESETLST [RESETSAVE NIL (BQUOTE (CLOSEF (\, ERRFILE]
(RESETSAVE NIL (BQUOTE (DDALL.REPORT (\, ERRFILE)
T)))
(RESETSAVE NIL (BQUOTE (DDALL.REPORT)))
(for X in DDALL.FNS do (if (KEYDOWNP (QUOTE STOP))
then (ERROR!)
elseif (OR (NULL STARTFROM)
(ALPHORDER STARTFROM X))
then (DDALL.1 X SMASHDEF? ERRFILE)))
(SETQ DDALL.LASTFN "end"])
(COLLECT.ALL.FNS
[LAMBDA NIL
(DECLARE (GLOBALVARS DDALL.FNS)) (* jmh
"27-Jan-86 18:12")
(SETQ DDALL.FNS NIL)
[MAPATOMS (FUNCTION (LAMBDA (X)
(if (AND (CCODEP (GETD X))
(NEQ (NTHCHAR X 1)
(QUOTE \))
(NOT (FMEMB X UNSAFE.TO.MODIFY.FNS))
(NOT (DDALL.OK.LOCKEDP X)))
then (push DDALL.FNS X]
(SETQ DDALL.FNS (SORT DDALL.FNS))
(LENGTH DDALL.FNS])
)
(PUTPROPS D2DTEST COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1052 2546 (DD 1062 . 2350) (SHOWOL 2352 . 2544)) (2547 3577 (PRINTCODELIST 2557 . 3575)
) (3578 4325 (DESCRIBEFN 3588 . 4323)) (4326 7612 (DDI 4336 . 5381) (DDI.1 5383 . 6780) (DDI.1A 6782
. 7303) (DDI.1B 7305 . 7610)) (7613 12878 (DDALL.INIT 7623 . 8530) (DDALL.OK 8532 . 9608) (
DDALL.OK.LOCKEDP 9610 . 10184) (DDALL.1 10186 . 11450) (DDALL.REPORT 11452 . 12876)) (12879 14848 (
DDLIST 12889 . 13847) (COLLECT.FNS.OF 13849 . 14160) (COLLECT.D2D.FNS 14162 . 14846)) (14849 16905 (
DDALL 14859 . 16224) (COLLECT.ALL.FNS 16226 . 16903)))))
STOP