(FILECREATED " 2-Jun-86 12:54:34" {ERIS}<TAMARIN>WORK>DT>DT.;20 21230
changes to: (VARS DTCOMS)
(FNS TCO DT.1)
previous date: " 8-Apr-86 16:44:43" {ERIS}<TAMARIN>WORK>DT>DT.;18)
(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT DTCOMS)
(RPAQQ DTCOMS [(COMS (* entire D->T translation process)
(FILES DDISASM D2T TASM)
(FNS DT))
(COMS (* some handy front-end functions)
(FNS LOFILE LOFILE.1)
(GLOBALVARS LOFILE.RESUMELIST)
(FNS COFILE CO CO.1 CO.1I)
(GLOBALVARS COFILE.RESUMELIST CO.RESUMELIST)
(FNS TCO)
(GLOBALVARS TCO.RESUMELIST)
(FNS DTFILE DT.1 DT.1I)
(GLOBALVARS DTFILE.RESUMELIST DT.RESUMELIST)
(ADVISE EDITF))
(COMS (* some user-interface utilities)
(FNS DT.ERROR)
(FNS DT.INFILEP DT.FILEINLISTP DT.FNINFILELISTP DT.ROOTFILENAME (* file-list
handlers))
(INITVARS OPTIMIZATIONSOFFFILES DFNFLGFILES (* file lists))
(INITVARS DT.LASTARG DT.LASTFILEARG (* restart points))
(FNS DT.XXLIST DT.XXFILEFNS DT.XXFILEFNS.1 (* skeletons)))
(COMS (* compiler-generated subfunction stuff)
(FNS DT.SUBFNS DT.ISIMMSUBFNOF))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA])
(* entire D->T translation process)
(FILESLOAD DDISASM D2T TASM)
(DEFINEQ
(DT
[LAMBDA (FNARG NOARGHERE) (* jmh " 8-Apr-86 14:25")
(* * convert the ccodep definitions of all the fns indicated by FNARG <see
LOFILE.1 for how> -- conventions inherited from DT.XXLIST)
(LET ((BREAKNAME (QUOTE DT)))
(if NOARGHERE
then (DT.ERROR "too many args" NOARGHERE BREAKNAME)
else (DT.XXLIST BREAKNAME (FUNCTION DT.1)
(QUOTE DT.LASTARG)
(QUOTE CO.RESUMELIST)
FNARG])
)
(* some handy front-end functions)
(DEFINEQ
(LOFILE
[LAMBDA (FILEARG NOARGHERE) (* jmh " 8-Apr-86 12:28")
(* * load all the files indicated by FILEARG --
respect DFNFLGFILES <see LOFILE.1 for how> --
conventions inherited from DT.XXFILE, DT.ROOTFILENAME)
(if NOARGHERE
then (DT.ERROR "too many args" NOARGHERE (QUOTE LOFILE))
else (DT.XXLIST (QUOTE LOFILE)
(FUNCTION LOFILE.1)
(QUOTE DT.LASTFILEARG)
(QUOTE LOFILE.RESUMELIST)
FILEARG])
(LOFILE.1
[LAMBDA (FILE) (* jmh " 8-Apr-86 13:04")
(* * if this file has DFNFLGness then LOADFNS all its fns PROP else LOAD it)
(DECLARE (GLOBALVARS DFNFLGFILES))
(OR (BOUNDP (QUOTE DFNFLGFILES))
(SETQ DFNFLGFILES NIL))
(if (DT.FILEINLISTP FILE DFNFLGFILES (QUOTE LOFILE))
then (printout T "LOADFNing from " FILE " ..." T)
(LOADFNS T FILE (QUOTE PROP))
else (LOAD FILE])
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS LOFILE.RESUMELIST)
)
(DEFINEQ
(COFILE
[LAMBDA (FILEARG NOARGHERE) (* jmh " 8-Apr-86 12:29")
(* * apply CO to the list-of-FNS of each of the files indicated by FILEARG --
conventions inherited from DT.XXFILE, DT.ROOTFILENAME)
(if NOARGHERE
then (DT.ERROR "too many args" NOARGHERE (QUOTE COFILE))
else (DT.XXFILEFNS (QUOTE COFILE)
(FUNCTION CO)
(QUOTE DT.LASTFILEARG)
(QUOTE COFILE.RESUMELIST)
FILEARG])
(CO
[LAMBDA (FNARG NOARGHERE) (* jmh " 8-Apr-86 14:24")
(* * compile all the fns indicated by FNARG <see CO.1 for how> --
conventions inherited from DT.XXLIST)
(LET ((BREAKNAME (QUOTE CO)))
(if NOARGHERE
then (DT.ERROR "too many args" NOARGHERE BREAKNAME)
else (DT.XXLIST BREAKNAME (FUNCTION CO.1)
(QUOTE DT.LASTARG)
(QUOTE CO.RESUMELIST)
FNARG])
(CO.1
[LAMBDA (FN) (* jmh " 8-Apr-86 15:29")
(* * compile FN "ST N" except <1> wrap compile in OPTIMIZATIONSOFF = fn being
compiled is DT.INFILEP to some file in OPTIMIZATIONSOFFFILES <2> if fn is on
any file in DFNFLGFILES then compile to CODE properties vs to definition cells)
(DECLARE (GLOBALVARS OPTIMIZATIONSOFFFILES DFNFLGFILES))
(LET ((VIRGINFN (VIRGINFN FN))
(BREAKNAME (QUOTE CO)))
(if (NULL VIRGINFN)
then (DT.ERROR "no VIRGINFN def for" FN BREAKNAME)
else (RESETLST (RESETSAVE OPTIMIZATIONSOFF (DT.FNINFILELISTP FN OPTIMIZATIONSOFFFILES
BREAKNAME))
(if (DT.FNINFILELISTP FN DFNFLGFILES BREAKNAME)
then (printout T "compiling " FN " --")
(PUTD (QUOTE CO.1.TEMPFN)
NIL)
(CO.1I (QUOTE CO.1.TEMPFN)
VIRGINFN)
(LET [(CCODEP (GETD (QUOTE CO.1.TEMPFN]
(if (NULL CCODEP)
then (DT.ERROR "compile failed" FN BREAKNAME)
elseif (DT.SUBFNS (QUOTE CO.1.TEMPFN)
CCODEP)
then (DT.ERROR "fn has subfns" FN BREAKNAME)
else (if (EQ (fetch (CODEARRAY FRAMENAME) of CCODEP)
(QUOTE CO.1.TEMPFN))
then (replace (CODEARRAY FRAMENAME) of CCODEP
with FN))
(PUTPROP FN (QUOTE CODE)
CCODEP)
FN))
else (CO.1I FN VIRGINFN])
(CO.1I
[LAMBDA (FN EXPRDEF) (* jmh " 8-Apr-86 12:39")
(* * COMPILE1 FN EXPRDEF T "ST N")
(LET ((LAPFLG NIL)
(STRF T)
(SVFLG T)
(LCFIL NIL)
(LSTFIL T))
(DECLARE (SPECVARS LAPFLG STRF SVFLG LCFIL LSTFIL))
(COMPILE1 FN EXPRDEF T])
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS COFILE.RESUMELIST CO.RESUMELIST)
)
(DEFINEQ
(TCO
[LAMBDA (FNARG NOARGHERE) (* jmh " 2-Jun-86 12:14")
(* * compile all the fns indicated by FNARG and convert them to Tamarin code -- conventions inherited from
DT.XXLIST)
(LET ((BREAKNAME (QUOTE TCO)))
(if NOARGHERE
then (DT.ERROR "too many args" NOARGHERE BREAKNAME)
else (DT.XXLIST BREAKNAME [FUNCTION (LAMBDA (FN)
(AND (CO.1 FN)
(DT.1 FN]
(QUOTE DT.LASTARG)
(QUOTE TCO.RESUMELIST)
FNARG])
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS TCO.RESUMELIST)
)
(DEFINEQ
(DTFILE
[LAMBDA (FILEARG NOARGHERE) (* jmh " 8-Apr-86 14:22")
(* * apply DT to the list-of-FNS of each of the files indicated by FILEARG --
conventions inherited from DT.XXFILE, DT.ROOTFILENAME)
(if NOARGHERE
then (DT.ERROR "too many args" NOARGHERE (QUOTE DTFILE))
else (DT.XXFILEFNS (QUOTE COFILE)
(FUNCTION DT)
(QUOTE DT.LASTFILEARG)
(QUOTE DTFILE.RESUMELIST)
FILEARG])
(DT.1
[LAMBDA (FN) (* jmh "19-May-86 17:10")
(* * convert the ccodep definition of FN to a tcodep definition and hang that on FNs TCODE property -- if FN is a
FNS of some file on DFNFLGFILES then use the CODE property else use the definition cell -- also ok for FN to be a
ccodep in which case the return is <#errs %. the tcodep>)
(* * a tcodep is a list: car is byte array, some of the function header fields of which need massaging at load
time, and the cdr of which is a list of load/link information)
(DECLARE (GLOBALVARS DFNFLGFILES))
(if (NOT (LITATOM FN))
then (DT.1I FN)
else (LET ((BREAKNAME (QUOTE DT))
CCODEP X)
(if [NULL (SETQ CCODEP (if (DT.FNINFILELISTP FN DFNFLGFILES BREAKNAME)
then (GETPROP FN (QUOTE CODE))
else (GETD FN]
then (DT.ERROR "no code definition for" FN BREAKNAME)
elseif (DT.SUBFNS FN CCODEP)
then (DT.ERROR "fn has subfns:" FN BREAKNAME)
else (printout T FN T)
(SETQ X (DT.1I CCODEP))
(if (AND (LISTP X)
(LISTP (CDR X))
(ARRAYP (CADR X)))
then (PUTPROP FN (QUOTE TCODE)
(CDR X))
(if (ZEROP (CAR X))
then (CADR X])
(DT.1I
[LAMBDA (CCODEP)
(DECLARE (GLOBALVARS DTCCODEP DDA D2T TASM)) (* jmh " 8-Apr-86 15:00")
(PROG NIL
(PROGN (SETQ DTCCODEP CCODEP)
(SETQ DDA (QUOTE ??))
(SETQ D2T (QUOTE ??))
(SETQ TASM (QUOTE ??)))
(SETQ DDA (DDISASM CCODEP))
(if (NOT (ZEROP (CAR DDA)))
then (printout T (CAR DDA)
" errors in DDISASM" T)
(RETURN DDA))
(SETQ D2T (D2T (CDR DDA)))
(if (NOT (ZEROP (CAR D2T)))
then (printout T (CAR D2T)
" errors in D2T" T)
(RETURN D2T))
(SETQ TASM (TASM (CDR D2T)))
(if (NOT (ZEROP (CAR TASM)))
then (printout T (CAR TASM)
" errors in TASM" T))
(RETURN TASM])
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS DTFILE.RESUMELIST DT.RESUMELIST)
)
(PUTPROPS EDITF READVICE [NIL (AROUND NIL (LET [(DFNFLGSHOULDBE (if (DT.FNINFILELISTP
(CAR EDITFX)
(GETTOPVAL (QUOTE DFNFLGFILES)
))
then
(QUOTE PROP]
(if (NEQ (GETTOPVAL (QUOTE DFNFLG))
DFNFLGSHOULDBE)
then
(HELP "to edit this fn, DFNFLG should be"
DFNFLGSHOULDBE))
*
(if (NEQ (GETTOPVAL (QUOTE DFNFLG))
DFNFLGSHOULDBE)
then
(HELP
"ooh! to edit this fn, DFNFLG should have been"
DFNFLGSHOULDBE])
(READVISE EDITF)
(* some user-interface utilities)
(DEFINEQ
(DT.ERROR
[LAMBDA (MESS1 MESS2 BREAKNAME) (* jmh " 8-Apr-86 10:18")
(APPLY* (QUOTE BREAK1)
NIL T (OR BREAKNAME (QUOTE DT.ERROR))
NIL T (LIST (MKSTRING MESS1)
MESS2])
)
(DEFINEQ
(DT.INFILEP
[LAMBDA (FN FILE BREAKNAME) (* jmh " 8-Apr-86 10:20")
(* * return FN/NIL as FN is/isn't mentioned in FILE's FILE property's coms var
-- error if FILE doesn't have one -- but if FN is NIL then return list of FNS
of the coms var)
(OR BREAKNAME (SETQ BREAKNAME (QUOTE DT.INFILEP)))
(LET*[(ROOT (DT.ROOTFILENAME FILE))
[FILEPROP (AND ROOT (GETPROP ROOT (QUOTE FILE]
[COMSATOM (OR (AND FILEPROP (CAAR FILEPROP))
(AND ROOT (PACK* ROOT (QUOTE COMS]
(COMS (AND COMSATOM (LITATOM COMSATOM)
(BOUNDP COMSATOM)
(EVALV COMSATOM]
(if (NOT (LISTP COMS))
then (DT.ERROR "file has no COMS:" FILE BREAKNAME)
elseif FN
then (if (INFILECOMS? FN (QUOTE FNS)
COMS)
then FN
else NIL)
else (INFILECOMS? NIL (QUOTE FNS)
COMS])
(DT.FILEINLISTP
[LAMBDA (FILE FILELIST BREAKNAME) (* jmh " 8-Apr-86 11:32")
(* * if FILE is in LIST then return FILE else NIL)
(OR BREAKNAME (SETQ BREAKNAME (QUOTE DT.FILEINLISTP)))
(LET ((ROOT (DT.ROOTFILENAME FILE)))
(if (NULL ROOT)
then (DT.ERROR "bad file name:" FILE BREAKNAME)
elseif (for FILE2 in FILELIST thereis (EQ ROOT (DT.ROOTFILENAME FILE2)))
then FILE])
(DT.FNINFILELISTP
[LAMBDA (FN FILELIST BREAKNAME) (* jmh " 8-Apr-86 12:47")
(* * if FN is a FNS of any file in LIST then return FN else NIL)
(OR BREAKNAME (SETQ BREAKNAME (QUOTE DT.FNINFILELISTP)))
(if (for FILE in FILELIST thereis (DT.INFILEP FN FILE BREAKNAME))
then FN
else NIL])
(DT.ROOTFILENAME
[LAMBDA (FILENAME) (* jmh " 8-Apr-86 09:06")
(LET (ROOT)
(SETQ ROOT (U-CASE (ROOTFILENAME FILENAME)))
(if (EQ (QUOTE .DCOM)
(SUBATOM ROOT -5))
then (SETQ ROOT (SUBATOM ROOT 1 -6)))
(if [AND (OR (LITATOM FILENAME)
(STRINGP FILENAME))
(NOT (ZEROP (NCHARS ROOT]
then ROOT])
)
(RPAQ? OPTIMIZATIONSOFFFILES NIL)
(RPAQ? DFNFLGFILES NIL)
(RPAQ? DT.LASTARG NIL)
(RPAQ? DT.LASTFILEARG NIL)
(DEFINEQ
(DT.XXLIST
[LAMBDA (MY.PRINT.NAME FN.TO.APPLY.TO.EACH LAST.ARG.ATOM RESUME.LIST.ATOM ARG)
(* jmh " 8-Apr-86 14:49")
(* * apply FN.TO.APPLY.TO.EACH to each element of ARG <to ARG itself if it is
NLISTP> -- handles STOP key and resuming,redoing with same argument)
(* * MY.PRINT.NAME is for messages -- FN.TO.APPLY.TO.EACH is APPLYable to one
argument and returns NIL only if it thinks the looping should STOP --
RESUME.LIST.ATOM points to the remaining-arg list used for restart --
ARG is either NIL = reuse what LAST.ARG.ATOM points to or T = restart or LISTP
= a list of things or a single thing -- a thing being the kind of argument
FN.TO.APPLY.TO.EACH wants -- FN.TO.APPLY.TO.EACH should check its arg)
(LET*((PROCESSED-ARG (if (NULL ARG)
then (if (BOUNDP LAST.ARG.ATOM)
then (GETTOPVAL LAST.ARG.ATOM))
elseif (AND (EQ T ARG)
(BOUNDP RESUME.LIST.ATOM))
then (GETTOPVAL RESUME.LIST.ATOM)
else (SETTOPVAL LAST.ARG.ATOM ARG)))
NTODO NDONE THING OK?)
(if (OR (NULL PROCESSED-ARG)
(LISTP PROCESSED-ARG))
then (SETQ NTODO (LENGTH PROCESSED-ARG))
(SETQ NDONE 0)
(SETTOPVAL RESUME.LIST.ATOM PROCESSED-ARG)
[while (AND [SETQ OK? (PROGN (BLOCK)
(NOT (KEYDOWNP (QUOTE STOP]
(SETQ THING (pop (GETTOPVAL RESUME.LIST.ATOM)))
(add NDONE 1)
(SETQ OK? (APPLY* FN.TO.APPLY.TO.EACH THING]
else (SETQ NTODO 1)
(SETQ NDONE 1)
(SETQ OK? (APPLY* FN.TO.APPLY.TO.EACH PROCESSED-ARG)))
(if (NOT OK?)
then (printout T MY.PRINT.NAME " aborted in " NDONE " of " NTODO T)
NIL
elseif (OR (NEQ NDONE NTODO)
(ZEROP NTODO))
then (printout T MY.PRINT.NAME " completed " NDONE " of " NTODO T)
NIL
elseif (OR (NEQ 1 NDONE)
(NEQ 1 NTODO))
then (LIST MY.PRINT.NAME (QUOTE completed)
NDONE
(QUOTE of)
NTODO)
else OK?])
(DT.XXFILEFNS
[LAMBDA (MY.PRINT.NAME FN.TO.APPLY.TO.EACH.FN.LIST LAST.ARG.ATOM RESUME.LIST.ATOM ARG)
(* jmh " 8-Apr-86 14:49")
(* * apply FN.TO.APPLY.TO.EACH.FN.LIST to the list of FNS of each file
indicated by ARG -- handles list argument, STOP key and resuming,redoing with
same argument)
(* * MY.PRINT.NAME is for messages -- FN.TO.APPLY.TO.EACH.FN.LIST is APPLYable
to one argument, a list of FNS of the COMS variable of a file, and returns NIL
only if it thinks the looping should STOP --
RESUME.LIST.ATOM points to the list of file litatoms used for restart --
ARG is either a litatom or a list of litatoms or NIL = reuse that pointed to by
LAST.ARG.ATOM or T = restart)
(* * when a litatom used as a filename what is actually used is its
DT.ROOTFILENAME)
(LET*((PROCESSED-ARG (if (NULL ARG)
then (if (BOUNDP LAST.ARG.ATOM)
then (GETTOPVAL LAST.ARG.ATOM))
elseif (AND (EQ T ARG)
(BOUNDP RESUME.LIST.ATOM))
then (GETTOPVAL RESUME.LIST.ATOM)
else (SETTOPVAL LAST.ARG.ATOM ARG)))
TOT-NFILES NFILES-DONE FILE OK?)
(if (OR (NULL PROCESSED-ARG)
(LISTP PROCESSED-ARG))
then (SETQ TOT-NFILES (LENGTH PROCESSED-ARG))
(SETQ NFILES-DONE 0)
(SETTOPVAL RESUME.LIST.ATOM PROCESSED-ARG)
[while (AND [SETQ OK? (PROGN (BLOCK)
(NOT (KEYDOWNP (QUOTE STOP]
(SETQ FILE (pop (GETTOPVAL RESUME.LIST.ATOM)))
(add NFILES-DONE 1)
(SETQ OK? (DT.XXFILEFNS.1 MY.PRINT.NAME FN.TO.APPLY.TO.EACH.FN.LIST FILE]
else (SETQ TOT-NFILES 1)
(SETQ NFILES-DONE 1)
(SETQ OK? (DT.XXFILEFNS.1 MY.PRINT.NAME FN.TO.APPLY.TO.EACH.FN.LIST PROCESSED-ARG)))
(if (NOT OK?)
then (printout T MY.PRINT.NAME " aborted in file " NFILES-DONE " of " TOT-NFILES T)
NIL
elseif (OR (NEQ NFILES-DONE TOT-NFILES)
(ZEROP TOT-NFILES))
then (printout T MY.PRINT.NAME " completed " NFILES-DONE " of " TOT-NFILES T)
NIL
elseif (OR (NEQ 1 NFILES-DONE)
(NEQ 1 TOT-NFILES))
then (LIST MY.PRINT.NAME (QUOTE completed)
NFILES-DONE
(QUOTE of)
TOT-NFILES)
else OK?])
(DT.XXFILEFNS.1
[LAMBDA (MY.PRINT.NAME FN.TO.APPLY.TO.FN.LIST FILE) (* jmh " 8-Apr-86 10:33")
(* * ensure that FILE is a LITATOM having a COMS variable, then apply
FN-TO-DO-TO-1-FN to each function in the COMS variable --
passes this list of FNS to DT.XXFN)
(* * when a litatom used as a filename what is actually used is the
ROOTFILENAME, uppercase, with .dcom stripped off)
(LET ((FNS (DT.INFILEP NIL FILE MY.PRINT.NAME)))
(if (NULL FNS)
then (DT.ERROR "file has no FNS:" FILE MY.PRINT.NAME)
else (APPLY* FN.TO.APPLY.TO.FN.LIST FNS])
)
(* compiler-generated subfunction stuff)
(DEFINEQ
(DT.SUBFNS
[LAMBDA (FNNAME CCODEP) (* jmh " 8-Apr-86 16:44")
(* * supposed to return list of subfns of FNNAME called in CCODEP)
NIL])
(DT.ISIMMSUBFNOF
[LAMBDA (SUBFN FN) (* jmh " 8-Apr-86 16:41")
(AND (EQUAL (CONCAT FN (QUOTE A))
(SUBSTRING SUBFN 1 -5))
(NUMBERP (SUBATOM SUBFN -4])
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PUTPROPS DT COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1462 2064 (DT 1472 . 2062)) (2108 3243 (LOFILE 2118 . 2718) (LOFILE.1 2720 . 3241)) (
3312 7062 (COFILE 3322 . 3889) (CO 3891 . 4450) (CO.1 4452 . 6687) (CO.1I 6689 . 7060)) (7145 7735 (
TCO 7155 . 7733)) (7801 10762 (DTFILE 7811 . 8378) (DT.1 8380 . 9845) (DT.1I 9847 . 10760)) (11478
11745 (DT.ERROR 11488 . 11743)) (11746 14233 (DT.INFILEP 11756 . 12829) (DT.FILEINLISTP 12831 . 13357)
(DT.FNINFILELISTP 13359 . 13758) (DT.ROOTFILENAME 13760 . 14231)) (14362 20518 (DT.XXLIST 14372 .
16948) (DT.XXFILEFNS 16950 . 19806) (DT.XXFILEFNS.1 19808 . 20516)) (20568 21025 (DT.SUBFNS 20578 .
20790) (DT.ISIMMSUBFNOF 20792 . 21023)))))
STOP