(FILECREATED "19-Nov-84 19:02:04" {AZTEC}<TRILLIUM>BIRTHDAY84>RERELEASE>TRI-COMPILE.;2 15955
changes to: (FNS COMPILE.SUBITEMS.EVAL COMPILE.SIMPLE.ITYPE COMPILE.INTERNAL.FNS.IF.NECESSARY
COMPILE.INTERNAL.FNS)
(VARS TRI-COMPILECOMS)
previous date: " 7-Sep-84 14:22:40" {AZTEC}<TRILLIUM>BIRTHDAY84>RERELEASE>TRI-COMPILE.;1)
(PRETTYCOMPRINT TRI-COMPILECOMS)
(RPAQQ TRI-COMPILECOMS ((VARS (TRILLIUM.INTERNAL.FNS)
(KEEP.INTERNAL.EXPRS)
(COMPILE.ON.LOAD))
(FNS COMPILE.COMPOSITE.ITYPE COMPILE.INTERNAL.FNS COMPILE.INTERNAL.FNS.IF.NECESSARY
COMPILE.INTO.PROG COMPILE.ITEM.TYPE COMPILE.SIMPLE.ITYPE COMPILE.SUBITEMS
COMPILE.SUBITEMS.EVAL COMPILE.SUBITEMS.FOREACH COMPILE.SUBITEMS.HELP COMPILE.SUBITEMS.IF
COMPILE.SUBITEMS.INCREMENT COMPILE.SUBITEMS.ITEM COMPILE.SUBITEMS.SELECT
GET.ANALYSIS.FNNAME GET.ANALYSISFN NOTE.INTERNAL.FN QCOMPILE! RECOMPILE.ITEMTYPES
SET.ANALYSISFN)))
(RPAQQ TRILLIUM.INTERNAL.FNS NIL)
(RPAQQ KEEP.INTERNAL.EXPRS NIL)
(RPAQQ COMPILE.ON.LOAD NIL)
(DEFINEQ
(COMPILE.COMPOSITE.ITYPE
[LAMBDA (ITYPE DESCRIPTION) (* HaKo "27-Jul-84 16:46")
(* Compiles a PROG form containing bindings for the item type parameters and all forms necessary to analyze an
item of this composite type. The bindings and body forms are collected in lower support functions using TCONC
cells, and then assembled into a PROG form)
(PROG ((SUBITEM.SPECS (GET.FIELDQ DESCRIPTION SUBITEM.SPECS ITEM.TYPE))
(BINDINGS (TCONC NIL (QUOTE $SubItem$)))
(PROGBODY (CONS)))
(COND
((NULL SUBITEM.SPECS)
(RETURN)))
[TCONC BINDINGS (LIST (QUOTE $SubitemsTcell$)
(QUOTE (CONS]
[for PARAMETER.NAME in (ITEM.TYPE.PARAMETER.NAMES ITYPE)
do (TCONC BINDINGS PARAMETER.NAME)
(TCONC PROGBODY (SUBST PARAMETER.NAME (QUOTE Param)
(QUOTE (SETQ Param (GET.PARAM $Item$ (QUOTE Param]
(COMPILE.SUBITEMS SUBITEM.SPECS BINDINGS PROGBODY)
[TCONC PROGBODY (QUOTE (SET.FIELD $Item$ (QUOTE SUBITEMS)
(CAR $SubitemsTcell$]
[TCONC PROGBODY (QUOTE (SET.FIELD $Item$ (QUOTE BOUNDING.BOX)
(COMPOSITE.BOUNDING.BOX (CAR $SubitemsTcell$]
(RETURN (LIST (COMPILE.INTO.PROG BINDINGS PROGBODY])
(COMPILE.INTERNAL.FNS
[LAMBDA NIL (* kkm "19-Nov-84 15:50")
(* PH " 7-Sep-84 14:16")
(* HaKo "15-Aug-84 17:11")
(DECLARE (GLOBALVARS KEEP.INTERNAL.EXPRS TRILLIUM.INTERNAL.FNS))
(for FNS on TRILLIUM.INTERNAL.FNS when (LISTP (GETD (CAR FNS)))
do (THINKING (QCOMPILE! FNS (NOT KEEP.INTERNAL.EXPRS)))
(RETURN])
(COMPILE.INTERNAL.FNS.IF.NECESSARY
[LAMBDA NIL (* kkm "19-Nov-84 15:50")
(* PH " 7-Sep-84 14:16")
(* HaKo "15-Aug-84 17:11")
(DECLARE (GLOBALVARS COMPILE.ON.LOAD))
(AND COMPILE.ON.LOAD (COMPILE.INTERNAL.FNS])
(COMPILE.INTO.PROG
[LAMBDA (BINDINGS PROGBODY) (* HaKo " 8-SEP-83 11:33")
(* Creates a (PROG (bindings) progbody) expression. All variables bound in this PROG whose pname does not start
with $ are declared to be special)
(PROG (VAR DECLS)
(SETQ DECLS (for BINDING in (CAR BINDINGS) unless [EQ [CHCON1 (SETQ VAR
(COND
((ATOM BINDING)
BINDING)
(T (CAR BINDING]
(CONSTANT (CHCON1 (QUOTE $]
collect VAR))
(RETURN (CONS (QUOTE PROG)
(CONS (CAR BINDINGS)
(COND
(DECLS (CONS (LIST (QUOTE DECLARE)
(CONS (QUOTE SPECVARS)
DECLS))
(CAR PROGBODY)))
(T (CAR PROGBODY])
(COMPILE.ITEM.TYPE
[LAMBDA (ITYPE) (* HaKo "26-Jul-84 11:02")
(* DAHJr " 5-DEC-83 10:38")
(* Defines a LAMBDA form containing all actions necessary to analyze an item of this type, puts it as the function
definition of "Analyze.<ITYPE>", and stores it as the analysis function for this item type)
(PROG (FNNAME COMPFORM ITYPEDESCR)
(COND
((NOT (LITATOM ITYPE))
(TROUBLE.WITH.TRILLIUM "Illegal item type: " ITYPE)))
(SETQ ITYPEDESCR (ITEM.TYPE.DESCRIPTION ITYPE))
(COND
((NULL ITYPEDESCR)
(TROUBLE.WITH.TRILLIUM "No description for item type" ITYPE)))
[SETQ COMPFORM (COND
((GETPROP ITYPE (QUOTE COMPOSITE?))
(COMPILE.COMPOSITE.ITYPE ITYPE ITYPEDESCR))
(T (COMPILE.SIMPLE.ITYPE ITYPE ITYPEDESCR]
(SETQ COMPFORM (CONS (QUOTE LAMBDA)
(CONS (QUOTE ($Item$))
COMPFORM)))
(SETQ FNNAME (GET.ANALYSIS.FNNAME ITYPE))
(SET.ANALYSISFN ITYPE FNNAME)
(PUTD FNNAME COMPFORM)
(NOTE.INTERNAL.FN FNNAME)
(RETURN FNNAME])
(COMPILE.SIMPLE.ITYPE
[LAMBDA (ITYPE DESCRIPTION) (* kkm "19-Nov-84 11:35")
(* If an analyze function is defined for this item type (on FNS list of ITYPE) then call it.
If a bounding.box is defined for ITYPE use it to set the BOUNDING.BOX field, otherwise use the first REGION field
of the item)
(PROG ((COMPFORM (CONS))
(PRIM.ANALFN (GETPROP ITYPE (QUOTE ANALYZE)))
(PRIM.BBOXFN (GETPROP ITYPE (QUOTE BOUNDING.BOX)))
REGIONPARAM)
[COND
(PRIM.ANALFN (TCONC COMPFORM (LIST PRIM.ANALFN (QUOTE $Item$]
(COND
[PRIM.BBOXFN (TCONC COMPFORM (LIST (QUOTE SET.FIELDQ)
(QUOTE $Item$)
(QUOTE BOUNDING.BOX)
(LIST PRIM.BBOXFN (QUOTE $Item$]
[[SETQ REGIONPARAM (for PARAMETER in (GET.FIELDQ DESCRIPTION PARAMETERS ITEM.TYPE)
thereis (EQUAL (GET.FIELDQ PARAMETER TYPE)
(QUOTE (REGION]
(TCONC COMPFORM (LIST (QUOTE SET.FIELDQ)
(QUOTE $Item$)
(QUOTE BOUNDING.BOX)
(LIST (QUOTE GET.PARAMQ)
(QUOTE $Item$)
(GET.FIELDQ REGIONPARAM NAME]
(T (SHOULDNT "Item type needs a Bounding.Box function")))
(RETURN (CAR COMPFORM])
(COMPILE.SUBITEMS
[LAMBDA (SUBITEM.SPECS BINDINGS PROGBODY) (* edited: " 6-JUL-82 15:59")
(for SPEC in SUBITEM.SPECS do (SELECTQ (CAR SPEC)
(ITEM (COMPILE.SUBITEMS.ITEM SPEC BINDINGS PROGBODY))
(FOREACH (COMPILE.SUBITEMS.FOREACH SPEC BINDINGS PROGBODY))
(LABEL (COMPILE.SUBITEMS.ITEM (CADDR SPEC)
BINDINGS PROGBODY
(CADR SPEC)))
(SELECT (COMPILE.SUBITEMS.SELECT SPEC BINDINGS PROGBODY))
(IF (COMPILE.SUBITEMS.IF SPEC BINDINGS PROGBODY))
(INCREMENT (COMPILE.SUBITEMS.INCREMENT SPEC BINDINGS
PROGBODY))
(EVAL (COMPILE.SUBITEMS.EVAL SPEC BINDINGS PROGBODY))
(HELP (COMPILE.SUBITEMS.HELP SPEC BINDINGS PROGBODY))
(ERROR "Unrecognized keyword in COMPILE.SUBITEMS"])
(COMPILE.SUBITEMS.EVAL
[LAMBDA (SPEC BINDINGS PROGBODY) (* HaKo " 6-Aug-84 16:02")
(* HK " 1-JUL-82 17:17")
(DECLARE (SPECVARS EvalFn))
(PROG ((EvalFn (CADR SPEC)))
[COND
((LISTP EvalFn)
(SETQ EvalFn (CAR EvalFn]
(TCONC PROGBODY (BQUOTE (for $SubItem$ in (, EvalFn $Item$)
do (ANALYZE.ITEM $SubItem$)
(TCONC $SubitemsTcell$ $SubItem$])
(COMPILE.SUBITEMS.FOREACH
[LAMBDA (SPEC BINDINGS PROGBODY) (* HK "28-JUN-82 14:07")
(PROG (ISPEC SUPPLEMENT REST (LOCALLISTDEFS (CONS))
(LOCALNUMDEFS (CONS))
(LOCALBINDINGS (CONS))
(LOCALFORMS (CONS)))
(for ELEM on (CDR SPEC) until (EQ (CAR ELEM)
(QUOTE DO))
do (SETQ ISPEC (CAR ELEM))
(OR (LITATOM (CAR ISPEC))
(ERROR "Non-atomic iteration variable in COMPILE.SUBITEMS.FOREACH"))
(SELECTQ (CADR ISPEC)
[IN [SETQ SUPPLEMENT (MKATOM (CONCAT "$List.Of$" (CAR ISPEC]
(TCONC LOCALLISTDEFS (CONS (CAR ISPEC)
SUPPLEMENT))
(TCONC LOCALBINDINGS (CAR ISPEC))
(TCONC LOCALBINDINGS (LIST SUPPLEMENT (CADDR ISPEC]
[(FROM BY TO)
(SETQ SUPPLEMENT (LIST 1 1 NIL))
(for PHRASE on (CDR ISPEC) by (CDDR PHRASE)
do (SELECTQ (CAR PHRASE)
(FROM (RPLACA SUPPLEMENT (CADR PHRASE)))
(BY (RPLACA (CDR SUPPLEMENT)
(CADR PHRASE)))
(TO (RPLACA (CDDR SUPPLEMENT)
(CADR PHRASE)))
(ERROR "Unrecognized keyword in COMPILE.SUBITEMS.FOREACH")))
(TCONC LOCALNUMDEFS (CONS (CAR ISPEC)
SUPPLEMENT))
(TCONC LOCALBINDINGS (LIST (CAR ISPEC)
(CAR SUPPLEMENT]
(ERROR "Unrecognized keyword in COMPILE.SUBITEMS.FOREACH"))
finally (SETQ REST (CDR ELEM)))
(TCONC LOCALFORMS (QUOTE $loop$))
[for LOCAL in (CAR LOCALLISTDEFS)
do (TCONC LOCALFORMS (DSUBST (CAR LOCAL)
(QUOTE IV)
(SUBST (CDR LOCAL)
(QUOTE LST)
(QUOTE (COND ((NULL LST)
(RETURN))
(T (SETQ IV (CAR LST))
(SETQ LST (CDR LST]
[for LOCAL in (CAR LOCALNUMDEFS) unless (NULL (CADDDR LOCAL))
do (TCONC LOCALFORMS (DSUBST (CAR LOCAL)
(QUOTE IV)
(SUBST (CADDDR LOCAL)
(QUOTE LIMIT)
(QUOTE (COND ((IGREATERP IV LIMIT)
(RETURN]
(COMPILE.SUBITEMS REST LOCALBINDINGS LOCALFORMS)
[for LOCAL in (CAR LOCALNUMDEFS) unless (ZEROP (CADDR LOCAL))
do (TCONC LOCALFORMS (DSUBST (CAR LOCAL)
(QUOTE IV)
(SUBST (CADDR LOCAL)
(QUOTE INCREMENT)
(QUOTE (SETQ IV (IPLUS IV INCREMENT]
(TCONC LOCALFORMS (LIST (QUOTE GO)
(QUOTE $loop$)))
(TCONC PROGBODY (COMPILE.INTO.PROG LOCALBINDINGS LOCALFORMS])
(COMPILE.SUBITEMS.HELP
[LAMBDA (SPEC BINDINGS PROGBODY) (* edited: " 6-JUL-82 15:50")
(TCONC PROGBODY (QUOTE (HELP])
(COMPILE.SUBITEMS.IF
[LAMBDA (SPEC BINDINGS PROGBODY) (* edited: " 6-JUL-82 15:59")
(PROG ((SENSE T)
(THENPART (TCONC NIL (CADR SPEC)))
(ELSEPART (TCONC NIL T)))
[for PHRASE in (CDDR SPEC) do (SELECTQ PHRASE
(THEN (SETQ SENSE T))
(ELSE (SETQ SENSE NIL))
(COND
(SENSE (COMPILE.SUBITEMS (LIST PHRASE)
BINDINGS THENPART))
(T (COMPILE.SUBITEMS (LIST PHRASE)
BINDINGS ELSEPART]
(COND
[(CAR ELSEPART)
(TCONC PROGBODY (LIST (QUOTE COND)
(CAR THENPART)
(CAR ELSEPART]
(T (TCONC PROGBODY (LIST (QUOTE COND)
(CAR THENPART])
(COMPILE.SUBITEMS.INCREMENT
[LAMBDA (SPEC BINDINGS PROGBODY) (* HK "23-JUN-82 14:24")
(TCONC PROGBODY (LIST (QUOTE SETQ)
(CADR SPEC)
(LIST (QUOTE IPLUS)
(CADR SPEC)
(OR (CADDR SPEC)
1])
(COMPILE.SUBITEMS.ITEM
[LAMBDA (SPEC BINDINGS PROGBODY LABEL) (* HaKo "27-Jul-84 16:03")
(PROG (NEWITEM (TEMPLATE (CADR SPEC)))
(COND
[(ATOM TEMPLATE)
(SETQ NEWITEM (TCONC NIL (QUOTE LIST)))
(TCONC NEWITEM (QUOTE (QUOTE \TYPE)))
(TCONC NEWITEM (KWOTE TEMPLATE))
(for FIELD in (CDDR SPEC)
do (TCONC NEWITEM (KWOTE (CAR FIELD)))
(TCONC NEWITEM (CADR FIELD)))
(TCONC PROGBODY (LIST (QUOTE SETQ)
(QUOTE $SubItem$)
(CAR NEWITEM]
[(EQ (CAR TEMPLATE)
(QUOTE COPY))
[TCONC PROGBODY (LIST (QUOTE SETQ)
(QUOTE $SubItem$)
(LIST (QUOTE COPYALL)
(CADR TEMPLATE]
(for FIELD in (CDDR SPEC) do (TCONC PROGBODY (LIST (QUOTE SET.PARAM)
(QUOTE $SubItem$)
(KWOTE (CAR FIELD))
(CADR FIELD]
(T (ERROR "Unrecognized item specification: " TEMPLATE)))
[COND
((NULL LABEL))
((MEMB LABEL (CAR BINDINGS))
(ERROR "Attempt to rebind LABEL:" LABEL))
(T (TCONC BINDINGS LABEL)
(TCONC PROGBODY (LIST (QUOTE SETQ)
LABEL
(QUOTE $SubItem$]
(TCONC PROGBODY (LIST (GET.ANALYSISFN TEMPLATE T)
(QUOTE $SubItem$)))
(TCONC PROGBODY (LIST (QUOTE TCONC)
(QUOTE $SubitemsTcell$)
(QUOTE $SubItem$])
(COMPILE.SUBITEMS.SELECT
[LAMBDA (SPEC BINDINGS PROGBODY) (* HK "23-JUN-82 14:51")
(PROG (CLAUSEBODY (SELECTBODY (CONS)))
(for PHRASE in (CDDR SPEC)
do (SETQ CLAUSEBODY (TCONC NIL (CAR PHRASE)))
(COMPILE.SUBITEMS (CDR PHRASE)
BINDINGS CLAUSEBODY)
(TCONC SELECTBODY (CAR CLAUSEBODY)))
(TCONC SELECTBODY (LIST (QUOTE ERROR)
(QUOTE "Unrecognized selection in item type")))
(TCONC PROGBODY (CONS (QUOTE SELECTQ)
(CONS (CADR SPEC)
(CAR SELECTBODY])
(GET.ANALYSIS.FNNAME
[LAMBDA (ITYPE) (* HK "25-JUN-82 10:23")
(AND (LITATOM ITYPE)
(MKATOM (CONCAT "$Analyze$." ITYPE])
(GET.ANALYSISFN
[LAMBDA (ITYPE USE.DEFAULT) (* HK "21-JUL-82 17:07")
(* Returns the name of the analysis function for ITYPE. If this item type does not yet have a compiled definition
and a default is required, the analysis function is created (by having it point to ANALYZE.ITEM) Hence compiled
analysis functions ($Analyze$...) always call only other $Analyze$ functions)
(COND
[(LITATOM ITYPE)
(COND
((GETPROP ITYPE (QUOTE COMPILED.ANALYZE)))
(USE.DEFAULT (PROG ((ANALFN (GET.ANALYSIS.FNNAME ITYPE)))
(MOVD? (QUOTE ANALYZE.ITEM)
ANALFN)
(RETURN ANALFN]
(USE.DEFAULT (QUOTE ANALYZE.ITEM])
(NOTE.INTERNAL.FN
[LAMBDA (FNNAME) (* HaKo "15-Aug-84 17:10")
(DECLARE (GLOBALVARS TRILLIUM.INTERNAL.FNS))
(OR (FMEMB FNNAME TRILLIUM.INTERNAL.FNS)
(SETQ TRILLIUM.INTERNAL.FNS (SORT (CONS FNNAME TRILLIUM.INTERNAL.FNS])
(QCOMPILE!
[LAMBDA (FNS NOSAVE NOREDEFINE PRINTLAP) (* HaKo "26-Jul-84 15:22")
(* DAHJr "22-MAR-83 12:59")
(DECLARE (GLOBALVARS TrilliumBitBucket))
(COND
((NOT (BOUNDP (QUOTE TrilliumBitBucket)))
(SETQ TrilliumBitBucket (DSPCREATE))
(DSPOPERATION (QUOTE PAINT)
TrilliumBitBucket)
(DSPCLIPPINGREGION (QUOTE (0 0 0 0))
TrilliumBitBucket)))
(RESETLST (RESETSAVE DFNFLG T)
(RESETSAVE COUTFILE TrilliumBitBucket)
(for FN in (MKLIST FNS) when (LISTP (GETD FN))
do (OR NOSAVE (PUTPROP FN (QUOTE EXPR)
(GETD FN)))
(COMPILE! FN NOSAVE NOREDEFINE PRINTLAP])
(RECOMPILE.ITEMTYPES
[LAMBDA NIL (* HK "21-JUL-82 17:08")
(DECLARE (GLOBALVARS ITEM.TYPES))
(for ITYPE in ITEM.TYPES do (COMPILE.ITEM.TYPE ITYPE])
(SET.ANALYSISFN
[LAMBDA (ITYPE NEWVAL) (* HK "28-JUN-82 14:36")
(COND
((NOT (LITATOM ITYPE))
NIL)
((NULL NEWVAL)
(REMPROP ITYPE (QUOTE COMPILED.ANALYZE))
(REMPROP (GET.ANALYSIS.FNNAME ITYPE)
(QUOTE EXPR))
(PUTD (GET.ANALYSIS.FNNAME ITYPE)))
(T (PUTPROP ITYPE (QUOTE COMPILED.ANALYZE)
NEWVAL])
)
(DECLARE: DONTCOPY
(FILEMAP (NIL (1070 15933 (COMPILE.COMPOSITE.ITYPE 1080 . 2371) (COMPILE.INTERNAL.FNS 2373 . 2908) (
COMPILE.INTERNAL.FNS.IF.NECESSARY 2910 . 3321) (COMPILE.INTO.PROG 3323 . 4096) (COMPILE.ITEM.TYPE 4098
. 5326) (COMPILE.SIMPLE.ITYPE 5328 . 6571) (COMPILE.SUBITEMS 6573 . 7413) (COMPILE.SUBITEMS.EVAL 7415
. 7921) (COMPILE.SUBITEMS.FOREACH 7923 . 10369) (COMPILE.SUBITEMS.HELP 10371 . 10527) (
COMPILE.SUBITEMS.IF 10529 . 11233) (COMPILE.SUBITEMS.INCREMENT 11235 . 11486) (COMPILE.SUBITEMS.ITEM
11488 . 12844) (COMPILE.SUBITEMS.SELECT 12846 . 13411) (GET.ANALYSIS.FNNAME 13413 . 13591) (
GET.ANALYSISFN 13593 . 14307) (NOTE.INTERNAL.FN 14309 . 14592) (QCOMPILE! 14594 . 15317) (
RECOMPILE.ITEMTYPES 15319 . 15550) (SET.ANALYSISFN 15552 . 15931)))))
STOP