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
diff --git a/src/interp/database.lisp.pamphlet b/src/interp/database.lisp.pamphlet index c9d0bab..05edadc 100644 --- a/src/interp/database.lisp.pamphlet +++ b/src/interp/database.lisp.pamphlet @@ -14,169 +14,6 @@ (SETANDFILEQ |$getUnexposedOperations| 'T) -;fixUpPredicate(predClause, domainPreds, partial, sig) == -; -- merge the predicates in predClause and domainPreds into a -; -- single predicate -; [predicate, fn, :skip] := predClause -; if first predicate = "AND" then -; predicates := APPEND(domainPreds,rest predicate) -; else if predicate ^= MKQ "T" -;--was->then predicates:= REVERSE [predicate, :domainPreds] -; then predicates:= [predicate, :domainPreds] -; else predicates := domainPreds or [predicate] -; if #predicates > 1 then -; pred := ["AND",:predicates] -; [pred,:dependList]:=orderPredicateItems(pred,sig,skip) -; else -; pred := orderPredicateItems(first predicates,sig,skip) -; dependList:= if pred is ['isDomain,pvar,[.]] then [pvar] else nil -; pred := moveORsOutside pred -; if partial then pred := ["partial", :pred] -; [[pred, fn, :skip],:dependList] - -(DEFUN |fixUpPredicate| (|predClause| |domainPreds| |partial| |sig|) - (PROG (|predicate| |fn| |skip| |predicates| |LETTMP#1| |ISTMP#1| - |pvar| |ISTMP#2| |ISTMP#3| |dependList| |pred|) - (RETURN - (PROGN - (SPADLET |predicate| (CAR |predClause|)) - (SPADLET |fn| (CADR |predClause|)) - (SPADLET |skip| (CDDR |predClause|)) - (COND - ((BOOT-EQUAL (CAR |predicate|) 'AND) - (SPADLET |predicates| - (APPEND |domainPreds| (CDR |predicate|)))) - ((NEQUAL |predicate| (MKQ 'T)) - (SPADLET |predicates| (CONS |predicate| |domainPreds|))) - ('T - (SPADLET |predicates| - (OR |domainPreds| (CONS |predicate| NIL))))) - (COND - ((> (|#| |predicates|) 1) - (SPADLET |pred| (CONS 'AND |predicates|)) - (SPADLET |LETTMP#1| - (|orderPredicateItems| |pred| |sig| |skip|)) - (SPADLET |pred| (CAR |LETTMP#1|)) - (SPADLET |dependList| (CDR |LETTMP#1|)) |LETTMP#1|) - ('T - (SPADLET |pred| - (|orderPredicateItems| (CAR |predicates|) |sig| - |skip|)) - (SPADLET |dependList| - (COND - ((AND (PAIRP |pred|) - (EQ (QCAR |pred|) '|isDomain|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |pred|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |pvar| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |ISTMP#3| - (QCAR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL)))))))) - (CONS |pvar| NIL)) - ('T NIL))))) - (SPADLET |pred| (|moveORsOutside| |pred|)) - (COND (|partial| (SPADLET |pred| (CONS '|partial| |pred|)))) - (CONS (CONS |pred| (CONS |fn| |skip|)) |dependList|))))) - -;moveORsOutside p == -; p is ['AND,:q] => -; q := [moveORsOutside r for r in q] -; x := or/[r for r in q | r is ['OR,:s]] => -; moveORsOutside(['OR,:[['AND,:SUBST(t,x,q)] for t in CDR x]]) -; ['AND,:q] -; p - -(DEFUN |moveORsOutside| (|p|) - (PROG (|q| |s| |x|) - (RETURN - (SEQ (COND - ((AND (PAIRP |p|) (EQ (QCAR |p|) 'AND) - (PROGN (SPADLET |q| (QCDR |p|)) 'T)) - (SPADLET |q| - (PROG (G167169) - (SPADLET G167169 NIL) - (RETURN - (DO ((G167174 |q| (CDR G167174)) - (|r| NIL)) - ((OR (ATOM G167174) - (PROGN - (SETQ |r| (CAR G167174)) - NIL)) - (NREVERSE0 G167169)) - (SEQ (EXIT (SETQ G167169 - (CONS (|moveORsOutside| |r|) - G167169)))))))) - (COND - ((SPADLET |x| - (PROG (G167180) - (SPADLET G167180 NIL) - (RETURN - (DO ((G167187 NIL G167180) - (G167188 |q| (CDR G167188)) - (|r| NIL)) - ((OR G167187 (ATOM G167188) - (PROGN - (SETQ |r| (CAR G167188)) - NIL)) - G167180) - (SEQ (EXIT - (COND - ((AND (PAIRP |r|) - (EQ (QCAR |r|) 'OR) - (PROGN - (SPADLET |s| (QCDR |r|)) - 'T)) - (SETQ G167180 - (OR G167180 |r|)))))))))) - (|moveORsOutside| - (CONS 'OR - (PROG (G167199) - (SPADLET G167199 NIL) - (RETURN - (DO ((G167204 (CDR |x|) - (CDR G167204)) - (|t| NIL)) - ((OR (ATOM G167204) - (PROGN - (SETQ |t| (CAR G167204)) - NIL)) - (NREVERSE0 G167199)) - (SEQ (EXIT - (SETQ G167199 - (CONS - (CONS 'AND - (MSUBST |t| |x| |q|)) - G167199)))))))))) - ('T (CONS 'AND |q|)))) - ('T |p|)))))) - -;replaceVars(x,oldvars,newvars) == -; -- replace every identifier in oldvars with the corresponding -; -- identifier in newvars in the expression x -; for old in oldvars for new in newvars repeat -; x := substitute(new,old,x) -; x - -(DEFUN |replaceVars| (|x| |oldvars| |newvars|) - (SEQ (PROGN - (DO ((G167225 |oldvars| (CDR G167225)) (|old| NIL) - (G167226 |newvars| (CDR G167226)) (|new| NIL)) - ((OR (ATOM G167225) - (PROGN (SETQ |old| (CAR G167225)) NIL) - (ATOM G167226) - (PROGN (SETQ |new| (CAR G167226)) NIL)) - NIL) - (SEQ (EXIT (SPADLET |x| (MSUBST |new| |old| |x|))))) - |x|))) - ;getDomainFromMm mm == ; -- Returns the Domain (or package or category) of origin from a pattern ; -- modemap @@ -195,88 +32,119 @@ ; ['"getDomainFromMm",'"Can't find domain in modemap condition"]) ; val -(DEFUN |getDomainFromMm| (|mm|) - (PROG (|c| |cond| |cl| |condList| |dom| |ISTMP#1| |ISTMP#2| |cat| - |val|) - (RETURN - (SEQ (PROGN - (SPADLET |cond| (CADR |mm|)) - (COND - ((AND (PAIRP |cond|) (EQ (QCAR |cond|) '|partial|) - (PROGN (SPADLET |c| (QCDR |cond|)) 'T)) - (SPADLET |cond| |c|))) - (SPADLET |condList| - (COND - ((AND (PAIRP |cond|) (EQ (QCAR |cond|) 'AND) - (PROGN (SPADLET |cl| (QCDR |cond|)) 'T)) - |cl|) - ((AND (PAIRP |cond|) (EQ (QCAR |cond|) 'OR) - (PROGN - (SPADLET |ISTMP#1| (QCDR |cond|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| - (QCAR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCAR |ISTMP#2|) 'AND) - (PROGN - (SPADLET |cl| - (QCDR |ISTMP#2|)) - 'T)))))) - |cl|) - ('T (CONS |cond| NIL)))) - (SPADLET |val| - (DO ((G167289 |condList| (CDR G167289)) - (|condition| NIL)) - ((OR (ATOM G167289) - (PROGN - (SETQ |condition| (CAR G167289)) - NIL)) - NIL) - (SEQ (EXIT (COND - ((AND (PAIRP |condition|) - (EQ (QCAR |condition|) - '|isDomain|) - (PROGN - (SPADLET |ISTMP#1| - (QCDR |condition|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) '*1) - (PROGN - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |dom| - (QCAR |ISTMP#2|)) - 'T)))))) - (RETURN (|opOf| |dom|))) - ((AND (PAIRP |condition|) - (EQ (QCAR |condition|) - '|ofCategory|) - (PROGN - (SPADLET |ISTMP#1| - (QCDR |condition|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) '*1) - (PROGN - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |cat| - (QCAR |ISTMP#2|)) - 'T)))))) - (RETURN (|opOf| |cat|)))))))) - (COND - ((NULL |val|) - (|keyedSystemError| 'S2GE0016 - (CONS "getDomainFromMm" - (CONS "Can't find domain in modemap condition" - NIL)))) - ('T |val|))))))) +;(DEFUN |getDomainFromMm| (|mm|) +; (PROG (|c| |cond| |cl| |condList| |dom| |ISTMP#1| |ISTMP#2| |cat| +; |val|) +; (RETURN +; (SEQ (PROGN +; (SPADLET |cond| (CADR |mm|)) +; (COND +; ((AND (PAIRP |cond|) (EQ (QCAR |cond|) '|partial|) +; (PROGN (SPADLET |c| (QCDR |cond|)) 'T)) +; (SPADLET |cond| |c|))) +; (SPADLET |condList| +; (COND +; ((AND (PAIRP |cond|) (EQ (QCAR |cond|) 'AND) +; (PROGN (SPADLET |cl| (QCDR |cond|)) 'T)) +; |cl|) +; ((AND (PAIRP |cond|) (EQ (QCAR |cond|) 'OR) +; (PROGN +; (SPADLET |ISTMP#1| (QCDR |cond|)) +; (AND (PAIRP |ISTMP#1|) +; (PROGN +; (SPADLET |ISTMP#2| +; (QCAR |ISTMP#1|)) +; (AND (PAIRP |ISTMP#2|) +; (EQ (QCAR |ISTMP#2|) 'AND) +; (PROGN +; (SPADLET |cl| +; (QCDR |ISTMP#2|)) +; 'T)))))) +; |cl|) +; ('T (CONS |cond| NIL)))) +; (SPADLET |val| +; (DO ((G167289 |condList| (CDR G167289)) +; (|condition| NIL)) +; ((OR (ATOM G167289) +; (PROGN +; (SETQ |condition| (CAR G167289)) +; NIL)) +; NIL) +; (SEQ (EXIT (COND +; ((AND (PAIRP |condition|) +; (EQ (QCAR |condition|) +; '|isDomain|) +; (PROGN +; (SPADLET |ISTMP#1| +; (QCDR |condition|)) +; (AND (PAIRP |ISTMP#1|) +; (EQ (QCAR |ISTMP#1|) '*1) +; (PROGN +; (SPADLET |ISTMP#2| +; (QCDR |ISTMP#1|)) +; (AND (PAIRP |ISTMP#2|) +; (EQ (QCDR |ISTMP#2|) NIL) +; (PROGN +; (SPADLET |dom| +; (QCAR |ISTMP#2|)) +; 'T)))))) +; (RETURN (|opOf| |dom|))) +; ((AND (PAIRP |condition|) +; (EQ (QCAR |condition|) +; '|ofCategory|) +; (PROGN +; (SPADLET |ISTMP#1| +; (QCDR |condition|)) +; (AND (PAIRP |ISTMP#1|) +; (EQ (QCAR |ISTMP#1|) '*1) +; (PROGN +; (SPADLET |ISTMP#2| +; (QCDR |ISTMP#1|)) +; (AND (PAIRP |ISTMP#2|) +; (EQ (QCDR |ISTMP#2|) NIL) +; (PROGN +; (SPADLET |cat| +; (QCAR |ISTMP#2|)) +; 'T)))))) +; (RETURN (|opOf| |cat|)))))))) +; (COND +; ((NULL |val|) +; (|keyedSystemError| 'S2GE0016 +; (CONS "getDomainFromMm" +; (CONS "Can't find domain in modemap condition" +; NIL)))) +; ('T |val|))))))) + +(defun |getDomainFromMm| (mm) + (let (c cond condList val) + (setq cond (cadr mm)) + (when (and (pairp cond) (eq (qcar cond) '|partial|)) + (setq cond (qcdr cond))) + (setq condList + (cond + ((and (pairp cond) (eq (qcar cond) 'and)) + (qcdr cond)) + ((and (pairp cond) (eq (qcar cond) 'or) + (pairp (qcdr cond)) (pairp (qcar (qcdr cond))) + (eq (qcar (qcar (qcdr cond))) 'and)) + (qcdr (qcar (qcdr cond)))) + (t (list cond)))) + (setq val + (dolist (condition condList) + (when + (and (pairp condition) + (or (eq (qcar condition) '|isDomain|) + (eq (qcar condition) '|ofCategory|)) + (pairp (qcdr condition)) + (eq (qcar (qcdr condition)) '*1) + (pairp (qcdr (qcdr condition))) + (eq (qcdr (qcdr (qcdr condition))) nil)) + (return (|opOf| (caddr condition)))))) + (cond + ((null val) + (|keyedSystemError| 'S2GE0016 + (list "getDomainFromMm" "Can't find domain in modemap condition"))) + (t val)))) ;getFirstArgTypeFromMm mm == ; -- Returns the type of the first argument or nil @@ -516,269 +384,41 @@ ; ($getUnexposedOperations or isExposedConstructor(domName))] ; nil -(DEFUN |getInCoreModemaps| (|modemapList| |op| |nargs|) - (PROG (|mml| |dc| |sig| |domName| |cfn|) - (DECLARE (SPECIAL |$getUnexposedOperations|)) - (RETURN - (SEQ (COND - ((SPADLET |mml| (LASSOC |op| |modemapList|)) - (SPADLET |mml| (CAR |mml|)) - (PROG (G167477) - (SPADLET G167477 NIL) - (RETURN - (DO ((G167484 |mml| (CDR G167484)) (|x| NIL)) - ((OR (ATOM G167484) - (PROGN (SETQ |x| (CAR G167484)) NIL) - (PROGN - (PROGN - (SPADLET |dc| (CAAR |x|)) - (SPADLET |sig| (CDAR |x|)) - |x|) - NIL)) - (NREVERSE0 G167477)) - (SEQ (EXIT (COND - ((AND (COND - ((NUMBERP |nargs|) - (BOOT-EQUAL |nargs| - (|#| (CDR |sig|)))) - ('T 'T)) - (SPADLET |cfn| - (|abbreviate| - (SPADLET |domName| - (|getDomainFromMm| |x|)))) - (OR |$getUnexposedOperations| - (|isExposedConstructor| - |domName|))) - (SETQ G167477 (CONS |x| G167477)))))))))) - ('T NIL)))))) - -;mkAlistOfExplicitCategoryOps target == -; if target is ['add,a,:l] then -; target:=a -; target is ['Join,:l] => -; "UNION"/[mkAlistOfExplicitCategoryOps cat for cat in l] -; target is ['CATEGORY,.,:l] => -; l:= flattenSignatureList ['PROGN,:l] -; u:= -; [[atomizeOp op,:sig] for x in l | x is ['SIGNATURE,op,sig,:.]] -; where -; atomizeOp op == -; atom op => op -; op is [a] => a -; keyedSystemError("S2GE0016", -; ['"mkAlistOfExplicitCategoryOps",'"bad signature"]) -; opList:= REMDUP ASSOCLEFT u -; [[x,:fn(x,u)] for x in opList] where -; fn(op,u) == -; u is [[a,:b],:c] => (a=op => [b,:fn(op,c)]; fn(op,c)) -; isCategoryForm(target,$e) => nil -; keyedSystemError("S2GE0016", -; ['"mkAlistOfExplicitCategoryOps",'"bad signature"]) - -(DEFUN |mkAlistOfExplicitCategoryOps,atomizeOp| (|op|) - (PROG (|a|) - (RETURN - (SEQ (IF (ATOM |op|) (EXIT |op|)) - (IF (AND (PAIRP |op|) (EQ (QCDR |op|) NIL) - (PROGN (SPADLET |a| (QCAR |op|)) 'T)) - (EXIT |a|)) - (EXIT (|keyedSystemError| 'S2GE0016 - (CONS "mkAlistOfExplicitCategoryOps" - (CONS "bad signature" NIL)))))))) - -(DEFUN |mkAlistOfExplicitCategoryOps,fn| (|op| |u|) - (PROG (|ISTMP#1| |a| |b| |c|) - (RETURN - (SEQ (IF (AND (PAIRP |u|) - (PROGN - (SPADLET |ISTMP#1| (QCAR |u|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |b| (QCDR |ISTMP#1|)) - 'T))) - (PROGN (SPADLET |c| (QCDR |u|)) 'T)) - (EXIT (SEQ (IF (BOOT-EQUAL |a| |op|) - (EXIT (CONS |b| - (|mkAlistOfExplicitCategoryOps,fn| - |op| |c|)))) - (EXIT (|mkAlistOfExplicitCategoryOps,fn| |op| - |c|))))))))) - -(DEFUN |mkAlistOfExplicitCategoryOps| (|target|) - (PROG (|a| |l| |ISTMP#1| |op| |ISTMP#2| |sig| |u| |opList|) - (DECLARE (SPECIAL |$e|)) - (RETURN - (SEQ (PROGN - (COND - ((AND (PAIRP |target|) (EQ (QCAR |target|) '|add|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |target|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |l| (QCDR |ISTMP#1|)) - 'T)))) - (SPADLET |target| |a|))) - (COND - ((AND (PAIRP |target|) (EQ (QCAR |target|) '|Join|) - (PROGN (SPADLET |l| (QCDR |target|)) 'T)) - (PROG (G167561) - (SPADLET G167561 NIL) - (RETURN - (DO ((G167566 |l| (CDR G167566)) (|cat| NIL)) - ((OR (ATOM G167566) - (PROGN (SETQ |cat| (CAR G167566)) NIL)) - G167561) - (SEQ (EXIT (SETQ G167561 - (|union| G167561 - (|mkAlistOfExplicitCategoryOps| - |cat|))))))))) - ((AND (PAIRP |target|) (EQ (QCAR |target|) 'CATEGORY) - (PROGN - (SPADLET |ISTMP#1| (QCDR |target|)) - (AND (PAIRP |ISTMP#1|) - (PROGN (SPADLET |l| (QCDR |ISTMP#1|)) 'T)))) - (SPADLET |l| - (|flattenSignatureList| (CONS 'PROGN |l|))) - (SPADLET |u| - (PROG (G167577) - (SPADLET G167577 NIL) - (RETURN - (DO ((G167583 |l| (CDR G167583)) - (|x| NIL)) - ((OR (ATOM G167583) - (PROGN - (SETQ |x| (CAR G167583)) - NIL)) - (NREVERSE0 G167577)) - (SEQ (EXIT - (COND - ((AND (PAIRP |x|) - (EQ (QCAR |x|) 'SIGNATURE) - (PROGN - (SPADLET |ISTMP#1| - (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |op| - (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |sig| - (QCAR |ISTMP#2|)) - 'T)))))) - (SETQ G167577 - (CONS - (CONS - (|mkAlistOfExplicitCategoryOps,atomizeOp| - |op|) - |sig|) - G167577)))))))))) - (SPADLET |opList| (REMDUP (ASSOCLEFT |u|))) - (PROG (G167593) - (SPADLET G167593 NIL) - (RETURN - (DO ((G167598 |opList| (CDR G167598)) - (|x| NIL)) - ((OR (ATOM G167598) - (PROGN (SETQ |x| (CAR G167598)) NIL)) - (NREVERSE0 G167593)) - (SEQ (EXIT (SETQ G167593 - (CONS - (CONS |x| - (|mkAlistOfExplicitCategoryOps,fn| - |x| |u|)) - G167593)))))))) - ((|isCategoryForm| |target| |$e|) NIL) - ('T - (|keyedSystemError| 'S2GE0016 - (CONS "mkAlistOfExplicitCategoryOps" - (CONS "bad signature" NIL)))))))))) - -;flattenSignatureList(x) == -; atom x => nil -; x is ['SIGNATURE,:.] => [x] -; x is ['IF,cond,b1,b2] => -; append(flattenSignatureList b1, flattenSignatureList b2) -; x is ['PROGN,:l] => -; ll:= [] -; for x in l repeat -; x is ['SIGNATURE,:.] => ll:=cons(x,ll) -; ll:= append(flattenSignatureList x,ll) -; ll -; nil - -(DEFUN |flattenSignatureList| (|x|) - (PROG (|ISTMP#1| |cond| |ISTMP#2| |b1| |ISTMP#3| |b2| |l| |ll|) - (RETURN - (SEQ (COND - ((ATOM |x|) NIL) - ((AND (PAIRP |x|) (EQ (QCAR |x|) 'SIGNATURE)) - (CONS |x| NIL)) - ((AND (PAIRP |x|) (EQ (QCAR |x|) 'IF) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |cond| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |b1| (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN - (SPADLET |b2| (QCAR |ISTMP#3|)) - 'T)))))))) - (APPEND (|flattenSignatureList| |b1|) - (|flattenSignatureList| |b2|))) - ((AND (PAIRP |x|) (EQ (QCAR |x|) 'PROGN) - (PROGN (SPADLET |l| (QCDR |x|)) 'T)) - (SPADLET |ll| NIL) - (DO ((G167664 |l| (CDR G167664)) (|x| NIL)) - ((OR (ATOM G167664) - (PROGN (SETQ |x| (CAR G167664)) NIL)) - NIL) - (SEQ (EXIT (COND - ((AND (PAIRP |x|) - (EQ (QCAR |x|) 'SIGNATURE)) - (SPADLET |ll| (CONS |x| |ll|))) - ('T - (SPADLET |ll| - (APPEND - (|flattenSignatureList| |x|) - |ll|))))))) - |ll|) - ('T NIL)))))) - -;mkDatabasePred [a,t] == -; isCategoryForm(t,$e) => ['ofCategory,a,t] -; ['ofType,a,t] - -(DEFUN |mkDatabasePred| (G167684) - (PROG (|a| |t|) - (DECLARE (SPECIAL |$e|)) - (RETURN - (PROGN - (SPADLET |a| (CAR G167684)) - (SPADLET |t| (CADR G167684)) - (COND - ((|isCategoryForm| |t| |$e|) - (CONS '|ofCategory| (CONS |a| (CONS |t| NIL)))) - ('T (CONS '|ofType| (CONS |a| (CONS |t| NIL))))))))) - -;formal2Pattern x == -; SUBLIS(pairList($FormalMapVariableList,rest $PatternVariableList),x) - -(DEFUN |formal2Pattern| (|x|) - (DECLARE (SPECIAL |$PatternVariableList|)) - (SUBLIS (|pairList| |$FormalMapVariableList| - (CDR |$PatternVariableList|)) - |x|)) +;(DEFUN |getInCoreModemaps| (|modemapList| |op| |nargs|) +; (PROG (|mml| |dc| |sig| |domName| |cfn|) +; (DECLARE (SPECIAL |$getUnexposedOperations|)) +; (RETURN +; (SEQ (COND +; ((SPADLET |mml| (LASSOC |op| |modemapList|)) +; (SPADLET |mml| (CAR |mml|)) +; (PROG (G167477) +; (SPADLET G167477 NIL) +; (RETURN +; (DO ((G167484 |mml| (CDR G167484)) (|x| NIL)) +; ((OR (ATOM G167484) +; (PROGN (SETQ |x| (CAR G167484)) NIL) +; (PROGN +; (PROGN +; (SPADLET |dc| (CAAR |x|)) +; (SPADLET |sig| (CDAR |x|)) +; |x|) +; NIL)) +; (NREVERSE0 G167477)) +; (SEQ (EXIT (COND +; ((AND (COND +; ((NUMBERP |nargs|) +; (BOOT-EQUAL |nargs| +; (|#| (CDR |sig|)))) +; ('T 'T)) +; (SPADLET |cfn| +; (|abbreviate| +; (SPADLET |domName| +; (|getDomainFromMm| |x|)))) +; (OR |$getUnexposedOperations| +; (|isExposedConstructor| +; |domName|))) +; (SETQ G167477 (CONS |x| G167477)))))))))) +; ('T NIL)))))) ;updateDatabase(fname,cname,systemdir?) == ; -- for now in NRUNTIME do database update only if forced