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
diff --git a/src/interp/define.lisp.pamphlet b/src/interp/define.lisp.pamphlet index 7d413fe..ce7a9af 100644 --- a/src/interp/define.lisp.pamphlet +++ b/src/interp/define.lisp.pamphlet @@ -12,417 +12,6 @@ \begin{chunk}{*} (IN-PACKAGE "BOOT" ) -;mkOpVec(dom,siglist) == -; dom:= getPrincipalView dom -; substargs:= [['$,:dom.0],: -; [[a,:x] for a in $FormalMapVariableList for x in rest dom.0]] -; oplist:= getOperationAlistFromLisplib opOf dom.0 -; --new form is ( ) -; ops:= MAKE_-VEC (#siglist) -; for (opSig:= [op,sig]) in siglist for i in 0.. repeat -; u:= ASSQ(op,oplist) -; ASSOC(sig,u) is [.,n,.,'ELT] => ops.i := dom.n -; noplist:= SUBLIS(substargs,u) -; -- following variation on ASSOC needed for GENSYMS in Mutable domains -; AssocBarGensym(SUBST(dom.0,'$,sig),noplist) is [.,n,.,'ELT] => -; ops.i := dom.n -; ops.i := [Undef,[dom.0,i],:opSig] -; ops - -(DEFUN |mkOpVec| (|dom| |siglist|) - (PROG (|substargs| |oplist| |ops| |op| |sig| |u| |noplist| |ISTMP#1| - |ISTMP#2| |n| |ISTMP#3| |ISTMP#4|) - (declare (special |$FormalMapVariableList|)) - (RETURN - (SEQ (PROGN - (SPADLET |dom| (|getPrincipalView| |dom|)) - (SPADLET |substargs| - (CONS (CONS '$ (ELT |dom| 0)) - (PROG (G167887) - (SPADLET G167887 NIL) - (RETURN - (DO ((G167893 - |$FormalMapVariableList| - (CDR G167893)) - (|a| NIL) - (G167894 (CDR (ELT |dom| 0)) - (CDR G167894)) - (|x| NIL)) - ((OR (ATOM G167893) - (PROGN - (SETQ |a| (CAR G167893)) - NIL) - (ATOM G167894) - (PROGN - (SETQ |x| (CAR G167894)) - NIL)) - (NREVERSE0 G167887)) - (SEQ (EXIT - (SETQ G167887 - (CONS (CONS |a| |x|) - G167887))))))))) - (SPADLET |oplist| - (|getOperationAlistFromLisplib| - (|opOf| (ELT |dom| 0)))) - (SPADLET |ops| (make-array (|#| |siglist|))) - (DO ((G167928 |siglist| (CDR G167928)) (|opSig| NIL) - (|i| 0 (QSADD1 |i|))) - ((OR (ATOM G167928) - (PROGN (SETQ |opSig| (CAR G167928)) NIL) - (PROGN - (PROGN - (SPADLET |op| (CAR |opSig|)) - (SPADLET |sig| (CADR |opSig|)) - |opSig|) - NIL)) - NIL) - (SEQ (EXIT (PROGN - (SPADLET |u| (ASSQ |op| |oplist|)) - (COND - ((PROGN - (SPADLET |ISTMP#1| - (|assoc| |sig| |u|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |n| - (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |ISTMP#4| - (QCDR |ISTMP#3|)) - (AND (PAIRP |ISTMP#4|) - (EQ (QCDR |ISTMP#4|) - NIL) - (EQ (QCAR |ISTMP#4|) - 'ELT))))))))) - (SETELT |ops| |i| (ELT |dom| |n|))) - ('T - (SPADLET |noplist| - (SUBLIS |substargs| |u|)) - (COND - ((PROGN - (SPADLET |ISTMP#1| - (|AssocBarGensym| - (MSUBST (ELT |dom| 0) '$ |sig|) - |noplist|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |n| - (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |ISTMP#4| - (QCDR |ISTMP#3|)) - (AND (PAIRP |ISTMP#4|) - (EQ (QCDR |ISTMP#4|) NIL) - (EQ (QCAR |ISTMP#4|) - 'ELT))))))))) - (SETELT |ops| |i| (ELT |dom| |n|))) - ('T - (SETELT |ops| |i| - (CONS |Undef| - (CONS - (CONS (ELT |dom| 0) - (CONS |i| NIL)) - |opSig|))))))))))) - |ops|))))) - -;genDomainViewName(a,category) == -;--+ -; a - -(DEFUN |genDomainViewName| (|a| |category|) - (declare (ignore |category|)) - |a|) - -;compDefWhereClause(['DEF,form,signature,specialCases,body],m,e) == -;-- 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) -; $sigAlist: local := nil -; $predAlist: local := nil -; -;-- 1. create sigList= list of all signatures which have embedded -;-- declarations moved into global variable $sigAlist -; sigList:= -; [transformType fetchType(a,x,e,form) for a in rest form for x in rest signature] -; where -; fetchType(a,x,e,form) == -; x => x -; getmode(a,e) or userError concat( -; '"There is no mode for argument",a,'"of function",first form) -; transformType x == -; atom x => x -; x is [":",R,Rtype] => -; ($sigAlist:= [[R,:transformType Rtype],:$sigAlist]; x) -; x is ['Record,:.] => x --RDJ 8/83 -; [first x,:[transformType y for y in rest x]] -; -;-- 2. replace each argument of the form (|| x p) by x, recording -;-- the given predicate in global variable $predAlist -; argList:= -; [removeSuchthat a for a in rest form] where -; removeSuchthat x == -; x is ["|",y,p] => ($predAlist:= [[y,:p],:$predAlist]; y) -; x -; -;-- 3. obtain a list of parameter identifiers (x1 .. xn) ordered so that -;-- the type of xi is independent of xj if i < j -; varList:= -; orderByDependency(ASSOCLEFT argDepAlist,ASSOCRIGHT argDepAlist) where -; argDepAlist:= -; [[x,:dependencies] for [x,:y] in argSigAlist] where -; dependencies() == -; setUnion(listOfIdentifiersIn y, -; DELETE(x,listOfIdentifiersIn LASSOC(x,$predAlist))) -; argSigAlist:= [:$sigAlist,:pairList(argList,sigList)] -; -;-- 4. construct a WhereList which declares and/or defines the xi's in -;-- the order constructed in step 3 -; (whereList:= [addSuchthat(x,[":",x,LASSOC(x,argSigAlist)]) for x in varList]) -; where addSuchthat(x,y) == (p:= LASSOC(x,$predAlist) => ["|",y,p]; y) -; -;-- 5. compile new ('DEF,("where",form',:WhereList),:.) where -;-- all argument parameters of form' are bound/declared in WhereList -; comp(form',m,e) where -; form':= -; ["where",defform,:whereList] where -; defform:= -; ['DEF,form'',signature',specialCases,body] where -; form'':= [first form,:argList] -; signature':= [first signature,:[nil for x in rest signature]] - -(DEFUN |compDefWhereClause,transformType| (|x|) - (PROG (|ISTMP#1| R |ISTMP#2| |Rtype|) - (declare (special |$sigAlist|)) - (RETURN - (SEQ (IF (ATOM |x|) (EXIT |x|)) - (IF (AND (PAIRP |x|) (EQ (QCAR |x|) '|:|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET R (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |Rtype| (QCAR |ISTMP#2|)) - 'T)))))) - (EXIT (SEQ (SPADLET |$sigAlist| - (CONS - (CONS R - (|compDefWhereClause,transformType| - |Rtype|)) - |$sigAlist|)) - (EXIT |x|)))) - (IF (AND (PAIRP |x|) (EQ (QCAR |x|) '|Record|)) (EXIT |x|)) - (EXIT (CONS (CAR |x|) - (PROG (G167983) - (SPADLET G167983 NIL) - (RETURN - (DO ((G167988 (CDR |x|) (CDR G167988)) - (|y| NIL)) - ((OR (ATOM G167988) - (PROGN - (SETQ |y| (CAR G167988)) - NIL)) - (NREVERSE0 G167983)) - (SEQ (EXIT (SETQ G167983 - (CONS - (|compDefWhereClause,transformType| - |y|) - G167983))))))))))))) - -(DEFUN |compDefWhereClause,fetchType| (|a| |x| |e| |form|) - (SEQ (IF |x| (EXIT |x|)) - (EXIT (OR (|getmode| |a| |e|) - (|userError| - (|concat| - "There is no mode for argument" - |a| "of function" (CAR |form|))))))) - -(DEFUN |compDefWhereClause,removeSuchthat| (|x|) - (PROG (|ISTMP#1| |y| |ISTMP#2| |p|) - (declare (special |$predAlist|)) - (RETURN - (SEQ (IF (AND (PAIRP |x|) (EQ (QCAR |x|) '|\||) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |y| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |p| (QCAR |ISTMP#2|)) - 'T)))))) - (EXIT (SEQ (SPADLET |$predAlist| - (CONS (CONS |y| |p|) |$predAlist|)) - (EXIT |y|)))) - (EXIT |x|))))) - -(DEFUN |compDefWhereClause,addSuchthat| (|x| |y|) - (PROG (|p|) - (declare (special |$predAlist|)) - (RETURN - (SEQ (IF (SPADLET |p| (LASSOC |x| |$predAlist|)) - (EXIT (CONS '|\|| (CONS |y| (CONS |p| NIL))))) - (EXIT |y|))))) - -(DEFUN |compDefWhereClause| (G168068 |m| |e|) - (PROG (|$sigAlist| |$predAlist| |form| |signature| |specialCases| - |body| |sigList| |argList| |argSigAlist| |x| |y| - |argDepAlist| |varList| |whereList| |form''| |signature'| - |defform| |form'|) - (DECLARE (SPECIAL |$sigAlist| |$predAlist|)) - (RETURN - (SEQ (PROGN - (SPADLET |form| (CADR G168068)) - (SPADLET |signature| (CADDR G168068)) - (SPADLET |specialCases| (CADDDR G168068)) - (SPADLET |body| (CAR (CDDDDR G168068))) - (SPADLET |$sigAlist| NIL) - (SPADLET |$predAlist| NIL) - (SPADLET |sigList| - (PROG (G168097) - (SPADLET G168097 NIL) - (RETURN - (DO ((G168103 (CDR |form|) (CDR G168103)) - (|a| NIL) - (G168104 (CDR |signature|) - (CDR G168104)) - (|x| NIL)) - ((OR (ATOM G168103) - (PROGN - (SETQ |a| (CAR G168103)) - NIL) - (ATOM G168104) - (PROGN - (SETQ |x| (CAR G168104)) - NIL)) - (NREVERSE0 G168097)) - (SEQ (EXIT (SETQ G168097 - (CONS - (|compDefWhereClause,transformType| - (|compDefWhereClause,fetchType| - |a| |x| |e| |form|)) - G168097)))))))) - (SPADLET |argList| - (PROG (G168117) - (SPADLET G168117 NIL) - (RETURN - (DO ((G168122 (CDR |form|) (CDR G168122)) - (|a| NIL)) - ((OR (ATOM G168122) - (PROGN - (SETQ |a| (CAR G168122)) - NIL)) - (NREVERSE0 G168117)) - (SEQ (EXIT (SETQ G168117 - (CONS - (|compDefWhereClause,removeSuchthat| - |a|) - G168117)))))))) - (SPADLET |argSigAlist| - (APPEND |$sigAlist| - (|pairList| |argList| |sigList|))) - (SPADLET |argDepAlist| - (PROG (G168133) - (SPADLET G168133 NIL) - (RETURN - (DO ((G168139 |argSigAlist| - (CDR G168139)) - (G168034 NIL)) - ((OR (ATOM G168139) - (PROGN - (SETQ G168034 (CAR G168139)) - NIL) - (PROGN - (PROGN - (SPADLET |x| (CAR G168034)) - (SPADLET |y| (CDR G168034)) - G168034) - NIL)) - (NREVERSE0 G168133)) - (SEQ (EXIT (SETQ G168133 - (CONS - (CONS |x| - (|union| - (|listOfIdentifiersIn| |y|) - (|delete| |x| - (|listOfIdentifiersIn| - (LASSOC |x| |$predAlist|))))) - G168133)))))))) - (SPADLET |varList| - (|orderByDependency| (ASSOCLEFT |argDepAlist|) - (ASSOCRIGHT |argDepAlist|))) - (SPADLET |whereList| - (PROG (G168150) - (SPADLET G168150 NIL) - (RETURN - (DO ((G168155 |varList| (CDR G168155)) - (|x| NIL)) - ((OR (ATOM G168155) - (PROGN - (SETQ |x| (CAR G168155)) - NIL)) - (NREVERSE0 G168150)) - (SEQ (EXIT (SETQ G168150 - (CONS - (|compDefWhereClause,addSuchthat| - |x| - (CONS '|:| - (CONS |x| - (CONS - (LASSOC |x| |argSigAlist|) - NIL)))) - G168150)))))))) - (SPADLET |form''| (CONS (CAR |form|) |argList|)) - (SPADLET |signature'| - (CONS (CAR |signature|) - (PROG (G168165) - (SPADLET G168165 NIL) - (RETURN - (DO ((G168170 (CDR |signature|) - (CDR G168170)) - (|x| NIL)) - ((OR (ATOM G168170) - (PROGN - (SETQ |x| (CAR G168170)) - NIL)) - (NREVERSE0 G168165)) - (SEQ (EXIT - (SETQ G168165 - (CONS NIL G168165))))))))) - (SPADLET |defform| - (CONS 'DEF - (CONS |form''| - (CONS |signature'| - (CONS |specialCases| - (CONS |body| NIL)))))) - (SPADLET |form'| - (CONS '|where| (CONS |defform| |whereList|))) - (|comp| |form'| |m| |e|)))))) - ;orderByDependency(vl,dl) == ; -- vl is list of variables, dl is list of dependency-lists ; selfDependents:= [v for v in vl for d in dl | MEMQ(v,d)] diff --git a/src/interp/info.lisp.pamphlet b/src/interp/info.lisp.pamphlet index 469838a..951368f 100644 --- a/src/interp/info.lisp.pamphlet +++ b/src/interp/info.lisp.pamphlet @@ -1034,19 +1034,16 @@ modemap is of the form : ((op (targ arg1 arg2 ... argn)) pred (elt $ n)) (COND ((BOOT-EQUAL |name| '$) (SPADLET |$e| - (|augModemapsFromCategory| |name| - |name| |name| |cat| |$e|))) + (|augModemapsFromCategory| + |name| |name| |cat| |$e|))) ('T - (SPADLET |viewName| - (|genDomainViewName| |name| |cat|)) - (|genDomainView| |viewName| |name| |cat| - '|HasCategory|) + (|genDomainView| |name| |cat| '|HasCategory|) (COND - ((NULL (member |viewName| + ((NULL (member |name| |$functorLocalParameters|)) (SPADLET |$functorLocalParameters| (APPEND |$functorLocalParameters| - (CONS |viewName| NIL)))) + (CONS |name| NIL)))) ('T NIL)))) (SAY "augmenting " |name| ": " |cat|) diff --git a/src/interp/lisplib.lisp.pamphlet b/src/interp/lisplib.lisp.pamphlet index f5f7104..7930461 100644 --- a/src/interp/lisplib.lisp.pamphlet +++ b/src/interp/lisplib.lisp.pamphlet @@ -2156,8 +2156,7 @@ (|addConstructorModemaps| |name| |functorForm| |e|)) ((AND (ATOM |functorForm|) (SPADLET |catform| (|getmode| |functorForm| |e|))) - (|augModemapsFromCategory| |name| |name| |functorForm| - |catform| |e|)) + (|augModemapsFromCategory| |name| |functorForm| |catform| |e|)) ((SPADLET |mappingForm| (|getmodeOrMapping| (KAR |functorForm|) |e|)) (COND @@ -2167,8 +2166,7 @@ (SPADLET |catform| (|substituteCategoryArguments| (CDR |functorForm|) |categoryForm|)) - (|augModemapsFromCategory| |name| |name| |functorForm| - |catform| |e|)) + (|augModemapsFromCategory| |name| |functorForm| |catform| |e|)) ('T (|stackMessage| (CONS |functorForm| (CONS '| is an unknown mode| NIL))) diff --git a/src/interp/modemap.lisp.pamphlet b/src/interp/modemap.lisp.pamphlet index 19353b7..126835d 100644 --- a/src/interp/modemap.lisp.pamphlet +++ b/src/interp/modemap.lisp.pamphlet @@ -673,7 +673,6 @@ ; e:= addModemap(op,domainName,sig,cond,fnsel',e) ; e:= addModemap(op,domainName,sig,cond,fnsel,e) ; e - (DEFUN |augModemapsFromCategoryRep| (|domainName| |repDefn| |functorBody| |categoryForm| |e|) (PROG (|fnAlist| |LETTMP#1| |repFnAlist| |catform| |lhs| |op| |sig| @@ -813,13 +812,13 @@ ; e (DEFUN |augModemapsFromCategory| - (|domainName| |domainView| |functorForm| |categoryForm| |e|) + (|domainName| |functorForm| |categoryForm| |e|) (PROG (|LETTMP#1| |fnAlist| |condlist| |op| |sig| |cond| |fnsel|) (declare (special |$base|)) (RETURN (SEQ (PROGN (SPADLET |LETTMP#1| - (|evalAndSub| |domainName| |domainView| + (|evalAndSub| |domainName| |domainName| |functorForm| |categoryForm| |e|)) (SPADLET |fnAlist| (CAR |LETTMP#1|)) (SPADLET |e| (CADR |LETTMP#1|))