From d450acd65d494740aaf8447a53ed6681731ba973 Mon Sep 17 00:00:00 2001 From: Tim Daly Date: Sat, 11 Jul 2015 17:58:39 -0400 Subject: [PATCH] books/bookvol5 merge functions used from i-coerce Goal: Literate Axiom Every function in src/input/i-coerce.lisp that was referenced in bookvol5 was moved and rewritten from i-coerce to bookvol5. --- books/bookvol5.pamphlet | 1865 +++++++++++++++++++++- changelog | 3 + patch | 7 +- src/axiom-website/patches.html | 2 + src/interp/i-coerce.lisp.pamphlet | 3163 +------------------------------------ 5 files changed, 1855 insertions(+), 3185 deletions(-) diff --git a/books/bookvol5.pamphlet b/books/bookvol5.pamphlet index 9cf41d4..7aa2868 100644 --- a/books/bookvol5.pamphlet +++ b/books/bookvol5.pamphlet @@ -26368,7 +26368,6 @@ The result is a substitution list or 'failed. \end{chunk} \defun{defaultTargetFE}{defaultTargetFE} -\calls{defaultTargetFE}{typeIsASmallInteger} \calls{defaultTargetFE}{isEqualOrSubDomain} \calls{defaultTargetFE}{ifcar} \calls{defaultTargetFE}{defaultTargetFE} @@ -26388,7 +26387,7 @@ The result is a substitution list or 'failed. (consp (qcdr a)) (eq (qcddr a) nil)) (equal a |$RationalNumber|) (member (qcar a) (list (qcar |$Symbol|) '|RationalRadicals| '|Pi|)) - (|typeIsASmallInteger| a) + (equal a |$SingleInteger|) (|isEqualOrSubDomain| a |$Integer|) (equal a '(|AlgebraicNumber|))) (if (ifcar options) @@ -26431,6 +26430,1767 @@ The result is a substitution list or 'failed. \end{chunk} +\chapter{Coercions} + +\begin{verbatim} + main algorithms for canCoerceFrom and coerceInteractive + +coerceInteractive and canCoerceFrom are the two coercion functions +for $InteractiveMode. They translate RN, RF and RR to QF I, QF P +and RE RN, respectively, and call coerceInt or canCoerce, which +both work in the same way (e.g. coercion from t1 to t2): +1. they try to coerce t1 to t2 directly (tower coercion), and, if + this fails, to coerce t1 to the last argument of t2 and embed + this last argument into t2. These embedding functions are now only + defined in the algebra code. (RSS 2-27-87) +2. the tower coercion looks whether there is any applicable local + coercion, which means, one defined in boot or in algebra code. + If there is an applicable function from a constructor, which is + inside the type tower of t1, to the top level constructor of t2, + then this constructor is bubbled up inside t1. This means, + special coercion functions (defined in boot) are called, which + commute two constructors in a tower. Then the local coercion is + called on these constructors, which both are on top level now. +example: +let t1 = A B C D E (short for (A (B (C (D (E))))), where A ... E are + type constructors), and t2 = F D G H I J +there is no coercion from t1 to t2 directly, so we try to coerce + t1 to s1 = D G H I J, the last argument of t2 +we create the type s2 = A D B C E and call a local coercion A2A + from t1 to s2, which, by recursively calling coerce, bubbles up + the constructor D +then we call a commute coerce from s2 to s3 = D A B C E and a local + coerce D2D from s3 to s1 +finally we embed s1 into t2, which completes the coercion t1 to t2 +the result of canCoerceFrom is TRUE or NIL +the result of coerceInteractive is a object or NIL (=failed) +all boot coercion functions have the following result: +1. if u=$fromCoerceable$, then TRUE or NIL +2. if the coercion succeeds, the coerced value (this may be NIL) +3. if the coercion fails, they throw to a catch point in + coerceByFunction + +\end{verbatim} + +\defun{coerceInteractive}{coerceInteractive} +\calls{coerceInteractive}{objMode} +\calls{coerceInteractive}{objVal} +\calls{coerceInteractive}{clearDependentMaps} +\calls{coerceInteractive}{throwKeyedMsg} +\calls{coerceInteractive}{startTimingProcess} +\calls{coerceInteractive}{mkObj} +\calls{coerceInteractive}{mkObjWrap} +\calls{coerceInteractive}{coerceInt0} +\calls{coerceInteractive}{stopTimingProcess} +\usesdollar{coerceInteractive}{insideCoerceInteractive} +\usesdollar{coerceInteractive}{OutputForm} +\usesdollar{coerceInteractive}{mapName} +\usesdollar{coerceInteractive}{compilingMap} +\usesdollar{coerceInteractive}{NoValueMode} +\usesdollar{coerceInteractive}{EmptyMode} +\begin{chunk}{defun coerceInteractive} +(defun |coerceInteractive| (triple t2) + (let (|$insideCoerceInteractive| t1 val expr2 result) + (declare (special |$insideCoerceInteractive| |$OutputForm| + |$mapName| |$compilingMap| |$NoValueMode| |$EmptyMode|)) + (setq t1 (|objMode| triple)) + (setq val (|objVal| triple)) + (cond + ((or (null t2) (equal t2 |$EmptyMode|)) nil) + ((equal t2 t1) triple) + ((equal t2 '|$NoValueMode|) (mkObj val t2)) + (t + (when (eq (car t2) '|SubDomain|) (setq t2 (second t2))) + (cond + ((|member| t1 + '((|Category|) (|Mode|) (|Domain|) (|SubDomain| (|Domain|)))) + (when (equal t2 |$OutputForm|) (mkObj val t2))) + ((equal t1 '|$NoValueMode|) + (when |$compilingMap| (|clearDependentMaps| |$mapName| nil)) + (|throwKeyedMsg| + (format nil + "You are trying to use something (probably a loop) in a ~ + situation where a value is expected. In particular, you ~ + are trying to convert this to the type %1p . The following ~ + information may help: possible function name: %2p") + (list t2 |$mapName|))) + (t + (setq |$insideCoerceInteractive| t) + (setq expr2 (equal t2 |$OutputForm|)) + (cond + (expr2 (|startTimingProcess| '|print|)) + (t (|startTimingProcess| '|coercion|))) + (setq result + (cond + ((and expr2 (equal t1 val)) (mkObj val |$OutputForm|)) + ((and expr2 (eq (car t1) '|Variable|)) + (mkObjWrap (second t1) |$OutputForm|)) + (t (|coerceInt0| triple t2)))) + (cond + (expr2 (|stopTimingProcess| '|print|)) + (t (|stopTimingProcess| '|coercion|))) + result)))))) + +\end{chunk} + +\defun{coerceInt}{coerceInt} +\calls{coerceInt}{coerceInt1} +\calls{coerceInt}{objMode} +\calls{coerceInt}{getMinimalVarMode} +\calls{coerceInt}{unwrap} +\calls{coerceInt}{objVal} +\calls{coerceInt}{coerceInt} +\begin{chunk}{defun coerceInt} +(defun |coerceInt| (triple t2) + (let (val newMode newVal) + (if (setq val (|coerceInt1| triple t2)) + val + (when (eq (car (|objMode| triple)) '|Variable|) + (setq newMode (|getMinimalVarMode| (|unwrap| (|objVal| triple)) nil)) + (setq newVal (|coerceInt| triple newMode)) + (|coerceInt| newVal t2))))) + +\end{chunk} + +\defun{coerceInt0}{coerceInt0} +\calls{coerceInt0}{objVal} +\calls{coerceInt0}{objMode} +\calls{coerceInt0}{conCoerceFrom} +\calls{coerceInt0}{isWrapped} +\calls{coerceInt0}{intCodeGenCOERCE} +\calls{coerceInt0}{unwrap} +\calls{coerceInt0}{coerceInt0} +\calls{coerceInt0}{mkObj} +\calls{coerceInt0}{coerceInt} +\calls{coerceInt0}{objSetMode} +\usesdollar{coerceInt0}{OutputForm} +\usesdollar{coerceInt0}{Any} +\usesdollar{coerceInt0}{genValue} +This is the top level interactive coercion, which transfers all RN, RF and RR +into equivalent types +\begin{chunk}{defun coerceInt0} +(defun |coerceInt0| (triple t2) + (prog (val t1 s1 s2 let1 t1p valp ans x) + (declare (special |$OutputForm| |$Any| |$genValue|)) + (return + (progn + (setq val (|objVal| triple)) + (setq t1 (|objMode| triple)) + (cond + ((eq val '|$fromCoerceable$|) (|canCoerceFrom| t1 t2)) + ((equal t1 t2) triple) + (t + (cond + ((equal t2 |$OutputForm|) (setq s1 t1) (setq s2 t2)) + (t + (setq s1 t1) + (setq s2 t2) + (when (equal s1 s2) (return (mkObj val t2))))) + (cond + ; handle case where we must generate code + ((and (null (|isWrapped| val)) + (or + (null (eq (car t1) '|FunctionCalled|)) + (null |$genValue|))) + (|intCodeGenCOERCE| triple t2)) + ((and (equal t1 |$Any|) + (nequal t2 |$OutputForm|) + (progn + (setq let1 (|unwrap| val)) + (setq t1p (car let1)) + (setq valp (cdr let1)) + let1) + (setq ans (|coerceInt0| (mkObjWrap valp t1p) t2))) + ans) + (t + (unless (eq s1 t1) (setq triple (mkObj val s1))) + (when (setq x (|coerceInt| triple s2)) + (cond + ((eq s2 t2) x) + (t + (|objSetMode| x t2) + x))))))))))) + +\end{chunk} + +\defun{coerceInt1}{coerceInt1} +This is general interactive coercion. The result is a new triple +with type m2 or NIL (= failed). +\calls{coerceInt1}{NRTcompileEvalForm} +\calls{coerceInt1}{absolutelyCanCoerceByCheating} +\calls{coerceInt1}{asTupleAsList} +\calls{coerceInt1}{bottomUp} +\calls{coerceInt1}{coerceByFunction} +\calls{coerceInt1}{coerceInt1} +\calls{coerceInt1}{coerceInt2Union} +\calls{coerceInt1}{coerceIntAlgebraicConstant} +\calls{coerceInt1}{coerceIntFromUnion} +\calls{coerceInt1}{coerceIntTower} +\calls{coerceInt1}{coerceIntX} +\calls{coerceInt1}{coerceInt} +\calls{coerceInt1}{coerceRetract} +\calls{coerceInt1}{coerceSubDomain} +\calls{coerceInt1}{compareTypeLists} +\calls{coerceInt1}{deconstructT} +\calls{coerceInt1}{evalDomain} +\calls{coerceInt1}{getFunctionFromDomain} +\calls{coerceInt1}{getValue} +\calls{coerceInt1}{isEqualOrSubDomain} +\calls{coerceInt1}{isSubDomain} +\calls{coerceInt1}{mkAtreeNode} +\calls{coerceInt1}{mkAtree} +\calls{coerceInt1}{mkObjWrap} +\calls{coerceInt1}{mkObj} +\calls{coerceInt1}{nequal} +\calls{coerceInt1}{nreverse0} +\calls{coerceInt1}{objMode} +\calls{coerceInt1}{objVal} +\calls{coerceInt1}{selectLocalMms} +\calls{coerceInt1}{selectMms1} +\calls{coerceInt1}{transferPropsToNode} +\calls{coerceInt1}{unwrap} +\catches{coerceInt1}{coerceOrCroaker} +\usesdollar{coerceInt1}{useCoerceOrCroak} +\usesdollar{coerceInt1}{Integer} +\usesdollar{coerceInt1}{QuotientField} +\usesdollar{coerceInt1}{e} +\usesdollar{coerceInt1}{genValue} +\usesdollar{coerceInt1}{Symbol} +\usesdollar{coerceInt1}{AnonymousFunction} +\usesdollar{coerceInt1}{OutputForm} +\usesdollar{coerceInt1}{String} +\usesdollar{coerceInt1}{Any} +\usesdollar{coerceInt1}{Void} +\usesdollar{coerceInt1}{NonNegativeInteger} +\usesdollar{coerceInt1}{PositiveInteger} +\usesdollar{coerceInt1}{EmptyMode} +\usesdollar{coerceInt1}{SingleInteger} +\begin{chunk}{defun coerceInt1} +(defun |coerceInt1| (triple t2) + (prog (|$useCoerceOrCroak| t1 sintp t1p valp s body vars tree val symNode + mms ml oldName intName t3 triplep let1 arg tt ans) + (declare (special |$useCoerceOrCroak| |$Integer| |$QuotientField| + |$e| |$genValue| |$Symbol| |$AnonymousFunction| + |$OutputForm| |$String| |$Any| |$Void| |$SingleInteger| + |$NonNegativeInteger| |$PositiveInteger| |$EmptyMode|)) + (return + (seq + (progn + (setq |$useCoerceOrCroak| t) + (cond + ((equal t2 |$EmptyMode|) nil) + (t + (setq t1 (|objMode| triple)) + (cond + ((equal t1 t2) triple) + (t + (setq val (|objVal| triple)) + (cond + ((|absolutelyCanCoerceByCheating| t1 t2) (mkObj val t2)) + ((|isSubDomain| t2 t1) (|coerceSubDomain| val t1 t2)) + (t + (cond + ((equal t1 |$SingleInteger|) + (cond + ((or (equal t2 |$Integer|) (equal t2 |$SingleInteger|)) + (return (mkObj val t2))) + (t + (setq sintp (typep val 'fixnum)) + (cond + ((and sintp (equal t2 |$PositiveInteger|) (> val 0)) + (return (mkObj val t2))) + ((and sintp (equal t2 |$NonNegativeInteger|) (>= val 0)) + (return (mkObj val t2)))))))) + (cond + ((and (equal t2 |$SingleInteger|) + (|isEqualOrSubDomain| t1 |$Integer|) + (integerp val)) + (cond + ((typep val 'fixnum) (mkObj val t2)) + (t nil))) + ((equal t2 |$Void|) (mkObj (|voidValue|) |$Void|)) + ((equal t2 |$Any|) (mkObjWrap (cons t1 (|unwrap| val)) '(|Any|))) + ((and (equal t1 |$Any|) + (nequal t2 |$OutputForm|) + (progn + (setq let1 (|unwrap| val)) + (setq t1p (car let1)) + (setq valp (cdr let1)) + let1) + (setq ans (|coerceInt| (mkObjWrap valp t1p) t2))) + ans) + ; tagged union selectors + ((or (and (eq (car t1) '|Variable|) (equal (cadr t1) t2)) + (and (eq (car t2) '|Variable|) (equal (cadr t2) t1))) + (mkObj val t2)) + ((stringp t2) + (cond + ((and (eq (first t1) '|Variable|) + (equal t2 (pname (second t1)))) + (mkObjWrap t2 t2)) + (t + (setq valp (|unwrap| val)) + (when (and (equal t2 valp) + (or (equal valp t1) (equal t1 |$String|))) + (mkObj val t2))))) + ((eq (first t1) '|Tuple|) + (|coerceInt1| + (mkObjWrap + (|asTupleAsList| (|unwrap| val)) + (list '|List| (setq s (second t1)))) + t2)) + ((and (consp t1) (eq (qcar t1) '|Union|)) + (|coerceIntFromUnion| triple t2)) + ((and (consp t2) (eq (qcar t2) '|Union|)) + (|coerceInt2Union| triple t2)) + ((and (stringp t1) (equal t2 |$String|)) + (mkObj val |$String|)) + ((and (stringp t1) (eq (car t2) '|Variable|)) + (when (equal t1 (pname (second t2))) (mkObjWrap (second t2) t2))) + ((and (stringp t1) (equal t1 (|unwrap| val))) + (when (equal t2 |$OutputForm|) (mkObj t1 |$OutputForm|))) + ((atom t1) nil) + (t + (cond + ((and (equal t1 |$AnonymousFunction|) + (eq (car t2) '|Mapping|)) + (setq |$useCoerceOrCroak| nil) + (setq let1 (|unwrap| val)) + (setq vars (cadr let1)) + (setq body (cddr let1)) + (setq vars + (cond + ((atom vars) (cons vars nil)) + ((and (consp vars) (eq (qcar vars) '|Tuple|)) (cdr vars)) + (t vars))) + (cond + ((nequal (|#| (cddr t2)) (|#| vars)) '|continue|) + (t + (setq tree + (|mkAtree| + (cons 'adef + (cons vars + (cons (cons (cadr t2) (cddr t2)) + (cons (loop for x in (cdr t2) collect nil) + body)))))) + (cond + ((eq + (catch '|coerceOrCroaker| (|bottomUp| tree)) '|croaked|) + nil) + (t (return (|getValue| tree)))))))) + (cond + ((and (equal t1 |$Symbol|) (eq (car t2) '|Mapping|)) + (cond + ((null (setq mms + (|selectMms1| (|unwrap| val) nil + (cddr t2) (cddr t2) (cadr t2)))) + nil) + (t + (cond + ((nequal (cadaar mms) (cadr t2)) nil) + (|$genValue| + (mkObjWrap + (|getFunctionFromDomain| + (|unwrap| val) (caaar mms) (cddaar mms)) t2)) + (t + (mkObj + (|NRTcompileEvalForm| + (|unwrap| val) (cdaar mms) (|evalDomain| (caaar mms))) + t2)))))) + ((and (eq (car t1) '|Variable|) (eq (car t2) '|Mapping|)) + (setq mms + (|selectMms1| (cadr t1) (cadr t2) (cddr t2) (cddr t2) nil)) + (cond + ((and (null mms) + (null + (setq mms + (|selectMms1| (cadr t1) (cadr t2) + (cddr t2) (cddr t2) t)))) + nil) + (t + (cond + ((nequal (cadaar mms) (cadr t2)) nil) + ((eq (caaaar mms) '|_FreeFunction_|) + (mkObj (cdaaar mms) t2)) + (|$genValue| + (mkObjWrap + (|getFunctionFromDomain| (cadr t1) (caaar mms) + (cddaar mms)) t2)) + (t + (mkObj + (|NRTcompileEvalForm| (cadr t1) (cdr (caar mms)) + (|evalDomain| (caaar mms))) + t2)))))) + ((and (eq (car t1) '|FunctionCalled|) (eq (qcar t2) '|Mapping|)) + (setq symNode (|mkAtreeNode| (cadr t1))) + (|transferPropsToNode| (cadr t1) symNode) + (cond + ((null + (setq mms + (|selectLocalMms| symNode (cadr t1) (cddr t2) (cadr t2)))) + nil) + (t + (cond + ((nequal (cadaar mms) (cadr t2)) nil) + (t + (setq ml (cons (cadr t2) (cddr t2))) + (setq intName + (when + (some #'(lambda (mm) + (setq oldName (second mm)) + (|compareTypeLists| (cdar mm) ml)) mms) + (list oldName))) + (cond + ((null intName) nil) + (t (mkObjWrap intName t2)))))))) + ((eq (car t1) '|FunctionCalled|) + (setq t3 (|get| (second t1) '|mode| |$e|)) + (when (and (eq (car t3) '|Mapping|) + (setq triplep (|coerceInt| triple t3))) + (|coerceInt| triplep t2))) + ((and (eq (car t1) '|Variable|) + (consp t2) + (or (|isEqualOrSubDomain| t2 |$Integer|) + (equal t2 (list |$QuotientField| |$Integer|)) + (member (car t2) + '(|RationalNumber| |BigFloat| + |NewFloat| |Float| |DoubleFloat|)))) + nil) + (t + (setq ans + (or + (|coerceRetract| triple t2) + (|coerceIntTower| triple t2) + (progn + (setq arg (cdr (|deconstructT| t2))) + (and arg + (progn + (setq tt (|coerceInt| triple (|last| arg))) + (and tt (|coerceByFunction| tt t2))))))) + (or ans + (and (|isSubDomain| t1 |$Integer|) + (|coerceInt| (mkObj val |$Integer|) t2)) + (|coerceIntAlgebraicConstant| triple t2) + (|coerceIntX| val t1 t2))))))))))))))))) + +\end{chunk} + +\defun{coerceByFunction}{coerceByFunction} +\begin{chunk}{defun coerceByFunction} +(defun |coerceByFunction| (t$ m2) + (let ($ m1 ud x tmp1 a tmp2 b funName mm dc tar args slot dcVector fun fn + d val env code m1p m2p) + (declare (special $ |$coerceFailure| |$Boolean|)) + (setq x (|objVal| T$)) + (cond + ((eq x '|$fromCoerceable$|) nil) + ((eq (car m2) '|Union|) nil) + (t + (setq m1 (|objMode| t$)) + (cond + ((and (consp m2) (eq (qcar m2) '|Boolean|) + (consp m1) (eq (qcar m1) '|Equation|) + (PROGN + (setq tmp1 (cdr m1)) + (and (consp tmp1) (eq (cdr tmp1) nil) + (progn (setq ud (car tmp1)) t)))) + (setq dcVector (|evalDomain| ud)) + (setq fun + (cond + ((|isWrapped| x) + (|NRTcompiledLookup| '= (list |$Boolean| '$ '$) dcVector)) + (t + (|NRTcompileEvalForm| '= (list |$Boolean| '$ '$) dcVector)))) + (setq fn (car fun)) + (setq d (cdr fun)) + (cond + ((|isWrapped| x) + (setq x (|unwrap| x)) + (mkObjWrap (spadcall (car x) (cdr x) fun) m2)) + ((null (and (consp x) (eq (car x) 'spadcall) + (progn + (setq tmp1 (cdr x)) + (and (consp tmp1) + (progn + (setq a (car tmp1)) + (setq tmp2 (cdr tmp1)) + (and (consp tmp2) + (progn + (setq b (car tmp2)) t))))))) + (|keyedSystemError| "Generated code is incorrect for equation" nil)) + (t + (setq code (list 'spadcall a b fun)) + (mkObj code |$Boolean|)))) + (t + (cond + ((null + (setq mm (|coerceConvertMmSelection| (setq funName '|coerce|) m1 m2))) + (setq mm + (|coerceConvertMmSelection| (setq funName '|convert|) m1 m2)))) + (when mm + (setq dc (caar mm)) + (setq tar (cadar mm)) + (setq args (cddar mm)) + (setq slot (cadr mm)) + (setq dcVector (|evalDomain| dc)) + (setq fun + (cond + ((|isWrapped| x) (|NRTcompiledLookup| funName slot dcVector)) + (t (|NRTcompileEvalForm| funName slot dcVector)))) + (setq fn (car fun)) + (setq d (cdr fun)) + (cond + ((equal fn #'|Undef|) nil) + ((|isWrapped| x) + (setq $ dcVector) + (setq val (catch '|coerceFailure| (spadcall (|unwrap| x) fun))) + (cond + ((equal val |$coerceFailure|) nil) + (t (mkObjWrap val m2)))) + (t + (setq env fun) + (setq code (list '|failCheck| (list 'spadcall x env))) + (mkObj code m2)))))))))) + +\end{chunk} + +\defun{coerceIntTower}{coerceIntTower} +This tries to find a coercion from top level t2 to somewhere inside t1 +It builds a new argument type, for which coercion is called recursively +\calls{coerceIntTower}{coerceIntPermute} +\calls{coerceIntTower}{coerceIntSpecial} +\calls{coerceIntTower}{last} +\calls{coerceIntTower}{coerceIntTest} +\calls{coerceIntTower}{constructT} +\calls{coerceIntTower}{replaceLast} +\calls{coerceIntTower}{deconstructT} +\calls{coerceIntTower}{bubbleConstructor} +\calls{coerceIntTower}{isValidType} +\calls{coerceIntTower}{coerceIntCommute} +\calls{coerceIntTower}{coerceIntByMap} +\calls{coerceIntTower}{coerceIntTableOrFunction} +\begin{chunk}{defun coerceIntTower} +(defun |coerceIntTower| (triple t2) + (let (t1 c1 arg1 tt c arg tl let1 c2 arg2 s x) + (cond + ((setq x (|coerceIntByMap| triple t2)) x) + ((setq x (|coerceIntCommute| triple t2)) x) + ((setq x (|coerceIntPermute| triple t2)) x) + ((setq x (|coerceIntSpecial| triple t2)) x) + ((setq x (|coerceIntTableOrFunction| triple t2)) x) + (t + (setq t1 (|objMode| triple)) + (setq let1 (|deconstructT| t1)) + (setq c1 (car let1)) + (setq arg1 (cdr let1)) + (and arg1 + (progn + (setq tl nil) + (setq arg arg1) + (loop until (or x (not arg)) do + (setq tt (|last| arg)) + (setq let1 (|deconstructT| tt)) + (setq c (car let1)) + (setq arg (cdr let1)) + (setq tl (cons c (cons arg tl))) + (cond + ((setq x (and arg (|coerceIntTest| tt t2))) + (cond + ((cddr tl) + (setq s + (|constructT| c1 + (|replaceLast| arg1 (|bubbleConstructor| tl)))) + (cond + ((null (|isValidType| s)) (setq x nil)) + ((setq x (or (|coerceIntByMap| triple s) + (|coerceIntTableOrFunction| triple s))) + (setq let1 (|deconstructT| (|last| s))) + (setq c2 (car let1)) + (setq arg2 (cdr let1)) + (setq s (|bubbleConstructor| (list c2 arg2 c1 arg1))) + (cond + ((null (|isValidType| s)) (setq x nil)) + ((setq x (|coerceIntCommute| x s)) + (setq x (or (|coerceIntByMap| x t2) + (|coerceIntTableOrFunction| x t2)))))))) + (t + (setq s (|bubbleConstructor| (list c arg c1 arg1))) + (cond + ((null (|isValidType| s)) (setq x nil)) + ((setq x (|coerceIntCommute| triple s)) + (setq x (or (|coerceIntByMap| x t2) + (|coerceIntTableOrFunction| x t2)))))))))) + x)))))) + +\end{chunk} + +\defun{coerceIntTest}{coerceIntTest} +This looks whether there exists a table entry or a coercion function. +Thus the type can be bubbled before coerceIntTableOrFunction is called. +\calls{coerceIntTest}{coerceConvertMmSelection} +\calls{coerceIntTest}{assq} +\usesdollar{coerceIntTest}{CoerceTable} +\usesdollar{coerceIntTest}{useConvertForCoercions} +\begin{chunk}{defun coerceIntTest} +(defun |coerceIntTest| (t1 t2) + (let (p b) + (declare (special |$useConvertForCoercions| |$CoerceTable|)) + (or (equal t1 t2) + (setq b + (and (setq p (assq (car t1) |$CoerceTable|)) + (assq (car t2) (cdr p)))) + (or b + (|coerceConvertMmSelection| '|coerce| t1 t2) + (and |$useConvertForCoercions| + (|coerceConvertMmSelection| '|convert| t1 t2)))))) + +\end{chunk} + +\defun{coerceConvertMmSelection}{coerceConvertMmSelection} +This calls selectMms with \verb|$Coerce=NIL| and tests for required +target type. funName is either 'coerce or 'convert. +\begin{verbatim} + mmS := [[sig,[targ,arg],:pred] for x in l | x is [sig,[.,arg],:pred] and + hasCorrectTarget(m2,sig) and sig is [dc,targ,oarg] and oarg = m1] +\end{verbatim} +\calls{coerceConvertMmSelection}{coerceConvertMmSelection;AL} +\calls{coerceConvertMmSelection}{selectMms1} +\usesdollar{coerceConvertMmSelection}{reportBottomUpFlag} +\usesdollar{coerceConvertMmSelection}{declaredMode} +\begin{chunk}{defun coerceConvertMmSelection} +(defun |coerceConvertMmSelection| (&rest g1) + (labels ( + (checktargets (funName m1 m2) + (let (|$declaredMode| |$reportBottomUpFlag|) + (declare (special |$declaredMode| |$reportBottomUpFlag|)) + (setq |$declaredMode| nil) + (setq |$reportBottomUpFlag| nil) + (car + (loop for x in (|selectMms1| funName m2 (list m1) (list m1) nil) + collect + (when (and (|hasCorrectTarget| m2 (car x)) (equal (caddar x) m1)) + (cons (car x) (cons (cons (cadar x) (list (cadadr x))) (cddr x))))))))) + (let (g3) + (if (setq g3 (hget |coerceConvertMmSelection;AL| g1)) + (|CDRwithIncrement| g3) + (cdr (hput |coerceConvertMmSelection;AL| g1 + (cons 1 (apply #'checktargets g1)))))))) + +\end{chunk} + +\defun{hasCorrectTarget}{hasCorrectTarget} +This tests whether the target of signature sig is either m or a union +containing m. It also discards TEQ as it is not meant to be used at top-level +\begin{chunk}{defun hasCorrectTarget 0} +(defun |hasCorrectTarget| (m sig) + (let (tar) + (setq tar (second sig)) + (cond + ((eq (caar sig) '|TypeEquivalence|) nil) + ((equal m tar) t) + ((and (eq (car tar) '|Union|) + (eq (third tar) '|failed|)) + (equal (second tar) m)) + ((and (eq (car tar) '|Union|) + (eq (second tar) '|failed|) + (equal (third tar) m)))))) + +\end{chunk} + +\defun{coerceIntPermute}{coerceIntPermute} +\calls{coerceIntPermute}{member} +\calls{coerceIntPermute}{objMode} +\calls{coerceIntPermute}{computeTTTranspositions} +\calls{coerceIntPermute}{coerceInt} +\begin{chunk}{defun coerceIntPermute} +(defun |coerceIntPermute| (object t2) + (let (t1 towers ok) + (cond + ((|member| t2 '((|Integer|) (|OutputForm|))) nil) + (t + (setq t1 (|objMode| object)) + (setq towers (|computeTTTranspositions| t1 t2)) + ; At this point, CAR towers = t1 and last towers should be similar + ; to t2 in the sense that the components of t1 are in the same order + ; as in t2. If length towers = 2 and t2 = last towers, we quit to + ; avoid an infinte loop. + (cond + ((or (null towers) (null (cdr towers))) nil) + ((and (null (cddr towers)) (equal t2 (cadr towers))) nil) + (t + (setq ok t) + ; do the coercions successively, quitting if any fail + (loop for tt in (cdr towers) while ok do + (unless (setq object (|coerceInt| object tt)) (setq ok nil))) + (when ok object))))))) + +\end{chunk} + +\defun{computeTTTranspositions}{computeTTTranspositions} +\calls{computeTTTranspositions}{decomposeTypeIntoTower} +\calls{computeTTTranspositions}{member} +\calls{computeTTTranspositions}{nequal} +\calls{computeTTTranspositions}{msort} +\calls{computeTTTranspositions}{remdup} +\calls{computeTTTranspositions}{length} +\calls{computeTTTranspositions}{list2vec} +\calls{computeTTTranspositions}{permuteToOrder} +\calls{computeTTTranspositions}{setelt} +\calls{computeTTTranspositions}{vec2list} +\calls{computeTTTranspositions}{reassembleTowerIntoType} +\begin{chunk}{defun computeTTTranspositions} +(defun |computeTTTranspositions| (t1 t2) + (labels ( + (compress (z start len) + (cond + ((>= start len) z) + ((|member| start z) (compress z (1+ start) len)) + (t + (compress + (loop for i in z do collect (if (> start i) i (1- i))) start len))))) + (let (tl1 tl2 p2p n1 p2 perms tower tt towers) + ; decompose t1 into its tower parts + (setq tl1 (|decomposeTypeIntoTower| t1)) + (setq tl2 (|decomposeTypeIntoTower| t2)) + (cond + ; if not at least 2 parts, don't bother working here + ((null (and (cdr tl1) (cdr tl2))) nil) + (t + ; determine the relative order of the parts of t1 in t2 + (setq p2 (nreverse0 (loop for d1 in tl1 collect (position d1 tl2)))) + (cond + ; something not present + ((|member| (- 1) p2) nil) + (t + ; if they are all ascending, this function will do nothing + (setq p2p (msort p2)) + (cond + ((equal p2 p2p) nil) + ; if anything is repeated twice, leave + ((nequal p2p (msort (remdup p2p))) nil) + (t + ; create a list of permutations that transform the tower parts + ; of t1 into the order they are in in t2 + (setq n1 (|#| tl1)) + (setq p2 (list2vec (compress p2 0 (|#| (remdup tl1))))) + ; p2 now has the same position numbers as p1, we need to determine + ; a list of permutations that takes p1 into p2. + (setq perms (|permuteToOrder| p2 (- n1 1) 0)) + (setq towers (list tl1)) + (setq tower (list2vec tl1)) + (loop for perm in perms do + (setq tt (elt tower (car perm))) + (setelt tower (car perm) (elt tower (cdr perm))) + (setelt tower (cdr perm) tt) + (setq towers (cons (vec2list tower) towers))) + (setq towers (nreverse0 + (loop for tower in towers collect (|reassembleTowerIntoType| tower)))) + (unless (equal (car towers) t2) (setq towers (cons t2 towers))) + (nreverse towers)))))))))) + +\end{chunk} + +\defun{permuteToOrder}{permuteToOrder} +\calls{permuteToOrder}{permuteToOrder} +\calls{permuteToOrder}{setelt} +\begin{chunk}{defun permuteToOrder} +(defun |permuteToOrder| (p n start) + (let (r x perms tt stpos) + (setq r (- n start)) + (cond + ((<= r 0) nil) + ((eql r 1) + (cond + ((> (elt p (+ r 1)) (elt p r)) nil) + (t (list (cons r (+ r 1)))))) + ((equal (elt p start) start) (|permuteToOrder| p n (+ start 1))) + (t + (setq stpos nil) + (loop for i from (+ start 1) to n while (not stpos) do + (when (equal (elt p i) start) (setq stpos i))) + (setq perms nil) + (loop while (not (equal stpos start)) do + (setq x (- stpos 1)) + (setq perms (cons (cons x stpos) perms)) + (setq tt (elt p stpos)) + (setelt p stpos (elt p x)) + (setelt p x tt) + (setq stpos x)) + (append (nreverse perms) (|permuteToOrder| p n (+ start 1))))))) + +\end{chunk} + +\defun{decomposeTypeIntoTower}{decomposeTypeIntoTower} +\calls{decomposeTypeIntoTower}{decomposeTypeIntoTower} +\calls{decomposeTypeIntoTower}{deconstructT} +\begin{chunk}{defun decomposeTypeIntoTower} +(defun |decomposeTypeIntoTower| (tt) + (let (rd) + (cond + ((atom tt) (list tt)) + ((null (cdr (|deconstructT| tt))) (list tt)) + (t + (setq rd (reverse tt)) + (cons (reverse (cdr rd)) (|decomposeTypeIntoTower| (car rd))))))) + +\end{chunk} + +\defun{reassembleTowerIntoType}{reassembleTowerIntoType} +\calls{reassembleTowerIntoType}{reassembleTowerIntoType} +\begin{chunk}{defun reassembleTowerIntoType} +(defun |reassembleTowerIntoType| (tower) + (let (let1) + (cond + ((atom tower) tower) + ((null (cdr tower)) (car tower)) + (t + (setq let1 (reverse tower)) + (|reassembleTowerIntoType| + (append (nreverse (cddr let1)) + (list (append (second let1) (list (first let1)))))))))) + +\end{chunk} + +\defun{coerceIntCommute}{coerceIntCommute} +\calls{coerceIntCommute}{objMode} +\calls{coerceIntCommute}{coerceCommuteTest} +\calls{coerceIntCommute}{underDomainOf} +\calls{coerceIntCommute}{getl} +\calls{coerceIntCommute}{strconc} +\calls{coerceIntCommute}{objValUnwrap} +\calls{coerceIntCommute}{mkObjWrap} +\usesdollar{coerceIntCommute}{coerceFailure} +\catches{coerceIntCommute}{coerceFailure} +\begin{chunk}{defun coerceIntCommute} +(defun |coerceIntCommute| (obj target) + (let (source s t$ d fun u c) + (declare (special |$coerceFailure|)) + (setq source (|objMode| obj)) + (cond + ((null (|coerceCommuteTest| source target)) nil) + (t + (setq s (|underDomainOf| source)) + (setq t$ (|underDomainOf| target)) + (cond + ((equal source t$) nil) + ((setq d (car source)) + (setq fun + (or (getl d '|coerceCommute|) + (intern (strconc "commute" (princ-to-string d))))) + (cond + ((canFuncall? fun) + (put d '|coerceCommute| fun) + (setq u (|objValUnwrap| obj)) + (setq c (catch '|coerceFailure| (funcall fun u source s target t$))) + (cond + ((equal c |$coerceFailure|) nil) + ((eq u '|$fromCoerceable$|) c) + (t (mkObjWrap c target))))))))))) + +\end{chunk} + +\defun{coerceCommuteTest}{coerceCommuteTest} +\calls{coerceCommuteTest}{isLegitimateMode} +\calls{coerceCommuteTest}{underDomainOf} +\calls{coerceCommuteTest}{deconstructT} +\begin{chunk}{defun coerceCommuteTest} +(defun |coerceCommuteTest| (t1 t2) + (let (u1 u2) + (cond + ((null (|isLegitimateMode| t2 nil nil)) nil) + ((null (setq u1 (|underDomainOf| t1))) nil) + ((null (setq u2 (|underDomainOf| t2))) nil) + ((null (|underDomainOf| u1)) nil) + ((null (|underDomainOf| u2)) nil) + (t + (and (equal (car (|deconstructT| t1)) (car (|deconstructT| u2))) + (equal (car (|deconstructT| t2)) (car (|deconstructT| u1)))))))) + +\end{chunk} + +\defun{coerceIntTableOrFunction}{coerceIntTableOrFunction} +This function does the actual coercion to t2, but not to an +argument type of t2 +\calls{coerceIntTableOrFunction}{isValidType} +\calls{coerceIntTableOrFunction}{isLegitimateMode} +\calls{coerceIntTableOrFunction}{objMode} +\calls{coerceIntTableOrFunction}{assq} +\calls{coerceIntTableOrFunction}{coerceByTable} +\calls{coerceIntTableOrFunction}{objVal} +\calls{coerceIntTableOrFunction}{coerceByFunction} +\usesdollar{coerceIntTableOrFunction}{CoerceTable} +\begin{chunk}{defun coerceIntTableOrFunction} +(defun |coerceIntTableOrFunction| (triple t2) + (let (t1 p tmp1) + (declare (special |$CoerceTable|)) + (cond + ((null (|isValidType| t2)) nil) + ((null (|isLegitimateMode| t2 nil nil)) nil) + (t + (setq t1 (|objMode| triple)) + (setq p (assq (car t1) |$CoerceTable|)) + (cond + ((and p (setq tmp1 (assq (car t2) (cdr p)))) + (cond + ((eq (third tmp1) '|Identity|) (mkObj (|objVal| triple) t2)) + ((eq (second tmp1) '|total|) + (or (|coerceByTable| (third tmp1) (|objVal| triple) t1 t2 t) + (|coerceByFunction| triple t2))) + (t + (or (|coerceByTable| (third tmp1) (|objVal| triple) t1 t2 nil) + (|coerceByFunction| triple t2))))) + (t (|coerceByFunction| triple t2))))))) + +\end{chunk} + +\defun{coerceByTable}{coerceByTable} +\calls{coerceByTable}{isWrapped} +\calls{coerceByTable}{unwrap} +\calls{coerceByTable}{mkObjWrap} +\calls{coerceByTable}{isTotalCoerce} +\calls{coerceByTable}{mkObj} +\calls{coerceByTable}{mkq} +\usesdollar{coerceByTable}{OutputForm} +\usesdollar{coerceByTable}{coerceFailure} +\catches{coerceByTable}{coerceFailure} +\begin{chunk}{defun coerceByTable} +(defun |coerceByTable| (fn x t1 t2 isTotalCoerce) + (let (c) + (declare (special |$coerceFailure| |$OutputForm|)) + (cond + ((equal t2 |$OutputForm|) nil) + ((|isWrapped| x) + (setq x (|unwrap| x)) + (setq c (catch '|coerceFailure| (funcall fn x t1 t2))) + (unless (equal c |$coerceFailure|) (mkObjWrap c t2))) + (|isTotalCoerce| (mkObj (list fn x (mkq t1) (mkq t2)) t2)) + (t + (mkObj (list '|catchCoerceFailure| (mkq fn) x (mkq t1) (mkq t2)) t2))))) + +\end{chunk} + +\defun{catchCoerceFailure}{catchCoerceFailure} +This function is funcalled from code constructed by {\bf coerceByTable}. +\calls{catchCoerceFailure}{unwrap} +\calls{catchCoerceFailure}{wrap} +\calls{catchCoerceFailure}{throwKeyedMsgCannotCoerceWithValue} +\usesdollar{catchCoerceFailure}{coerceFailure} +\catches{catchCoerceFailure}{coerceFailure} +\begin{chunk}{defun catchCoerceFailure} +(defun |catchCoerceFailure| (fn x t1 t2) + (let (c) + (declare (special |$coerceFailure|)) + (setq c (catch '|coerceFailure| (funcall fn x t1 t2))) + (if (equal c |$coerceFailure|) + (|throwKeyedMsgCannotCoerceWithValue| (|wrap| (|unwrap| x)) t1 t2) + c))) + +\end{chunk} + +\defun{coerceIntSpecial}{coerceIntSpecial} +\calls{coerceIntSpecial}{objMode} +\calls{coerceIntSpecial}{coerceInt} +\begin{chunk}{defun coerceIntSpecial} +(defun |coerceIntSpecial| (triple t2) + (let (x) + (when (and (eq (first t2) '|SimpleAlgebraicExtension|) + (equal (second t2) (|objMode| triple))) + (unless (setq x (|coerceInt| triple (third t2))) + (|coerceInt| x t2)))))) + +\end{chunk} + +\defun{coerceIntByMap}{coerceIntByMap} +The idea is this: if t1 is D U1 and t2 is D U2, then look for a map: +\verb|(U1 -> U2, D U1) -> D U2|. If it exists, then create a function +to do the coercion on the element level and call the map function. +\calls{coerceIntByMap}{objMode} +\calls{coerceIntByMap}{length} +\calls{coerceIntByMap}{deconstructT} +\calls{coerceIntByMap}{nequal} +\calls{coerceIntByMap}{valueArgsEqual?} +\calls{coerceIntByMap}{underDomainOf} +\calls{coerceIntByMap}{member} +\calls{coerceIntByMap}{isSubDomain} +\calls{coerceIntByMap}{sayFunctionSelection} +\calls{coerceIntByMap}{selectMms1} +\calls{coerceIntByMap}{sayFunctionSelectionResult} +\calls{coerceIntByMap}{compiledLookup} +\calls{coerceIntByMap}{evalDomain} +\calls{coerceIntByMap}{wrapped2Quote} +\calls{coerceIntByMap}{objVal} +\calls{coerceIntByMap}{timedEvaluate} +\calls{coerceIntByMap}{mkObjWrap} +\catches{coerceIntByMap}{coerceFailure} +\begin{chunk}{defun coerceIntByMap} +(defun |coerceIntByMap| (triple t2) + (let (t1 top u1 u2 args mms fun code val) + (declare (special |$coerceFailure| |$reportBottomUpFlag|)) + (setq t1 (|objMode| triple)) + (cond + ((equal t2 t1) triple) + (t + (setq u2 (|deconstructT| t2)) ; compute t2 first because of Expression + (cond + ((eql 1 (|#| u2)) nil) ; no under domain + (t + (setq u1 (|deconstructT| t1)) + (cond + ((eql 1 (|#| u1)) nil) + ((nequal (caar u1) (caar u2)) nil) ; constructors not equal + ((null (|valueArgsEqual?| t1 t2)) nil) + (t + ; handle a couple of special cases for subdomains of Integer + (setq top (caar u1)) + (setq u1 (|underDomainOf| t1)) + (setq u2 (|underDomainOf| t2)) + (cond + ((and (|member| top + '(|List| |Vector| |Segment| |Stream| + |UniversalSegment| |Array|)) + (|isSubDomain| u1 u2)) + (mkObj (|objVal| triple) t2)) + (t + (setq args (list (list '|Mapping| u2 u1) t1)) + (when |$reportBottomUpFlag| + (|sayFunctionSelection| '|map| args t2 nil + "coercion facility (map)")) + (setq mms (|selectMms1| '|map| t2 args args nil)) + (when |$reportBottomUpFlag| + (|sayFunctionSelectionResult| '|map| args mms)) + (cond + ((null mms) nil) + (t + (setq fun + (|compiledLookup| '|map| (cdaar mms) (|evalDomain| (caaar mms)))) + (cond + ((null fun) nil) + (t + (cond + ((equal (car fun) #'|Undef|) nil) + (t + ; now compile a function to do the coercion + (setq code + (list 'spadcall + (list 'cons + (list 'function '|coerceIntByMapInner|) + (mkq (cons u1 u2))) + (|wrapped2Quote| (|objVal| triple)) + (mkq fun))) + ; and apply the function + (setq val (catch '|coerceFailure| (|timedEvaluate| code))) + (unless (equal val |$coerceFailure|) + (mkObjWrap val t2)))))))))))))))))) + +\end{chunk} + +\defun{coerceIntByMapInner}{coerceIntByMapInner} +This is a helper function for {\bf coerceIntByMap} which constructs +a {\bf spadcall} and then evaluates it. +\calls{coerceIntByMapInner}{coerceOrThrowFailure} +\begin{chunk}{defun coerceIntByMapInner} +(defun |coerceIntByMapInner| (arg g1) + (|coerceOrThrowFailure| arg (car g1) (cdr g1))) + +\end{chunk} + +\defun{coerceOrThrowFailure}{coerceOrThrowFailure} +\calls{coerceOrThrowFailure}{coerceOrRetract} +\calls{coerceOrThrowFailure}{mkObjWrap} +\calls{coerceOrThrowFailure}{coercionFailure} +\calls{coerceOrThrowFailure}{objValUnwrap} +\begin{chunk}{defun coerceOrThrowFailure} +(defun |coerceOrThrowFailure| (value t1 t2) + (let (result) + (or (setq result (|coerceOrRetract| (mkObjWrap value t1) t2)) + (|coercionFailure|)) + (|objValUnwrap| result))) + +\end{chunk} + +\defun{coercionFailure}{coercionFailure} +This does a throw on coercion failure. +\throws{coercionFailure}{coerceFailure} +\begin{chunk}{defun coercionFailure} +(defun |coercionFailure| () + (declare (special |$coerceFailure|)) + (throw '|coerceFailure| |$coerceFailure|)) + +\end{chunk} + +\defun{valueArgsEqual?}{valueArgsEqual?} +\verb|[u1,:u2]| gets passed as the ``environment'', which is why we have this +slightly clumsy locution JHD 31.July,1990 + +This returns true if the object-valued arguments to t1 and t2 are the same +under coercion +\calls{valueArgsEqual?}{getdatabase} +\calls{valueArgsEqual?}{getConstructorSignature} +\calls{valueArgsEqual?}{replaceSharps} +\calls{valueArgsEqual?}{coerceInt} +\calls{valueArgsEqual?}{mkObjWrap} +\calls{valueArgsEqual?}{algEqual} +\calls{valueArgsEqual?}{objValUnwrap} +\begin{chunk}{defun valueArgsEqual?} +(defun |valueArgsEqual?| (t1 t2) + (let (coSig constrSig tl1 tl2 newVal done value trip) + (setq coSig (cdr (getdatabase (car t1) 'cosig))) + (setq constrSig (cdr (|getConstructorSignature| (car t1)))) + (setq tl1 (|replaceSharps| constrSig t1)) + (setq tl2 (|replaceSharps| constrSig t2)) + (cond + ((null (member nil coSig)) t) + (t + (setq done nil) + (setq value t) + (loop for a1 in (cdr t1) for a2 in (cdr t2) for cs in coSig + for m1 in tl1 for m2 in tl2 while (not done) do + (cond + ((null cs) + (setq trip (mkObjWrap a1 m1)) + (setq newVal (|coerceInt| trip m2)) + (cond + ((null newVal) + (setq done t) + (setq value nil)) + ((null (|algEqual| a2 (|objValUnwrap| newVal) m2)) + (setq done t) + (setq value nil)))))) + value)))) + +\end{chunk} + +\defun{algEqual}{algEqual} +This function sees if 2 objects of the same domain are equal by using the +$=$ from the domain. The objects should not be wrapped. +\calls{algEqual}{spadcall} +\calls{algEqual}{compiledLookupCheck} +\calls{algEqual}{evalDomain} +\usesdollar{algEqual}{Boolean} +\begin{chunk}{defun algEqual} +(defun |algEqual| (object1 object2 domain) + (declare (special |$Boolean|)) + (spadcall object1 object2 + (|compiledLookupCheck| '= (list |$Boolean| '$ '$) (|evalDomain| domain)))) + +\end{chunk} + +\defun{coerceIntFromUnion}{coerceIntFromUnion} +\begin{chunk}{defun coerceIntFromUnion} +(defun |coerceIntFromUnion| (object t2) + (|coerceInt| (|coerceUnion2Branch| object) t2)) + +\end{chunk} + +\defun{coerceInt2Union}{coerceInt2Union} +\begin{chunk}{defun coerceInt2Union} +(defun |coerceInt2Union| (object union) + (let (unionDoms t1 val valp noCoerce) + (declare (special |$String|)) + (setq unionDoms (|stripUnionTags| (cdr union))) + (setq t1 (|objMode| object)) + (cond + ((|member| t1 unionDoms) (|coerceBranch2Union| object union)) + (t + (setq val (|objVal| object)) + (setq valp (|unwrap| val)) + (cond + ((and (equal t1 |$String|) (|member| valp unionDoms)) + (|coerceBranch2Union| (mkObj val valp) union)) + (t + (setq noCoerce t) + (setq valp nil) + (loop for d in unionDoms while noCoerce do + (when (setq valp (|coerceInt| object d)) (setq noCoerce nil))) + (when valp (|coerceBranch2Union| valp union)))))))) + +\end{chunk} + +\defun{coerceBranch2Union}{coerceBranch2Union} +\calls{coerceBranch2Union}{orderUnionEntries} +\calls{coerceBranch2Union}{mkPredList} +\calls{coerceBranch2Union}{stripUnionTags} +\calls{coerceBranch2Union}{position} +\calls{coerceBranch2Union}{keyedSystemError} +\calls{coerceBranch2Union}{objMode} +\calls{coerceBranch2Union}{objVal} +\calls{coerceBranch2Union}{mkObjWrap} +\calls{coerceBranch2Union}{removeQuote} +\calls{coerceBranch2Union}{unwrap} +\calls{coerceBranch2Union}{mkObj} +\begin{chunk}{defun coerceBranch2Union} +(defun |coerceBranch2Union| (object union) + (let (predList doms p val tag) + (setq doms (|orderUnionEntries| (cdr union))) + (setq predList (|mkPredList| doms)) + (setq doms (|stripUnionTags| doms)) + (setq p (|position| (|objMode| object) doms)) + (cond + ((equal p (- 1)) + (|keyedSystemError| "The type %1p is not branch of %2p" + (list (|objMode| object) union))) + (t + (setq val (|objVal| object)) + (if (eq (car (setq tag (elt predlist p))) 'eqcar) + (mkObjWrap (cons (|removeQuote| (third tag)) (|unwrap| val)) union) + (mkObj val union)))))) + +\end{chunk} + +\defun{coerceIntAlgebraicConstant}{coerceIntAlgebraicConstant} +\calls{coerceIntAlgebraicConstant}{objMode} +\calls{coerceIntAlgebraicConstant}{objValUnwrap} +\calls{coerceIntAlgebraicConstant}{ofCategory} +\calls{coerceIntAlgebraicConstant}{mkObjWrap} +\calls{coerceIntAlgebraicConstant}{getConstantFromDomain} +\begin{chunk}{defun coerceIntAlgebraicConstant} +(defun |coerceIntAlgebraicConstant| (object t2) + (let (t1 val) + (setq t1 (|objMode| object)) + (setq val (|objValUnwrap| object)) + (cond + ((and (|ofCategory| t1 '(|Monoid|)) + (|ofCategory| t2 '(|Monoid|)) + (equal val (|getConstantFromDomain| '(|One|) t1))) + (mkObjWrap (|getConstantFromDomain| '(|One|) t2) t2)) + ((and (|ofCategory| t1 '(|AbelianMonoid|)) + (|ofCategory| t2 '(|AbelianMonoid|)) + (equal val (|getConstantFromDomain| '(|Zero|) t1))) + (mkObjWrap (|getConstantFromDomain| '(|Zero|) t2) t2))))) + +\end{chunk} + +\defun{getConstantFromDomain}{getConstantFromDomain} +The function {\bf getConstantFromDomain} is used to look up the +constants $0$ and $1$ from the given domainForm. + +If isPartialMode returns true then the +domain modemap contains the constant \verb|$EmptyMode| which indicates +that the domain is not fully formed. In this case we return nil. + +\calls{getConstantFromDomain}{isPartialMode} +\calls{getConstantFromDomain}{opOf} +\calls{getConstantFromDomain}{lassoc} +\calls{getConstantFromDomain}{getOperationAlistFromLisplib} +\calls{getConstantFromDomain}{getConstantFromDomain} +\calls{getConstantFromDomain}{throwKeyedMsg} +\calls{getConstantFromDomain}{spadcall} +\calls{getConstantFromDomain}{compiledLookupCheck} +\calls{getConstantFromDomain}{evalDomain} +\begin{chunk}{defun getConstantFromDomain} +(defun |getConstantFromDomain| (form domainForm) + (let (key entryList) + (unless (|isPartialMode| domainForm) + (setq key (|opOf| form)) + (setq entryList + (lassoc key (|getOperationAlistFromLisplib| (car domainForm)))) + (cond + ((null (eq (cdr entryList) nil)) + (cond + ((eq key '|One|) (|getConstantFromDomain| (list '|1|) domainForm)) + ((eq key '|Zero|) (|getConstantFromDomain| (list '|0|) domainForm)) + (t + (|throwKeyedMsg| "No such constant %1 in domain %2p ." + (list form domainForm))))) + (t + ; there should be exactly one item under this key of that form + (spadcall + (|compiledLookupCheck| key (caar entryList) + (|evalDomain| domainForm)))))))) + +\end{chunk} + +\defun{compareTypeLists}{compareTypeLists} +Rreturns true if every type in tl1 is equal or is a subdomain of +the corresponding type in tl2 +\begin{chunk}{defun compareTypeLists} +(defun |compareTypeLists| (tl1 tl2) + (not + (loop for t1 in tl1 for t2 in tl2 + do (when (null (|isEqualOrSubDomain| t1 t2)) (return t))))) + +\end{chunk} + +\defun{coerceIntX}{coerceIntX} +Try to coerce a (List (None)) into a different domain +\calls{coerceIntX}{unwrap} +\calls{coerceIntX}{underDomainOf} +\calls{coerceIntX}{coerceInt} +\calls{coerceIntX}{mkObjWrap} +\begin{chunk}{defun coerceIntX} +(defun |coerceIntX| (val t1 t2) + (let (t0) + (when (and (equal t1 '(|List| (|None|))) + (null (|unwrap| val)) + (setq t0 (|underDomainOf| t2))) + (|coerceInt| (mkObjWrap val (list '|List| t0)) t2)))) + +\end{chunk} + +\defun{coerceSubDomain}{coerceSubDomain} +\calls{coerceSubDomain}{getdatabase} +\calls{coerceSubDomain}{coerceSubDomain} +\calls{coerceSubDomain}{coerceImmediateSubDomain} +\begin{chunk}{defun coerceSubDomain} +(defun |coerceSubDomain| (val tSuper tSub) + (let (super) + (unless (eq val '|$fromCoerceable$|) + (setq super (getdatabase (car tSub) 'superdomain)) + (cond + ((equal (car super) tSuper) + (|coerceImmediateSubDomain| val tSuper tSub (second super))) + ((|coerceSubDomain| val tSuper (car super)) + (|coerceImmediateSubDomain| val (car super) tSub (second super))))))) + +\end{chunk} + +\defun{coerceImmediateSubDomain}{coerceImmediateSubDomain} +\calls{coerceImmediateSubDomain}{getSubDomainPredicate} +\begin{chunk}{defun coerceImmediateSubDomain} +(defun |coerceImmediateSubDomain| (val tSuper tSub pred) + (when (funcall (|getSubDomainPredicate| tSuper tSub pred) val nil) + (mkObj val tSub))) + +\end{chunk} + +\defun{getSubDomainPredicate}{getSubDomainPredicate} +\calls{getSubDomainPredicate}{msubst} +\calls{getSubDomainPredicate}{removeZeroOne} +\calls{getSubDomainPredicate}{interpret} +\calls{getSubDomainPredicate}{mkAtree} +\calls{getSubDomainPredicate}{transferPropsToNode} +\calls{getSubDomainPredicate}{selectLocalMms} +\calls{getSubDomainPredicate}{hput} +\usesdollar{getSubDomainPredicate}{env} +\usesdollar{getSubDomainPredicate}{superHash} +\usesdollar{getSubDomainPredicate}{Boolean} +\usesdollar{getSubDomainPredicate}{InteractiveFrame} +\begin{chunk}{defun getSubDomainPredicate} +(defun |getSubDomainPredicate| (tSuper tSub pred) + (let (|$env| name decl arg predp defn op predfn) + (declare (special |$env| |$superHash| |$Boolean| |$InteractiveFrame|)) + (setq |$env| |$InteractiveFrame|) + (cond + ((setq predfn (hget |$superHash| (cons tSuper tSub))) predfn) + (t + (setq name (gensym)) + (setq decl (list '|:| name (list '|Mapping| |$Boolean| tSuper))) + (|interpret| decl nil) + (setq arg (gensym)) + (setq predp (msubst arg '|#1| pred)) + (setq defn + (list 'def (list name arg) '(nil nil) '(nil nil) (|removeZeroOne| predp))) + (|interpret| defn nil) + (setq op (|mkAtree| name)) + (|transferPropsToNode| name op) + (setq predfn (cadar (|selectLocalMms| op name (list tSuper) |$Boolean|))) + (hput |$superHash| (cons tSuper tSub) predfn) + predfn)))) + +\end{chunk} + +\defun{absolutelyCanCoerceByCheating}{absolutelyCanCoerceByCheating} +This typically involves subdomains and towers where the only +difference is a subdomain +\calls{absolutelyCanCoerceByCheating}{isEqualOrSubDomain|} +\calls{absolutelyCanCoerceByCheating}{deconstructT} +\calls{absolutelyCanCoerceByCheating}{nequal} +\calls{absolutelyCanCoerceByCheating}{absolutelyCanCoerceByCheating} +\usesdollar{absolutelyCanCoerceByCheating}{SingleInteger} +\usesdollar{absolutelyCanCoerceByCheating}{Integer} +\begin{chunk}{defun absolutelyCanCoerceByCheating} +(defun |absolutelyCanCoerceByCheating| (t1 t2) + (let (let1 let2) + (declare (special |$Integer| |$SingleInteger|)) + (cond + ((|isEqualOrSubDomain| t1 t2) t) + ((and (equal t1 |$SingleInteger|) (equal t2 |$Integer|)) t) + ((or (atom t1) (atom t2)) nil) + (t + (setq let1 (|deconstructT| t1)) + (setq let2 (|deconstructT| t2)) + (cond + ((and (equal (car let1) '(|Stream|)) + (equal (car let2) '(|InfiniteTuple|))) + (cond + ((nequal (|#| (cdr let1)) (|#| (cdr let2))) nil) + (t + (every #'identity + (loop for x1 in (cdr let1) for x2 in (cdr let2) collect + (|absolutelyCanCoerceByCheating| x1 x2)))))) + ((nequal (car let1) (car let2)) nil) + ((nequal (|#| (cdr let1)) (|#| (cdr let2))) nil) + (t + (every #'identity + (loop for x1 in (cdr let1) for x2 in (cdr let2) collect + (|absolutelyCanCoerceByCheating| x1 x2))))))))) + +\end{chunk} + +\defun{coerceOrRetract}{coerceOrRetract} +\calls{coerceOrRetract}{coerceInteractive} +\calls{coerceOrRetract}{retract} +\begin{chunk}{defun coerceOrRetract} +(defun |coerceOrRetract| (z m) + (prog (tp tt ans) + (return + (cond + ((setq tp (|coerceInteractive| z m)) tp) + (t + (setq tt z) + (setq ans nil) + (do () (nil nil) + (cond + (ans (return ans)) + (t + (setq tt (|retract| tt)) + (cond + ((eq tt '|failed|) (return ans)) + (t (setq ans (|coerceInteractive| tt m))))))) + ans))))) + +\end{chunk} + +\defun{retract2Specialization}{retract2Specialization} +Handle some specialization retraction cases, like matrices +\calls{retract2Specialization}{objVal} +\calls{retract2Specialization}{unwrap} +\calls{retract2Specialization}{objMode} +\calls{retract2Specialization}{mkObjWrap} +\calls{retract2Specialization}{coerceUnion2Branch} +\calls{retract2Specialization}{coerceInt} +\calls{retract2Specialization}{remdup} +\calls{retract2Specialization}{varsInPoly} +\calls{retract2Specialization}{mkObj} +\calls{retract2Specialization}{member} +\calls{retract2Specialization}{retract} +\calls{retract2Specialization}{objValUnwrap} +\calls{retract2Specialization}{objMode} +\calls{retract2Specialization}{resolveTypeListAny} +\calls{retract2Specialization}{isRectangularList} +\calls{retract2Specialization}{get} +\calls{retract2Specialization}{isPartialMode} +\usesdollar{retract2Specialization}{e} +\usesdollar{retract2Specialization}{QuotientField} +\usesdollar{retract2Specialization}{Symbol} +\usesdollar{retract2Specialization}{Integer} +\usesdollar{retract2Specialization}{Any} +\usesdollar{retract2Specialization}{NonNegativeInteger} +\usesdollar{retract2Specialization}{PositiveInteger} +\begin{chunk}{defun retract2Specialization} +(defun |retract2Specialization| (object) + (prog (val type dom obj dp bad vl tl ep vlp n D num den valp m) + (declare (special |$e| |$QuotientField| |$Symbol| |$Integer| |$Any| + |$NonNegativeInteger| |$PositiveInteger|)) + (return + (seq + (progn + (setq val (|objVal| object)) + (setq valp (|unwrap| val)) + (setq type (|objMode| object)) + (cond + ; type is Any + ((equal type |$Any|) + (setq dom (car valp)) + (setq obj (cdr valp)) + (mkObjWrap obj dom)) + ; type is ['Union,:unionDoms] + ((eq (car type) '|Union|) + (|coerceUnion2Branch| object)) + ; type is Symbol + ((equal type |$Symbol|) + (mkObjWrap 1 (list '|OrderedVariableList| (list valp)))) + ; type is ['OrderedVariableList,var] + ((eq (car type) '|OrderedVariableList|) + (|coerceInt| + (mkObjWrap (elt (second type) (- valp 1)) |$Symbol|) + '(|Polynomial| (|Integer|)))) + ; type is ['Polynomial,d] + ((eq (car type) '|Polynomial|) + (cond + ((eql (car valp) 1) + (when (eql 1 (|#| (remdup (|varsInPoly| valp)))) + (|coerceInt| object + (list '|UnivariatePolynomial| (second valp) (second type))))) + ((eql (car valp) 0) (|coerceInt| object (second type))) + (t nil))) + ; type is ['Matrix,d] + ((eq (car type) '|Matrix|) + (setq n (|#| valp)) + (setq m (|#| (elt valp 0))) + (cond + ((= n m) (mkObj val (list '|SquareMatrix| n (second type)))) + (t (mkObj val (list '|RectangularMatrix| n m (second type)))))) + ; type is ['RectangularMatrix,n,m,d] + ((eq (first type) '|RectangularMatrix|) + (setq n (second type)) + (setq m (third type)) + (setq d (fourth type)) + (when (eql n m) (mkObj val (list '|SquareMatrix| n d)))) + ; type is [agg,d] agg is |Vector|,|Segment|, or |UniversalSegment| + ((|member| (first type) '(|Vector| |Segment| |UniversalSegment|)) + (cond + ((equal (second type) |$PositiveInteger|) + (mkObj val (cons (first type) (list |$NonNegativeInteger|)))) + ((equal (second type) |$NonNegativeInteger|) + (mkObj val (list (first type) |$Integer|))))) + ; type is ['Array,bds,d] + ((eq (first type) '|Array|) + (cond + ((equal (third type) |$PositiveInteger|) + (mkObj val (list '|Array| (second type) |$NonNegativeInteger|))) + ((equal (third type) |$NonNegativeInteger|) + (mkObj val (list '|Array| (second type) |$Integer|))))) + ; type is ['List,d] + ((eq (car type) '|List|) + (setq d (second type)) + (setq dp (second d)) + (cond + ; type isnt ['List,dp] + ((null (eq (car d) '|List|)) + (cond + ((equal d |$PositiveInteger|) + (mkObj val (list '|List| |$NonNegativeInteger|))) + ((equal d |$NonNegativeInteger|) + (mkObj val (list '|List| |$Integer|))) + ((null valp) nil) + (t + (setq vl nil) + (setq tl nil) + (setq bad nil) + (loop for e in valp while (not bad) do + (cond + ((equal (setq ep (|retract| (mkObjWrap e d))) '|failed|) + (setq bad t)) + (t + (setq vl (cons (|objValUnwrap| ep) vl)) + (setq tl (cons (|objMode| ep) tl))))) + (cond + (bad nil) + ((equal (setq m (|resolveTypeListAny| tl)) d) nil) + ((equal d m) nil) + (t + (setq vlp nil) + (setq ep t) + (loop for e in vl for tt in tl while ep do + (cond + ((equal tt m) (setq vlp (cons e vlp))) + (t + (setq ep (|coerceInt| (mkObjWrap e tt) m)) + (when ep (setq vlp (cons (|objValUnwrap| ep) vlp)))))) + (mkObjWrap vlp (list '|List| m))))))) + ((equal dp |$PositiveInteger|) + (mkObj val (list '|List| (list '|List| |$NonNegativeInteger|)))) + ((equal dp |$NonNegativeInteger|) + (mkObj val (list '|List| (list '|List| |$Integer|)))) + ((or (eq (car dp) '|Variable|) + (eq (car dp) '|OrderedVariableList|)) + (|coerceInt| object (list '|List| (list '|List| |$Symbol|)))) + (t + (setq n (|#| valp)) + (setq m (|#| (elt valp 0))) + (cond + ((null (|isRectangularList| valp n m)) nil) + (t (|coerceInt| object (list '|Matrix| dp))))))) + ; type is ['Expression,d] + ((eq (car type) '|Expression|) + (setq num (car valp)) + (setq den (cdr valp)) + (cond + ((null (equal (car num) 0)) nil) + ((null (equal (car den) 0)) nil) + (t + (mkObjWrap (cons (cdr num) (cdr den)) + (list |$QuotientField| (second type)))))) + ; type is ['SimpleAlgebraicExtension,k,rep,.] + ; try to retract as an element of rep and see if we can get an element of k + ((eq (car type) '|SimpleAlgebraicExtension|) + (setq valp (|retract| (mkObj val (third type)))) + (do () + ((null (and (nequal valp '|failed|) + (nequal (|objMode| valp) (second type)))) + nil) + (setq valp (|retract| valp))) + (unless (equal valp '|failed|) valp)) + ; type is ['UnivariatePuiseuxSeries,coef,var,cen] + ((eq (car type) '|UnivariatePuiseuxSeries|) + (|coerceInt| object + (list '|UnivariateLaurentSeries| + (second type) (third type) (fourth type)))) + ; type is ['UnivariateLaurentSeries,coef,var,cen] + ((eq (car type) '|UnivariateLaurentSeries|) + (|coerceInt| object + (list '|UnivariateTaylorSeries| + (second type) (third type) (fourth type)))) + ; type is ['FunctionCalled,name] + ((eq (car type) '|FunctionCalled|) + (cond + ((null (setq m (|get| (second type) '|mode| |$e|))) nil) + ((|isPartialMode| m) nil) + (t (mkObj val m)))) + (t nil))))))) + +\end{chunk} + +\defun{coerceUnion2Branch}{coerceUnion2Branch} +\calls{coerceUnion2Branch}{orderUnionEntries} +\calls{coerceUnion2Branch}{objMode} +\calls{coerceUnion2Branch}{mkPredList} +\calls{coerceUnion2Branch}{stripUnionTags} +\calls{coerceUnion2Branch}{objValUnwrap} +\calls{coerceUnion2Branch}{evalSharpOne} +\calls{coerceUnion2Branch}{mkObj} +\calls{coerceUnion2Branch}{objVal} +\begin{chunk}{defun coerceUnion2Branch} +(defun |coerceUnion2Branch| (object) + (let (predList doms valp predicate targetType) + (setq doms (|orderUnionEntries| (cdr (|objMode| object)))) + (setq predList (|mkPredList| doms)) + (setq doms (|stripUnionTags| doms)) + (setq valp (|objValUnwrap| object)) + (loop for typ in doms for pred in predList while (not targetType) do + (when (|evalSharpOne| pred valp) + (setq predicate pred) + (setq targetType typ))) + (cond + ((null targetType) + (|keyedSystemError| "Cannot determine branch of Union." nil)) + ((eq (car predicate) 'eqcar) (mkObjWrap (cdr valp) targetType)) + (t (mkObj (|objVal| object) targetType))))) + +\end{chunk} + +\defun{stripUnionTags}{stripUnionTags} +\begin{chunk}{defun stripUnionTags} +(defun |stripUnionTags| (doms) + (loop for dom in doms + collect (if (eq (first dom) '|:|) (third dom) dom))) + +\end{chunk} + +\defun{evalSharpOne}{evalSharpOne} +\begin{chunk}{defun evalSharpOne 0} +(defun |evalSharpOne| (x |#1|) + (declare (special |#1|)) + (eval `(let() (declare (special |#1|)) ,x))) + +\end{chunk} + +\defun{retractUnderDomain}{retractUnderDomain} +\calls{retractUnderDomain}{underDomainOf} +\calls{retractUnderDomain}{deconstructT} +\calls{retractUnderDomain}{nequal} +\calls{retractUnderDomain}{constructT} +\calls{retractUnderDomain}{coerceInt} +\begin{chunk}{defun retractUnderDomain} +(defun |retractUnderDomain| (object type underDomain) + (let (ud let1 typep objectp) + (cond + ((null (setq ud (|underDomainOf| underDomain))) '|failed|) + (t + (setq let1 (|deconstructT| type)) + (cond + ((nequal 1 (|#| (cdr let1))) '|failed|) + ((nequal 1 (|#| (car let1))) '|failed|) + (t + (setq typep (|constructT| (car let1) (list ud))) + (cond + ((setq objectp (|coerceInt| object typep)) objectp) + (t '|failed|)))))))) + +\end{chunk} + +\defun{coerceRetract}{coerceRetract} +\calls{coerceRetract}{objValUnwrap} +\calls{coerceRetract}{objMode} +\calls{coerceRetract}{isEqualOrSubDomain} +\calls{coerceRetract}{mkObjWrap} +\calls{coerceRetract}{retractByFunction} +\calls{coerceRetract}{getl} +\calls{coerceRetract}{canFuncall?} +\usesdollar{coerceRetract}{coerceFailure} +\usesdollar{coerceRetract}{SingleInteger} +\usesdollar{coerceRetract}{OutputForm} +\usesdollar{coerceRetract}{Symbol} +\usesdollar{coerceRetract}{Integer} +\catches{coerceRetract}{coerceFailure} +\begin{chunk}{defun coerceRetract} +(defun |coerceRetract| (object t2) + (let (val t1 fun c) + (declare (special |$coerceFailure| |$OutputForm| |$Symbol| |$Integer| + |$SingleInteger|)) + (cond + ((eq (setq val (|objValUnwrap| object)) '|$fromCoerceable$|) nil) + (t + (setq t1 (|objMode| object)) + (cond + ((equal t2 |$OutputForm|) nil) + ((and (|isEqualOrSubDomain| t1 |$Integer|) + (equal t2 |$SingleInteger|) + (typep val 'fixnum)) + (mkObjWrap val t2)) + ((equal t1 |$Integer|) nil) + ((equal t1 |$Symbol|) nil) + ((equal t1 |$OutputForm|) nil) + ((setq c (|retractByFunction| object t2)) c) + ((consp t1) + (setq fun + (or (getl (car t1) '|retract|) + (intern (strconc "retract" (princ-to-string (car t1)))))) + (when (canFuncall? fun) + (put (car t1) '|retract| fun) + (setq c (catch '|coerceFailure| (funcall fun object t2))) + (unless (equal c |$coerceFailure|) c)))))))) + +\end{chunk} + +\defun{retractByFunction}{retractByFunction} +\calls{retractByFunction}{objValUnwrap} +\calls{retractByFunction}{sayFunctionSelection} +\calls{retractByFunction}{findFunctionInDomain} +\calls{retractByFunction}{orderMms} +\calls{retractByFunction}{sayFunctionSelectionResult} +\calls{retractByFunction}{evalDomain} +\calls{retractByFunction}{compiledLookup} +\calls{retractByFunction}{coerceUnion2Branch} +\calls{retractByFunction}{mkObjWrap} +\calls{retractByFunction}{spadcall} +\calls{retractByFunction}{objMode} +\usesdollar{retractByFunction}{reportBottomUpFlag} +\usesdollar{retractByFunction}{dollar} +\begin{chunk}{defun retractByFunction} +(defun |retractByFunction| (object u) + (let (|$reportBottomUpFlag| $ tt val target funName mms dcVector fun objectp) + (declare (special |$reportBottomUpFlag| $)) + (setq tt (|objMode| object)) + (setq val (|objValUnwrap| object)) + (setq target (list '|Union| u "failed")) + (setq funName '|retractIfCan|) + (when |$reportBottomUpFlag| + (|sayFunctionSelection| funName (list tt) target + nil "coercion facility (retraction)")) + (when + (setq mms + (append + (|findFunctionInDomain| funName tt target (list tt) (list tt) nil t) + (|findFunctionInDomain| funName u target (list tt) (list tt) nil t))) + (setq mms (|orderMms| funName mms (list tt) (list tt) target))) + (when |$reportBottomUpFlag| + (|sayFunctionSelectionResult| funName (list tt) mms)) + (when mms + (setq dcVector (|evalDomain| (caaar mms))) + (setq fun (|compiledLookup| funName (list target tt) dcVector)) + (cond + ((null fun) nil) + ((equal (car fun) #'|Undef|) nil) + (t + (setq $ dcVector) + (setq objectp + (|coerceUnion2Branch| (mkObjWrap (spadcall val fun) target))) + (when (equal u (|objMode| objectp)) objectp)))))) + +\end{chunk} + \chapter{System Command Handling} The system commands are the top-level commands available in Axiom that can all be invoked by prefixing the symbol with a closed-paren. @@ -26975,36 +28735,12 @@ Thus: ; NMSORT [n for [n,:.] in CAAR $InteractiveFrame | ; (n ^= "--macros--" and n^= "--flags--")] \end{verbatim} -\calls{getWorkspaceNames}{seq} \calls{getWorkspaceNames}{nmsort} -\calls{getWorkspaceNames}{exit} \usesdollar{getWorkspaceNames}{InteractiveFrame} \begin{chunk}{defun getWorkspaceNames} (defun |getWorkspaceNames| () - (PROG (n) - (declare (special |$InteractiveFrame|)) - (return - (seq (nmsort (PROG (G166322) - (setq G166322 NIL) - (RETURN - (DO ((G166329 (CAAR |$InteractiveFrame|) - (CDR G166329)) - (G166313 NIL)) - ((OR (ATOM G166329) - (PROGN - (SETQ G166313 (CAR G166329)) - NIL) - (PROGN - (PROGN - (setq n (CAR G166313)) - G166313) - NIL)) - (NREVERSE0 G166322)) - (SEQ (EXIT (COND - ((AND (not (eq n '|--macros--|)) - (not (eq n '|--flags--|))) - (SETQ G166322 - (CONS n G166322)))))))))))))) + (declare (special |$InteractiveFrame|)) + (nmsort (loop for g2 in (caar |$InteractiveFrame|) collect (car g2)))) \end{chunk} @@ -41141,6 +42877,13 @@ alternate polynomial types of Symbols. \end{chunk} +\defun{isTaggedUnion}{isTaggedUnion} +\begin{chunk}{defun isTaggedUnion} +(defun |isTaggedUnion| (u) + (and (eq (car u) '|Union|) (eq (caadr u) '|:|))) + +\end{chunk} + \defun{mkEvalableRecord}{mkEvalableRecord} \calls{mkEvalableRecord}{mkEvalable} \begin{chunk}{defun mkEvalableRecord} @@ -53779,9 +55522,9 @@ This is a list with the fields (PROG (numChars default stringName spadType filter mess2) (declare (special |$curPage|)) (return - (SEQ (DO ((G166358 strings (CDR G166358)) (G166343 nil)) - ((or (atom G166358) - (progn (setq G166343 (CAR G166358)) nil) + (SEQ (DO ((g2 strings (CDR g2)) (G166343 nil)) + ((or (atom g2) + (progn (setq G166343 (CAR g2)) nil) (progn (progn (setq numChars (car G166343)) @@ -55235,8 +56978,8 @@ This is a list with the fields nil)))) (|bcHt| "Select one of the following: \\newline\\tab{3} ") (setq links - (prog (G167460) - (setq G167460 nil) + (prog (g2) + (setq g2 nil) (return (DO ((G167465 values (cdr G167465)) (opt nil)) @@ -55244,8 +56987,8 @@ This is a list with the fields (progn (setq opt (car G167465)) nil)) - (NREVERSE0 G167460)) - (SEQ (EXIT (setq G167460 + (NREVERSE0 g2)) + (SEQ (EXIT (setq g2 (cons (cons (STRCONC "" @@ -55253,7 +56996,7 @@ This is a list with the fields (cons "\\newline\\tab{3}" (cons functionToCall (cons opt nil)))) - G167460)))))))) + g2)))))))) (|htMakePage| (cons (cons '|bcLispLinks| links) nil)) (|bcHt| (cons @@ -57403,8 +59146,8 @@ There are 8 parts of an htPage: (cond ((eq (qcar conform) '|Join|) (jfn - (|delete| '(|Type| |Object|) (qcdr conform)) - (|delete| '(|Type| |Object|) (ifcdr domform)))) + (|delete| '(|Type| object) (qcdr conform)) + (|delete| '(|Type| object) (ifcdr domform)))) ((eq (qcar conform) 'category) nil) (t (|domainsOf| conform domform))) (|domainsOf| conform domform)))) @@ -59951,6 +61694,7 @@ There are 8 parts of an htPage: \getchunk{defun emptyInterpreterFrame 0} \getchunk{defun endedp 0} +\getchunk{defun evalSharpOne 0} \getchunk{defun fin 0} \getchunk{defun findFrameInRing 0} @@ -59973,6 +61717,7 @@ There are 8 parts of an htPage: \getchunk{defun getPreStL 0} \getchunk{defun getspoolname 0} +\getchunk{defun hasCorrectTarget 0} \getchunk{defun hasOptArgs? 0} \getchunk{defun ignorep 0} @@ -60195,6 +61940,7 @@ There are 8 parts of an htPage: \getchunk{defun abbQuery} \getchunk{defun abbreviations} \getchunk{defun abbreviationsSpad2Cmd} +\getchunk{defun absolutelyCanCoerceByCheating} \getchunk{defun addBinding} \getchunk{defun addBindingInteractive} \getchunk{defun addInputLibrary} @@ -60202,6 +61948,7 @@ There are 8 parts of an htPage: \getchunk{defun addoperations} \getchunk{defun addTraceItem} \getchunk{defun algCoerceInteractive} +\getchunk{defun algEqual} \getchunk{defun allConstructors} \getchunk{defun allOperations} \getchunk{defun alqlGetOrigin} @@ -60323,6 +62070,7 @@ There are 8 parts of an htPage: \getchunk{defun canFuncall?} \getchunk{defun categoryopen} +\getchunk{defun catchCoerceFailure} \getchunk{defun changeHistListLen} \getchunk{defun changeToNamedInterpreterFrame} \getchunk{defun charDigitVal} @@ -60348,10 +62096,38 @@ There are 8 parts of an htPage: \getchunk{defun close} \getchunk{defun closeInterpreterFrame} \getchunk{defun cmpnote} +\getchunk{defun coerceBranch2Union} +\getchunk{defun coerceByFunction} +\getchunk{defun coerceByTable} +\getchunk{defun coerceCommuteTest} +\getchunk{defun coerceConvertMmSelection} +\getchunk{defun coerceImmediateSubDomain} +\getchunk{defun coerceInt} +\getchunk{defun coerceInt0} +\getchunk{defun coerceInt1} +\getchunk{defun coerceIntX} +\getchunk{defun coerceIntAlgebraicConstant} +\getchunk{defun coerceIntByMap} +\getchunk{defun coerceIntByMapInner} +\getchunk{defun coerceIntCommute} +\getchunk{defun coerceInteractive} +\getchunk{defun coerceIntFromUnion} +\getchunk{defun coerceIntPermute} +\getchunk{defun coerceIntSpecial} +\getchunk{defun coerceIntTableOrFunction} +\getchunk{defun coerceIntTest} +\getchunk{defun coerceIntTower} +\getchunk{defun coerceInt2Union} +\getchunk{defun coerceOrRetract} +\getchunk{defun coerceOrThrowFailure} +\getchunk{defun coerceRetract} \getchunk{defun coerceSpadArgs2E} \getchunk{defun coerceSpadFunValue2E} +\getchunk{defun coerceSubDomain} \getchunk{defun coerceTraceArgs2E} \getchunk{defun coerceTraceFunValue2E} +\getchunk{defun coerceUnion2Branch} +\getchunk{defun coercionFailure} \getchunk{defun commandAmbiguityError} \getchunk{defun commandError} \getchunk{defun commandErrorIfAmbiguous} @@ -60359,10 +62135,12 @@ There are 8 parts of an htPage: \getchunk{defun commandsForUserLevel} \getchunk{defun commandUserLevelError} \getchunk{defun compareposns} +\getchunk{defun compareTypeLists} \getchunk{defun compileBoot} \getchunk{defun compiledLookup} \getchunk{defun compiledLookupCheck} \getchunk{defun computeDomainVariableAlist} +\getchunk{defun computeTTTranspositions} \getchunk{defun condErrorMsg} \getchunk{defun conLowerCaseConTran} \getchunk{defun conOpPage} @@ -60415,6 +62193,7 @@ There are 8 parts of an htPage: \getchunk{defun dbSubConform} \getchunk{defun dbWordFrom} \getchunk{defun decideHowMuch} +\getchunk{defun decomposeTypeIntoTower} \getchunk{defun defaultTargetFE} \getchunk{defun defiostream} \getchunk{defun deldatabase} @@ -60525,6 +62304,7 @@ There are 8 parts of an htPage: \getchunk{defun getAndSay} \getchunk{defun getBpiNameIfTracedMap} \getchunk{defun getBrowseDatabase} +\getchunk{defun getConstantFromDomain} \getchunk{defun getConstructorDocumentation} \getchunk{defun getdatabase} \getchunk{defun getDependentsOfConstructor} @@ -60549,6 +62329,7 @@ There are 8 parts of an htPage: \getchunk{defun getRefvU16} \getchunk{defun getRefvU32} \getchunk{defun getStFromMsg} +\getchunk{defun getSubDomainPredicate} \getchunk{defun getSystemCommandLine} \getchunk{defun getTraceOption} \getchunk{defun getTraceOption,hn} @@ -60779,6 +62560,7 @@ There are 8 parts of an htPage: \getchunk{defun isSharpVarWithNum} \getchunk{defun isSubForRedundantMapName} \getchunk{defun isSystemDirectory} +\getchunk{defun isTaggedUnion} \getchunk{defun isTraceGensym} \getchunk{defun isUncompiledMap} @@ -61198,6 +62980,7 @@ There are 8 parts of an htPage: \getchunk{defun pathnameTypeId} \getchunk{defun patternVarsOf} \getchunk{defun patternVarsOf1} +\getchunk{defun permuteToOrder} \getchunk{defun pcounters} \getchunk{defun pfAbSynOp} \getchunk{defun pfAbSynOp?} @@ -61442,6 +63225,7 @@ There are 8 parts of an htPage: \getchunk{defun readline} \getchunk{defun readSpadProfileIfThere} \getchunk{defun readSpad2Cmd} +\getchunk{defun reassembleTowerIntoType} \getchunk{defun recordAndPrint} \getchunk{defun recordFrame} \getchunk{defun recordNewValue} @@ -61486,6 +63270,9 @@ There are 8 parts of an htPage: \getchunk{defun restart0} \getchunk{defun restoreHistory} \getchunk{defun retract} +\getchunk{defun retractByFunction} +\getchunk{defun retractUnderDomain} +\getchunk{defun retract2Specialization} \getchunk{defun rread} \getchunk{defun ruleLhsTran} \getchunk{defun rulePredicateTran} @@ -61624,6 +63411,7 @@ There are 8 parts of an htPage: \getchunk{defun stringMatches?} \getchunk{defun string2Constructor} \getchunk{defun StringToDir} +\getchunk{defun stripUnionTags} \getchunk{defun strpos} \getchunk{defun strposl} \getchunk{defun stupidIsSpadFunction} @@ -61704,6 +63492,7 @@ There are 8 parts of an htPage: \getchunk{defun userLevelErrorMessage} \getchunk{defun validateOutputDirectory} +\getchunk{defun valueArgsEqual?} \getchunk{defun vec2list} \getchunk{defun voidValue} diff --git a/changelog b/changelog index 25e65dc..2ed0602 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,6 @@ +20150711 tpd src/axiom-website/patches.html 20150711.03.tpd.patch +20150711 tpd src/interp/i-coerce merge functions used from i-coerce +20150711 tpd books/bookvol5 merge functions used from i-coerce 20150711 tpd src/axiom-website/patches.html 20150711.02.tpd.patch 20150711 tpd src/input/series.input minor fixes to test suite 20150711 tpd src/input/intlf.input minor fixes to test suite diff --git a/patch b/patch index 3ebf28b..e507943 100644 --- a/patch +++ b/patch @@ -1,5 +1,6 @@ -books/bookvol10.3, src/input/intlf,series minor test fixes +books/bookvol5 merge functions used from i-coerce -Goal: Clean Axiom Test Suite +Goal: Literate Axiom -Minor test fixes. +Every function in src/input/i-coerce.lisp that was referenced +in bookvol5 was moved and rewritten from i-coerce to bookvol5. diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 3205461..472c235 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -5094,6 +5094,8 @@ src/input/*.input
books/bookvol13 add references to CQQ proofs
20150711.02.tpd.patch books/bookvol10.3, src/input/intlf,series minor test fixes
+20150711.03.tpd.patch +books/bookvol5 merge functions used from i-coerce
diff --git a/src/interp/i-coerce.lisp.pamphlet b/src/interp/i-coerce.lisp.pamphlet index e638b34..c312134 100644 --- a/src/interp/i-coerce.lisp.pamphlet +++ b/src/interp/i-coerce.lisp.pamphlet @@ -93,496 +93,7 @@ The special routines that do the coercions typically involve a "2" (|throwKeyedMsgCannotCoerceWithValue| (|objVal| |triple|) (|objMode| |triple|) |t|)))))))) -;coerceOrThrowFailure(value, t1, t2) == -; (result := coerceOrRetract(objNewWrap(value, t1), t2)) or -; coercionFailure() -; objValUnwrap(result) - -(DEFUN |coerceOrThrowFailure| (|value| |t1| |t2|) - (PROG (|result|) - (RETURN - (PROGN - (OR (setq |result| - (|coerceOrRetract| (mkObjWrap |value| |t1|) - |t2|)) - (|coercionFailure|)) - (|objValUnwrap| |result|))))) - ;--% Retraction functions -;retractUnderDomain(object,type,underDomain) == -; null (ud := underDomainOf underDomain) => 'failed -; [c,:args] := deconstructT type -; 1 ^= #args => 'failed -; 1 ^= #c => 'failed -; type'' := constructT(c,[ud]) -; (object' := coerceInt(object,type'')) => object' -; 'failed - -(DEFUN |retractUnderDomain| (|object| |type| |underDomain|) - (PROG (|ud| |LETTMP#1| |c| |args| |type''| |object'|) - (RETURN - (COND - ((NULL (setq |ud| (|underDomainOf| |underDomain|))) - '|failed|) - ('T (setq |LETTMP#1| (|deconstructT| |type|)) - (setq |c| (CAR |LETTMP#1|)) - (setq |args| (CDR |LETTMP#1|)) - (COND - ((NEQUAL 1 (|#| |args|)) '|failed|) - ((NEQUAL 1 (|#| |c|)) '|failed|) - ('T (setq |type''| (|constructT| |c| (CONS |ud| NIL))) - (COND - ((setq |object'| (|coerceInt| |object| |type''|)) - |object'|) - ('T '|failed|))))))))) - -;retract2Specialization object == -; -- handles some specialization retraction cases, like matrices -; val := objVal object -; val' := unwrap val -; type := objMode object -; type = $Any => -; [dom,:obj] := val' -; objNewWrap(obj,dom) -; type is ['Union,:unionDoms] => coerceUnion2Branch object -; type = $Symbol => -; objNewWrap(1,['OrderedVariableList,[val']]) -; type is ['OrderedVariableList,var] => -; coerceInt(objNewWrap(var.(val'-1),$Symbol), '(Polynomial (Integer))) -;-- !! following retract seems wrong and breaks ug13.input -;-- type is ['Variable,var] => -;-- coerceInt(object,$Symbol) -; type is ['Polynomial,D] => -; val' is [ =1,x,:.] => -; vl := REMDUP reverse varsInPoly val' -; 1 = #vl => coerceInt(object,['UnivariatePolynomial,x,D]) -; NIL -; val' is [ =0,:.] => coerceInt(object, D) -; NIL -; type is ['Matrix,D] => -; n := # val' -; m := # val'.0 -; n = m => objNew(val,['SquareMatrix,n,D]) -; objNew(val,['RectangularMatrix,n,m,D]) -; type is ['RectangularMatrix,n,m,D] => -; n = m => objNew(val,['SquareMatrix,n,D]) -; NIL -; (type is [agg,D]) and (agg in '(Vector Segment UniversalSegment)) => -; D = $PositiveInteger => objNew(val,[agg,$NonNegativeInteger]) -; D = $NonNegativeInteger => objNew(val,[agg,$Integer]) -; NIL -; type is ['Array,bds,D] => -; D = $PositiveInteger => objNew(val,['Array,bds,$NonNegativeInteger]) -; D = $NonNegativeInteger => objNew(val,['Array,bds,$Integer]) -; NIL -; type is ['List,D] => -; D isnt ['List,D'] => -; -- try to retract elements -; D = $PositiveInteger => objNew(val,['List,$NonNegativeInteger]) -; D = $NonNegativeInteger => objNew(val,['List,$Integer]) -; null val' => nil -;-- null (um := underDomainOf D) => nil -;-- objNewWrap(nil,['List,um]) -; vl := nil -; tl := nil -; bad := nil -; for e in val' while not bad repeat -; (e' := retract objNewWrap(e,D)) = 'failed => bad := true -; vl := [objValUnwrap e',:vl] -; tl := [objMode e',:tl] -; bad => NIL -; (m := resolveTypeListAny tl) = D => NIL -; D = equiType(m) => NIL -; vl' := nil -; for e in vl for t in tl repeat -; t = m => vl' := [e,:vl'] -; e' := coerceInt(objNewWrap(e,t),m) -; null e' => return NIL -; vl' := [objValUnwrap e',:vl'] -; objNewWrap(vl',['List,m]) -; D' = $PositiveInteger => -; objNew(val,['List,['List,$NonNegativeInteger]]) -; D' = $NonNegativeInteger => -; objNew(val,['List,['List,$Integer]]) -; D' is ['Variable,.] or D' is ['OrderedVariableList,.] => -; coerceInt(object,['List,['List,$Symbol]]) -; n := # val' -; m := # val'.0 -; null isRectangularList(val',n,m) => NIL -; coerceInt(object,['Matrix,D']) -; type is ['Expression,D] => -; [num,:den] := val' -; -- coerceRetract already handles case where den = 1 -; num isnt [0,:num] => NIL -; den isnt [0,:den] => NIL -; objNewWrap([num,:den],[$QuotientField, D]) -; type is ['SimpleAlgebraicExtension,k,rep,.] => -; -- try to retract as an element of rep and see if we can get an -; -- element of k -; val' := retract objNew(val,rep) -; while (val' ^= 'failed) and -; (equiType(objMode val') ^= k) repeat -; val' := retract val' -; val' = 'failed => NIL -; val' -; type is ['UnivariatePuiseuxSeries, coef, var, cen] => -; coerceInt(object, ['UnivariateLaurentSeries, coef, var, cen]) -; type is ['UnivariateLaurentSeries, coef, var, cen] => -; coerceInt(object, ['UnivariateTaylorSeries, coef, var, cen]) -; type is ['FunctionCalled,name] => -; null (m := get(name,'mode,$e)) => NIL -; isPartialMode m => NIL -; objNew(val,m) -; NIL - -(DEFUN |retract2Specialization| (|object|) - (PROG (|val| |type| |dom| |obj| |unionDoms| |x| |agg| |bds| |D'| - |bad| |vl| |tl| |e'| |vl'| |n| D |num| |den| |k| |rep| - |val'| |coef| |ISTMP#2| |var| |ISTMP#3| |cen| |ISTMP#1| - |name| |m|) - (DECLARE (SPECIAL |$e| |$QuotientField| |$Symbol| |$Integer| |$Any| - |$NonNegativeInteger| |$PositiveInteger|)) - (RETURN - (SEQ (PROGN - (setq |val| (|objVal| |object|)) - (setq |val'| (|unwrap| |val|)) - (setq |type| (|objMode| |object|)) - (COND - ((BOOT-EQUAL |type| |$Any|) (setq |dom| (CAR |val'|)) - (setq |obj| (CDR |val'|)) - (mkObjWrap |obj| |dom|)) - ((AND (CONSP |type|) (EQ (QCAR |type|) '|Union|) - (PROGN (setq |unionDoms| (QCDR |type|)) 'T)) - (|coerceUnion2Branch| |object|)) - ((BOOT-EQUAL |type| |$Symbol|) - (mkObjWrap 1 - (CONS '|OrderedVariableList| - (CONS (CONS |val'| NIL) NIL)))) - ((AND (CONSP |type|) - (EQ (QCAR |type|) '|OrderedVariableList|) - (PROGN - (setq |ISTMP#1| (QCDR |type|)) - (AND (CONSP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN - (setq |var| (QCAR |ISTMP#1|)) - 'T)))) - (|coerceInt| - (mkObjWrap (ELT |var| (- |val'| 1)) - |$Symbol|) - '(|Polynomial| (|Integer|)))) - ((AND (CONSP |type|) (EQ (QCAR |type|) '|Polynomial|) - (PROGN - (setq |ISTMP#1| (QCDR |type|)) - (AND (CONSP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (setq D (QCAR |ISTMP#1|)) 'T)))) - (COND - ((AND (CONSP |val'|) (EQUAL (QCAR |val'|) 1) - (PROGN - (setq |ISTMP#1| (QCDR |val'|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (setq |x| (QCAR |ISTMP#1|)) - 'T)))) - (setq |vl| - (REMDUP (REVERSE (|varsInPoly| |val'|)))) - (COND - ((EQL 1 (|#| |vl|)) - (|coerceInt| |object| - (CONS '|UnivariatePolynomial| - (CONS |x| (CONS D NIL))))) - ('T NIL))) - ((AND (CONSP |val'|) (EQUAL (QCAR |val'|) 0)) - (|coerceInt| |object| D)) - ('T NIL))) - ((AND (CONSP |type|) (EQ (QCAR |type|) '|Matrix|) - (PROGN - (setq |ISTMP#1| (QCDR |type|)) - (AND (CONSP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (setq D (QCAR |ISTMP#1|)) 'T)))) - (setq |n| (|#| |val'|)) - (setq |m| (|#| (ELT |val'| 0))) - (COND - ((BOOT-EQUAL |n| |m|) - (mkObj |val| - (CONS '|SquareMatrix| (CONS |n| (CONS D NIL))))) - ('T - (mkObj |val| - (CONS '|RectangularMatrix| - (CONS |n| (CONS |m| (CONS D NIL)))))))) - ((AND (CONSP |type|) - (EQ (QCAR |type|) '|RectangularMatrix|) - (PROGN - (setq |ISTMP#1| (QCDR |type|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (setq |n| (QCAR |ISTMP#1|)) - (setq |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (PROGN - (setq |m| (QCAR |ISTMP#2|)) - (setq |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND (CONSP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN - (setq D (QCAR |ISTMP#3|)) - 'T)))))))) - (COND - ((BOOT-EQUAL |n| |m|) - (mkObj |val| - (CONS '|SquareMatrix| (CONS |n| (CONS D NIL))))) - ('T NIL))) - ((AND (CONSP |type|) - (PROGN - (setq |agg| (QCAR |type|)) - (setq |ISTMP#1| (QCDR |type|)) - (AND (CONSP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (setq D (QCAR |ISTMP#1|)) 'T))) - (|member| |agg| - '(|Vector| |Segment| |UniversalSegment|))) - (COND - ((BOOT-EQUAL D |$PositiveInteger|) - (mkObj |val| - (CONS |agg| (CONS |$NonNegativeInteger| NIL)))) - ((BOOT-EQUAL D |$NonNegativeInteger|) - (mkObj |val| (CONS |agg| (CONS |$Integer| NIL)))) - ('T NIL))) - ((AND (CONSP |type|) (EQ (QCAR |type|) '|Array|) - (PROGN - (setq |ISTMP#1| (QCDR |type|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (setq |bds| (QCAR |ISTMP#1|)) - (setq |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (setq D (QCAR |ISTMP#2|)) - 'T)))))) - (COND - ((BOOT-EQUAL D |$PositiveInteger|) - (mkObj |val| - (CONS '|Array| - (CONS |bds| - (CONS |$NonNegativeInteger| NIL))))) - ((BOOT-EQUAL D |$NonNegativeInteger|) - (mkObj |val| - (CONS '|Array| - (CONS |bds| (CONS |$Integer| NIL))))) - ('T NIL))) - ((AND (CONSP |type|) (EQ (QCAR |type|) '|List|) - (PROGN - (setq |ISTMP#1| (QCDR |type|)) - (AND (CONSP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (setq D (QCAR |ISTMP#1|)) 'T)))) - (COND - ((NULL (AND (CONSP D) (EQ (QCAR D) '|List|) - (PROGN - (setq |ISTMP#1| (QCDR D)) - (AND (CONSP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN - (setq |D'| (QCAR |ISTMP#1|)) - 'T))))) - (COND - ((BOOT-EQUAL D |$PositiveInteger|) - (mkObj |val| - (CONS '|List| - (CONS |$NonNegativeInteger| NIL)))) - ((BOOT-EQUAL D |$NonNegativeInteger|) - (mkObj |val| - (CONS '|List| (CONS |$Integer| NIL)))) - ((NULL |val'|) NIL) - ('T (setq |vl| NIL) (setq |tl| NIL) - (setq |bad| NIL) - (DO ((G166347 |val'| (CDR G166347)) - (|e| NIL)) - ((OR (ATOM G166347) - (PROGN (SETQ |e| (CAR G166347)) NIL) - (NULL (NULL |bad|))) - NIL) - (SEQ (EXIT (COND - ((BOOT-EQUAL - (setq |e'| - (|retract| - (mkObjWrap |e| D))) - '|failed|) - (setq |bad| 'T)) - ('T - (setq |vl| - (CONS (|objValUnwrap| |e'|) - |vl|)) - (setq |tl| - (CONS (|objMode| |e'|) |tl|))))))) - (COND - (|bad| NIL) - ((BOOT-EQUAL - (setq |m| (|resolveTypeListAny| |tl|)) - D) - NIL) - ((BOOT-EQUAL D |m|) NIL) - ('T (setq |vl'| NIL) - (DO ((G166358 |vl| (CDR G166358)) - (|e| NIL) - (G166359 |tl| (CDR G166359)) - (|t| NIL)) - ((OR (ATOM G166358) - (PROGN - (SETQ |e| (CAR G166358)) - NIL) - (ATOM G166359) - (PROGN - (SETQ |t| (CAR G166359)) - NIL)) - NIL) - (SEQ (EXIT (COND - ((BOOT-EQUAL |t| |m|) - (setq |vl'| - (CONS |e| |vl'|))) - ('T - (setq |e'| - (|coerceInt| - (mkObjWrap |e| |t|) |m|)) - (COND - ((NULL |e'|) (RETURN NIL)) - ('T - (setq |vl'| - (CONS - (|objValUnwrap| |e'|) - |vl'|))))))))) - (mkObjWrap |vl'| - (CONS '|List| (CONS |m| NIL)))))))) - ((BOOT-EQUAL |D'| |$PositiveInteger|) - (mkObj |val| - (CONS '|List| - (CONS (CONS '|List| - (CONS |$NonNegativeInteger| NIL)) - NIL)))) - ((BOOT-EQUAL |D'| |$NonNegativeInteger|) - (mkObj |val| - (CONS '|List| - (CONS (CONS '|List| (CONS |$Integer| NIL)) - NIL)))) - ((OR (AND (CONSP |D'|) (EQ (QCAR |D'|) '|Variable|) - (PROGN - (setq |ISTMP#1| (QCDR |D'|)) - (AND (CONSP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL)))) - (AND (CONSP |D'|) - (EQ (QCAR |D'|) '|OrderedVariableList|) - (PROGN - (setq |ISTMP#1| (QCDR |D'|)) - (AND (CONSP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL))))) - (|coerceInt| |object| - (CONS '|List| - (CONS (CONS '|List| (CONS |$Symbol| NIL)) - NIL)))) - ('T (setq |n| (|#| |val'|)) - (setq |m| (|#| (ELT |val'| 0))) - (COND - ((NULL (|isRectangularList| |val'| |n| |m|)) NIL) - ('T - (|coerceInt| |object| - (CONS '|Matrix| (CONS |D'| NIL)))))))) - ((AND (CONSP |type|) (EQ (QCAR |type|) '|Expression|) - (PROGN - (setq |ISTMP#1| (QCDR |type|)) - (AND (CONSP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (setq D (QCAR |ISTMP#1|)) 'T)))) - (setq |num| (CAR |val'|)) - (setq |den| (CDR |val'|)) - (COND - ((NULL (AND (CONSP |num|) (EQUAL (QCAR |num|) 0) - (PROGN (setq |num| (QCDR |num|)) 'T))) - NIL) - ((NULL (AND (CONSP |den|) (EQUAL (QCAR |den|) 0) - (PROGN (setq |den| (QCDR |den|)) 'T))) - NIL) - ('T - (mkObjWrap (CONS |num| |den|) - (CONS |$QuotientField| (CONS D NIL)))))) - ((AND (CONSP |type|) - (EQ (QCAR |type|) '|SimpleAlgebraicExtension|) - (PROGN - (setq |ISTMP#1| (QCDR |type|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (setq |k| (QCAR |ISTMP#1|)) - (setq |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (PROGN - (setq |rep| (QCAR |ISTMP#2|)) - (setq |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND (CONSP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL)))))))) - (setq |val'| (|retract| (mkObj |val| |rep|))) - (DO () - ((NULL (AND (NEQUAL |val'| '|failed|) - (NEQUAL (|objMode| |val'|) - |k|))) - NIL) - (SEQ (EXIT (setq |val'| (|retract| |val'|))))) - (COND ((BOOT-EQUAL |val'| '|failed|) NIL) ('T |val'|))) - ((AND (CONSP |type|) - (EQ (QCAR |type|) '|UnivariatePuiseuxSeries|) - (PROGN - (setq |ISTMP#1| (QCDR |type|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (setq |coef| (QCAR |ISTMP#1|)) - (setq |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (PROGN - (setq |var| (QCAR |ISTMP#2|)) - (setq |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND (CONSP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN - (setq |cen| - (QCAR |ISTMP#3|)) - 'T)))))))) - (|coerceInt| |object| - (CONS '|UnivariateLaurentSeries| - (CONS |coef| (CONS |var| (CONS |cen| NIL)))))) - ((AND (CONSP |type|) - (EQ (QCAR |type|) '|UnivariateLaurentSeries|) - (PROGN - (setq |ISTMP#1| (QCDR |type|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (setq |coef| (QCAR |ISTMP#1|)) - (setq |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (PROGN - (setq |var| (QCAR |ISTMP#2|)) - (setq |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND (CONSP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN - (setq |cen| - (QCAR |ISTMP#3|)) - 'T)))))))) - (|coerceInt| |object| - (CONS '|UnivariateTaylorSeries| - (CONS |coef| (CONS |var| (CONS |cen| NIL)))))) - ((AND (CONSP |type|) - (EQ (QCAR |type|) '|FunctionCalled|) - (PROGN - (setq |ISTMP#1| (QCDR |type|)) - (AND (CONSP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN - (setq |name| (QCAR |ISTMP#1|)) - 'T)))) - (COND - ((NULL (setq |m| (|get| |name| '|mode| |$e|))) - NIL) - ((|isPartialMode| |m|) NIL) - ('T (mkObj |val| |m|)))) - ('T NIL))))))) ;coerceOrConvertOrRetract(T,m) == ; $useConvertForCoercions : local := true @@ -596,181 +107,6 @@ The special routines that do the coercions typically involve a "2" (setq |$useConvertForCoercions| 'T) (|coerceOrRetract| T$ |m|))))) -;coerceOrRetract(T,m) == -; (t' := coerceInteractive(T,m)) => t' -; t := T -; ans := nil -; repeat -; ans => return ans -; t := retract t -- retract is new name for pullback -; t = 'failed => return ans -; ans := coerceInteractive(t,m) -; ans - -(DEFUN |coerceOrRetract| (T$ |m|) - (PROG (|t'| |t| |ans|) - (RETURN - (SEQ (COND - ((setq |t'| (|coerceInteractive| T$ |m|)) |t'|) - ('T (setq |t| T$) (setq |ans| NIL) - (DO () (NIL NIL) - (SEQ (EXIT (COND - (|ans| (RETURN |ans|)) - ('T (setq |t| (|retract| |t|)) - (COND - ((BOOT-EQUAL |t| '|failed|) - (RETURN |ans|)) - ('T - (setq |ans| - (|coerceInteractive| |t| |m|))))))))) - |ans|)))))) - -;coerceRetract(object,t2) == -; -- tries to handle cases such as P I -> I -; (val := objValUnwrap(object)) = "$fromCoerceable$" => NIL -; t1 := objMode object -; t2 = $OutputForm => NIL -; isEqualOrSubDomain(t1,$Integer) and typeIsASmallInteger(t2) and SMINTP(val) => -; objNewWrap(val,t2) -; t1 = $Integer => NIL -; t1 = $Symbol => NIL -; t1 = $OutputForm => NIL -; (c := retractByFunction(object, t2)) => c -; t1 is [D,:.] => -; fun := GET(D,'retract) or -; INTERN STRCONC('"retract",princ-to-string D) -; functionp fun => -; PUT(D,'retract,fun) -; c := CATCH('coerceFailure,FUNCALL(fun,object,t2)) -; (c = $coerceFailure) => NIL -; c -; NIL -; NIL - -(DEFUN |coerceRetract| (|object| |t2|) - (PROG (|val| |t1| D |fun| |c|) - (DECLARE (SPECIAL |$coerceFailure| |$OutputForm| |$Symbol| - |$Integer|)) - (RETURN - (COND - ((BOOT-EQUAL (setq |val| (|objValUnwrap| |object|)) - '|$fromCoerceable$|) - NIL) - ('T (setq |t1| (|objMode| |object|)) - (COND - ((BOOT-EQUAL |t2| |$OutputForm|) NIL) - ((AND (|isEqualOrSubDomain| |t1| |$Integer|) - (|typeIsASmallInteger| |t2|) (typep |val| 'fixnum)) - (mkObjWrap |val| |t2|)) - ((BOOT-EQUAL |t1| |$Integer|) NIL) - ((BOOT-EQUAL |t1| |$Symbol|) NIL) - ((BOOT-EQUAL |t1| |$OutputForm|) NIL) - ((setq |c| (|retractByFunction| |object| |t2|)) |c|) - ((AND (CONSP |t1|) (PROGN (setq D (QCAR |t1|)) 'T)) - (setq |fun| - (OR (GETL D '|retract|) - (INTERN (STRCONC "retract" - (princ-to-string D))))) - (COND - ((canFuncall? |fun|) (PUT D '|retract| |fun|) - (setq |c| - (CATCH '|coerceFailure| - (FUNCALL |fun| |object| |t2|))) - (COND ((BOOT-EQUAL |c| |$coerceFailure|) NIL) ('T |c|))) - ('T NIL))) - ('T NIL))))))) - -;retractByFunction(object,u) == -; -- tries to retract by using function "retractIfCan" -; -- if the type belongs to the correct category. -; $reportBottomUpFlag: local := NIL -; t := objMode object -; -- JHD/CRF not ofCategory(t,['RetractableTo,u]) => NIL -; val := objValUnwrap object -; -- try to get and apply the function "retractable?" -; target := ['Union,u,'"failed"] -; funName := 'retractIfCan -; if $reportBottomUpFlag then -; sayFunctionSelection(funName,[t],target,NIL, -; '"coercion facility (retraction)") -; -- JHD/CRF if (mms := findFunctionInDomain(funName,t,target,[t],[t],'T,'T)) -; -- MCD: changed penultimate variable to NIL. -; if (mms := append(findFunctionInDomain(funName,t,target,[t],[t],NIL,'T), -; findFunctionInDomain(funName,u,target,[t],[t],NIL,'T))) -;-- The above two lines were: (RDJ/BMT 6/95) -;-- if (mms := append(findFunctionInDomain(funName,t,target,[t],[t],'T,'T), -;-- findFunctionInDomain(funName,u,target,[t],[t],'T,'T))) -; then mms := orderMms(funName,mms,[t],[t],target) -; if $reportBottomUpFlag then -; sayFunctionSelectionResult(funName,[t],mms) -; null mms => NIL -; -- [[dc,:.],slot,.]:= CAR mms -; dc := CAAAR mms -; slot := CADAR mms -; dcVector:= evalDomain dc -; fun := -;--+ -; compiledLookup(funName,[target,t],dcVector) -; NULL fun => NIL -; CAR(fun) = function Undef => NIL -;--+ -; $: fluid := dcVector -; object' := coerceUnion2Branch objNewWrap(SPADCALL(val,fun),target) -; u' := objMode object' -; u = u' => object' -; NIL - -(DEFUN |retractByFunction| (|object| |u|) - (PROG (|$reportBottomUpFlag| $ |t| |val| |target| |funName| |mms| - |dc| |slot| |dcVector| |fun| |object'| |u'|) - (DECLARE (SPECIAL |$reportBottomUpFlag| $)) - (RETURN - (PROGN - (setq |$reportBottomUpFlag| NIL) - (setq |t| (|objMode| |object|)) - (setq |val| (|objValUnwrap| |object|)) - (setq |target| - (CONS '|Union| - (CONS |u| (CONS "failed" NIL)))) - (setq |funName| '|retractIfCan|) - (COND - (|$reportBottomUpFlag| - (|sayFunctionSelection| |funName| (CONS |t| NIL) |target| - NIL "coercion facility (retraction)"))) - (COND - ((setq |mms| - (APPEND (|findFunctionInDomain| |funName| |t| - |target| (CONS |t| NIL) (CONS |t| NIL) - NIL 'T) - (|findFunctionInDomain| |funName| |u| - |target| (CONS |t| NIL) (CONS |t| NIL) - NIL 'T))) - (setq |mms| - (|orderMms| |funName| |mms| (CONS |t| NIL) - (CONS |t| NIL) |target|)))) - (COND - (|$reportBottomUpFlag| - (|sayFunctionSelectionResult| |funName| (CONS |t| NIL) - |mms|))) - (COND - ((NULL |mms|) NIL) - ('T (setq |dc| (CAAAR |mms|)) - (setq |slot| (CADAR |mms|)) - (setq |dcVector| (|evalDomain| |dc|)) - (setq |fun| - (|compiledLookup| |funName| - (CONS |target| (CONS |t| NIL)) |dcVector|)) - (COND - ((NULL |fun|) NIL) - ((BOOT-EQUAL (CAR |fun|) #'|Undef|) NIL) - ('T (setq $ |dcVector|) - (setq |object'| - (|coerceUnion2Branch| - (mkObjWrap (SPADCALL |val| |fun|) - |target|))) - (setq |u'| (|objMode| |object'|)) - (COND ((BOOT-EQUAL |u| |u'|) |object'|) ('T NIL)))))))))) - ;--% Coercion utilities ;-- The next function extracts the structural definition of constants ;-- from a given domain. For example, getConstantFromDomain('(One),S) @@ -832,59 +168,6 @@ domain modemap contains the constant [[$EmptyMode]] which indicates that the domain is not fully formed. In this case we return [[NIL]]. \end{enumerate} \begin{chunk}{*} -;getConstantFromDomain(form,domainForm) == -; isPartialMode domainForm => NIL -; opAlist := getOperationAlistFromLisplib first domainForm -; key := opOf form -; entryList := LASSOC(key,opAlist) -; entryList isnt [[sig, ., ., .]] => -; key = "One" => getConstantFromDomain(["1"], domainForm) -; key = "Zero" => getConstantFromDomain(["0"], domainForm) -; throwKeyedMsg("S2IC0008",[form,domainForm]) -; -- i.e., there should be exactly one item under this key of that form -; domain := evalDomain domainForm -; SPADCALL compiledLookupCheck(key,sig,domain) - -(DEFUN |getConstantFromDomain| (|form| |domainForm|) - (PROG (|opAlist| |key| |entryList| |ISTMP#1| |sig| |ISTMP#2| - |ISTMP#3| |ISTMP#4| |domain|) - (RETURN - (COND - ((|isPartialMode| |domainForm|) NIL) - ('T - (setq |opAlist| - (|getOperationAlistFromLisplib| (CAR |domainForm|))) - (setq |key| (|opOf| |form|)) - (setq |entryList| (LASSOC |key| |opAlist|)) - (COND - ((NULL (AND (CONSP |entryList|) (EQ (QCDR |entryList|) NIL) - (PROGN - (setq |ISTMP#1| (QCAR |entryList|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (setq |sig| (QCAR |ISTMP#1|)) - (setq |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (PROGN - (setq |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND (CONSP |ISTMP#3|) - (PROGN - (setq |ISTMP#4| - (QCDR |ISTMP#3|)) - (AND (CONSP |ISTMP#4|) - (EQ (QCDR |ISTMP#4|) NIL))))))))))) - (COND - ((BOOT-EQUAL |key| '|One|) - (|getConstantFromDomain| (CONS '|1| NIL) |domainForm|)) - ((BOOT-EQUAL |key| '|Zero|) - (|getConstantFromDomain| (CONS '|0| NIL) |domainForm|)) - ('T - (|throwKeyedMsg| "No such constant %1 in domain %2p ." - (CONS |form| (CONS |domainForm| NIL)))))) - ('T (setq |domain| (|evalDomain| |domainForm|)) - (SPADCALL (|compiledLookupCheck| |key| |sig| |domain|))))))))) - ;domainOne(domain) == getConstantFromDomain('(One),domain) (DEFUN |domainOne| (|domain|) @@ -913,25 +196,6 @@ that the domain is not fully formed. In this case we return [[NIL]]. (|algEqual| |object| (|getConstantFromDomain| '(|Zero|) |domain|) |domain|)) -;algEqual(object1, object2, domain) == -; -- sees if 2 objects of the same domain are equal by using the -; -- "=" from the domain -; -- objects should not be wrapped -;-- eqfunc := getFunctionFromDomain("=",domain,[domain,domain]) -; eqfunc := compiledLookupCheck("=",[$Boolean,'$,'$],evalDomain domain) -; SPADCALL(object1,object2, eqfunc) - -(DEFUN |algEqual| (|object1| |object2| |domain|) - (PROG (|eqfunc|) - (DECLARE (SPECIAL |$Boolean|)) - (RETURN - (PROGN - (setq |eqfunc| - (|compiledLookupCheck| '= - (CONS |$Boolean| (CONS '$ (CONS '$ NIL))) - (|evalDomain| |domain|))) - (SPADCALL |object1| |object2| |eqfunc|))))) - \end{chunk} \begin{verbatim} main algorithms for canCoerceFrom and coerceInteractive @@ -1957,83 +1221,6 @@ Interpreter Coercion Query Functions |ans|))))) -;absolutelyCanCoerceByCheating(t1,t2) == -; -- this typically involves subdomains and towers where the only -; -- difference is a subdomain -; isEqualOrSubDomain(t1,t2) => true -; typeIsASmallInteger(t1) and t2 = $Integer => true -; ATOM(t1) or ATOM(t2) => false -; [tl1,:u1] := deconstructT t1 -; [tl2,:u2] := deconstructT t2 -; tl1 = '(Stream) and tl2 = '(InfiniteTuple) => -; #u1 ^= #u2 => false -; "and"/[absolutelyCanCoerceByCheating(x1,x2) for x1 in u1 for x2 in u2] -; tl1 ^= tl2 => false -; #u1 ^= #u2 => false -; "and"/[absolutelyCanCoerceByCheating(x1,x2) for x1 in u1 for x2 in u2] - -(DEFUN |absolutelyCanCoerceByCheating| (|t1| |t2|) - (PROG (|tl1| |u1| |LETTMP#1| |tl2| |u2|) - (DECLARE (SPECIAL |$Integer|)) - (RETURN - (SEQ (COND - ((|isEqualOrSubDomain| |t1| |t2|) 'T) - ((AND (|typeIsASmallInteger| |t1|) - (BOOT-EQUAL |t2| |$Integer|)) - 'T) - ((OR (ATOM |t1|) (ATOM |t2|)) NIL) - ('T (setq |LETTMP#1| (|deconstructT| |t1|)) - (setq |tl1| (CAR |LETTMP#1|)) - (setq |u1| (CDR |LETTMP#1|)) - (setq |LETTMP#1| (|deconstructT| |t2|)) - (setq |tl2| (CAR |LETTMP#1|)) - (setq |u2| (CDR |LETTMP#1|)) - (COND - ((AND (BOOT-EQUAL |tl1| '(|Stream|)) - (BOOT-EQUAL |tl2| '(|InfiniteTuple|))) - (COND - ((NEQUAL (|#| |u1|) (|#| |u2|)) NIL) - ('T - (PROG (G167180) - (setq G167180 'T) - (RETURN - (DO ((G167187 NIL (NULL G167180)) - (G167188 |u1| (CDR G167188)) - (|x1| NIL) - (G167189 |u2| (CDR G167189)) - (|x2| NIL)) - ((OR G167187 (ATOM G167188) - (PROGN - (SETQ |x1| (CAR G167188)) - NIL) - (ATOM G167189) - (PROGN - (SETQ |x2| (CAR G167189)) - NIL)) - G167180) - (SEQ (EXIT (SETQ G167180 - (AND G167180 - (|absolutelyCanCoerceByCheating| - |x1| |x2|))))))))))) - ((NEQUAL |tl1| |tl2|) NIL) - ((NEQUAL (|#| |u1|) (|#| |u2|)) NIL) - ('T - (PROG (G167199) - (setq G167199 'T) - (RETURN - (DO ((G167206 NIL (NULL G167199)) - (G167207 |u1| (CDR G167207)) (|x1| NIL) - (G167208 |u2| (CDR G167208)) (|x2| NIL)) - ((OR G167206 (ATOM G167207) - (PROGN (SETQ |x1| (CAR G167207)) NIL) - (ATOM G167208) - (PROGN (SETQ |x2| (CAR G167208)) NIL)) - G167199) - (SEQ (EXIT (SETQ G167199 - (AND G167199 - (|absolutelyCanCoerceByCheating| - |x1| |x2|)))))))))))))))) - ;absolutelyCannotCoerce(t1,t2) == ; -- response of true means "definitely cannot coerce" ; -- this is largely an efficiency hack @@ -2150,1017 +1337,29 @@ Interpreter Coercion Query Functions (DECLARE (SPECIAL |$SingleInteger|)) (BOOT-EQUAL |x| |$SingleInteger|)) -;--% Interpreter Coercion Functions -;coerceInteractive(triple,t2) == -; -- bind flag for recording/reporting instantiations -; -- (see recordInstantiation) -; t1 := objMode triple -; val := objVal triple -; null(t2) or t2 = $EmptyMode => NIL -; t2 = t1 => triple -; t2 = '$NoValueMode => objNew(val,t2) -; if t2 is ['SubDomain,x,.] then t2:= x -; -- JHD added category Aug 1996 for BasicMath -; t1 in '((Category) (Mode) (Domain) (SubDomain (Domain))) => -; t2 = $OutputForm => objNew(val,t2) -; NIL -; t1 = '$NoValueMode => -; if $compilingMap then clearDependentMaps($mapName,nil) -; throwKeyedMsg("S2IC0009",[t2,$mapName]) -; $insideCoerceInteractive: local := true -; expr2 := EQUAL(t2,$OutputForm) -; if expr2 then startTimingProcess 'print -; else startTimingProcess 'coercion -; -- next 2 lines handle cases like '"failed" -; result := -; expr2 and (t1 = val) => objNew(val,$OutputForm) -; expr2 and t1 is ['Variable,var] => objNewWrap(var,$OutputForm) -; coerceInt0(triple,t2) -; if expr2 then stopTimingProcess 'print -; else stopTimingProcess 'coercion -; result - -(DEFUN |coerceInteractive| (|triple| |t2|) - (PROG (|$insideCoerceInteractive| |t1| |val| |x| |ISTMP#2| |expr2| - |ISTMP#1| |var| |result|) - (DECLARE (SPECIAL |$insideCoerceInteractive| |$OutputForm| - |$mapName| |$compilingMap| |$NoValueMode| - |$EmptyMode|)) - (RETURN - (PROGN - (setq |t1| (|objMode| |triple|)) - (setq |val| (|objVal| |triple|)) - (COND - ((OR (NULL |t2|) (BOOT-EQUAL |t2| |$EmptyMode|)) NIL) - ((BOOT-EQUAL |t2| |t1|) |triple|) - ((BOOT-EQUAL |t2| '|$NoValueMode|) (mkObj |val| |t2|)) - ('T - (COND - ((AND (CONSP |t2|) (EQ (QCAR |t2|) '|SubDomain|) - (PROGN - (setq |ISTMP#1| (QCDR |t2|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (setq |x| (QCAR |ISTMP#1|)) - (setq |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL)))))) - (setq |t2| |x|))) - (COND - ((|member| |t1| - '((|Category|) (|Mode|) (|Domain|) - (|SubDomain| (|Domain|)))) - (COND - ((BOOT-EQUAL |t2| |$OutputForm|) (mkObj |val| |t2|)) - ('T NIL))) - ((BOOT-EQUAL |t1| '|$NoValueMode|) - (COND - (|$compilingMap| (|clearDependentMaps| |$mapName| NIL))) - (|throwKeyedMsg| - (format nil - "You are trying to use something (probably a loop) in a ~ - situation where a value is expected. In particular, you ~ - are trying to convert this to the type %1p . The following ~ - information may help: possible function name: %2p") - (CONS |t2| (CONS |$mapName| NIL)))) - ('T (setq |$insideCoerceInteractive| 'T) - (setq |expr2| (BOOT-EQUAL |t2| |$OutputForm|)) - (COND - (|expr2| (|startTimingProcess| '|print|)) - ('T (|startTimingProcess| '|coercion|))) - (setq |result| - (COND - ((AND |expr2| (BOOT-EQUAL |t1| |val|)) - (mkObj |val| |$OutputForm|)) - ((AND |expr2| (CONSP |t1|) - (EQ (QCAR |t1|) '|Variable|) - (PROGN - (setq |ISTMP#1| (QCDR |t1|)) - (AND (CONSP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN - (setq |var| - (QCAR |ISTMP#1|)) - 'T)))) - (mkObjWrap |var| |$OutputForm|)) - ('T (|coerceInt0| |triple| |t2|)))) - (COND - (|expr2| (|stopTimingProcess| '|print|)) - ('T (|stopTimingProcess| '|coercion|))) - |result|)))))))) - -;coerceInt0(triple,t2) == -; -- top level interactive coercion, which transfers all RN, RF and RR -; -- into equivalent types -; val := objVal triple -; t1 := objMode triple -; val='_$fromCoerceable_$ => canCoerceFrom(t1,t2) -; t1 = t2 => triple -; if t2 = $OutputForm then -; s1 := t1 -; s2 := t2 -; else -; s1 := equiType(t1) -; s2 := equiType(t2) -; s1 = s2 => return objNew(val,t2) -; -- t1 is ['Mapping,:.] and t2 ^= '(Any) => NIL -; -- note: may be able to coerce TO mapping -; -- treat Exit like Any -; -- handle case where we must generate code -; null(isWrapped val) and -; (t1 isnt ['FunctionCalled,:.] or not $genValue)=> -; intCodeGenCOERCE(triple,t2) -; t1 = $Any and t2 ^= $OutputForm and ([t1',:val'] := unwrap val) and -; (ans := coerceInt0(objNewWrap(val',t1'),t2)) => ans -; if not EQ(s1,t1) then triple := objNew(val,s1) -; x := coerceInt(triple,s2) => -; EQ(s2,t2) => x -; objSetMode(x,t2) -; x -; NIL - -(DEFUN |coerceInt0| (|triple| |t2|) - (PROG (|val| |t1| |s1| |s2| |LETTMP#1| |t1'| |val'| |ans| |x|) - (DECLARE (SPECIAL |$OutputForm| |$Any| |$genValue|)) - (RETURN - (PROGN - (setq |val| (|objVal| |triple|)) - (setq |t1| (|objMode| |triple|)) - (COND - ((BOOT-EQUAL |val| '|$fromCoerceable$|) - (|canCoerceFrom| |t1| |t2|)) - ((BOOT-EQUAL |t1| |t2|) |triple|) - ('T - (COND - ((BOOT-EQUAL |t2| |$OutputForm|) (setq |s1| |t1|) - (setq |s2| |t2|)) - ('T (setq |s1| |t1|) - (setq |s2| |t2|) - (COND - ((BOOT-EQUAL |s1| |s2|) (RETURN (mkObj |val| |t2|)))))) - (COND - ((AND (NULL (|isWrapped| |val|)) - (OR (NULL (AND (CONSP |t1|) - (EQ (QCAR |t1|) '|FunctionCalled|))) - (NULL |$genValue|))) - (|intCodeGenCOERCE| |triple| |t2|)) - ((AND (BOOT-EQUAL |t1| |$Any|) (NEQUAL |t2| |$OutputForm|) - (PROGN - (setq |LETTMP#1| (|unwrap| |val|)) - (setq |t1'| (CAR |LETTMP#1|)) - (setq |val'| (CDR |LETTMP#1|)) - |LETTMP#1|) - (setq |ans| - (|coerceInt0| (mkObjWrap |val'| |t1'|) - |t2|))) - |ans|) - ('T - (COND - ((NULL (EQ |s1| |t1|)) - (setq |triple| (mkObj |val| |s1|)))) - (COND - ((setq |x| (|coerceInt| |triple| |s2|)) - (COND - ((EQ |s2| |t2|) |x|) - ('T (|objSetMode| |x| |t2|) |x|))) - ('T NIL)))))))))) - -;coerceInt(triple, t2) == -; val := coerceInt1(triple, t2) => val -; t1 := objMode triple -; t1 is ['Variable, :.] => -; newMode := getMinimalVarMode(unwrap objVal triple, nil) -; newVal := coerceInt(triple, newMode) -; coerceInt(newVal, t2) -; nil - -(DEFUN |coerceInt| (|triple| |t2|) - (PROG (|val| |t1| |newMode| |newVal|) - (RETURN - (COND - ((setq |val| (|coerceInt1| |triple| |t2|)) |val|) - ('T (setq |t1| (|objMode| |triple|)) - (COND - ((AND (CONSP |t1|) (EQ (QCAR |t1|) '|Variable|)) - (setq |newMode| - (|getMinimalVarMode| - (|unwrap| (|objVal| |triple|)) NIL)) - (setq |newVal| (|coerceInt| |triple| |newMode|)) - (|coerceInt| |newVal| |t2|)) - ('T NIL))))))) - -;coerceInt1(triple,t2) == -; -- general interactive coercion -; -- the result is a new triple with type m2 or NIL (= failed) -; $useCoerceOrCroak: local := true -; t2 = $EmptyMode => NIL -; t1 := objMode triple -; t1=t2 => triple -; val := objVal triple -; absolutelyCanCoerceByCheating(t1,t2) => objNew(val,t2) -; isSubDomain(t2, t1) => coerceSubDomain(val, t1, t2) -; if typeIsASmallInteger(t1) then -; (t2 = $Integer) or typeIsASmallInteger(t2) => return objNew(val,t2) -; sintp := SINTP val -; sintp and (t2 = $PositiveInteger) and val > 0 => return objNew(val,t2) -; sintp and (t2 = $NonNegativeInteger) and val >= 0 => return objNew(val,t2) -; typeIsASmallInteger(t2) and isEqualOrSubDomain(t1, $Integer) and INTP val => -; SINTP val => objNew(val,t2) -; NIL -; t2 = $Void => objNew(voidValue(),$Void) -; t2 = $Any => objNewWrap([t1,:unwrap val],'(Any)) -; t1 = $Any and t2 ^= $OutputForm and ([t1',:val'] := unwrap val) and -; (ans := coerceInt(objNewWrap(val',t1'),t2)) => ans -; -- next is for tagged union selectors for the time being -; t1 is ['Variable,=t2] or t2 is ['Variable,=t1] => objNew(val,t2) -; STRINGP t2 => -; t1 is ['Variable,v] and (t2 = PNAME(v)) => objNewWrap(t2,t2) -; val' := unwrap val -; (t2 = val') and ((val' = t1) or (t1 = $String)) => objNew(val,t2) -; NIL -; -- t1 is ['Tuple,S] and t2 ^= '(OutputForm) => -; t1 is ['Tuple,S] => -; coerceInt1(objNewWrap(asTupleAsList unwrap val, ['List, S]), t2) -; t1 is ['Union,:.] => coerceIntFromUnion(triple,t2) -; t2 is ['Union,:.] => coerceInt2Union(triple,t2) -; (STRINGP t1) and (t2 = $String) => objNew(val,$String) -; (STRINGP t1) and (t2 is ['Variable,v]) => -; t1 = PNAME(v) => objNewWrap(v,t2) -; NIL -; (STRINGP t1) and (t1 = unwrap val) => -; t2 = $OutputForm => objNew(t1,$OutputForm) -; NIL -; atom t1 => NIL -; if t1 = $AnonymousFunction and (t2 is ['Mapping,target,:margl]) then -; $useCoerceOrCroak := nil -; [.,vars,:body] := unwrap val -; vars := -; atom vars => [vars] -; vars is ['Tuple,:.] => rest vars -; vars -; #margl ^= #vars => 'continue -; tree := mkAtree ['ADEF,vars,[target,:margl],[NIL for x in rest t2],:body] -; CATCH('coerceOrCroaker, bottomUp tree) = 'croaked => nil -; return getValue tree -; (t1 = $Symbol) and (t2 is ['Mapping,target,:margl]) => -; null (mms := selectMms1(unwrap val,nil,margl,margl,target)) => NIL -; [dc,targ,:argl] := CAAR mms -; targ ^= target => NIL -; $genValue => -; fun := getFunctionFromDomain(unwrap val,dc,argl) -; objNewWrap(fun,t2) -; val := NRTcompileEvalForm(unwrap val, CDR CAAR mms, evalDomain dc) -; objNew(val, t2) -; (t1 is ['Variable,sym]) and (t2 is ['Mapping,target,:margl]) => -; null (mms := selectMms1(sym,target,margl,margl,NIL)) => -; null (mms := selectMms1(sym,target,margl,margl,true)) => NIL -; [dc,targ,:argl] := CAAR mms -; targ ^= target => NIL -; dc is ["__FreeFunction__",:freeFun] => objNew( freeFun, t2 ) -; $genValue => objNewWrap( getFunctionFromDomain(sym,dc,argl), t2 ) -; val := NRTcompileEvalForm(sym, CDR CAAR mms, evalDomain dc) -; objNew(val, t2) -; (t1 is ['FunctionCalled,sym]) and (t2 is ['Mapping,target,:margl]) => -; symNode := mkAtreeNode sym -; transferPropsToNode(sym,symNode) -; null (mms := selectLocalMms(symNode,sym,margl,target)) => NIL -; [dc,targ,:argl] := CAAR mms -; targ ^= target => NIL -; ml := [target,:margl] -; intName := -; or/[mm for mm in mms | (mm is [[., :ml1],oldName,:.] -; and compareTypeLists(ml1,ml))] => [oldName] -; NIL -; null intName => NIL -; objNewWrap(intName,t2) -; (t1 is ['FunctionCalled,sym]) => -; (t3 := get(sym,'mode,$e)) and t3 is ['Mapping,:.] => -; (triple' := coerceInt(triple,t3)) => coerceInt(triple',t2) -; NIL -; NIL -; EQ(CAR(t1),'Variable) and CONSP(t2) and -; (isEqualOrSubDomain(t2,$Integer) or -; (t2 = [$QuotientField, $Integer]) or MEMQ(CAR(t2), -; '(RationalNumber BigFloat NewFloat Float DoubleFloat))) => NIL -; ans := coerceRetract(triple,t2) or coerceIntTower(triple,t2) or -; [.,:arg]:= deconstructT t2 -; arg and -; t:= coerceInt(triple,last arg) -; t and coerceByFunction(t,t2) -; ans or (isSubDomain(t1,$Integer) and -; coerceInt(objNew(val,$Integer),t2)) or -; coerceIntAlgebraicConstant(triple,t2) or -; coerceIntX(val,t1,t2) +;getUnionOrRecordTags u == +; tags := nil +; if u is ['Union, :tl] or u is ['Record, :tl] then +; for t in tl repeat +; if t is [":",tag,.] then tags := cons(tag, tags) +; tags -(DEFUN |coerceInt1| (|triple| |t2|) - (PROG (|$useCoerceOrCroak| |t1| |sintp| |t1'| |val'| S |v| |body| - |vars| |tree| |fun| |freeFun| |val| |target| |margl| - |symNode| |mms| |dc| |targ| |argl| |ml| |ml1| |ISTMP#2| - |oldName| |intName| |ISTMP#1| |sym| |t3| |triple'| - |LETTMP#1| |arg| |t| |ans|) - (DECLARE (SPECIAL |$useCoerceOrCroak| |$Integer| |$QuotientField| - |$e| |$genValue| |$Symbol| |$AnonymousFunction| - |$OutputForm| |$String| |$Any| |$Void| - |$NonNegativeInteger| |$PositiveInteger| - |$EmptyMode|)) +(DEFUN |getUnionOrRecordTags| (|u|) + (PROG (|tl| |ISTMP#1| |tag| |ISTMP#2| |tags|) (RETURN (SEQ (PROGN - (setq |$useCoerceOrCroak| 'T) + (setq |tags| NIL) (COND - ((BOOT-EQUAL |t2| |$EmptyMode|) NIL) - ('T (setq |t1| (|objMode| |triple|)) - (COND - ((BOOT-EQUAL |t1| |t2|) |triple|) - ('T (setq |val| (|objVal| |triple|)) - (COND - ((|absolutelyCanCoerceByCheating| |t1| |t2|) - (mkObj |val| |t2|)) - ((|isSubDomain| |t2| |t1|) - (|coerceSubDomain| |val| |t1| |t2|)) - ('T - (COND - ((|typeIsASmallInteger| |t1|) - (COND - ((OR (BOOT-EQUAL |t2| |$Integer|) - (|typeIsASmallInteger| |t2|)) - (RETURN (mkObj |val| |t2|))) - ('T (setq |sintp| (typep |val| 'fixnum)) - (COND - ((AND |sintp| - (BOOT-EQUAL |t2| - |$PositiveInteger|) - (> |val| 0)) - (RETURN (mkObj |val| |t2|))) - ((AND |sintp| - (BOOT-EQUAL |t2| - |$NonNegativeInteger|) - (>= |val| 0)) - (RETURN (mkObj |val| |t2|)))))))) - (COND - ((AND (|typeIsASmallInteger| |t2|) - (|isEqualOrSubDomain| |t1| |$Integer|) - (integerp |val|)) - (COND - ((typep |val| 'fixnum) (mkObj |val| |t2|)) - ('T NIL))) - ((BOOT-EQUAL |t2| |$Void|) - (mkObj (|voidValue|) |$Void|)) - ((BOOT-EQUAL |t2| |$Any|) - (mkObjWrap (CONS |t1| (|unwrap| |val|)) - '(|Any|))) - ((AND (BOOT-EQUAL |t1| |$Any|) - (NEQUAL |t2| |$OutputForm|) - (PROGN - (setq |LETTMP#1| (|unwrap| |val|)) - (setq |t1'| (CAR |LETTMP#1|)) - (setq |val'| (CDR |LETTMP#1|)) - |LETTMP#1|) - (setq |ans| - (|coerceInt| - (mkObjWrap |val'| |t1'|) - |t2|))) - |ans|) - ((OR (AND (CONSP |t1|) - (EQ (QCAR |t1|) '|Variable|) - (PROGN - (setq |ISTMP#1| (QCDR |t1|)) - (AND (CONSP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (EQUAL (QCAR |ISTMP#1|) |t2|)))) - (AND (CONSP |t2|) - (EQ (QCAR |t2|) '|Variable|) - (PROGN - (setq |ISTMP#1| (QCDR |t2|)) - (AND (CONSP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (EQUAL (QCAR |ISTMP#1|) |t1|))))) - (mkObj |val| |t2|)) - ((STRINGP |t2|) - (COND - ((AND (CONSP |t1|) - (EQ (QCAR |t1|) '|Variable|) - (PROGN - (setq |ISTMP#1| (QCDR |t1|)) - (AND (CONSP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN - (setq |v| (QCAR |ISTMP#1|)) - 'T))) - (BOOT-EQUAL |t2| (PNAME |v|))) - (mkObjWrap |t2| |t2|)) - ('T (setq |val'| (|unwrap| |val|)) - (COND - ((AND (BOOT-EQUAL |t2| |val'|) - (OR (BOOT-EQUAL |val'| |t1|) - (BOOT-EQUAL |t1| |$String|))) - (mkObj |val| |t2|)) - ('T NIL))))) - ((AND (CONSP |t1|) (EQ (QCAR |t1|) '|Tuple|) - (PROGN - (setq |ISTMP#1| (QCDR |t1|)) - (AND (CONSP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN - (setq S (QCAR |ISTMP#1|)) - 'T)))) - (|coerceInt1| - (mkObjWrap - (|asTupleAsList| (|unwrap| |val|)) - (CONS '|List| (CONS S NIL))) - |t2|)) - ((AND (CONSP |t1|) (EQ (QCAR |t1|) '|Union|)) - (|coerceIntFromUnion| |triple| |t2|)) - ((AND (CONSP |t2|) (EQ (QCAR |t2|) '|Union|)) - (|coerceInt2Union| |triple| |t2|)) - ((AND (STRINGP |t1|) - (BOOT-EQUAL |t2| |$String|)) - (mkObj |val| |$String|)) - ((AND (STRINGP |t1|) (CONSP |t2|) - (EQ (QCAR |t2|) '|Variable|) - (PROGN - (setq |ISTMP#1| (QCDR |t2|)) - (AND (CONSP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN - (setq |v| (QCAR |ISTMP#1|)) - 'T)))) - (COND - ((BOOT-EQUAL |t1| (PNAME |v|)) - (mkObjWrap |v| |t2|)) - ('T NIL))) - ((AND (STRINGP |t1|) - (BOOT-EQUAL |t1| (|unwrap| |val|))) - (COND - ((BOOT-EQUAL |t2| |$OutputForm|) - (mkObj |t1| |$OutputForm|)) - ('T NIL))) - ((ATOM |t1|) NIL) - ('T - (COND - ((AND (BOOT-EQUAL |t1| |$AnonymousFunction|) - (CONSP |t2|) - (EQ (QCAR |t2|) '|Mapping|) - (PROGN - (setq |ISTMP#1| (QCDR |t2|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (setq |target| - (QCAR |ISTMP#1|)) - (setq |margl| - (QCDR |ISTMP#1|)) - 'T)))) - (setq |$useCoerceOrCroak| NIL) - (setq |LETTMP#1| (|unwrap| |val|)) - (setq |vars| (CADR |LETTMP#1|)) - (setq |body| (CDDR |LETTMP#1|)) - (setq |vars| - (COND - ((ATOM |vars|) - (CONS |vars| NIL)) - ((AND (CONSP |vars|) - (EQ (QCAR |vars|) '|Tuple|)) - (CDR |vars|)) - ('T |vars|))) - (COND - ((NEQUAL (|#| |margl|) (|#| |vars|)) - '|continue|) - ('T - (setq |tree| - (|mkAtree| - (CONS 'ADEF - (CONS |vars| - (CONS - (CONS |target| |margl|) - (CONS - (PROG (G167455) - (setq G167455 NIL) - (RETURN - (DO - ((G167460 - (CDR |t2|) - (CDR G167460)) - (|x| NIL)) - ((OR (ATOM G167460) - (PROGN - (SETQ |x| - (CAR G167460)) - NIL)) - (NREVERSE0 - G167455)) - (SEQ - (EXIT - (SETQ G167455 - (CONS NIL - G167455))))))) - |body|)))))) - (COND - ((BOOT-EQUAL - (CATCH '|coerceOrCroaker| - (|bottomUp| |tree|)) - '|croaked|) - NIL) - ('T (RETURN (|getValue| |tree|)))))))) - (COND - ((AND (BOOT-EQUAL |t1| |$Symbol|) - (CONSP |t2|) - (EQ (QCAR |t2|) '|Mapping|) - (PROGN - (setq |ISTMP#1| (QCDR |t2|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (setq |target| - (QCAR |ISTMP#1|)) - (setq |margl| - (QCDR |ISTMP#1|)) - 'T)))) - (COND - ((NULL (setq |mms| - (|selectMms1| (|unwrap| |val|) - NIL |margl| |margl| |target|))) - NIL) - ('T (setq |LETTMP#1| (CAAR |mms|)) - (setq |dc| (CAR |LETTMP#1|)) - (setq |targ| (CADR |LETTMP#1|)) - (setq |argl| (CDDR |LETTMP#1|)) - (COND - ((NEQUAL |targ| |target|) NIL) - (|$genValue| - (setq |fun| - (|getFunctionFromDomain| - (|unwrap| |val|) |dc| |argl|)) - (mkObjWrap |fun| |t2|)) - ('T - (setq |val| - (|NRTcompileEvalForm| - (|unwrap| |val|) - (CDR (CAAR |mms|)) - (|evalDomain| |dc|))) - (mkObj |val| |t2|)))))) - ((AND (CONSP |t1|) - (EQ (QCAR |t1|) '|Variable|) - (PROGN - (setq |ISTMP#1| (QCDR |t1|)) - (AND (CONSP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN - (setq |sym| (QCAR |ISTMP#1|)) - 'T))) - (CONSP |t2|) - (EQ (QCAR |t2|) '|Mapping|) - (PROGN - (setq |ISTMP#1| (QCDR |t2|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (setq |target| - (QCAR |ISTMP#1|)) - (setq |margl| - (QCDR |ISTMP#1|)) - 'T)))) - (SEQ (COND - ((NULL - (setq |mms| - (|selectMms1| |sym| |target| - |margl| |margl| NIL))) - (EXIT - (COND - ((NULL - (setq |mms| - (|selectMms1| |sym| |target| - |margl| |margl| T))) - (EXIT NIL)))))) - (setq |LETTMP#1| (CAAR |mms|)) - (setq |dc| (CAR |LETTMP#1|)) - (setq |targ| (CADR |LETTMP#1|)) - (setq |argl| (CDDR |LETTMP#1|)) - (COND - ((NEQUAL |targ| |target|) - (EXIT NIL)) - ((AND (CONSP |dc|) - (EQ (QCAR |dc|) '|_FreeFunction_|) - (PROGN - (setq |freeFun| (QCDR |dc|)) - 'T)) - (EXIT (mkObj |freeFun| |t2|)))) - (COND - (|$genValue| - (EXIT - (mkObjWrap - (|getFunctionFromDomain| |sym| - |dc| |argl|) - |t2|)))) - (setq |val| - (|NRTcompileEvalForm| |sym| - (CDR (CAAR |mms|)) - (|evalDomain| |dc|))) - (mkObj |val| |t2|))) - ((AND (CONSP |t1|) - (EQ (QCAR |t1|) '|FunctionCalled|) - (PROGN - (setq |ISTMP#1| (QCDR |t1|)) - (AND (CONSP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN - (setq |sym| (QCAR |ISTMP#1|)) - 'T))) - (CONSP |t2|) - (EQ (QCAR |t2|) '|Mapping|) - (PROGN - (setq |ISTMP#1| (QCDR |t2|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (setq |target| - (QCAR |ISTMP#1|)) - (setq |margl| - (QCDR |ISTMP#1|)) - 'T)))) - (setq |symNode| (|mkAtreeNode| |sym|)) - (|transferPropsToNode| |sym| |symNode|) - (COND - ((NULL (setq |mms| - (|selectLocalMms| |symNode| |sym| - |margl| |target|))) - NIL) - ('T (setq |LETTMP#1| (CAAR |mms|)) - (setq |dc| (CAR |LETTMP#1|)) - (setq |targ| (CADR |LETTMP#1|)) - (setq |argl| (CDDR |LETTMP#1|)) - (COND - ((NEQUAL |targ| |target|) NIL) - ('T - (setq |ml| - (CONS |target| |margl|)) - (setq |intName| - (COND - ((PROG (G167466) - (setq G167466 NIL) - (RETURN - (DO - ((G167473 NIL - G167466) - (G167474 |mms| - (CDR G167474)) - (|mm| NIL)) - ((OR G167473 - (ATOM G167474) - (PROGN - (SETQ |mm| - (CAR G167474)) - NIL)) - G167466) - (SEQ - (EXIT - (COND - ((AND - (CONSP |mm|) - (PROGN - (setq - |ISTMP#1| - (QCAR - |mm|)) - (AND - (CONSP - |ISTMP#1|) - (PROGN - (setq - |ml1| - (QCDR - |ISTMP#1|)) - 'T))) - (PROGN - (setq - |ISTMP#2| - (QCDR - |mm|)) - (AND - (CONSP - |ISTMP#2|) - (PROGN - (setq - |oldName| - (QCAR - |ISTMP#2|)) - 'T))) - (|compareTypeLists| - |ml1| |ml|)) - (SETQ - G167466 - (OR G167466 - |mm|))))))))) - (CONS |oldName| NIL)) - ('T NIL))) - (COND - ((NULL |intName|) NIL) - ('T (mkObjWrap |intName| |t2|)))))))) - ((AND (CONSP |t1|) - (EQ (QCAR |t1|) '|FunctionCalled|) - (PROGN - (setq |ISTMP#1| (QCDR |t1|)) - (AND (CONSP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN - (setq |sym| (QCAR |ISTMP#1|)) - 'T)))) - (COND - ((AND (setq |t3| - (|get| |sym| '|mode| |$e|)) - (CONSP |t3|) - (EQ (QCAR |t3|) '|Mapping|)) - (COND - ((setq |triple'| - (|coerceInt| |triple| |t3|)) - (|coerceInt| |triple'| |t2|)) - ('T NIL))) - ('T NIL))) - ((AND (EQ (CAR |t1|) '|Variable|) - (CONSP |t2|) - (OR (|isEqualOrSubDomain| |t2| - |$Integer|) - (BOOT-EQUAL |t2| - (CONS |$QuotientField| - (CONS |$Integer| NIL))) - (member (CAR |t2|) - '(|RationalNumber| |BigFloat| - |NewFloat| |Float| - |DoubleFloat|)))) - NIL) - ('T - (setq |ans| - (OR - (|coerceRetract| |triple| |t2|) - (|coerceIntTower| |triple| |t2|) - (PROGN - (setq |LETTMP#1| - (|deconstructT| |t2|)) - (setq |arg| - (CDR |LETTMP#1|)) - (AND |arg| - (PROGN - (setq |t| - (|coerceInt| |triple| - (|last| |arg|))) - (AND |t| - (|coerceByFunction| |t| - |t2|))))))) - (OR |ans| - (AND (|isSubDomain| |t1| |$Integer|) - (|coerceInt| - (mkObj |val| |$Integer|) |t2|)) - (|coerceIntAlgebraicConstant| |triple| - |t2|) - (|coerceIntX| |val| |t1| |t2|))))))))))))))))) - -;coerceSubDomain(val, tSuper, tSub) == -; -- Try to coerce from a sub domain to a super domain -; val = '_$fromCoerceable_$ => nil -; super := GETDATABASE(first tSub, 'SUPERDOMAIN) -; superDomain := first super -; superDomain = tSuper => -; coerceImmediateSubDomain(val, tSuper, tSub, CADR super) -; coerceSubDomain(val, tSuper, superDomain) => -; coerceImmediateSubDomain(val, superDomain, tSub, CADR super) -; nil - -(DEFUN |coerceSubDomain| (|val| |tSuper| |tSub|) - (PROG (|super| |superDomain|) - (RETURN - (COND - ((BOOT-EQUAL |val| '|$fromCoerceable$|) NIL) - ('T (setq |super| (GETDATABASE (CAR |tSub|) 'SUPERDOMAIN)) - (setq |superDomain| (CAR |super|)) - (COND - ((BOOT-EQUAL |superDomain| |tSuper|) - (|coerceImmediateSubDomain| |val| |tSuper| |tSub| - (CADR |super|))) - ((|coerceSubDomain| |val| |tSuper| |superDomain|) - (|coerceImmediateSubDomain| |val| |superDomain| |tSub| - (CADR |super|))) - ('T NIL))))))) - -;coerceImmediateSubDomain(val, tSuper, tSub, pred) == -; predfn := getSubDomainPredicate(tSuper, tSub, pred) -; FUNCALL(predfn, val, nil) => objNew(val, tSub) -; nil - -(DEFUN |coerceImmediateSubDomain| (|val| |tSuper| |tSub| |pred|) - (PROG (|predfn|) - (RETURN - (PROGN - (setq |predfn| - (|getSubDomainPredicate| |tSuper| |tSub| |pred|)) - (COND - ((FUNCALL |predfn| |val| NIL) (mkObj |val| |tSub|)) - ('T NIL)))))) - -;getSubDomainPredicate(tSuper, tSub, pred) == -; $env: local := $InteractiveFrame -; predfn := HGET($superHash, CONS(tSuper, tSub)) => predfn -; name := GENSYM() -; decl := ['_:, name, ['Mapping, $Boolean, tSuper]] -; interpret(decl, nil) -; arg := GENSYM() -; pred' := SUBST(arg, "#1", pred) -; defn := ['DEF, [name, arg], '(NIL NIL), '(NIL NIL), removeZeroOne pred'] -; interpret(defn, nil) -; op := mkAtree name -; transferPropsToNode(name, op) -; predfn := CADAR selectLocalMms(op, name, [tSuper],$Boolean) -; HPUT($superHash, CONS(tSuper, tSub), predfn) -; predfn - -(DEFUN |getSubDomainPredicate| (|tSuper| |tSub| |pred|) - (PROG (|$env| |name| |decl| |arg| |pred'| |defn| |op| |predfn|) - (DECLARE (SPECIAL |$env| |$superHash| |$Boolean| - |$InteractiveFrame|)) - (RETURN - (PROGN - (setq |$env| |$InteractiveFrame|) - (COND - ((setq |predfn| - (HGET |$superHash| (CONS |tSuper| |tSub|))) - |predfn|) - ('T (setq |name| (GENSYM)) - (setq |decl| - (CONS '|:| - (CONS |name| - (CONS (CONS '|Mapping| - (CONS |$Boolean| - (CONS |tSuper| NIL))) - NIL)))) - (|interpret| |decl| NIL) (setq |arg| (GENSYM)) - (setq |pred'| (MSUBST |arg| '|#1| |pred|)) - (setq |defn| - (CONS 'DEF - (CONS (CONS |name| (CONS |arg| NIL)) - (CONS '(NIL NIL) - (CONS '(NIL NIL) - (CONS (|removeZeroOne| |pred'|) - NIL)))))) - (|interpret| |defn| NIL) (setq |op| (|mkAtree| |name|)) - (|transferPropsToNode| |name| |op|) - (setq |predfn| - (CADAR (|selectLocalMms| |op| |name| - (CONS |tSuper| NIL) |$Boolean|))) - (HPUT |$superHash| (CONS |tSuper| |tSub|) |predfn|) - |predfn|)))))) - -;coerceIntX(val,t1, t2) == -; -- some experimental things -; t1 = '(List (None)) => -; -- this will almost always be an empty list -; null unwrap val => -; -- try getting a better flavor of List -; null (t0 := underDomainOf(t2)) => NIL -; coerceInt(objNewWrap(val,['List,t0]),t2) -; NIL -; NIL - -(DEFUN |coerceIntX| (|val| |t1| |t2|) - (PROG (|t0|) - (RETURN - (COND - ((BOOT-EQUAL |t1| '(|List| (|None|))) - (COND - ((NULL (|unwrap| |val|)) - (COND - ((NULL (setq |t0| (|underDomainOf| |t2|))) NIL) - ('T - (|coerceInt| - (mkObjWrap |val| (CONS '|List| (CONS |t0| NIL))) - |t2|)))) - ('T NIL))) - ('T NIL))))) - -;compareTypeLists(tl1,tl2) == -; -- returns true if every type in tl1 is = or is a subdomain of -; -- the corresponding type in tl2 -; for t1 in tl1 for t2 in tl2 repeat -; null isEqualOrSubDomain(t1,t2) => return NIL -; true - -(DEFUN |compareTypeLists| (|tl1| |tl2|) - (PROG () - (RETURN - (SEQ (DO ((G167600 |tl1| (CDR G167600)) (|t1| NIL) - (G167601 |tl2| (CDR G167601)) (|t2| NIL)) - ((OR (ATOM G167600) - (PROGN (SETQ |t1| (CAR G167600)) NIL) - (ATOM G167601) - (PROGN (SETQ |t2| (CAR G167601)) NIL)) - NIL) - (SEQ (EXIT (COND - ((NULL (|isEqualOrSubDomain| |t1| |t2|)) - (EXIT (RETURN NIL))))))) - 'T)))) - -;coerceIntAlgebraicConstant(object,t2) == -; -- should use = from domain, but have to check on defaults code -; t1 := objMode object -; val := objValUnwrap object -; ofCategory(t1,'(Monoid)) and ofCategory(t2,'(Monoid)) and -; val = getConstantFromDomain('(One),t1) => -; objNewWrap(getConstantFromDomain('(One),t2),t2) -; ofCategory(t1,'(AbelianMonoid)) and ofCategory(t2,'(AbelianMonoid)) and -; val = getConstantFromDomain('(Zero),t1) => -; objNewWrap(getConstantFromDomain('(Zero),t2),t2) -; NIL - -(DEFUN |coerceIntAlgebraicConstant| (|object| |t2|) - (PROG (|t1| |val|) - (RETURN - (PROGN - (setq |t1| (|objMode| |object|)) - (setq |val| (|objValUnwrap| |object|)) - (COND - ((AND (|ofCategory| |t1| '(|Monoid|)) - (|ofCategory| |t2| '(|Monoid|)) - (BOOT-EQUAL |val| - (|getConstantFromDomain| '(|One|) |t1|))) - (mkObjWrap (|getConstantFromDomain| '(|One|) |t2|) |t2|)) - ((AND (|ofCategory| |t1| '(|AbelianMonoid|)) - (|ofCategory| |t2| '(|AbelianMonoid|)) - (BOOT-EQUAL |val| - (|getConstantFromDomain| '(|Zero|) |t1|))) - (mkObjWrap (|getConstantFromDomain| '(|Zero|) |t2|) |t2|)) - ('T NIL)))))) - -;stripUnionTags doms == -; [if dom is [":",.,dom'] then dom' else dom for dom in doms] - -(DEFUN |stripUnionTags| (|doms|) - (PROG (|ISTMP#1| |ISTMP#2| |dom'|) - (RETURN - (SEQ (PROG (G167639) - (setq G167639 NIL) - (RETURN - (DO ((G167650 |doms| (CDR G167650)) (|dom| NIL)) - ((OR (ATOM G167650) - (PROGN (SETQ |dom| (CAR G167650)) NIL)) - (NREVERSE0 G167639)) - (SEQ (EXIT (SETQ G167639 - (CONS (COND - ((AND (CONSP |dom|) - (EQ (QCAR |dom|) '|:|) - (PROGN - (setq |ISTMP#1| - (QCDR |dom|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (setq |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) - NIL) - (PROGN - (setq |dom'| - (QCAR |ISTMP#2|)) - 'T)))))) - |dom'|) - ('T |dom|)) - G167639))))))))))) - -;isTaggedUnion u == -; u is ['Union,:tl] and tl and first tl is [":",.,.] and true - -(DEFUN |isTaggedUnion| (|u|) - (PROG (|tl| |ISTMP#1| |ISTMP#2| |ISTMP#3|) - (RETURN - (AND (CONSP |u|) (EQ (QCAR |u|) '|Union|) - (PROGN (setq |tl| (QCDR |u|)) 'T) |tl| - (PROGN - (setq |ISTMP#1| (CAR |tl|)) - (AND (CONSP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) '|:|) - (PROGN - (setq |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (PROGN - (setq |ISTMP#3| (QCDR |ISTMP#2|)) - (AND (CONSP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL))))))) - 'T)))) - -;getUnionOrRecordTags u == -; tags := nil -; if u is ['Union, :tl] or u is ['Record, :tl] then -; for t in tl repeat -; if t is [":",tag,.] then tags := cons(tag, tags) -; tags - -(DEFUN |getUnionOrRecordTags| (|u|) - (PROG (|tl| |ISTMP#1| |tag| |ISTMP#2| |tags|) - (RETURN - (SEQ (PROGN - (setq |tags| NIL) - (COND - ((OR (AND (CONSP |u|) (EQ (QCAR |u|) '|Union|) - (PROGN (setq |tl| (QCDR |u|)) 'T)) - (AND (CONSP |u|) (EQ (QCAR |u|) '|Record|) - (PROGN (setq |tl| (QCDR |u|)) 'T))) - (DO ((G167701 |tl| (CDR G167701)) (|t| NIL)) - ((OR (ATOM G167701) - (PROGN (SETQ |t| (CAR G167701)) NIL)) - NIL) - (SEQ (EXIT (COND - ((AND (CONSP |t|) (EQ (QCAR |t|) '|:|) + ((OR (AND (CONSP |u|) (EQ (QCAR |u|) '|Union|) + (PROGN (setq |tl| (QCDR |u|)) 'T)) + (AND (CONSP |u|) (EQ (QCAR |u|) '|Record|) + (PROGN (setq |tl| (QCDR |u|)) 'T))) + (DO ((G167701 |tl| (CDR G167701)) (|t| NIL)) + ((OR (ATOM G167701) + (PROGN (SETQ |t| (CAR G167701)) NIL)) + NIL) + (SEQ (EXIT (COND + ((AND (CONSP |t|) (EQ (QCAR |t|) '|:|) (PROGN (setq |ISTMP#1| (QCDR |t|)) (AND (CONSP |ISTMP#1|) @@ -3175,1330 +1374,6 @@ Interpreter Coercion Query Functions ('T NIL))))))) |tags|))))) -;coerceUnion2Branch(object) == -; [.,:unionDoms] := objMode object -; doms := orderUnionEntries unionDoms -; predList:= mkPredList doms -; doms := stripUnionTags doms -; val' := objValUnwrap object -; predicate := NIL -; targetType:= NIL -; for typ in doms for pred in predList while ^targetType repeat -; evalSharpOne(pred,val') => -; predicate := pred -; targetType := typ -; null targetType => keyedSystemError("S2IC0013",NIL) -; predicate is ['EQCAR,.,p] => objNewWrap(CDR val',targetType) -; objNew(objVal object,targetType) - -(defun |evalSharpOne| (x |#1|) - (declare (special |#1|)) - (eval `(let() (declare (special |#1|)) ,x))) - -(DEFUN |coerceUnion2Branch| (|object|) - (PROG (|LETTMP#1| |unionDoms| |predList| |doms| |val'| |predicate| - |targetType| |ISTMP#1| |ISTMP#2| |p|) - (RETURN - (SEQ (PROGN - (setq |LETTMP#1| (|objMode| |object|)) - (setq |unionDoms| (CDR |LETTMP#1|)) - (setq |doms| (|orderUnionEntries| |unionDoms|)) - (setq |predList| (|mkPredList| |doms|)) - (setq |doms| (|stripUnionTags| |doms|)) - (setq |val'| (|objValUnwrap| |object|)) - (setq |predicate| NIL) - (setq |targetType| NIL) - (SEQ (DO ((G167741 |doms| (CDR G167741)) (|typ| NIL) - (G167742 |predList| (CDR G167742)) - (|pred| NIL)) - ((OR (ATOM G167741) - (PROGN (SETQ |typ| (CAR G167741)) NIL) - (ATOM G167742) - (PROGN (SETQ |pred| (CAR G167742)) NIL) - (NULL (NULL |targetType|))) - NIL) - (SEQ (EXIT (COND - ((|evalSharpOne| |pred| |val'|) - (EXIT (PROGN - (setq |predicate| |pred|) - (setq |targetType| |typ|)))))))) - (COND - ((NULL |targetType|) - (|keyedSystemError| - "Cannot determine branch of Union." NIL)) - ((AND (CONSP |predicate|) - (EQ (QCAR |predicate|) 'EQCAR) - (PROGN - (setq |ISTMP#1| (QCDR |predicate|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (setq |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (setq |p| (QCAR |ISTMP#2|)) - 'T)))))) - (mkObjWrap (CDR |val'|) |targetType|)) - ('T (mkObj (|objVal| |object|) |targetType|))))))))) - -;coerceBranch2Union(object,union) == -; -- assumes type is a member of unionDoms -; unionDoms := CDR union -; doms := orderUnionEntries unionDoms -; predList:= mkPredList doms -; doms := stripUnionTags doms -; p := position(objMode object,doms) -; p = -1 => keyedSystemError("S2IC0014",[objMode object,union]) -; val := objVal object -; predList.p is ['EQCAR,.,tag] => -; objNewWrap([removeQuote tag,:unwrap val],union) -; objNew(val,union) - -(DEFUN |coerceBranch2Union| (|object| |union|) - (PROG (|unionDoms| |predList| |doms| |p| |val| |ISTMP#1| |ISTMP#2| - |ISTMP#3| |tag|) - (RETURN - (PROGN - (setq |unionDoms| (CDR |union|)) - (setq |doms| (|orderUnionEntries| |unionDoms|)) - (setq |predList| (|mkPredList| |doms|)) - (setq |doms| (|stripUnionTags| |doms|)) - (setq |p| (|position| (|objMode| |object|) |doms|)) - (COND - ((BOOT-EQUAL |p| (- 1)) - (|keyedSystemError| "The type %1p is not branch of %2p" - (CONS (|objMode| |object|) (CONS |union| NIL)))) - ('T (setq |val| (|objVal| |object|)) - (COND - ((PROGN - (setq |ISTMP#1| (ELT |predList| |p|)) - (AND (CONSP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) 'EQCAR) - (PROGN - (setq |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (PROGN - (setq |ISTMP#3| (QCDR |ISTMP#2|)) - (AND (CONSP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN - (setq |tag| (QCAR |ISTMP#3|)) - 'T))))))) - (mkObjWrap - (CONS (|removeQuote| |tag|) (|unwrap| |val|)) - |union|)) - ('T (mkObj |val| |union|))))))))) - -;coerceInt2Union(object,union) == -; -- coerces to a Union type, adding numeric tags -; -- first cut -; unionDoms := stripUnionTags CDR union -; t1 := objMode object -; MEMBER(t1,unionDoms) => coerceBranch2Union(object,union) -; val := objVal object -; val' := unwrap val -; (t1 = $String) and MEMBER(val',unionDoms) => -; coerceBranch2Union(objNew(val,val'),union) -; noCoerce := true -; val' := nil -; for d in unionDoms while noCoerce repeat -; (val' := coerceInt(object,d)) => noCoerce := nil -; val' => coerceBranch2Union(val',union) -; NIL - -(DEFUN |coerceInt2Union| (|object| |union|) - (PROG (|unionDoms| |t1| |val| |val'| |noCoerce|) - (DECLARE (SPECIAL |$String|)) - (RETURN - (SEQ (PROGN - (setq |unionDoms| (|stripUnionTags| (CDR |union|))) - (setq |t1| (|objMode| |object|)) - (COND - ((|member| |t1| |unionDoms|) - (|coerceBranch2Union| |object| |union|)) - ('T (setq |val| (|objVal| |object|)) - (setq |val'| (|unwrap| |val|)) - (COND - ((AND (BOOT-EQUAL |t1| |$String|) - (|member| |val'| |unionDoms|)) - (|coerceBranch2Union| (mkObj |val| |val'|) - |union|)) - ('T (setq |noCoerce| 'T) (setq |val'| NIL) - (SEQ (DO ((G167805 |unionDoms| (CDR G167805)) - (|d| NIL)) - ((OR (ATOM G167805) - (PROGN - (SETQ |d| (CAR G167805)) - NIL) - (NULL |noCoerce|)) - NIL) - (SEQ (EXIT (COND - ((setq |val'| - (|coerceInt| |object| |d|)) - (EXIT (setq |noCoerce| NIL))))))) - (COND - (|val'| (EXIT (|coerceBranch2Union| |val'| - |union|)))) - NIL)))))))))) - -;coerceIntFromUnion(object,t2) == -; -- coerces from a Union type to something else -; coerceInt(coerceUnion2Branch object,t2) - -(DEFUN |coerceIntFromUnion| (|object| |t2|) - (|coerceInt| (|coerceUnion2Branch| |object|) |t2|)) - -;coerceIntByMap(triple,t2) == -; -- idea is this: if t1 is D U1 and t2 is D U2, then look for -; -- map: (U1 -> U2, D U1) -> D U2. If it exists, then create a -; -- function to do the coercion on the element level and call the -; -- map function. -; t1 := objMode triple -; t2 = t1 => triple -; u2 := deconstructT t2 -- compute t2 first because of Expression -; 1 = #u2 => NIL -- no under domain -; u1 := deconstructT t1 -; 1 = #u1 => NIL -; CAAR u1 ^= CAAR u2 => nil -- constructors not equal -; ^valueArgsEqual?(t1, t2) => NIL -;-- CAR u1 ^= CAR u2 => NIL -; top := CAAR u1 -; u1 := underDomainOf t1 -; u2 := underDomainOf t2 -; -- handle a couple of special cases for subdomains of Integer -; top in '(List Vector Segment Stream UniversalSegment Array) -; and isSubDomain(u1,u2) => objNew(objVal triple, t2) -; args := [['Mapping,u2,u1],t1] -; if $reportBottomUpFlag then -; sayFunctionSelection('map,args,t2,NIL, -; '"coercion facility (map)") -; mms := selectMms1('map,t2,args,args,NIL) -; if $reportBottomUpFlag then -; sayFunctionSelectionResult('map,args,mms) -; null mms => NIL -; [[dc,:sig],slot,.]:= CAR mms -; fun := compiledLookup('map,sig,evalDomain(dc)) -; NULL fun => NIL -; [fn,:d]:= fun -; fn = function Undef => NIL -; -- now compile a function to do the coercion -; code := ['SPADCALL,['CONS,["function","coerceIntByMapInner"],MKQ [u1,:u2]], -; wrapped2Quote objVal triple,MKQ fun] -; -- and apply the function -; val := CATCH('coerceFailure,timedEvaluate code) -; (val = $coerceFailure) => NIL -; objNewWrap(val,t2) - -(DEFUN |coerceIntByMap| (|triple| |t2|) - (PROG (|t1| |top| |u1| |u2| |args| |mms| |LETTMP#1| |dc| |sig| |slot| - |fun| |fn| |d| |code| |val|) - (DECLARE (SPECIAL |$coerceFailure| |$reportBottomUpFlag|)) - (RETURN - (PROGN - (setq |t1| (|objMode| |triple|)) - (COND - ((BOOT-EQUAL |t2| |t1|) |triple|) - ('T (setq |u2| (|deconstructT| |t2|)) - (COND - ((EQL 1 (|#| |u2|)) NIL) - ('T (setq |u1| (|deconstructT| |t1|)) - (COND - ((EQL 1 (|#| |u1|)) NIL) - ((NEQUAL (CAAR |u1|) (CAAR |u2|)) NIL) - ((NULL (|valueArgsEqual?| |t1| |t2|)) NIL) - ('T (setq |top| (CAAR |u1|)) - (setq |u1| (|underDomainOf| |t1|)) - (setq |u2| (|underDomainOf| |t2|)) - (COND - ((AND (|member| |top| - '(|List| |Vector| |Segment| |Stream| - |UniversalSegment| |Array|)) - (|isSubDomain| |u1| |u2|)) - (mkObj (|objVal| |triple|) |t2|)) - ('T - (setq |args| - (CONS (CONS '|Mapping| - (CONS |u2| (CONS |u1| NIL))) - (CONS |t1| NIL))) - (COND - (|$reportBottomUpFlag| - (|sayFunctionSelection| '|map| |args| |t2| - NIL - "coercion facility (map)"))) - (setq |mms| - (|selectMms1| '|map| |t2| |args| |args| - NIL)) - (COND - (|$reportBottomUpFlag| - (|sayFunctionSelectionResult| '|map| |args| - |mms|))) - (COND - ((NULL |mms|) NIL) - ('T (setq |LETTMP#1| (CAR |mms|)) - (setq |dc| (CAAR |LETTMP#1|)) - (setq |sig| (CDAR |LETTMP#1|)) - (setq |slot| (CADR |LETTMP#1|)) - (setq |fun| - (|compiledLookup| '|map| |sig| - (|evalDomain| |dc|))) - (COND - ((NULL |fun|) NIL) - ('T (setq |fn| (CAR |fun|)) - (setq |d| (CDR |fun|)) - (COND - ((BOOT-EQUAL |fn| #'|Undef|) - NIL) - ('T - (setq |code| - (CONS 'SPADCALL - (CONS - (CONS 'CONS - (CONS - (CONS 'function - (CONS '|coerceIntByMapInner| - NIL)) - (CONS (MKQ (CONS |u1| |u2|)) - NIL))) - (CONS - (|wrapped2Quote| - (|objVal| |triple|)) - (CONS (MKQ |fun|) NIL))))) - (setq |val| - (CATCH '|coerceFailure| - (|timedEvaluate| |code|))) - (COND - ((BOOT-EQUAL |val| |$coerceFailure|) - NIL) - ('T (mkObjWrap |val| |t2|))))))))))))))))))))) - -;coerceIntByMapInner(arg,[u1,:u2]) == coerceOrThrowFailure(arg,u1,u2) - -(DEFUN |coerceIntByMapInner| (|arg| G167859) - (PROG (|u1| |u2|) - (RETURN - (PROGN - (setq |u1| (CAR G167859)) - (setq |u2| (CDR G167859)) - (|coerceOrThrowFailure| |arg| |u1| |u2|))))) - -;-- [u1,:u2] gets passed as the "environment", which is why we have this -;-- slightly clumsy locution JHD 31.July,1990 -;valueArgsEqual?(t1, t2) == -; -- returns true if the object-valued arguments to t1 and t2 are the same -; -- under coercion -; coSig := CDR GETDATABASE(CAR t1, 'COSIG) -; constrSig := CDR getConstructorSignature CAR t1 -; tl1 := replaceSharps(constrSig, t1) -; tl2 := replaceSharps(constrSig, t2) -; not MEMQ(NIL, coSig) => true -; done := false -; value := true -; for a1 in CDR t1 for a2 in CDR t2 for cs in coSig -; for m1 in tl1 for m2 in tl2 while not done repeat -; ^cs => -; trip := objNewWrap(a1, m1) -; newVal := coerceInt(trip, m2) -; null newVal => (done := true; value := false) -; ^algEqual(a2, objValUnwrap newVal, m2) => -; (done := true; value := false) -; value - -(DEFUN |valueArgsEqual?| (|t1| |t2|) - (PROG (|coSig| |constrSig| |tl1| |tl2| |trip| |newVal| |done| - |value|) - (RETURN - (SEQ (PROGN - (setq |coSig| (CDR (GETDATABASE (CAR |t1|) 'COSIG))) - (setq |constrSig| - (CDR (|getConstructorSignature| (CAR |t1|)))) - (setq |tl1| (|replaceSharps| |constrSig| |t1|)) - (setq |tl2| (|replaceSharps| |constrSig| |t2|)) - (COND - ((NULL (member NIL |coSig|)) 'T) - ('T (setq |done| NIL) (setq |value| 'T) - (SEQ (DO ((G167888 (CDR |t1|) (CDR G167888)) - (|a1| NIL) - (G167889 (CDR |t2|) (CDR G167889)) - (|a2| NIL) - (G167890 |coSig| (CDR G167890)) - (|cs| NIL) (G167891 |tl1| (CDR G167891)) - (|m1| NIL) (G167892 |tl2| (CDR G167892)) - (|m2| NIL)) - ((OR (ATOM G167888) - (PROGN (SETQ |a1| (CAR G167888)) NIL) - (ATOM G167889) - (PROGN (SETQ |a2| (CAR G167889)) NIL) - (ATOM G167890) - (PROGN (SETQ |cs| (CAR G167890)) NIL) - (ATOM G167891) - (PROGN (SETQ |m1| (CAR G167891)) NIL) - (ATOM G167892) - (PROGN (SETQ |m2| (CAR G167892)) NIL) - (NULL (NULL |done|))) - NIL) - (SEQ (EXIT (COND - ((NULL |cs|) - (EXIT - (PROGN - (setq |trip| - (mkObjWrap |a1| |m1|)) - (setq |newVal| - (|coerceInt| |trip| |m2|)) - (COND - ((NULL |newVal|) - (setq |done| 'T) - (setq |value| NIL)) - ((NULL - (|algEqual| |a2| - (|objValUnwrap| |newVal|) - |m2|)) - (setq |done| 'T) - (setq |value| NIL)))))))))) - (EXIT |value|))))))))) - -;coerceIntTower(triple,t2) == -; -- tries to find a coercion from top level t2 to somewhere inside t1 -; -- builds new argument type, for which coercion is called recursively -; x := coerceIntByMap(triple,t2) => x -; x := coerceIntCommute(triple,t2) => x -; x := coerceIntPermute(triple,t2) => x -; x := coerceIntSpecial(triple,t2) => x -; x := coerceIntTableOrFunction(triple,t2) => x -; t1 := objMode triple -; [c1,:arg1]:= deconstructT t1 -; arg1 and -; TL:= NIL -; arg:= arg1 -; until x or not arg repeat -; t:= last arg -; [c,:arg]:= deconstructT t -; TL:= [c,arg,:TL] -; x := arg and coerceIntTest(t,t2) => -; CDDR TL => -; s := constructT(c1,replaceLast(arg1,bubbleConstructor TL)) -; (null isValidType(s)) => (x := NIL) -; x := (coerceIntByMap(triple,s) or -; coerceIntTableOrFunction(triple,s)) => -; [c2,:arg2]:= deconstructT last s -; s:= bubbleConstructor [c2,arg2,c1,arg1] -; (null isValidType(s)) => (x := NIL) -; x:= coerceIntCommute(x,s) => -; x := (coerceIntByMap(x,t2) or -; coerceIntTableOrFunction(x,t2)) -; s:= bubbleConstructor [c,arg,c1,arg1] -; (null isValidType(s)) => (x := NIL) -; x:= coerceIntCommute(triple,s) => -; x:= (coerceIntByMap(x,t2) or -; coerceIntTableOrFunction(x,t2)) -; x - -(DEFUN |coerceIntTower| (|triple| |t2|) - (PROG (|t1| |c1| |arg1| |t| |c| |arg| TL |LETTMP#1| |c2| |arg2| |s| - |x|) - (RETURN - (SEQ (COND - ((setq |x| (|coerceIntByMap| |triple| |t2|)) |x|) - ((setq |x| (|coerceIntCommute| |triple| |t2|)) |x|) - ((setq |x| (|coerceIntPermute| |triple| |t2|)) |x|) - ((setq |x| (|coerceIntSpecial| |triple| |t2|)) |x|) - ((setq |x| (|coerceIntTableOrFunction| |triple| |t2|)) - |x|) - ('T (setq |t1| (|objMode| |triple|)) - (setq |LETTMP#1| (|deconstructT| |t1|)) - (setq |c1| (CAR |LETTMP#1|)) - (setq |arg1| (CDR |LETTMP#1|)) - (AND |arg1| - (PROGN - (setq TL NIL) - (setq |arg| |arg1|) - (DO ((G167962 NIL (OR |x| (NULL |arg|)))) - (G167962 NIL) - (SEQ (EXIT (PROGN - (setq |t| (|last| |arg|)) - (setq |LETTMP#1| - (|deconstructT| |t|)) - (setq |c| (CAR |LETTMP#1|)) - (setq |arg| (CDR |LETTMP#1|)) - (setq TL - (CONS |c| (CONS |arg| TL))) - (COND - ((setq |x| - (AND |arg| - (|coerceIntTest| |t| |t2|))) - (COND - ((CDDR TL) - (setq |s| - (|constructT| |c1| - (|replaceLast| |arg1| - (|bubbleConstructor| TL)))) - (COND - ((NULL (|isValidType| |s|)) - (setq |x| NIL)) - ((setq |x| - (OR - (|coerceIntByMap| - |triple| |s|) - (|coerceIntTableOrFunction| - |triple| |s|))) - (setq |LETTMP#1| - (|deconstructT| - (|last| |s|))) - (setq |c2| - (CAR |LETTMP#1|)) - (setq |arg2| - (CDR |LETTMP#1|)) - (setq |s| - (|bubbleConstructor| - (CONS |c2| - (CONS |arg2| - (CONS |c1| - (CONS |arg1| NIL)))))) - (COND - ((NULL - (|isValidType| |s|)) - (setq |x| NIL)) - ((setq |x| - (|coerceIntCommute| - |x| |s|)) - (setq |x| - (OR - (|coerceIntByMap| |x| - |t2|) - (|coerceIntTableOrFunction| - |x| |t2|)))))))) - ('T - (setq |s| - (|bubbleConstructor| - (CONS |c| - (CONS |arg| - (CONS |c1| - (CONS |arg1| NIL)))))) - (COND - ((NULL (|isValidType| |s|)) - (setq |x| NIL)) - ((setq |x| - (|coerceIntCommute| - |triple| |s|)) - (setq |x| - (OR - (|coerceIntByMap| |x| - |t2|) - (|coerceIntTableOrFunction| - |x| |t2|))))))))))))) - |x|)))))))) - -;coerceIntSpecial(triple,t2) == -; t1 := objMode triple -; t2 is ['SimpleAlgebraicExtension,R,U,.] and t1 = R => -; null (x := coerceInt(triple,U)) => NIL -; coerceInt(x,t2) -; NIL - -(DEFUN |coerceIntSpecial| (|triple| |t2|) - (PROG (|t1| |ISTMP#1| R |ISTMP#2| U |ISTMP#3| |x|) - (RETURN - (PROGN - (setq |t1| (|objMode| |triple|)) - (COND - ((AND (CONSP |t2|) - (EQ (QCAR |t2|) '|SimpleAlgebraicExtension|) - (PROGN - (setq |ISTMP#1| (QCDR |t2|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (setq R (QCAR |ISTMP#1|)) - (setq |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (PROGN - (setq U (QCAR |ISTMP#2|)) - (setq |ISTMP#3| (QCDR |ISTMP#2|)) - (AND (CONSP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL))))))) - (BOOT-EQUAL |t1| R)) - (COND - ((NULL (setq |x| (|coerceInt| |triple| U))) NIL) - ('T (|coerceInt| |x| |t2|)))) - ('T NIL)))))) - -;coerceIntTableOrFunction(triple,t2) == -; -- this function does the actual coercion to t2, but not to an -; -- argument type of t2 -; null isValidType t2 => NIL -- added 9-18-85 by RSS -; null isLegitimateMode(t2,NIL,NIL) => NIL -- added 6-28-87 by RSS -; t1 := objMode triple -; p:= ASSQ(CAR t1,$CoerceTable) -; p and ASSQ(CAR t2,CDR p) is [.,:[tag,fun]] => -; val := objVal triple -; fun='Identity => objNew(val,t2) -; tag='total => -; coerceByTable(fun,val,t1,t2,'T) or coerceByFunction(triple,t2) -; coerceByTable(fun,val,t1,t2,NIL) or coerceByFunction(triple,t2) -; coerceByFunction(triple,t2) - -(DEFUN |coerceIntTableOrFunction| (|triple| |t2|) - (PROG (|t1| |p| |ISTMP#1| |ISTMP#2| |tag| |ISTMP#3| |fun| |val|) - (DECLARE (SPECIAL |$CoerceTable|)) - (RETURN - (COND - ((NULL (|isValidType| |t2|)) NIL) - ((NULL (|isLegitimateMode| |t2| NIL NIL)) NIL) - ('T (setq |t1| (|objMode| |triple|)) - (setq |p| (ASSQ (CAR |t1|) |$CoerceTable|)) - (COND - ((AND |p| - (PROGN - (setq |ISTMP#1| (ASSQ (CAR |t2|) (CDR |p|))) - (AND (CONSP |ISTMP#1|) - (PROGN - (setq |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (PROGN - (setq |tag| (QCAR |ISTMP#2|)) - (setq |ISTMP#3| (QCDR |ISTMP#2|)) - (AND (CONSP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN - (setq |fun| - (QCAR |ISTMP#3|)) - 'T)))))))) - (setq |val| (|objVal| |triple|)) - (COND - ((BOOT-EQUAL |fun| '|Identity|) (mkObj |val| |t2|)) - ((BOOT-EQUAL |tag| '|total|) - (OR (|coerceByTable| |fun| |val| |t1| |t2| 'T) - (|coerceByFunction| |triple| |t2|))) - ('T - (OR (|coerceByTable| |fun| |val| |t1| |t2| NIL) - (|coerceByFunction| |triple| |t2|))))) - ('T (|coerceByFunction| |triple| |t2|)))))))) - -;coerceCommuteTest(t1,t2) == -; null isLegitimateMode(t2,NIL,NIL) => NIL -; -- sees whether t1 = D1 D2 R and t2 = D2 D1 S -; null (u1 := underDomainOf t1) => NIL -; null (u2 := underDomainOf t2) => NIL -; -- must have underdomains (ie, R and S must be there) -; null (v1 := underDomainOf u1) => NIL -; null (v2 := underDomainOf u2) => NIL -; -- now check that cross of constructors is correct -; (CAR(deconstructT t1) = CAR(deconstructT u2)) and -; (CAR(deconstructT t2) = CAR(deconstructT u1)) - -(DEFUN |coerceCommuteTest| (|t1| |t2|) - (PROG (|u1| |u2| |v1| |v2|) - (RETURN - (COND - ((NULL (|isLegitimateMode| |t2| NIL NIL)) NIL) - ((NULL (setq |u1| (|underDomainOf| |t1|))) NIL) - ((NULL (setq |u2| (|underDomainOf| |t2|))) NIL) - ((NULL (setq |v1| (|underDomainOf| |u1|))) NIL) - ((NULL (setq |v2| (|underDomainOf| |u2|))) NIL) - ('T - (AND (BOOT-EQUAL (CAR (|deconstructT| |t1|)) - (CAR (|deconstructT| |u2|))) - (BOOT-EQUAL (CAR (|deconstructT| |t2|)) - (CAR (|deconstructT| |u1|))))))))) - -;coerceIntCommute(obj,target) == -; -- note that the value in obj may be $fromCoerceable$, for canCoerce -; source := objMode obj -; null coerceCommuteTest(source,target) => NIL -; S := underDomainOf source -; T := underDomainOf target -; source = T => NIL -- handle in other ways -; source is [D,:.] => -; fun := GET(D,'coerceCommute) or -; INTERN STRCONC('"commute",princ-to-string D) -; functionp fun => -; PUT(D,'coerceCommute,fun) -; u := objValUnwrap obj -; c := CATCH('coerceFailure,FUNCALL(fun,u,source,S,target,T)) -; (c = $coerceFailure) => NIL -; u = "$fromCoerceable$" => c -; objNewWrap(c,target) -; NIL -; NIL - -(DEFUN |coerceIntCommute| (|obj| |target|) - (PROG (|source| S T$ D |fun| |u| |c|) - (DECLARE (SPECIAL |$coerceFailure|)) - (RETURN - (PROGN - (setq |source| (|objMode| |obj|)) - (COND - ((NULL (|coerceCommuteTest| |source| |target|)) NIL) - ('T (setq S (|underDomainOf| |source|)) - (setq T$ (|underDomainOf| |target|)) - (COND - ((BOOT-EQUAL |source| T$) NIL) - ((AND (CONSP |source|) - (PROGN (setq D (QCAR |source|)) 'T)) - (setq |fun| - (OR (GETL D '|coerceCommute|) - (INTERN (STRCONC "commute" - (princ-to-string D))))) - (COND - ((canFuncall? |fun|) (PUT D '|coerceCommute| |fun|) - (setq |u| (|objValUnwrap| |obj|)) - (setq |c| - (CATCH '|coerceFailure| - (FUNCALL |fun| |u| |source| S |target| T$))) - (COND - ((BOOT-EQUAL |c| |$coerceFailure|) NIL) - ((BOOT-EQUAL |u| '|$fromCoerceable$|) |c|) - ('T (mkObjWrap |c| |target|)))) - ('T NIL))) - ('T NIL)))))))) - -;coerceIntPermute(object,t2) == -; t2 in '((Integer) (OutputForm)) => NIL -; t1 := objMode object -; towers := computeTTTranspositions(t1,t2) -; -- at this point, CAR towers = t1 and last towers should be similar -; -- to t2 in the sense that the components of t1 are in the same order -; -- as in t2. If length towers = 2 and t2 = last towers, we quit to -; -- avoid an infinte loop. -; NULL towers or NULL CDR towers => NIL -; NULL CDDR towers and t2 = CADR towers => NIL -; -- do the coercions successively, quitting if any fail -; ok := true -; for t in CDR towers while ok repeat -; null (object := coerceInt(object,t)) => ok := NIL -; ok => object -; NIL - -(DEFUN |coerceIntPermute| (|object| |t2|) - (PROG (|t1| |towers| |ok|) - (RETURN - (SEQ (COND - ((|member| |t2| '((|Integer|) (|OutputForm|))) NIL) - ('T (setq |t1| (|objMode| |object|)) - (setq |towers| (|computeTTTranspositions| |t1| |t2|)) - (COND - ((OR (NULL |towers|) (NULL (CDR |towers|))) NIL) - ((AND (NULL (CDDR |towers|)) - (BOOT-EQUAL |t2| (CADR |towers|))) - NIL) - ('T (setq |ok| 'T) - (SEQ (DO ((G168100 (CDR |towers|) (CDR G168100)) - (|t| NIL)) - ((OR (ATOM G168100) - (PROGN (SETQ |t| (CAR G168100)) NIL) - (NULL |ok|)) - NIL) - (SEQ (EXIT (COND - ((NULL - (setq |object| - (|coerceInt| |object| |t|))) - (EXIT (setq |ok| NIL))))))) - (COND (|ok| (EXIT |object|))) NIL))))))))) - -;computeTTTranspositions(t1,t2) == -; -- decompose t1 into its tower parts -; tl1 := decomposeTypeIntoTower t1 -; tl2 := decomposeTypeIntoTower t2 -; -- if not at least 2 parts, don't bother working here -; null (rest tl1 and rest tl2) => NIL -; -- determine the relative order of the parts of t1 in t2 -; p2 := [position(d1,tl2) for d1 in tl1] -; member(-1,p2) => NIL -- something not present -; -- if they are all ascending, this function will do nothing -; p2' := MSORT p2 -; p2 = p2' => NIL -; -- if anything is repeated twice, leave -; p2' ^= MSORT REMDUP p2' => NIL -; -- create a list of permutations that transform the tower parts -; -- of t1 into the order they are in in t2 -; n1 := #tl1 -; p2 := LIST2VEC compress(p2,0,# REMDUP tl1) where -; compress(l,start,len) == -; start >= len => l -; member(start,l) => compress(l,start+1,len) -; compress([(i < start => i; i - 1) for i in l],start,len) -; -- p2 now has the same position numbers as p1, we need to determine -; -- a list of permutations that takes p1 into p2. -; -- them -; perms := permuteToOrder(p2,n1-1,0) -; towers := [tl1] -; tower := LIST2VEC tl1 -; for perm in perms repeat -; t := tower.(CAR perm) -; tower.(CAR perm) := tower.(CDR perm) -; tower.(CDR perm) := t -; towers := CONS(VEC2LIST tower,towers) -; towers := [reassembleTowerIntoType tower for tower in towers] -; if CAR(towers) ^= t2 then towers := cons(t2,towers) -; NREVERSE towers - -(DEFUN |computeTTTranspositions,compress| (|l| |start| |len|) - (PROG () - (RETURN - (SEQ (IF (>= |start| |len|) (EXIT |l|)) - (IF (|member| |start| |l|) - (EXIT (|computeTTTranspositions,compress| |l| - (+ |start| 1) |len|))) - (EXIT (|computeTTTranspositions,compress| - (PROG (G168121) - (setq G168121 NIL) - (RETURN - (DO ((G168126 |l| (CDR G168126)) - (|i| NIL)) - ((OR (ATOM G168126) - (PROGN - (SETQ |i| (CAR G168126)) - NIL)) - (NREVERSE0 G168121)) - (SEQ (EXIT (SETQ G168121 - (CONS - (SEQ - (IF (> |start| |i|) - (EXIT |i|)) - (EXIT (- |i| 1))) - G168121))))))) - |start| |len|)))))) - -(DEFUN |computeTTTranspositions| (|t1| |t2|) - (PROG (|tl1| |tl2| |p2'| |n1| |p2| |perms| |tower| |t| |towers|) - (RETURN - (SEQ (PROGN - (setq |tl1| (|decomposeTypeIntoTower| |t1|)) - (setq |tl2| (|decomposeTypeIntoTower| |t2|)) - (COND - ((NULL (AND (CDR |tl1|) (CDR |tl2|))) NIL) - ('T - (setq |p2| - (PROG (G168143) - (setq G168143 NIL) - (RETURN - (DO ((G168148 |tl1| (CDR G168148)) - (|d1| NIL)) - ((OR (ATOM G168148) - (PROGN - (SETQ |d1| (CAR G168148)) - NIL)) - (NREVERSE0 G168143)) - (SEQ (EXIT - (SETQ G168143 - (CONS (|position| |d1| |tl2|) - G168143)))))))) - (COND - ((|member| (- 1) |p2|) NIL) - ('T (setq |p2'| (MSORT |p2|)) - (COND - ((BOOT-EQUAL |p2| |p2'|) NIL) - ((NEQUAL |p2'| (MSORT (REMDUP |p2'|))) NIL) - ('T (setq |n1| (|#| |tl1|)) - (setq |p2| - (LIST2VEC - (|computeTTTranspositions,compress| - |p2| 0 (|#| (REMDUP |tl1|))))) - (setq |perms| - (|permuteToOrder| |p2| - (- |n1| 1) 0)) - (setq |towers| (CONS |tl1| NIL)) - (setq |tower| (LIST2VEC |tl1|)) - (DO ((G168161 |perms| (CDR G168161)) - (|perm| NIL)) - ((OR (ATOM G168161) - (PROGN - (SETQ |perm| (CAR G168161)) - NIL)) - NIL) - (SEQ (EXIT (PROGN - (setq |t| - (ELT |tower| (CAR |perm|))) - (SETELT |tower| (CAR |perm|) - (ELT |tower| (CDR |perm|))) - (SETELT |tower| (CDR |perm|) |t|) - (setq |towers| - (CONS (VEC2LIST |tower|) - |towers|)))))) - (setq |towers| - (PROG (G168171) - (setq G168171 NIL) - (RETURN - (DO - ((G168176 |towers| - (CDR G168176)) - (|tower| NIL)) - ((OR (ATOM G168176) - (PROGN - (SETQ |tower| (CAR G168176)) - NIL)) - (NREVERSE0 G168171)) - (SEQ - (EXIT - (SETQ G168171 - (CONS - (|reassembleTowerIntoType| - |tower|) - G168171)))))))) - (COND - ((NEQUAL (CAR |towers|) |t2|) - (setq |towers| (CONS |t2| |towers|)))) - (NREVERSE |towers|)))))))))))) - -;decomposeTypeIntoTower t == -; ATOM t => [t] -; d := deconstructT t -; NULL rest d => [t] -; rd := REVERSE t -; [reverse QCDR rd,:decomposeTypeIntoTower QCAR rd] - -(DEFUN |decomposeTypeIntoTower| (|t|) - (PROG (|d| |rd|) - (RETURN - (COND - ((ATOM |t|) (CONS |t| NIL)) - ('T (setq |d| (|deconstructT| |t|)) - (COND - ((NULL (CDR |d|)) (CONS |t| NIL)) - ('T (setq |rd| (REVERSE |t|)) - (CONS (REVERSE (QCDR |rd|)) - (|decomposeTypeIntoTower| (QCAR |rd|)))))))))) - -;reassembleTowerIntoType tower == -; ATOM tower => tower -; NULL rest tower => CAR tower -; [:top,t,s] := tower -; reassembleTowerIntoType [:top,[:t,s]] - -(DEFUN |reassembleTowerIntoType| (|tower|) - (PROG (|LETTMP#1| |s| |t| |top|) - (RETURN - (COND - ((ATOM |tower|) |tower|) - ((NULL (CDR |tower|)) (CAR |tower|)) - ('T (setq |LETTMP#1| (REVERSE |tower|)) - (setq |s| (CAR |LETTMP#1|)) (setq |t| (CADR |LETTMP#1|)) - (setq |top| (NREVERSE (CDDR |LETTMP#1|))) - (|reassembleTowerIntoType| - (APPEND |top| (CONS (APPEND |t| (CONS |s| NIL)) NIL)))))))) - -;permuteToOrder(p,n,start) == -; -- p is a vector of the numbers 0..n. This function returns a list -; -- of swaps of adjacent elements so that p will be in order. We only -; -- begin looking at index start -; r := n - start -; r <= 0 => NIL -; r = 1 => -; p.r < p.(r+1) => NIL -; [[r,:(r+1)]] -; p.start = start => permuteToOrder(p,n,start+1) -; -- bubble up element start to the top. Find out where it is -; stpos := NIL -; for i in start+1..n while not stpos repeat -; if p.i = start then stpos := i -; perms := NIL -; while stpos ^= start repeat -; x := stpos - 1 -; perms := [[x,:stpos],:perms] -; t := p.stpos -; p.stpos := p.x -; p.x := t -; stpos := x -; APPEND(NREVERSE perms,permuteToOrder(p,n,start+1)) - -(DEFUN |permuteToOrder| (|p| |n| |start|) - (PROG (|r| |x| |perms| |t| |stpos|) - (RETURN - (SEQ (PROGN - (setq |r| (- |n| |start|)) - (COND - ((<= |r| 0) NIL) - ((EQL |r| 1) - (COND - ((> (ELT |p| (+ |r| 1)) (ELT |p| |r|)) NIL) - ('T (CONS (CONS |r| (+ |r| 1)) NIL)))) - ((BOOT-EQUAL (ELT |p| |start|) |start|) - (|permuteToOrder| |p| |n| (+ |start| 1))) - ('T (setq |stpos| NIL) - (DO ((|i| (+ |start| 1) (+ |i| 1))) - ((OR (> |i| |n|) (NULL (NULL |stpos|))) NIL) - (SEQ (EXIT (COND - ((BOOT-EQUAL (ELT |p| |i|) |start|) - (setq |stpos| |i|)) - ('T NIL))))) - (setq |perms| NIL) - (DO () ((NULL (NEQUAL |stpos| |start|)) NIL) - (SEQ (EXIT (PROGN - (setq |x| (- |stpos| 1)) - (setq |perms| - (CONS (CONS |x| |stpos|) - |perms|)) - (setq |t| (ELT |p| |stpos|)) - (SETELT |p| |stpos| (ELT |p| |x|)) - (SETELT |p| |x| |t|) - (setq |stpos| |x|))))) - (APPEND (NREVERSE |perms|) - (|permuteToOrder| |p| |n| (+ |start| 1)))))))))) - -;coerceConvertMmSelection(funName,m1,m2) == -; -- calls selectMms with $Coerce=NIL and tests for required -; -- target type. funName is either 'coerce or 'convert. -; $declaredMode : local:= NIL -; $reportBottomUpFlag : local:= NIL -; l := selectMms1(funName,m2,[m1],[m1],NIL) -; mmS := [[sig,[targ,arg],:pred] for x in l | x is [sig,[.,arg],:pred] and -; hasCorrectTarget(m2,sig) and sig is [dc,targ,oarg] and oarg = m1] -; mmS and CAR mmS - -(defun |coerceConvertMmSelection| (&rest g1) - (let (g3) - (cond - ((setq g3 (hget |coerceConvertMmSelection;AL| g1)) - (|CDRwithIncrement| g3)) - (t - (cdr (hput |coerceConvertMmSelection;AL| g1 - (cons 1 (apply #'|coerceConvertMmSelection;| g1)))))))) - - -(defun |coerceConvertMmSelection;| (funName m1 m2) - (prog (|$declaredMode| |$reportBottomUpFlag| z sig tmp3 arg pred dc tmp1 - targ tmp2 oarg mmS g1) - (declare (special |$declaredMode| |$reportBottomUpFlag|)) - (return - (seq - (progn - (setq |$declaredMode| nil) - (setq |$reportBottomUpFlag| nil) - (setq z (|selectMms1| funName m2 (cons m1 nil) (cons m1 nil) nil)) - (setq mmS - (do ((g2 z (cdr g2)) (x nil)) - ((or (atom g2) (progn (setq x (car g2)) nil)) (nreverse0 g1)) - (SEQ (EXIT - (cond - ((and (consp x) - (progn - (setq sig (qcar x)) - (setq tmp1 (qcdr x)) - (and (consp tmp1) - (progn - (setq tmp2 (qcar tmp1)) - (and (consp tmp2) - (progn - (setq tmp3 (qcdr tmp2)) - (and (consp tmp3) - (eq (qcdr tmp3) nil) - (progn (setq arg (qcar tmp3)) T))))) - (progn - (setq pred (qcdr tmp1)) - t))) - (|hasCorrectTarget| m2 sig) - (consp sig) - (progn - (setq dc (qcar sig)) - (setq tmp1 (qcdr sig)) - (and (consp tmp1) - (progn - (setq targ (qcar tmp1)) - (setq tmp2 (qcdr tmp1)) - (and (consp tmp2) - (eq (qcdr tmp2) nil) - (progn - (setq oarg (qcar tmp2)) - t))))) - (boot-equal oarg m1)) - (setq g1 - (cons - (cons sig (cons (cons targ (cons arg nil)) pred)) - g1)))))))) - (and mms (car mmS))))))) - -(put '|coerceConvertMmSelection| '|cacheInfo| - '(|coerceConvertMmSelection| |coerceConvertMmSelection;AL| - |hash-tableWithCounts| - (setq |coerceConvertMmSelection;AL| (make-hashtable 'uequal)) - (|hashCount| |coerceConvertMmSelection;AL|))) - -(setq |coerceConvertMmSelection;AL| (make-hashtable 'uequal)) - -;coerceIntTest(t1,t2) == -; -- looks whether there exists a table entry or a coercion function -; -- thus the type can be bubbled before coerceIntTableOrFunction is called -; t1=t2 or -; b:= -; p:= ASSQ(CAR t1,$CoerceTable) -; p and ASSQ(CAR t2,CDR p) -; b or coerceConvertMmSelection('coerce,t1,t2) or -; ($useConvertForCoercions and -; coerceConvertMmSelection('convert,t1,t2)) - -(DEFUN |coerceIntTest| (|t1| |t2|) - (PROG (|p| |b|) - (DECLARE (SPECIAL |$useConvertForCoercions| |$CoerceTable|)) - (RETURN - (OR (BOOT-EQUAL |t1| |t2|) - (PROGN - (setq |b| - (PROGN - (setq |p| (ASSQ (CAR |t1|) |$CoerceTable|)) - (AND |p| (ASSQ (CAR |t2|) (CDR |p|))))) - (OR |b| (|coerceConvertMmSelection| '|coerce| |t1| |t2|) - (AND |$useConvertForCoercions| - (|coerceConvertMmSelection| '|convert| |t1| |t2|)))))))) - -;coerceByTable(fn,x,t1,t2,isTotalCoerce) == -; -- catch point for 'failure in boot coercions -; t2 = $OutputForm and ^(newType? t1) => NIL -; isWrapped x => -; x:= unwrap x -; c:= CATCH('coerceFailure,FUNCALL(fn,x,t1,t2)) -; c=$coerceFailure => NIL -; objNewWrap(c,t2) -; isTotalCoerce => objNew([fn,x,MKQ t1,MKQ t2],t2) -; objNew(['catchCoerceFailure,MKQ fn,x,MKQ t1,MKQ t2],t2) - -(DEFUN |coerceByTable| (|fn| |x| |t1| |t2| |isTotalCoerce|) - (PROG (|c|) - (DECLARE (SPECIAL |$coerceFailure| |$OutputForm|)) - (RETURN - (COND - ((equal |t2| |$OutputForm|) - NIL) - ((|isWrapped| |x|) (setq |x| (|unwrap| |x|)) - (setq |c| - (CATCH '|coerceFailure| - (FUNCALL |fn| |x| |t1| |t2|))) - (COND - ((BOOT-EQUAL |c| |$coerceFailure|) NIL) - ('T (mkObjWrap |c| |t2|)))) - (|isTotalCoerce| - (mkObj - (CONS |fn| - (CONS |x| - (CONS (MKQ |t1|) (CONS (MKQ |t2|) NIL)))) - |t2|)) - ('T - (mkObj - (CONS '|catchCoerceFailure| - (CONS (MKQ |fn|) - (CONS |x| - (CONS (MKQ |t1|) (CONS (MKQ |t2|) NIL))))) - |t2|)))))) - -;catchCoerceFailure(fn,x,t1,t2) == -; -- compiles a catchpoint for compiling boot coercions -; c:= CATCH('coerceFailure,FUNCALL(fn,x,t1,t2)) -; c = $coerceFailure => -; throwKeyedMsgCannotCoerceWithValue(wrap unwrap x,t1,t2) -; c - -(DEFUN |catchCoerceFailure| (|fn| |x| |t1| |t2|) - (PROG (|c|) - (DECLARE (SPECIAL |$coerceFailure|)) - (RETURN - (PROGN - (setq |c| - (CATCH '|coerceFailure| (FUNCALL |fn| |x| |t1| |t2|))) - (COND - ((BOOT-EQUAL |c| |$coerceFailure|) - (|throwKeyedMsgCannotCoerceWithValue| - (|wrap| (|unwrap| |x|)) |t1| |t2|)) - ('T |c|)))))) - -;coercionFailure() == -; -- does the throw on coercion failure -; THROW('coerceFailure,$coerceFailure) - -(DEFUN |coercionFailure| () - (DECLARE (SPECIAL |$coerceFailure|)) - (THROW '|coerceFailure| |$coerceFailure|)) - -;coerceByFunction(T,m2) == -; -- using the new modemap selection without coercions -; -- should not be called by canCoerceFrom -; x := objVal T -; x = '_$fromCoerceable_$ => NIL -; m2 is ['Union,:.] => NIL -; m1 := objMode T -; m2 is ['Boolean,:.] and m1 is ['Equation,ud] => -; dcVector := evalDomain ud -; fun := -; isWrapped x => -; NRTcompiledLookup("=", [$Boolean, '$, '$], dcVector) -; NRTcompileEvalForm("=", [$Boolean, '$, '$], dcVector) -; [fn,:d]:= fun -; isWrapped x => -; x:= unwrap x -; mkObjWrap(SPADCALL(CAR x,CDR x,fun),m2) -; x isnt ['SPADCALL,a,b,:.] => keyedSystemError("S2IC0015",NIL) -; code := ['SPADCALL, a, b, fun] -; objNew(code,$Boolean) -; -- If more than one function is found, any should suffice, I think -scm -; if not (mm := coerceConvertMmSelection(funName := 'coerce,m1,m2)) then -; mm := coerceConvertMmSelection(funName := 'convert,m1,m2) -; mm => -; [[dc,tar,:args],slot,.]:= mm -; dcVector := evalDomain(dc) -; fun:= -; isWrapped x => -; NRTcompiledLookup(funName,slot,dcVector) -; NRTcompileEvalForm(funName,slot,dcVector) -; [fn,:d]:= fun -; fn = function Undef => NIL -; isWrapped x => -; $: fluid := dcVector -; val := CATCH('coerceFailure, SPADCALL(unwrap x,fun)) -; (val = $coerceFailure) => NIL -; objNewWrap(val,m2) -; env := fun -; code := ['failCheck, ['SPADCALL, x, env]] -;-- tar is ['Union,:.] => objNew(['failCheck,code],m2) -; objNew(code,m2) -; -- try going back to types like RN instead of QF I -; m1' := eqType m1 -; m2' := eqType m2 -; (m1 ^= m1') or (m2 ^= m2') => coerceByFunction(objNew(x,m1'),m2') -; NIL - -(DEFUN |coerceByFunction| (T$ |m2|) - (PROG ($ |m1| |ud| |x| |ISTMP#1| |a| |ISTMP#2| |b| |funName| |mm| - |dc| |tar| |args| |slot| |dcVector| |fun| |fn| |d| |val| - |env| |code| |m1'| |m2'|) - (DECLARE (SPECIAL $ |$coerceFailure| |$Boolean|)) - (RETURN - (PROGN - (setq |x| (|objVal| T$)) - (COND - ((BOOT-EQUAL |x| '|$fromCoerceable$|) NIL) - ((AND (CONSP |m2|) (EQ (QCAR |m2|) '|Union|)) NIL) - ('T (setq |m1| (|objMode| T$)) - (COND - ((AND (CONSP |m2|) (EQ (QCAR |m2|) '|Boolean|) - (CONSP |m1|) (EQ (QCAR |m1|) '|Equation|) - (PROGN - (setq |ISTMP#1| (QCDR |m1|)) - (AND (CONSP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (setq |ud| (QCAR |ISTMP#1|)) 'T)))) - (setq |dcVector| (|evalDomain| |ud|)) - (setq |fun| - (COND - ((|isWrapped| |x|) - (|NRTcompiledLookup| '= - (CONS |$Boolean| (CONS '$ (CONS '$ NIL))) - |dcVector|)) - ('T - (|NRTcompileEvalForm| '= - (CONS |$Boolean| (CONS '$ (CONS '$ NIL))) - |dcVector|)))) - (setq |fn| (CAR |fun|)) (setq |d| (CDR |fun|)) - (COND - ((|isWrapped| |x|) (setq |x| (|unwrap| |x|)) - (mkObjWrap (SPADCALL (CAR |x|) (CDR |x|) |fun|) - |m2|)) - ((NULL (AND (CONSP |x|) (EQ (QCAR |x|) 'SPADCALL) - (PROGN - (setq |ISTMP#1| (QCDR |x|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (setq |a| (QCAR |ISTMP#1|)) - (setq |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (PROGN - (setq |b| (QCAR |ISTMP#2|)) - 'T))))))) - (|keyedSystemError| - "Generated code is incorrect for equation" NIL)) - ('T - (setq |code| - (CONS 'SPADCALL - (CONS |a| (CONS |b| (CONS |fun| NIL))))) - (mkObj |code| |$Boolean|)))) - ('T - (COND - ((NULL (setq |mm| - (|coerceConvertMmSelection| - (setq |funName| '|coerce|) |m1| - |m2|))) - (setq |mm| - (|coerceConvertMmSelection| - (setq |funName| '|convert|) |m1| |m2|)))) - (COND - (|mm| (setq |dc| (CAAR |mm|)) - (setq |tar| (CADAR |mm|)) - (setq |args| (CDDAR |mm|)) - (setq |slot| (CADR |mm|)) - (setq |dcVector| (|evalDomain| |dc|)) - (setq |fun| - (COND - ((|isWrapped| |x|) - (|NRTcompiledLookup| |funName| |slot| - |dcVector|)) - ('T - (|NRTcompileEvalForm| |funName| - |slot| |dcVector|)))) - (setq |fn| (CAR |fun|)) - (setq |d| (CDR |fun|)) - (COND - ((BOOT-EQUAL |fn| #'|Undef|) NIL) - ((|isWrapped| |x|) (setq $ |dcVector|) - (setq |val| - (CATCH '|coerceFailure| - (SPADCALL (|unwrap| |x|) |fun|))) - (COND - ((BOOT-EQUAL |val| |$coerceFailure|) NIL) - ('T (mkObjWrap |val| |m2|)))) - ('T (setq |env| |fun|) - (setq |code| - (CONS '|failCheck| - (CONS - (CONS 'SPADCALL - (CONS |x| (CONS |env| NIL))) - NIL))) - (mkObj |code| |m2|)))) - ('T (setq |m1'| |m1|) - (setq |m2'| |m2|) - (COND - ((OR (NEQUAL |m1| |m1'|) (NEQUAL |m2| |m2'|)) - (|coerceByFunction| (mkObj |x| |m1'|) |m2'|)) - ('T NIL)))))))))))) - -;hasCorrectTarget(m,sig is [dc,tar,:.]) == -; -- tests whether the target of signature sig is either m or a union -; -- containing m. It also discards TEQ as it is not meant to be -; -- used at top-level -; dc is ['TypeEquivalence,:.] => NIL -; m=tar => 'T -; tar is ['Union,t,'failed] => t=m -; tar is ['Union,'failed,t] and t=m - -(DEFUN |hasCorrectTarget| (|m| |sig|) - (PROG (|dc| |tar| |ISTMP#1| |ISTMP#2| |t|) - (RETURN - (PROGN - (setq |dc| (CAR |sig|)) - (setq |tar| (CADR |sig|)) - (COND - ((AND (CONSP |dc|) (EQ (QCAR |dc|) '|TypeEquivalence|)) NIL) - ((BOOT-EQUAL |m| |tar|) 'T) - ((AND (CONSP |tar|) (EQ (QCAR |tar|) '|Union|) - (PROGN - (setq |ISTMP#1| (QCDR |tar|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (setq |t| (QCAR |ISTMP#1|)) - (setq |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (EQ (QCAR |ISTMP#2|) '|failed|)))))) - (BOOT-EQUAL |t| |m|)) - ('T - (AND (CONSP |tar|) (EQ (QCAR |tar|) '|Union|) - (PROGN - (setq |ISTMP#1| (QCDR |tar|)) - (AND (CONSP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) '|failed|) - (PROGN - (setq |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (setq |t| (QCAR |ISTMP#2|)) - 'T))))) - (BOOT-EQUAL |t| |m|)))))))) - - \end{chunk} \eject \begin{thebibliography}{99} -- 1.7.5.4