diff --git a/books/bookvol9.pamphlet b/books/bookvol9.pamphlet
index f02a36f..fe5d500 100644
--- a/books/bookvol9.pamphlet
+++ b/books/bookvol9.pamphlet
@@ -6156,7 +6156,6 @@ $\rightarrow$
\calls{mkEvalableCategoryForm}{compOrCroak}
\calls{mkEvalableCategoryForm}{getdatabase}
\calls{mkEvalableCategoryForm}{get}
-\calls{mkEvalableCategoryForm}{quotifyCategoryArgument}
\calls{mkEvalableCategoryForm}{mkq}
\refsdollar{mkEvalableCategoryForm}{Category}
\refsdollar{mkEvalableCategoryForm}{e}
@@ -9900,8 +9899,8 @@ Since we can't be sure we take the least disruptive course of action.
\begin{chunk}{defun doIt}
(defun |doIt| (item |$predl|)
(declare (special |$predl|))
- (prog ($genno x rhs tmp3 lhsp lhs rhsp rhsCode a doms b z tmp1
- tmp2 tmp6 op body tt functionPart u code)
+ (prog ($genno x rhs lhsp lhs rhsp rhsCode z tmp1 tmp2 tmp6 op body tt
+ functionPart u code)
(declare (special $genno |$e| |$EmptyMode| |$signatureOfForm|
|$QuickCode| |$LocalDomainAlist| |$Representation|
|$NRTopt| |$packagesUsed| |$functorsUsed|
@@ -10049,6 +10048,96 @@ Since we can't be sure we take the least disruptive course of action.
\end{chunk}
+\defun{doItIf}{doItIf}
+\begin{chunk}{defun doItIf}
+(defun |doItIf| (item |$predl| |$e|)
+ (declare (special |$predl| |$e|))
+ (labels (
+ (localExtras (oldFLP)
+ (let (oldFLPp flp1 gv ans nils n)
+ (declare (special |$functorLocalParameters| |$getDomainCode|))
+ (unless (eq oldFLP |$functorLocalParameters|)
+ (setq flp1 |$functorLocalParameters|)
+ (setq oldFLPp oldFLP)
+ (setq n 0)
+ (loop while oldFLPp
+ do
+ (setq oldFLPp (cdr oldFLPp))
+ (setq n (1+ n)))
+ (setq nils (setq ans nil))
+ (loop for u in flp1
+ do
+ (if (or (atom u)
+ (let (result)
+ (loop for v in |$getDomainCode|
+ do
+ (setq result (or result
+ (and (pairp v) (pairp (qcdr v))
+ (equal (qcar (qcdr v)) u)))))
+ result))
+ ; Now we have to add code to compile all the elements of
+ ; functorLocalParameters that were added during the conditional compilation
+ (setq nils (cons u nils))
+ (progn
+ (setq gv (gensym))
+ (setq ans (cons (list 'let gv u) ans))
+ (setq nils (CONS gv nils))))
+ (setq n (1+ n)))
+ (setq |$functorLocalParameters| (append oldFLP (nreverse nils)))
+ (nreverse ans)))))
+ (let (p x y olde tmp1 pp xp oldFLP yp)
+ (declare (special |$functorLocalParameters|))
+ (setq p (second item))
+ (setq x (third item))
+ (setq y (fourth item))
+ (setq olde |$e|)
+ (setq tmp1
+ (or (|comp| p |$Boolean| |$e|)
+ (|userError| (list "not a Boolean:" p))))
+ (setq pp (first tmp1))
+ (setq |$e| (third tmp1))
+ (setq oldFLP |$functorLocalParameters|)
+ (unless (eq x '|noBranch|)
+ (|compSingleCapsuleItem| x |$predl| (|getSuccessEnvironment| p |$e|))
+ (setq xp (localExtras oldFLP)))
+ (setq oldFLP |$functorLocalParameters|)
+ (unless (eq y '|noBranch|)
+ (|compSingleCapsuleItem| y |$predl| (|getInverseEnvironment| p olde))
+ (setq yp (localExtras oldFLP)))
+ (rplaca item 'cond)
+ (rplacd item (list (cons pp (cons x xp)) (cons ''t (cons y yp)))))))
+
+\end{chunk}
+
+\defun{isMacro}{isMacro}
+\calls{isMacro}{pairp}
+\calls{isMacro}{qcar}
+\calls{isMacro}{qcdr}
+\calls{isMacro}{get}
+\begin{chunk}{defun isMacro}
+(defun |isMacro| (x env)
+ (let (op args signature body)
+ (when
+ (and (pairp x) (eq (qcar x) 'def) (pairp (qcdr x))
+ (pairp (qcar (qcdr x))) (pairp (qcdr (qcdr x)))
+ (pairp (qcdr (qcdr (qcdr x))))
+ (pairp (qcdr (qcdr (qcdr (qcdr x)))))
+ (eq (qcdr (qcdr (qcdr (qcdr (qcdr x))))) nil))
+ (setq op (qcar (qcar (qcdr x))))
+ (setq args (qcdr (qcar (qcdr x))))
+ (setq signature (qcar (qcdr (qcdr x))))
+ (setq body (qcar (qcdr (qcdr (qcdr (qcdr x))))))
+ (when
+ (and (null (|get| op '|modemap| env))
+ (null args)
+ (null (|get| op '|mode| env))
+ (pairp signature)
+ (eq (qcdr signature) nil)
+ (null (qcar signature)))
+ body))))
+
+\end{chunk}
+
\defplist{case}{compCase plist}
\begin{chunk}{postvars}
(eval-when (eval load)
@@ -10170,6 +10259,11 @@ An angry JHD - August 15th., 1984
\calls{compCategory}{compCategoryItem}
\calls{compCategory}{mkExplicitCategoryFunction}
\calls{compCategory}{systemErrorHere}
+\defsdollar{compCategory}{sigList}
+\defsdollar{compCategory}{atList}
+\defsdollar{compCategory}{top-level}
+\refsdollar{compCategory}{sigList}
+\refsdollar{compCategory}{atList}
\begin{chunk}{defun compCategory}
(defun |compCategory| (form mode env)
(let ($top_level |$sigList| |$atList| domainOrPackage z rep)
@@ -10186,8 +10280,6 @@ An angry JHD - August 15th., 1984
(setq z (qcdr (qcdr form)))
(setq |$sigList| nil)
(setq |$atList| nil)
- (setq |$sigList| nil)
- (setq |$atList| nil)
(dolist (x z) (|compCategoryItem| x nil))
(setq rep
(|mkExplicitCategoryFunction| domainOrPackage |$sigList| |$atList|))
@@ -10197,6 +10289,56 @@ An angry JHD - August 15th., 1984
\end{chunk}
+\defun{mkExplicitCategoryFunction}{mkExplicitCategoryFunction}
+\calls{mkExplicitCategoryFunction}{mkq}
+\calls{mkExplicitCategoryFunction}{union}
+\calls{mkExplicitCategoryFunction}{mustInstantiate}
+\calls{mkExplicitCategoryFunction}{remdup}
+\calls{mkExplicitCategoryFunction}{identp}
+\calls{mkExplicitCategoryFunction}{nequal}
+\calls{mkExplicitCategoryFunction}{wrapDomainSub}
+\begin{chunk}{defun mkExplicitCategoryFunction}
+(defun |mkExplicitCategoryFunction| (domainOrPackage sigList atList)
+ (let (body sig parameters)
+ (setq body
+ (list '|mkCategory| (mkq domainOrPackage)
+ (cons 'list (reverse sigList))
+ (cons 'list (reverse atList))
+ (mkq
+ (let (result)
+ (loop for item in sigList
+ do
+ (setq sig (car (cdaadr item)))
+ (setq result
+ (|union| result
+ (loop for d in sig
+ when (|mustInstantiate| d)
+ collect d))))
+ result))
+ nil))
+ (setq parameters
+ (remdup
+ (let (result)
+ (loop for item in sigList
+ do
+ (setq sig (car (cdaadr item)))
+ (setq result
+ (append result
+ (loop for x in sig
+ when (and (identp x) (nequal x '$))
+ collect x))))
+ result)))
+ (|wrapDomainSub| parameters body)))
+
+\end{chunk}
+
+\defun{wrapDomainSub}{wrapDomainSub}
+\begin{chunk}{defun wrapDomainSub}
+(defun |wrapDomainSub| (parameters x)
+ (list '|DomainSubstitutionMacro| parameters x))
+
+\end{chunk}
+
\defplist{:}{compColon plist}
\begin{chunk}{postvars}
(eval-when (eval load)
@@ -10380,6 +10522,20 @@ An angry JHD - August 15th., 1984
\end{chunk}
+\defun{makeCategoryForm}{makeCategoryForm}
+\calls{makeCategoryForm}{isCategoryForm}
+\calls{makeCategoryForm}{compOrCroak}
+\refsdollar{makeCategoryForm}{EmptyMode}
+\begin{chunk}{defun makeCategoryForm}
+(defun |makeCategoryForm| (c env)
+ (let (tmp1)
+ (declare (special |$EmptyMode|))
+ (when (|isCategoryForm| c env)
+ (setq tmp1 (|compOrCroak| c |$EmptyMode| env))
+ (list (first tmp1) (third tmp1)))))
+
+\end{chunk}
+
\defplist{cons}{compCons plist}
\begin{chunk}{postvars}
(eval-when (eval load)
@@ -21302,6 +21458,7 @@ The current input line.
\getchunk{defun displayMissingFunctions}
\getchunk{defun displayPreCompilationErrors}
\getchunk{defun doIt}
+\getchunk{defun doItIf}
\getchunk{defun dollarTran}
\getchunk{defun domainMember}
\getchunk{defun drop}
@@ -21376,6 +21533,7 @@ The current input line.
\getchunk{defun isDomainSubst}
\getchunk{defun isFunctor}
\getchunk{defun isListConstructor}
+\getchunk{defun isMacro}
\getchunk{defun isSuperDomain}
\getchunk{defun isTokenDelimiter}
\getchunk{defun isUnionMode}
@@ -21398,6 +21556,7 @@ The current input line.
\getchunk{defun macroExpand}
\getchunk{defun macroExpandInPlace}
\getchunk{defun macroExpandList}
+\getchunk{defun makeCategoryForm}
\getchunk{defun makeCategoryPredicates}
\getchunk{defun makeFunctorArgumentParameters}
\getchunk{defun makeSimplePredicateOrNil}
@@ -21416,6 +21575,7 @@ The current input line.
\getchunk{defun mkConstructor}
\getchunk{defun mkDatabasePred}
\getchunk{defun mkEvalableCategoryForm}
+\getchunk{defun mkExplicitCategoryFunction}
\getchunk{defun mkNewModemapList}
\getchunk{defun mkOpVec}
\getchunk{defun mkUnion}
@@ -21691,6 +21851,7 @@ The current input line.
\getchunk{defun updateCategoryFrameForCategory}
\getchunk{defun updateCategoryFrameForConstructor}
+\getchunk{defun wrapDomainSub}
\getchunk{defun writeLib1}
\getchunk{postvars}
diff --git a/changelog b/changelog
index 3305292..03b75cc 100644
--- a/changelog
+++ b/changelog
@@ -1,3 +1,6 @@
+20110825 tpd src/axiom-website/patches.html 20110825.01.tpd.patch
+20110825 tpd src/interp/define.lisp treeshake compiler
+20110825 tpd books/bookvol9 treeshake compiler
20110824 tpd src/axiom-website/patches.html 20110824.01.tpd.patch
20110824 tpd src/interp/i-util.lisp treeshake compiler
20110824 tpd src/interp/define.lisp treeshake compiler
diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html
index 414c4ff..a7da462 100644
--- a/src/axiom-website/patches.html
+++ b/src/axiom-website/patches.html
@@ -3594,5 +3594,7 @@ books/bookvol9 treeshake compiler, remove compiler.lisp
src/interp/Makefile remove foam_l
20110824.01.tpd.patch
books/bookvol9 treeshake compiler
+20110825.01.tpd.patch
+books/bookvol9 treeshake compiler