diff --git a/books/bookvol9.pamphlet b/books/bookvol9.pamphlet
index 07a6745..4860fa2 100644
--- a/books/bookvol9.pamphlet
+++ b/books/bookvol9.pamphlet
@@ -6690,7 +6690,7 @@ $\rightarrow$
(equal (FindRep (qcdr (qcar (qcdr (qcdr body))))) (second body)))
(setq |$e| (|augModemapsFromCategoryRep| '$
(second body) (cdaddr body) target |$e|))
- (setq |$e| (|augModemapsFromCategory| '$ '$ '$ target |$e|))))
+ (setq |$e| (|augModemapsFromCategory| '$ '$ target |$e|))))
(setq |$signature| signaturep)
(setq operationAlist (sublis |$pairlis| (elt |$domainShell| 1)))
(setq parSignature (sublis |$pairlis| signaturep))
@@ -6927,7 +6927,6 @@ $\rightarrow$
\calls{makeFunctorArgumentParameters}{qcar}
\calls{makeFunctorArgumentParameters}{qcdr}
\calls{makeFunctorArgumentParameters}{genDomainViewList0}
-\calls{makeFunctorArgumentParameters}{genDomainView}
\calls{makeFunctorArgumentParameters}{union}
\usesdollar{makeFunctorArgumentParameters}{ConditionalOperators}
\usesdollar{makeFunctorArgumentParameters}{alternateViewList}
@@ -6954,7 +6953,7 @@ $\rightarrow$
(if (|isCategoryForm| s |$CategoryFrame|)
(if (and (pairp s) (eq (qcar s) '|Join|))
(|genDomainViewList0| a (rest s))
- (list (|genDomainView| a a s '|getDomainView|)))
+ (list (|genDomainView| a s '|getDomainView|)))
(list a)))
(findExtras (a target)
(cond
@@ -7025,7 +7024,6 @@ $\rightarrow$
\calls{genDomainViewList}{qcdr}
\calls{genDomainViewList}{isCategoryForm}
\calls{genDomainViewList}{genDomainView}
-\calls{genDomainViewList}{genDomainViewName}
\calls{genDomainViewList}{genDomainViewList}
\usesdollar{genDomainViewList}{EmptyEnvironment}
\begin{chunk}{defun genDomainViewList}
@@ -7038,9 +7036,7 @@ $\rightarrow$
nil)
(t
(cons
- (|genDomainView|
- (if firsttime id (|genDomainViewName| id (first catlist)))
- id (first catlist) '|getDomainView|)
+ (|genDomainView| id (first catlist) '|getDomainView|)
(|genDomainViewList| id (rest catlist) nil)))))
\end{chunk}
@@ -7056,12 +7052,12 @@ $\rightarrow$
\usesdollar{genDomainView}{e}
\usesdollar{genDomainView}{getDomainCode}
\begin{chunk}{defun genDomainView}
-(defun |genDomainView| (viewName originalName c viewSelector)
+(defun |genDomainView| (name c viewSelector)
(let (code cd)
(declare (special |$getDomainCode| |$e|))
(cond
((and (pairp c) (eq (qcar c) 'category) (pairp (qcdr c)))
- (|genDomainOps| viewName originalName c))
+ (|genDomainOps| name name c))
(t
(setq code
(if (and (pairp c) (eq (qcar c) '|SubsetCategory|)
@@ -7069,13 +7065,12 @@ $\rightarrow$
(eq (qcdr (qcdr (qcdr c))) nil))
(second c)
c))
- (setq |$e| (|augModemapsFromCategory| originalName viewName nil c |$e|))
+ (setq |$e| (|augModemapsFromCategory| name nil c |$e|))
(setq cd
- (list 'let viewName
- (list viewSelector originalName (|mkDomainConstructor| code))))
+ (list 'let name (list viewSelector name (|mkDomainConstructor| code))))
(unless (|member| cd |$getDomainCode|)
(setq |$getDomainCode| (cons cd |$getDomainCode|)))
- viewName))))
+ name))))
\end{chunk}
@@ -7117,6 +7112,171 @@ $\rightarrow$
\end{chunk}
+\defun{mkOpVec}{mkOpVec}
+\calls{mkOpVec}{getPrincipalView}
+\calls{mkOpVec}{getOperationAlistFromLisplib}
+\calls{mkOpVec}{opOf}
+\calls{mkOpVec}{length}
+\calls{mkOpVec}{assq}
+\calls{mkOpVec}{assoc}
+\calls{mkOpVec}{pairp}
+\calls{mkOpVec}{qcar}
+\calls{mkOpVec}{qcdr}
+\calls{mkOpVec}{sublis}
+\calls{mkOpVec}{AssocBarGensym}
+\calls{mkOpVec}{msubst}
+\usesdollar{mkOpVec}{FormalMapVariableList}
+\uses{mkOpVec}{Undef}
+\begin{chunk}{defun mkOpVec}
+(defun |mkOpVec| (dom siglist)
+ (let (substargs oplist ops u noplist n i tmp1)
+ (declare (special |$FormalMapVariableList| |Undef|))
+ (setq dom (|getPrincipalView| dom))
+ (setq substargs
+ (cons (cons '$ (elt dom 0))
+ (loop for a in |$FormalMapVariableList| for x in (rest (elt dom 0))
+ collect (cons a x))))
+ (setq oplist (|getOperationAlistFromLisplib| (|opOf| (elt dom 0))))
+ (setq ops (make-array (|#| siglist)))
+ (setq i -1)
+ (loop for opSig in siglist do
+ (incf i)
+ (setq u (assq (first opSig) oplist))
+ (setq tmp1 (|assoc| (second opSig) u))
+ (cond
+ ((and (pairp tmp1) (pairp (qcdr tmp1))
+ (pairp (qcdr (qcdr tmp1))) (pairp (qcdr (qcdr (qcdr tmp1))))
+ (eq (qcdr (qcdr (qcdr (qcdr tmp1)))) nil)
+ (eq (qcar (qcdr (qcdr (qcdr tmp1)))) 'elt))
+ (setelt ops i (elt dom (second tmp1))))
+ (t
+ (setq noplist (sublis substargs u))
+ (setq tmp1
+ (|AssocBarGensym| (msubst (elt dom 0) '$ (second opSig)) noplist))
+ (cond
+ ((and (pairp tmp1) (pairp (qcdr tmp1)) (pairp (qcdr (qcdr tmp1)))
+ (pairp (qcdr (qcdr (qcdr tmp1))))
+ (eq (qcdr (qcdr (qcdr (qcdr tmp1)))) nil)
+ (eq (qcar (qcdr (qcdr (qcdr tmp1)))) 'elt))
+ (setelt ops i (elt dom (second tmp1))))
+ (t
+ (setelt ops i (cons |Undef| (cons (list (elt dom 0) i) opSig))))))))
+ ops))
+
+\end{chunk}
+
+\defun{compDefWhereClause}{compDefWhereClause}
+\calls{compDefWhereClause}{pairp}
+\calls{compDefWhereClause}{qcar}
+\calls{compDefWhereClause}{qcdr}
+\calls{compDefWhereClause}{getmode}
+\calls{compDefWhereClause}{userError}
+\calls{compDefWhereClause}{concat}
+\calls{compDefWhereClause}{lassoc}
+\calls{compDefWhereClause}{pairList}
+\calls{compDefWhereClause}{union}
+\calls{compDefWhereClause}{listOfIdentifersIn}
+\calls{compDefWhereClause}{delete}
+\calls{compDefWhereClause}{orderByDependency}
+\calls{compDefWhereClause}{assocleft}
+\calls{compDefWhereClause}{assocright}
+\calls{compDefWhereClause}{comp}
+\usesdollar{compDefWhereClause}{sigAlist}
+\usesdollar{compDefWhereClause}{predAlist}
+\begin{chunk}{defun compDefWhereClause}
+(defun |compDefWhereClause| (arg mode env)
+ (labels (
+ (transformType (x)
+ (declare (special |$sigAlist|))
+ (cond
+ ((atom x) x)
+ ((and (pairp x) (eq (qcar x) '|:|) (pairp (qcdr x))
+ (pairp (qcdr (qcdr x))) (eq (qcdr (qcdr (qcdr x))) nil))
+ (setq |$sigAlist|
+ (cons (cons (second x) (transformType (third x)))
+ |$sigAlist|))
+ x)
+ ((and (pairp x) (eq (qcar x) '|Record|)) x)
+ (t
+ (cons (first x)
+ (loop for y in (rest x)
+ collect (transformType y))))))
+ (removeSuchthat (x)
+ (declare (special |$predAlist|))
+ (if (and (pairp x) (eq (qcar x) '|\||) (pairp (qcdr x))
+ (pairp (qcdr (qcdr x))) (eq (qcdr (qcdr (qcdr x))) nil))
+ (progn
+ (setq |$predAlist| (cons (cons (second x) (third x)) |$predAlist|))
+ (second x))
+ x))
+ (fetchType (a x env form)
+ (if x
+ x
+ (or (|getmode| a env)
+ (|userError| (|concat|
+ "There is no mode for argument" a "of function" (first form))))))
+ (addSuchthat (x y)
+ (let (p)
+ (declare (special |$predAlist|))
+ (if (setq p (lassoc x |$predAlist|)) (list '|\|| y p) y)))
+ )
+ (let (|$sigAlist| |$predAlist| form signature specialCases body sigList
+ argList argSigAlist argDepAlist varList whereList formxx signaturex
+ defform formx)
+ (declare (special |$sigAlist| |$predAlist|))
+; form is lhs (f a1 ... an) of definition; body is rhs;
+; signature is (t0 t1 ... tn) where t0= target type, ti=type of ai, i > 0;
+; specialCases is (NIL l1 ... ln) where li is list of special cases
+; which can be given for each ti
+;
+; removes declarative and assignment information from form and
+; signature, placing it in list L, replacing form by ("where",form',:L),
+; signature by a list of NILs (signifying declarations are in e)
+ (setq form (second arg))
+ (setq signature (third arg))
+ (setq specialCases (fourth arg))
+ (setq body (fifth arg))
+ (setq |$sigAlist| nil)
+ (setq |$predAlist| nil)
+; 1. create sigList= list of all signatures which have embedded
+; declarations moved into global variable $sigAlist
+ (setq sigList
+ (loop for a in (rest form) for x in (rest signature)
+ collect (transformType (fetchType a x env form))))
+; 2. replace each argument of the form (|| x p) by x, recording
+; the given predicate in global variable $predAlist
+ (setq argList
+ (loop for a in (rest form)
+ collect (removeSuchthat a)))
+ (setq argSigAlist (append |$sigAlist| (|pairList| argList sigList)))
+ (setq argDepAlist
+ (loop for pear in argSigAlist
+ collect
+ (cons (car pear)
+ (|union| (|listOfIdentifiersIn| (cdr pear))
+ (|delete| (car pear)
+ (|listOfIdentifiersIn| (lassoc (car pear) |$predAlist|)))))))
+; 3. obtain a list of parameter identifiers (x1 .. xn) ordered so that
+; the type of xi is independent of xj if i < j
+ (setq varList
+ (|orderByDependency| (assocleft argDepAlist) (assocright argDepAlist)))
+; 4. construct a WhereList which declares and/or defines the xi's in
+; the order constructed in step 3
+ (setq whereList
+ (loop for x in varList
+ collect (addSuchthat x (list '|:| x (lassoc x argSigAlist)))))
+ (setq formxx (cons (car form) argList))
+ (setq signaturex
+ (cons (car signature)
+ (loop for x in (rest signature) collect nil)))
+ (setq defform (list 'def formxx signaturex specialCases body))
+ (setq formx (cons '|where| (cons defform whereList)))
+; 5. compile new ('DEF,("where",form',:WhereList),:.) where
+; all argument parameters of form' are bound/declared in WhereList
+ (|comp| formx mode env))))
+
+\end{chunk}
+
\section{Indirect called comp routines}
In the {\bf compExpression} function there is the code:
\begin{verbatim}
@@ -16269,6 +16429,7 @@ if \verb|$InteractiveMode| then use a null outputstream
\getchunk{defun compDefineCategory2}
\getchunk{defun compDefineFunctor}
\getchunk{defun compDefineFunctor1}
+\getchunk{defun compDefWhereClause}
\getchunk{defun compElt}
\getchunk{defun compExit}
\getchunk{defun compExpression}
@@ -16399,6 +16560,7 @@ if \verb|$InteractiveMode| then use a null outputstream
\getchunk{defun meta-syntax-error}
\getchunk{defun mkCategoryPackage}
\getchunk{defun mkConstructor}
+\getchunk{defun mkOpVec}
\getchunk{defun modifyModeStack}
\getchunk{defun ncINTERPFILE}
diff --git a/changelog b/changelog
index 8efc2b6..a9ae233 100644
--- a/changelog
+++ b/changelog
@@ -1,3 +1,9 @@
+20110601 tpd src/axiom-website/patches.html 20110601.01.tpd.patch
+20110601 tpd src/interp/modemap.lisp treeshake compiler
+20110601 tpd src/interp/lisplib.lisp treeshake compiler
+20110601 tpd src/interp/info.lisp treeshake compiler
+20110601 tpd src/interp/define.lisp treeshake compiler
+20110601 tpd books/bookvol9 treeshake compiler
20110531 tpd src/axiom-website/patches.html 20110531.01.tpd.patch
20110531 tpd src/interp/define.lisp treeshake compiler
20110531 tpd books/bookvol9 treeshake compiler
diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html
index ef6e811..86792a5 100644
--- a/src/axiom-website/patches.html
+++ b/src/axiom-website/patches.html
@@ -3520,5 +3520,7 @@ books/bookvol9 treeshake compiler
books/bookvol9 treeshake compiler
20110531.01.tpd.patch
books/bookvol9 treeshake compiler
+20110601.01.tpd.patch
+books/bookvol9 treeshake compiler