diff --git a/books/bookvol9.pamphlet b/books/bookvol9.pamphlet
index dd345e0..f200df1 100644
--- a/books/bookvol9.pamphlet
+++ b/books/bookvol9.pamphlet
@@ -6612,6 +6612,105 @@ $\rightarrow$
\end{chunk}
+\defun{mkAlistOfExplicitCategoryOps}{mkAlistOfExplicitCategoryOps}
+\calls{mkAlistOfExplicitCategoryOps}{pairp}
+\calls{mkAlistOfExplicitCategoryOps}{qcar}
+\calls{mkAlistOfExplicitCategoryOps}{qcdr}
+\calls{mkAlistOfExplicitCategoryOps}{keyedSystemError}
+\calls{mkAlistOfExplicitCategoryOps}{union}
+\calls{mkAlistOfExplicitCategoryOps}{mkAlistOfExplicitCategoryOps}
+\calls{mkAlistOfExplicitCategoryOps}{flattenSignatureList}
+\calls{mkAlistOfExplicitCategoryOps}{nreverse0}
+\calls{mkAlistOfExplicitCategoryOps}{remdup}
+\calls{mkAlistOfExplicitCategoryOps}{assocleft}
+\calls{mkAlistOfExplicitCategoryOps}{isCategoryForm}
+\refsdollar{mkAlistOfExplicitCategoryOps}{e}
+\begin{chunk}{defun mkAlistOfExplicitCategoryOps}
+(defun |mkAlistOfExplicitCategoryOps| (target)
+ (labels (
+ (atomizeOp (op)
+ (cond
+ ((atom op) op)
+ ((and (pairp op) (eq (qcdr op) nil)) (qcar op))
+ (t (|keyedSystemError| 'S2GE0016
+ (list "mkAlistOfExplicitCategoryOps" "bad signature")))))
+ (fn (op u)
+ (if (and (pairp u) (pairp (qcar u)))
+ (if (equal (qcar (qcar u)) op)
+ (cons (qcdr (qcar u)) (fn op (qcdr u)))
+ (fn op (qcdr u))))))
+ (let (z tmp1 op sig u opList)
+ (declare (special |$e|))
+ (when (and (pairp target) (eq (qcar target) '|add|) (pairp (qcdr target)))
+ (setq target (second target)))
+ (cond
+ ((and (pairp target) (eq (qcar target) '|Join|))
+ (setq z (qcdr target))
+ (PROG (tmp1)
+ (RETURN
+ (DO ((G167566 z (CDR G167566)) (cat nil))
+ ((OR (ATOM G167566) (PROGN (setq cat (CAR G167566)) nil))
+ tmp1)
+ (setq tmp1 (|union| tmp1 (|mkAlistOfExplicitCategoryOps| cat)))))))
+ ((and (pairp target) (eq (qcar target) 'category)
+ (progn
+ (setq tmp1 (qcdr target))
+ (and (pairp tmp1)
+ (progn (setq z (qcdr tmp1)) t))))
+ (setq z (|flattenSignatureList| (cons 'progn z)))
+ (setq u
+ (prog (G167577)
+ (return
+ (do ((G167583 z (cdr G167583)) (x nil))
+ ((or (atom G167583)) (nreverse0 G167577))
+ (setq x (car G167583))
+ (cond
+ ((and (pairp x) (eq (qcar x) 'signature) (pairp (qcdr x))
+ (pairp (qcdr (qcdr x))))
+ (setq op (qcar (qcdr x)))
+ (setq sig (qcar (qcdr (qcdr x))))
+ (setq G167577 (cons (cons (atomizeOp op) sig) G167577))))))))
+ (setq opList (remdup (assocleft u)))
+ (prog (G167593)
+ (return
+ (do ((G167598 opList (cdr G167598)) (x nil))
+ ((or (atom G167598)) (nreverse0 G167593))
+ (setq x (car G167598))
+ (setq G167593 (cons (cons x (fn x u)) G167593))))))
+ ((|isCategoryForm| target |$e|) nil)
+ (t
+ (|keyedSystemError| 'S2GE0016
+ (list "mkAlistOfExplicitCategoryOps" "bad signature")))))))
+
+\end{chunk}
+
+\defun{flattenSignatureList}{flattenSignatureList}
+\calls{flattenSignatureList}{pairp}
+\calls{flattenSignatureList}{qcar}
+\calls{flattenSignatureList}{qcdr}
+\calls{flattenSignatureList}{flattenSignatureList}
+\begin{chunk}{defun flattenSignatureList}
+(defun |flattenSignatureList| (x)
+ (let (tmp1 cond tmp2 b1 tmp3 b2 z zz)
+ (cond
+ ((atom x) nil)
+ ((and (pairp x) (eq (qcar x) 'signature)) (list x))
+ ((and (pairp x) (eq (qcar x) 'if) (pairp (qcdr x))
+ (pairp (qcdr (qcdr x))) (pairp (qcdr (qcdr (qcdr x))))
+ (eq (qcdr (qcdr (qcdr (qcdr x)))) nil))
+ (append (|flattenSignatureList| (third x))
+ (|flattenSignatureList| (fourth x))))
+ ((and (pairp x) (eq (qcar x) 'progn))
+ (loop for x in (qcdr x)
+ do
+ (if (and (pairp x) (eq (qcar x) 'signature))
+ (setq zz (cons x zz))
+ (setq zz (append (|flattenSignatureList| x) zz))))
+ zz)
+ (t nil))))
+
+\end{chunk}
+
\defun{interactiveModemapForm}{interactiveModemapForm}
Create modemap form for use by the interpreter. This function
replaces all specific domains mentioned in the modemap with pattern
@@ -6667,6 +6766,110 @@ variables, and predicates
\end{chunk}
+\defun{replaceVars}{replaceVars}
+Replace every identifier in oldvars with the corresponding
+identifier in newvars in the expression x
+\calls{replaceVars}{msubst}
+\begin{chunk}{defun replaceVars}
+(defun |replaceVars| (x oldvars newvars)
+ (loop for old in oldvars for new in newvars
+ do (setq x (msubst new old x)))
+ x)
+
+\end{chunk}
+
+\defun{fixUpPredicate}{fixUpPredicate}
+\calls{fixUpPredicate}{pairp}
+\calls{fixUpPredicate}{qcar}
+\calls{fixUpPredicate}{qcdr}
+\calls{fixUpPredicate}{length}
+\calls{fixUpPredicate}{orderPredicateItems}
+\calls{fixUpPredicate}{moveORsOutside}
+\begin{chunk}{defun fixUpPredicate}
+(defun |fixUpPredicate| (predClause domainPreds partial sig)
+ (let (predicate fn skip predicates tmp1 dependList pred)
+ (setq predicate (car predClause))
+ (setq fn (cadr predClause))
+ (setq skip (cddr predClause))
+ (cond
+ ((eq (car predicate) 'and)
+ (setq predicates (append domainPreds (cdr predicate))))
+ ((nequal predicate (mkq t))
+ (setq predicates (cons predicate domainPreds)))
+ (t
+ (setq predicates (or domainPreds (list predicate)))))
+ (cond
+ ((> (|#| predicates) 1)
+ (setq pred (cons 'and predicates))
+ (setq tmp1 (|orderPredicateItems| pred sig skip))
+ (setq pred (car tmp1))
+ (setq dependlist (cdr tmp1))
+ tmp1)
+ (t
+ (setq pred (|orderPredicateItems| (car predicates) sig skip))
+ (setq dependList
+ (when (and (pairp pred) (eq (qcar pred) '|isDomain|)
+ (pairp (qcdr pred)) (pairp (qcdr (qcdr pred)))
+ (eq (qcdr (qcdr (qcdr pred))) nil)
+ (pairp (qcar (qcdr (qcdr pred))))
+ (eq (qcdr (qcar (qcdr (qcdr pred)))) nil))
+ (list (second pred))))))
+ (setq pred (|moveORsOutside| pred))
+ (when partial (setq pred (cons '|partial| pred)))
+ (cons (cons pred (cons fn skip)) dependList)))
+
+\end{chunk}
+
+\defun{moveORsOutside}{moveORsOutside}
+\calls{moveORsOutside}{moveORsOutside}
+\begin{chunk}{defun moveORsOutside}
+(defun |moveORsOutside| (p)
+ (let (q x)
+ (cond
+ ((and (pairp p) (eq (qcar p) 'and))
+ (setq q
+ (prog (G167169)
+ (return
+ (do ((G167174 (cdr p) (cdr G167174)) (|r| nil))
+ ((or (atom G167174)) (nreverse0 G167169))
+ (setq |r| (CAR G167174))
+ (setq G167169 (cons (|moveORsOutside| |r|) G167169))))))
+ (cond
+ ((setq x
+ (let (tmp1)
+ (loop for r in q
+ when (and (pairp r) (eq (qcar r) 'or))
+ do (setq tmp1 (or tmp1 r)))
+ tmp1))
+ (|moveORsOutside|
+ (cons 'or
+ (let (tmp1)
+ (loop for tt in (cdr x)
+ do (setq tmp1 (cons (cons 'and (msubst tt x q)) tmp1)))
+ (nreverse0 tmp1)))))
+ (t (cons 'and q))))
+ (t p))))
+
+;(defun |moveORsOutside| (p)
+; (let (q s x tmp1)
+; (cond
+; ((and (pairp p) (eq (qcar p) 'and))
+; (setq q (loop for r in (qcdr p) collect (|moveORsOutside| r)))
+; (setq tmp1
+; (loop for r in q
+; when (and (pairp r) (eq (qcdr r) 'or))
+; collect r))
+; (setq x (mapcar #'(lambda (a b) (or a b)) tmp1))
+; (if x
+; (|moveORsOutside|
+; (cons 'or
+; (loop for tt in (cdr x)
+; collect (cons 'and (msubst tt x q)))))
+; (cons 'and q)))
+; ('t p))))
+
+\end{chunk}
+
\defun{substVars}{substVars}
Make pattern variable substitutions.
\calls{substVars}{msubst}
@@ -7709,6 +7912,32 @@ where item has form
\end{chunk}
+\defun{formal2Pattern}{formal2Pattern}
+\calls{formal2Pattern}{sublis}
+\calls{formal2Pattern}{pairList}
+\refsdollar{formal2Pattern}{PatternVariableList}
+\begin{chunk}{defun formal2Pattern}
+(defun |formal2Pattern| (x)
+ (declare (special |$PatternVariableList|))
+ (sublis (|pairList| |$FormalMapVariableList| (cdr |$PatternVariableList|)) x))
+
+\end{chunk}
+
+\defun{mkDatabasePred}{mkDatabasePred}
+\calls{mkDatabasePred}{isCategoryForm}
+\refsdollar{mkDatabasePred}{e}
+\begin{chunk}{defun mkDatabasePred}
+(defun |mkDatabasePred| (arg)
+ (let (a z)
+ (declare (special |$e|))
+ (setq a (car arg))
+ (setq z (cadr arg))
+ (if (|isCategoryForm| z |$e|)
+ (list '|ofCategory| a z)
+ (list '|ofType| a z))))
+
+\end{chunk}
+
\defun{disallowNilAttribute}{disallowNilAttribute}
\begin{chunk}{defun disallowNilAttribute}
(defun |disallowNilAttribute| (x)
@@ -18198,9 +18427,12 @@ if \verb|$InteractiveMode| then use a null outputstream
\getchunk{defun evalAndSub}
\getchunk{defun extractCodeAndConstructTriple}
+\getchunk{defun flattenSignatureList}
\getchunk{defun finalizeLisplib}
\getchunk{defun fincomblock}
+\getchunk{defun fixUpPredicate}
\getchunk{defun floatexpid}
+\getchunk{defun formal2Pattern}
\getchunk{defun freelist}
\getchunk{defun get-a-line}
@@ -18277,13 +18509,16 @@ if \verb|$InteractiveMode| then use a null outputstream
\getchunk{defun mergeModemap}
\getchunk{defun mergeSignatureAndLocalVarAlists}
\getchunk{defun meta-syntax-error}
+\getchunk{defun mkAlistOfExplicitCategoryOps}
\getchunk{defun mkCategoryPackage}
\getchunk{defun mkConstructor}
+\getchunk{defun mkDatabasePred}
\getchunk{defun mkEvalableCategoryForm}
\getchunk{defun mkNewModemapList}
\getchunk{defun mkOpVec}
\getchunk{defun modifyModeStack}
\getchunk{defun modemapPattern}
+\getchunk{defun moveORsOutside}
\getchunk{defun ncINTERPFILE}
\getchunk{defun next-char}
@@ -18494,6 +18729,7 @@ if \verb|$InteractiveMode| then use a null outputstream
\getchunk{defun recompile-lib-file-if-necessary}
\getchunk{defun /rf-1}
\getchunk{defun removeSuperfluousMapping}
+\getchunk{defun replaceVars}
\getchunk{defun reportOnFunctorCompilation}
\getchunk{defun /RQ,LIB}
\getchunk{defun rwriteLispForm}
diff --git a/changelog b/changelog
index 8132aa4..d1703de 100644
--- a/changelog
+++ b/changelog
@@ -1,3 +1,6 @@
+20110731 tpd src/axiom-website/patches.html 20110731.01.tpd.patch
+20110731 tpd src/interp/database.lisp treeshake compiler
+20110731 tpd books/bookvol9 treeshake compiler
20110730 tpd src/axiom-website/patches.html 20110730.01.tpd.patch
20110730 tpd src/interp/patches.lisp treeshake compiler
20110730 tpd src/interp/database.lisp treeshake compiler
diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html
index 5ee0cb8..8994407 100644
--- a/src/axiom-website/patches.html
+++ b/src/axiom-website/patches.html
@@ -3566,5 +3566,7 @@ In process, not yet released
src/axiom-website/download.html add ubuntu
20110730.01.tpd.patch
books/bookvol9 treeshake compiler
+20110731.01.tpd.patch
+books/bookvol9 treeshake compiler