diff --git a/books/bookvol9.pamphlet b/books/bookvol9.pamphlet index a7f8f80..07a6745 100644 --- a/books/bookvol9.pamphlet +++ b/books/bookvol9.pamphlet @@ -6920,6 +6920,18 @@ $\rightarrow$ \end{chunk} \defun{makeFunctorArgumentParameters}{makeFunctorArgumentParameters} +\calls{makeFunctorArgumentParameters}{assq} +\calls{makeFunctorArgumentParameters}{msubst} +\calls{makeFunctorArgumentParameters}{isCategoryForm} +\calls{makeFunctorArgumentParameters}{pairp} +\calls{makeFunctorArgumentParameters}{qcar} +\calls{makeFunctorArgumentParameters}{qcdr} +\calls{makeFunctorArgumentParameters}{genDomainViewList0} +\calls{makeFunctorArgumentParameters}{genDomainView} +\calls{makeFunctorArgumentParameters}{union} +\usesdollar{makeFunctorArgumentParameters}{ConditionalOperators} +\usesdollar{makeFunctorArgumentParameters}{alternateViewList} +\usesdollar{makeFunctorArgumentParameters}{forceAdd} \begin{chunk}{defun makeFunctorArgumentParameters} (defun |makeFunctorArgumentParameters| (argl sigl target) (labels ( @@ -7000,6 +7012,111 @@ $\rightarrow$ \end{chunk} +\defun{genDomainViewList0}{genDomainViewList0} +\calls{genDomainViewList0}{getDomainViewList} +\begin{chunk}{defun genDomainViewList0} +(defun |genDomainViewList0| (id catlist) + (|genDomainViewList| id catlist t)) + +\end{chunk} + +\defun{genDomainViewList}{genDomainViewList} +\calls{genDomainViewList}{pairp} +\calls{genDomainViewList}{qcdr} +\calls{genDomainViewList}{isCategoryForm} +\calls{genDomainViewList}{genDomainView} +\calls{genDomainViewList}{genDomainViewName} +\calls{genDomainViewList}{genDomainViewList} +\usesdollar{genDomainViewList}{EmptyEnvironment} +\begin{chunk}{defun genDomainViewList} +(defun |genDomainViewList| (id catlist firsttime) + (declare (special |$EmptyEnvironment|)) + (cond + ((null catlist) nil) + ((and (pairp catlist) (eq (qcdr catlist) nil) + (null (|isCategoryForm| (first catlist) |$EmptyEnvironment|))) + nil) + (t + (cons + (|genDomainView| + (if firsttime id (|genDomainViewName| id (first catlist))) + id (first catlist) '|getDomainView|) + (|genDomainViewList| id (rest catlist) nil))))) + +\end{chunk} + +\defun{genDomainView}{genDomainView} +\calls{genDomainView}{genDomainOps} +\calls{genDomainView}{pairp} +\calls{genDomainView}{qcar} +\calls{genDomainView}{qcdr} +\calls{genDomainView}{augModemapsFromCategory} +\calls{genDomainView}{mkDomainConstructor} +\calls{genDomainView}{member} +\usesdollar{genDomainView}{e} +\usesdollar{genDomainView}{getDomainCode} +\begin{chunk}{defun genDomainView} +(defun |genDomainView| (viewName originalName c viewSelector) + (let (code cd) + (declare (special |$getDomainCode| |$e|)) + (cond + ((and (pairp c) (eq (qcar c) 'category) (pairp (qcdr c))) + (|genDomainOps| viewName originalName c)) + (t + (setq code + (if (and (pairp c) (eq (qcar c) '|SubsetCategory|) + (pairp (qcdr c)) (pairp (qcdr (qcdr c))) + (eq (qcdr (qcdr (qcdr c))) nil)) + (second c) + c)) + (setq |$e| (|augModemapsFromCategory| originalName viewName nil c |$e|)) + (setq cd + (list 'let viewName + (list viewSelector originalName (|mkDomainConstructor| code)))) + (unless (|member| cd |$getDomainCode|) + (setq |$getDomainCode| (cons cd |$getDomainCode|))) + viewName)))) + +\end{chunk} + +\defun{genDomainOps}{genDomainOps} +\calls{genDomainOps}{getOperationAlist} +\calls{genDomainOps}{substNames} +\calls{genDomainOps}{mkq} +\calls{genDomainOps}{mkDomainConstructor} +\calls{genDomainOps}{addModemap} +\usesdollar{genDomainOps}{e} +\usesdollar{genDomainOps}{ConditionalOperators} +\usesdollar{genDomainOps}{getDomainCode} +\begin{chunk}{defun genDomainOps} +(defun |genDomainOps| (viewName dom cat) + (let (siglist oplist cd opsig i) + (declare (special |$e| |$ConditionalOperators| |$getDomainCode|)) + (setq oplist (|getOperationAlist| dom dom cat)) + (setq siglist (loop for lst in oplist collect (first lst))) + (setq oplist (|substNames| dom viewName dom oplist)) + (setq cd + (list 'let viewName + (list '|mkOpVec| dom + (cons 'list + (loop for opsig in siglist do + collect + (list 'list (mkq (first opsig)) + (cons 'list + (loop for mode in (rest opsig) + collect (|mkDomainConstructor| mode))))))))) + (setq |$getDomainCode| (cons cd |$getDomainCode|)) + (setq i 0) + (loop for item in oplist do + (if (|member| (first item) |$ConditionalOperators|) + (setq |$e| (|addModemap| (caar item) dom (cadar item) nil + (list 'elt viewName (incf i)) |$e|)) + (setq |$e| (|addModemap| (caar item) dom (cadar item) (second item) + (list 'elt viewName (incf i)) |$e|)))) + viewName)) + +\end{chunk} + \section{Indirect called comp routines} In the {\bf compExpression} function there is the code: \begin{verbatim} @@ -16235,6 +16352,10 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun getTargetFromRhs} \getchunk{defun get-token} \getchunk{defun getToken} +\getchunk{defun genDomainOps} +\getchunk{defun genDomainViewList0} +\getchunk{defun genDomainViewList} +\getchunk{defun genDomainView} \getchunk{defun giveFormalParametersValues} \getchunk{defun hackforis} diff --git a/changelog b/changelog index cf2b1d5..8efc2b6 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,6 @@ +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 20110530 tpd src/axiom-website/patches.html 20110530.01.tpd.patch 20110530 tpd src/interp/define.lisp treeshake compiler 20110530 tpd books/bookvol9 treeshake compiler diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index ed3a2d4..ef6e811 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -3518,5 +3518,7 @@ src/axiom-website/download.html add ubuntu
books/bookvol9 treeshake compiler
20110530.01.tpd.patch books/bookvol9 treeshake compiler
+20110531.01.tpd.patch +books/bookvol9 treeshake compiler
diff --git a/src/interp/define.lisp.pamphlet b/src/interp/define.lisp.pamphlet index 9fa677c..7d413fe 100644 --- a/src/interp/define.lisp.pamphlet +++ b/src/interp/define.lisp.pamphlet @@ -12,236 +12,6 @@ \begin{chunk}{*} (IN-PACKAGE "BOOT" ) -;genDomainViewList0(id,catlist) == -; l:= genDomainViewList(id,catlist,true) -; l - -(DEFUN |genDomainViewList0| (|id| |catlist|) - (PROG (|l|) - (RETURN - (PROGN - (SPADLET |l| (|genDomainViewList| |id| |catlist| 'T)) - |l|)))) - -;genDomainViewList(id,catlist,firsttime) == -; null catlist => nil -; catlist is [y] and not isCategoryForm(y,$EmptyEnvironment) => nil -; [genDomainView(if firsttime then id else genDomainViewName(id,first catlist), -; id,first catlist,"getDomainView"),:genDomainViewList(id,rest catlist,nil)] - -(DEFUN |genDomainViewList| (|id| |catlist| |firsttime|) - (PROG (|y|) - (declare (special |$EmptyEnvironment|)) - (RETURN - (COND - ((NULL |catlist|) NIL) - ((AND (PAIRP |catlist|) (EQ (QCDR |catlist|) NIL) - (PROGN (SPADLET |y| (QCAR |catlist|)) 'T) - (NULL (|isCategoryForm| |y| |$EmptyEnvironment|))) - NIL) - ('T - (CONS (|genDomainView| - (COND - (|firsttime| |id|) - ('T (|genDomainViewName| |id| (CAR |catlist|)))) - |id| (CAR |catlist|) '|getDomainView|) - (|genDomainViewList| |id| (CDR |catlist|) NIL))))))) - -;genDomainView(viewName,originalName,c,viewSelector) == -; c is ['CATEGORY,.,:l] => genDomainOps(viewName,originalName,c) -; code:= -; c is ['SubsetCategory,c',.] => c' -; c -; $e:= augModemapsFromCategory(originalName,viewName,nil,c,$e) -; --$alternateViewList:= ((viewName,:code),:$alternateViewList) -; cd:= ['LET,viewName,[viewSelector,originalName,mkDomainConstructor code]] -; if null MEMBER(cd,$getDomainCode) then -; $getDomainCode:= [cd,:$getDomainCode] -; viewName - -(DEFUN |genDomainView| (|viewName| |originalName| |c| |viewSelector|) - (PROG (|l| |ISTMP#1| |c'| |ISTMP#2| |code| |cd|) - (declare (special |$getDomainCode| |$e|)) - (RETURN - (COND - ((AND (PAIRP |c|) (EQ (QCAR |c|) 'CATEGORY) - (PROGN - (SPADLET |ISTMP#1| (QCDR |c|)) - (AND (PAIRP |ISTMP#1|) - (PROGN (SPADLET |l| (QCDR |ISTMP#1|)) 'T)))) - (|genDomainOps| |viewName| |originalName| |c|)) - ('T - (SPADLET |code| - (COND - ((AND (PAIRP |c|) (EQ (QCAR |c|) '|SubsetCategory|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |c|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |c'| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL)))))) - |c'|) - ('T |c|))) - (SPADLET |$e| - (|augModemapsFromCategory| |originalName| |viewName| - NIL |c| |$e|)) - (SPADLET |cd| - (CONS 'LET - (CONS |viewName| - (CONS (CONS |viewSelector| - (CONS |originalName| - (CONS - (|mkDomainConstructor| |code|) - NIL))) - NIL)))) - (COND - ((NULL (|member| |cd| |$getDomainCode|)) - (SPADLET |$getDomainCode| (CONS |cd| |$getDomainCode|)))) - |viewName|))))) - -;genDomainOps(viewName,dom,cat) == -; oplist:= getOperationAlist(dom,dom,cat) -; siglist:= [sig for [sig,:.] in oplist] -; oplist:= substNames(dom,viewName,dom,oplist) -; cd:= -; ['LET,viewName,['mkOpVec,dom,['LIST,: -; [['LIST,MKQ op,['LIST,:[mkDomainConstructor mode for mode in sig]]] -; for [op,sig] in siglist]]]] -; $getDomainCode:= [cd,:$getDomainCode] -; for [opsig,cond,:.] in oplist for i in 0.. repeat -; if opsig in $ConditionalOperators then cond:=nil -; [op,sig]:=opsig -; $e:= addModemap(op,dom,sig,cond,['ELT,viewName,i],$e) -; viewName - -(DEFUN |genDomainOps| (|viewName| |dom| |cat|) - (PROG (|siglist| |oplist| |cd| |opsig| |cond| |op| |sig|) - (declare (special |$e| |$ConditionalOperators| |$getDomainCode|)) - (RETURN - (SEQ (PROGN - (SPADLET |oplist| (|getOperationAlist| |dom| |dom| |cat|)) - (SPADLET |siglist| - (PROG (G167741) - (SPADLET G167741 NIL) - (RETURN - (DO ((G167747 |oplist| (CDR G167747)) - (G167720 NIL)) - ((OR (ATOM G167747) - (PROGN - (SETQ G167720 (CAR G167747)) - NIL) - (PROGN - (PROGN - (SPADLET |sig| (CAR G167720)) - G167720) - NIL)) - (NREVERSE0 G167741)) - (SEQ (EXIT (SETQ G167741 - (CONS |sig| G167741)))))))) - (SPADLET |oplist| - (|substNames| |dom| |viewName| |dom| |oplist|)) - (SPADLET |cd| - (CONS 'LET - (CONS |viewName| - (CONS (CONS '|mkOpVec| - (CONS |dom| - (CONS - (CONS 'LIST - (PROG (G167759) - (SPADLET G167759 NIL) - (RETURN - (DO - ((G167765 |siglist| - (CDR G167765)) - (G167723 NIL)) - ((OR (ATOM G167765) - (PROGN - (SETQ G167723 - (CAR G167765)) - NIL) - (PROGN - (PROGN - (SPADLET |op| - (CAR G167723)) - (SPADLET |sig| - (CADR - G167723)) - G167723) - NIL)) - (NREVERSE0 G167759)) - (SEQ - (EXIT - (SETQ G167759 - (CONS - (CONS 'LIST - (CONS (MKQ |op|) - (CONS - (CONS 'LIST - (PROG - (G167776) - (SPADLET - G167776 - NIL) - (RETURN - (DO - ((G167781 - |sig| - (CDR - G167781)) - (|mode| - NIL)) - ((OR - (ATOM - G167781) - (PROGN - (SETQ - |mode| - (CAR - G167781)) - NIL)) - (NREVERSE0 - G167776)) - (SEQ - (EXIT - (SETQ - G167776 - (CONS - (|mkDomainConstructor| - |mode|) - G167776)))))))) - NIL))) - G167759)))))))) - NIL))) - NIL)))) - (SPADLET |$getDomainCode| (CONS |cd| |$getDomainCode|)) - (DO ((G167796 |oplist| (CDR G167796)) (G167731 NIL) - (|i| 0 (QSADD1 |i|))) - ((OR (ATOM G167796) - (PROGN (SETQ G167731 (CAR G167796)) NIL) - (PROGN - (PROGN - (SPADLET |opsig| (CAR G167731)) - (SPADLET |cond| (CADR G167731)) - G167731) - NIL)) - NIL) - (SEQ (EXIT (PROGN - (COND - ((|member| |opsig| - |$ConditionalOperators|) - (SPADLET |cond| NIL))) - (SPADLET |op| (CAR |opsig|)) - (SPADLET |sig| (CADR |opsig|)) - (SPADLET |$e| - (|addModemap| |op| |dom| |sig| - |cond| - (CONS 'ELT - (CONS |viewName| (CONS |i| NIL))) - |$e|)))))) - |viewName|))))) - ;mkOpVec(dom,siglist) == ; dom:= getPrincipalView dom ; substargs:= [['$,:dom.0],: