diff --git a/books/bookvol9.pamphlet b/books/bookvol9.pamphlet
index 80d0d0f..e3fd333 100644
--- a/books/bookvol9.pamphlet
+++ b/books/bookvol9.pamphlet
@@ -7074,30 +7074,6 @@ $\rightarrow$
\end{chunk}
-\defun{augModemapsFromCategory}{augModemapsFromCategory}
-\calls{augModemapsFromCategory}{evalAndSub}
-\calls{augModemapsFromCategory}{compilerMessage}
-\calls{augModemapsFromCategory}{putDomainsInScope}
-\calls{augModemapsFromCategory}{addModemapKnown}
-\defsdollar{augModemapsFromCategory}{base}
-\begin{chunk}{defun augModemapsFromCategory}
-(defun |augModemapsFromCategory| (domainName functorform categoryForm env)
- (let (tmp1 op sig cond fnsel)
- (declare (special |$base|))
- (setq tmp1 (|evalAndSub| domainName domainName functorform categoryForm env))
- (|compilerMessage| (list '|Adding | domainName '| modemaps|))
- (setq env (|putDomainsInScope| domainName (second tmp1)))
- (setq |$base| 4)
- (dolist (u (first tmp1))
- (setq op (caar u))
- (setq sig (cadar u))
- (setq cond (cadr u))
- (setq fnsel (caddr u))
- (setq env (|addModemapKnown| op domainName sig cond fnsel env)))
- env))
-
-\end{chunk}
-
\defun{genDomainOps}{genDomainOps}
\calls{genDomainOps}{getOperationAlist}
\calls{genDomainOps}{substNames}
@@ -7301,6 +7277,234 @@ $\rightarrow$
\end{chunk}
+\section{Functions to manipulate modemaps}
+
+\defun{addDomain}{addDomain}
+\calls{addDomain}{identp}
+\calls{addDomain}{qslessp}
+\calls{addDomain}{getDomainsInScope}
+\calls{addDomain}{domainMember}
+\calls{addDomain}{isLiteral}
+\calls{addDomain}{addNewDomain}
+\calls{addDomain}{getmode}
+\calls{addDomain}{pairp}
+\calls{addDomain}{isCategoryForm}
+\calls{addDomain}{isFunctor}
+\calls{addDomain}{constructor?}
+\calls{addDomain}{member}
+\calls{addDomain}{unknownTypeError}
+\begin{chunk}{defun addDomain}
+(defun |addDomain| (domain env)
+ (let (s name tmp1 tmp2 target)
+ (cond
+ ((atom domain)
+ (cond
+ ((eq domain '|$EmptyMode|) env)
+ ((eq domain '|$NoValueMode|) env)
+ ((or (null (identp domain))
+ (and (qslessp 2 (|#| (setq s (princ-to-string domain))))
+ (eq (|char| '|#|) (elt s 0))
+ (eq (|char| '|#|) (elt s 1))))
+ env)
+ ((member domain (|getDomainsInScope| env)) env)
+ ((|isLiteral| domain env) env)
+ (t (|addNewDomain| domain env))))
+ ((eq (setq name (car domain)) '|Category|) env)
+ ((|domainMember| domain (|getDomainsInScope| env)) env)
+ ((and (progn
+ (setq tmp1 (|getmode| name env))
+ (and (pairp tmp1) (eq (qcar tmp1) '|Mapping|)
+ (pairp (qcdr tmp1))))
+ (|isCategoryForm| (second tmp1) env))
+ (|addNewDomain| domain env))
+ ((or (|isFunctor| name) (|constructor?| name))
+ (|addNewDomain| domain env))
+ (t
+ (when (and (null (|isCategoryForm| domain env))
+ (null (|member| name '(|Mapping| category))))
+ (|unknownTypeError| name))
+ env))))
+
+\end{chunk}
+
+\defun{augModemapsFromCategory}{augModemapsFromCategory}
+\calls{augModemapsFromCategory}{evalAndSub}
+\calls{augModemapsFromCategory}{compilerMessage}
+\calls{augModemapsFromCategory}{putDomainsInScope}
+\calls{augModemapsFromCategory}{addModemapKnown}
+\defsdollar{augModemapsFromCategory}{base}
+\begin{chunk}{defun augModemapsFromCategory}
+(defun |augModemapsFromCategory| (domainName functorform categoryForm env)
+ (let (tmp1 op sig cond fnsel)
+ (declare (special |$base|))
+ (setq tmp1 (|evalAndSub| domainName domainName functorform categoryForm env))
+ (|compilerMessage| (list '|Adding | domainName '| modemaps|))
+ (setq env (|putDomainsInScope| domainName (second tmp1)))
+ (setq |$base| 4)
+ (dolist (u (first tmp1))
+ (setq op (caar u))
+ (setq sig (cadar u))
+ (setq cond (cadr u))
+ (setq fnsel (caddr u))
+ (setq env (|addModemapKnown| op domainName sig cond fnsel env)))
+ env))
+
+\end{chunk}
+
+\defun{evalAndSub}{evalAndSub}
+\calls{evalAndSub}{isCategory}
+\calls{evalAndSub}{substNames}
+\calls{evalAndSub}{contained}
+\calls{evalAndSub}{put}
+\calls{evalAndSub}{get}
+\calls{evalAndSub}{getOperationAlist}
+\defsdollar{evalAndSub}{lhsOfColon}
+\begin{chunk}{defun evalAndSub}
+(defun |evalAndSub| (domainName viewName functorForm form |$e|)
+ (declare (special |$e|))
+ (let (|$lhsOfColon| opAlist substAlist)
+ (declare (special |$lhsOfColon|))
+ (setq |$lhsOfColon| domainName)
+ (cond
+ ((|isCategory| form)
+ (list (|substNames| domainName viewName functorForm (elt form 1)) |$e|))
+ (t
+ (when (contained '$$ form)
+ (setq |$e| (|put| '$$ '|mode| (|get| '$ '|mode| |$e|) |$e|)))
+ (setq opAlist (|getOperationAlist| domainName functorForm form))
+ (setq substAlist (|substNames| domainName viewName functorForm opAlist))
+ (list substAlist |$e|)))))
+
+\end{chunk}
+
+\defun{getOperationAlist}{getOperationAlist}
+\calls{getOperationAlist}{getdatabase}
+\calls{getOperationAlist}{isFunctor}
+\calls{getOperationAlist}{systemError}
+\calls{getOperationAlist}{compMakeCategoryObject}
+\calls{getOperationAlist}{stackMessage}
+\usesdollar{getOperationAlist}{e}
+\usesdollar{getOperationAlist}{domainShell}
+\usesdollar{getOperationAlist}{insideFunctorIfTrue}
+\usesdollar{getOperationAlist}{functorForm}
+\begin{chunk}{defun getOperationAlist}
+(defun |getOperationAlist| (name functorForm form)
+ (let (u tt)
+ (declare (special |$e| |$domainShell| |$insideFunctorIfTrue| |$functorForm|))
+ (when (and (atom name) (getdatabase name 'niladic))
+ (setq functorform (list functorForm)))
+ (cond
+ ((and (setq u (|isFunctor| functorForm))
+ (null (and |$insideFunctorIfTrue|
+ (equal (first functorForm) (first |$functorForm|)))))
+ u)
+ ((and |$insideFunctorIfTrue| (eq name '$))
+ (if |$domainShell|
+ (elt |$domainShell| 1)
+ (|systemError| "$ has no shell now")))
+ ((setq tt (|compMakeCategoryObject| form |$e|))
+ (setq |$e| (third tt))
+ (elt (first tt) 1))
+ (t
+ (|stackMessage| (list '|not a category form: | form))))))
+
+\end{chunk}
+
+\defdollar{FormalMapVariableList}
+\begin{chunk}{initvars}
+(defvar |$FormalMapVariableList|
+ '(\#1 \#2 \#3 \#4 \#5 \#6 \#7 \#8 \#9 \#10 \#11 \#12 \#13 \#14 \#15))
+
+\end{chunk}
+
+\defun{substNames}{substNames}
+\calls{substNames}{substq}
+\calls{substNames}{isCategoryPackageName}
+\calls{substNames}{eqsubstlist}
+\calls{substNames}{nreverse0}
+\usesdollar{substNames}{FormalMapVariableList}
+\begin{chunk}{defun substNames}
+(defun |substNames| (domainName viewName functorForm opalist)
+ (let (nameForDollar sel pos modemapform tmp0 tmp1)
+ (declare (special |$FormalMapVariableList|))
+ (setq functorForm (substq '$$ '$ functorForm))
+ (setq nameForDollar
+ (if (|isCategoryPackageName| functorForm)
+ (second functorForm)
+ domainName))
+; following calls to SUBSTQ must copy to save RPLAC's in
+; putInLocalDomainReferences
+ (dolist (term
+ (eqsubstlist (kdr functorForm) |$FormalMapVariableList| opalist)
+ (nreverse0 tmp0))
+ (setq tmp1 (reverse term))
+ (setq sel (caar tmp1))
+ (setq pos (caddar tmp1))
+ (setq modemapform (nreverse (cdr tmp1)))
+ (push
+ (append
+ (substq '$ '$$ (substq nameForDollar '$ modemapform))
+ (list
+ (list sel viewName (if (eq domainName '$) pos (cadar modemapform)))))
+ tmp0))))
+
+\end{chunk}
+
+\defun{augModemapsFromCategoryRep}{augModemapsFromCategoryRep}
+\calls{augModemapsFromCategoryRep}{evalAndSub}
+\calls{augModemapsFromCategoryRep}{isCategory}
+\calls{augModemapsFromCategoryRep}{compilerMessage}
+\calls{augModemapsFromCategoryRep}{putDomainsInScope}
+\calls{augModemapsFromCategoryRep}{assoc}
+\calls{augModemapsFromCategoryRep}{msubst}
+\calls{augModemapsFromCategoryRep}{addModemap}
+\defsdollar{augModemapsFromCategoryRep}{base}
+\begin{chunk}{defun augModemapsFromCategoryRep}
+(defun |augModemapsFromCategoryRep|
+ (domainName repDefn functorBody categoryForm env)
+ (labels (
+ (redefinedList (op z)
+ (let (result)
+ (dolist (u z result)
+ (setq result (or result (redefined op u))))))
+ (redefined (opname u)
+ (let (op z result)
+ (when (pairp u)
+ (setq op (qcar u))
+ (setq z (qcdr u))
+ (cond
+ ((eq op 'def) (equal opname (caar z)))
+ ((member op '(progn seq)) (redefinedList opname z))
+ ((eq op 'cond)
+ (dolist (v z result)
+ (setq result (or result (redefinedList opname (cdr v)))))))))))
+ (let (fnAlist tmp1 repFnAlist catform lhs op sig cond fnsel u)
+ (declare (special |$base|))
+ (setq tmp1 (|evalAndSub| domainName domainName domainName categoryForm env))
+ (setq fnAlist (car tmp1))
+ (setq env (cadr tmp1))
+ (setq tmp1 (|evalAndSub| '|Rep| '|Rep| repDefn (|getmode| repDefn env) env))
+ (setq repFnAlist (car tmp1))
+ (setq env (cadr tmp1))
+ (setq catform
+ (if (|isCategory| categoryForm) (elt categoryForm 0) categoryForm))
+ (|compilerMessage| (list '|Adding | domainName '| modemaps|))
+ (setq env (|putDomainsInScope| domainName env))
+ (setq |$base| 4)
+ (dolist (term fnAlist)
+ (setq lhs (car term))
+ (setq op (caar term))
+ (setq sig (cadar term))
+ (setq cond (cadr term))
+ (setq fnsel (caddr term))
+ (setq u (|assoc| (msubst '|Rep| domainName lhs) repFnAlist))
+ (if (and u (null (redefinedList op functorBody)))
+ (setq env (|addModemap| op domainName sig cond (caddr u) env))
+ (setq env (|addModemap| op domainName sig cond fnsel env))))
+ env)))
+
+\end{chunk}
+
\section{Indirect called comp routines}
In the {\bf compExpression} function there is the code:
\begin{verbatim}
@@ -16408,6 +16612,7 @@ if \verb|$InteractiveMode| then use a null outputstream
\getchunk{defun action}
\getchunk{defun addclose}
+\getchunk{defun addDomain}
\getchunk{defun addEmptyCapsuleIfNecessary}
\getchunk{defun add-parens-and-semis-to-line}
\getchunk{defun Advance-Char}
@@ -16417,6 +16622,7 @@ if \verb|$InteractiveMode| then use a null outputstream
\getchunk{defun aplTranList}
\getchunk{defun argsToSig}
\getchunk{defun augModemapsFromCategory}
+\getchunk{defun augModemapsFromCategoryRep}
\getchunk{defun blankp}
\getchunk{defun bumperrorcount}
@@ -16527,6 +16733,7 @@ if \verb|$InteractiveMode| then use a null outputstream
\getchunk{defun errhuh}
\getchunk{defun escape-keywords}
\getchunk{defun escaped}
+\getchunk{defun evalAndSub}
\getchunk{defun extractCodeAndConstructTriple}
\getchunk{defun fincomblock}
@@ -16534,6 +16741,7 @@ if \verb|$InteractiveMode| then use a null outputstream
\getchunk{defun freelist}
\getchunk{defun get-a-line}
+\getchunk{defun getOperationAlist}
\getchunk{defun getScriptName}
\getchunk{defun getTargetFromRhs}
\getchunk{defun get-token}
@@ -16810,6 +17018,7 @@ if \verb|$InteractiveMode| then use a null outputstream
\getchunk{defun stack-pop}
\getchunk{defun stack-push}
\getchunk{defun storeblanks}
+\getchunk{defun substNames}
\getchunk{defun s-process}
\getchunk{defun token-install}
diff --git a/changelog b/changelog
index 51606c9..1691b5b 100644
--- a/changelog
+++ b/changelog
@@ -1,3 +1,7 @@
+20110708 tpd src/axiom-website/patches.html 20110708.01.tpd.patch
+20110708 tpd src/interp/vmlisp.lisp treehake compiler
+20110708 tpd src/interp/modemap.lisp treeshake compiler
+20110708 tpd books/bookvol9 treeshake compiler
20110707 tpd src/axiom-website/patches.html 20110707.01.tpd.patch
20110707 tpd src/interp/interp-proclaims.lisp change function arity
20110707 tpd src/interp/modemap.lisp treeshake compiler
diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html
index a5aa0c8..df34d98 100644
--- a/src/axiom-website/patches.html
+++ b/src/axiom-website/patches.html
@@ -3530,5 +3530,7 @@ books/bookvol5 remove dewriteify,s inner function
books/bookvol9 use \defsdollar and \refsdollar
20110707.01.tpd.patch
books/bookvol9 treeshake compiler
+20110708.01.tpd.patch
+books/bookvol9 treeshake compiler