diff --git a/changelog b/changelog index e16d5da..a3e00c4 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +20090819 tpd src/axiom-website/patches.html 20090819.02.tpd.patch +20090819 tpd src/interp/Makefile move i-coerce.boot to i-coerce.lisp +20090819 tpd src/interp/i-coerce.lisp added, rewritten from i-coerce.boot +20090819 tpd src/interp/i-coerce.boot removed, rewritten to i-coerce.lisp 20090819 tpd src/axiom-website/patches.html 20090819.01.tpd.patch 20090819 tpd books/bookvol5 add Steven Segletes to credits 20090819 tpd readme add Steven Segletes diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 5ccd813..ea758bc 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1820,5 +1820,7 @@ i-analy.lisp rewrite from boot to lisp
i-code.lisp rewrite from boot to lisp
20090819.01.tpd.patch books/bookvol5 add Steven Segletes to credits
+20090819.02.tpd.patch +i-coerce.lisp rewrite from boot to lisp
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 3b37b45..78afe67 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -427,7 +427,7 @@ DOCFILES=${DOC}/as.boot.dvi \ ${DOC}/hashcode.boot.dvi \ ${DOC}/htcheck.boot.dvi \ ${DOC}/ht-util.boot.dvi \ - ${DOC}/i-coerce.boot.dvi ${DOC}/i-coerfn.boot.dvi \ + ${DOC}/i-coerfn.boot.dvi \ ${DOC}/i-eval.boot.dvi ${DOC}/i-funsel.boot.dvi \ ${DOC}/i-intern.boot.dvi \ ${DOC}/i-map.boot.dvi ${DOC}/incl.boot.dvi \ @@ -3074,47 +3074,27 @@ ${MID}/i-code.lisp: ${IN}/i-code.lisp.pamphlet @ -\subsection{i-coerce.boot} +\subsection{i-coerce.lisp} <>= -${OUT}/i-coerce.${O}: ${MID}/i-coerce.clisp - @ echo 285 making ${OUT}/i-coerce.${O} from ${MID}/i-coerce.clisp - @ (cd ${MID} ; \ +${OUT}/i-coerce.${O}: ${MID}/i-coerce.lisp + @ echo 136 making ${OUT}/i-coerce.${O} from ${MID}/i-coerce.lisp + @ ( cd ${MID} ; \ if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/i-coerce.clisp"' \ + echo '(progn (compile-file "${MID}/i-coerce.lisp"' \ ':output-file "${OUT}/i-coerce.${O}") (${BYE}))' | ${DEPSYS} ; \ else \ - echo '(progn (compile-file "${MID}/i-coerce.clisp"' \ + echo '(progn (compile-file "${MID}/i-coerce.lisp"' \ ':output-file "${OUT}/i-coerce.${O}") (${BYE}))' | ${DEPSYS} \ >${TMP}/trace ; \ fi ) @ -<>= -${MID}/i-coerce.clisp: ${IN}/i-coerce.boot.pamphlet - @ echo 286 making ${MID}/i-coerce.clisp \ - from ${IN}/i-coerce.boot.pamphlet +<>= +${MID}/i-coerce.lisp: ${IN}/i-coerce.lisp.pamphlet + @ echo 137 making ${MID}/i-coerce.lisp from \ + ${IN}/i-coerce.lisp.pamphlet @ (cd ${MID} ; \ - ${TANGLE} ${IN}/i-coerce.boot.pamphlet >i-coerce.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "i-coerce.boot") (${BYE}))' \ - | ${DEPSYS} ; \ - else \ - echo '(progn (boottran::boottocl "i-coerce.boot") (${BYE}))' \ - | ${DEPSYS} >${TMP}/trace ; \ - fi ; \ - rm i-coerce.boot ) - -@ -<>= -${DOC}/i-coerce.boot.dvi: ${IN}/i-coerce.boot.pamphlet - @echo 287 making ${DOC}/i-coerce.boot.dvi \ - from ${IN}/i-coerce.boot.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/i-coerce.boot.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} i-coerce.boot ; \ - rm -f ${DOC}/i-coerce.boot.pamphlet ; \ - rm -f ${DOC}/i-coerce.boot.tex ; \ - rm -f ${DOC}/i-coerce.boot ) + ${TANGLE} ${IN}/i-coerce.lisp.pamphlet >i-coerce.lisp ) @ @@ -6599,8 +6579,7 @@ clean: <> <> -<> -<> +<> <> <> diff --git a/src/interp/i-coerce.boot.pamphlet b/src/interp/i-coerce.boot.pamphlet deleted file mode 100644 index 2bce4fa..0000000 --- a/src/interp/i-coerce.boot.pamphlet +++ /dev/null @@ -1,1444 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp i-coerce.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{Coercion conventions} -\begin{verbatim} -Coercion conventions - -Coercion involves the changing of the datatype of an object. This - can be done for conformality of operations or, for example, to - change the structure of an object into one that is understood by - the printing routines. - -The actual coercion is controlled by the function "coerce" which - takes and delivers wrapped operands. Also see the functions - interpCoerce and coerceInteractive. - -Sometimes one does not want to actually change the datatype but - rather wants to determine whether it is possible to do so. The - controlling function to do this is "canCoerceFrom". The value - passed to specific coercion routines in this case is - "$fromCoerceable$". The value returned is true or false. See - specific examples for more info. - -The special routines that do the coercions typically involve a "2" - in their names. For example, G2E converts type "Gaussian" to - type "Expression". These special routines take and deliver - unwrapped operands. The determination of which special routine - to use is often made by consulting the list $CoerceTable - (currently in COT BOOT) and this is controlled by coerceByTable. - Note that the special routines are in the file COERCEFN BOOT. -\end{verbatim} -\section{Function getConstantFromDomain} -[[getConstantFromDomain]] is used to look up the constants $0$ and $1$ -from the given [[domainForm]]. -\begin{enumerate} -\item if [[isPartialMode]] (see i-funsel.boot) returns true then the -domain modemap contains the constant [[$EmptyMode]] which indicates -that the domain is not fully formed. In this case we return [[NIL]]. -\end{enumerate} -<>= -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) - -@ -\section{License} -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> ---% Algebraic coercions using interactive code - -algCoerceInteractive(p,source,target) == - -- now called in some groebner code - $useConvertForCoercions : local := true - source := devaluate source - target := devaluate target - u := coerceInteractive(objNewWrap(p,source),target) - u => objValUnwrap(u) - error ['"can't convert",p,'"of mode",source,'"to mode",target] - -spad2BootCoerce(x,source,target) == - -- x : source and we wish to coerce to target - -- used in spad code for Any - null isValidType source => throwKeyedMsg("S2IE0004",[source]) - null isValidType target => throwKeyedMsg("S2IE0004",[target]) - x' := coerceInteractive(objNewWrap(x,source),target) => - objValUnwrap(x') - throwKeyedMsgCannotCoerceWithValue(wrap x,source,target) - ---% Functions for Coercion or Else We'll Get Rough - -coerceOrFail(triple,t,mapName) == - -- some code generated for this is in coerceInt0 - t = $NoValueMode => triple - t' := coerceInteractive(triple,t) - t' => objValUnwrap(t') - sayKeyedMsg("S2IC0004",[mapName,objMode triple,t]) - '"failed" - -coerceOrCroak(triple, t, mapName) == - -- this does the coercion and returns the value or dies - t = $NoValueMode => triple - t' := coerceOrConvertOrRetract(triple,t) - t' => objValUnwrap(t') - mapName = 'noMapName => - throwKeyedMsgCannotCoerceWithValue(objVal triple,objMode triple, t) - sayKeyedMsg("S2IC0005",[mapName]) - throwKeyedMsgCannotCoerceWithValue(objVal triple,objMode triple, t) - -coerceOrThrowFailure(value, t1, t2) == - (result := coerceOrRetract(objNewWrap(value, t1), t2)) or - coercionFailure() - objValUnwrap(result) - ---% Retraction functions - -retract object == - type := objMode object - STRINGP type => 'failed - type = $EmptyMode => 'failed - val := objVal object - not isWrapped val and val isnt ['MAP,:.] => 'failed - type' := equiType(type) - (ans := retract1 objNew(val,equiType(type))) = 'failed => ans - objNew(objVal ans,eqType objMode ans) - -retract1 object == - -- this function is the new version of the old "pullback" - -- it first tries to change the datatype of an object to that of - -- largest contained type. Examples: P RN -> RN, RN -> I - -- This is mostly for cases such as constant polynomials or - -- quotients with 1 in the denominator. - type := objMode object - STRINGP type => 'failed - val := objVal object - type = $PositiveInteger => objNew(val,$NonNegativeInteger) - type = $NonNegativeInteger => objNew(val,$Integer) - type = $Integer and SINTP unwrap val => objNew(val, $SingleInteger) - type' := equiType(type) - if not EQ(type,type') then object := objNew(val,type') - (1 = #type') or (type' is ['Union,:.]) or - (type' is ['FunctionCalled,.]) - or (type' is ['OrderedVariableList,.]) or (type is ['Variable,.]) => - (object' := retract2Specialization(object)) => object' - 'failed - null (underDomain := underDomainOf type') => 'failed - -- try to retract the "coefficients" - -- think of P RN -> P I or M RN -> M I - object' := retractUnderDomain(object,type,underDomain) - object' ^= 'failed => object' - -- see if we can use the retract functions - (object' := coerceRetract(object,underDomain)) => object' - -- see if we have a special case here - (object' := retract2Specialization(object)) => object' - 'failed - -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 - -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 - -coerceOrConvertOrRetract(T,m) == - $useConvertForCoercions : local := true - 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 - -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",STRINGIMAGE D) - functionp fun => - PUT(D,'retract,fun) - c := CATCH('coerceFailure,FUNCALL(fun,object,t2)) - (c = $coerceFailure) => NIL - c - NIL - 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 - ---% Coercion utilities - --- The next function extracts the structural definition of constants --- from a given domain. For example, getConstantFromDomain('(One),S) --- returns the representation of 1 in the domain S. - -constantInDomain?(form,domainForm) == - opAlist := getOperationAlistFromLisplib first domainForm - key := opOf form - entryList := LASSOC(key,opAlist) - entryList is [[., ., ., type]] and type in '(CONST ASCONST) => true - key = "One" => constantInDomain?(["1"], domainForm) - key = "Zero" => constantInDomain?(["0"], domainForm) - false - -<> - -domainOne(domain) == getConstantFromDomain('(One),domain) - -domainZero(domain) == getConstantFromDomain('(Zero),domain) - -equalOne(object, domain) == - -- tries using constant One and "=" from domain - -- object should not be wrapped - algEqual(object, getConstantFromDomain('(One),domain), domain) - -equalZero(object, domain) == - -- tries using constant Zero and "=" from domain - -- object should not be wrapped - 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) - ---% 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 - ---% Interpreter Coercion Query Functions - -canCoerce1(t1,t2) == - -- general test for coercion - -- the result is NIL if it fails - t1 = t2 => true - absolutelyCanCoerceByCheating(t1,t2) or t1 = '(None) or t2 = '(Any) or - t1 in '((Mode) (Domain) (SubDomain (Domain))) => - t2 = $OutputForm => true - NIL - -- next is for tagged union selectors for the time being - t1 is ['Variable,=t2] or t2 is ['Variable,=t1] => true - STRINGP t1 => - t2 = $String => true - t2 = $OutputForm => true - t2 is ['Union,:.] => canCoerceUnion(t1,t2) - t2 is ['Variable,v] and (t1 = PNAME(v)) => true - NIL - STRINGP t2 => - t1 is ['Variable,v] and (t2 = PNAME(v)) => true - NIL - atom t1 or atom t2 => NIL - null isValidType(t2) => NIL - - absolutelyCannotCoerce(t1,t2) => NIL - - nt1 := CAR t1 - nt2 := CAR t2 - - EQ(nt1,'Mapping) => EQ(nt2,'Any) - EQ(nt2,'Mapping) => - EQ(nt1,'Variable) or EQ(nt1,'FunctionCalled) => - canCoerceExplicit2Mapping(t1,t2) - NIL - EQ(nt1,'Union) or EQ(nt2,'Union) => canCoerceUnion(t1,t2) - - -- efficiency hack - t1 is ['Segment, s1] and t2 is ['UniversalSegment, s2] and - (isEqualOrSubDomain(s1, s2) or canCoerce(s1, s2)) => true - - t1 is ['Tuple,S] and t2 ^= '(OutputForm) => canCoerce(['List, S], t2) - - isRingT2 := ofCategory(t2,'(Ring)) - isRingT2 and isEqualOrSubDomain(t1,$Integer) => true - (ans := canCoerceTopMatching(t1,t2,nt1,nt2)) ^= 'maybe => ans - t2 = $Integer => canCoerceLocal(t1,t2) -- is true - ans := canCoerceTower(t1,t2) or - [.,:arg]:= deconstructT t2 - arg and - t:= last arg - canCoerce(t1,t) and canCoerceByFunction(t,t2) and 'T - ans or (t1 in '((PositiveInteger) (NonNegativeInteger)) - and canCoerce($Integer,t2)) - -canCoerceFrom0(t1,t2) == --- top level test for coercion, which transfers all RN, RF and RR into --- equivalent types - startTimingProcess 'querycoerce - q := - isEqualOrSubDomain(t1,t2) or t1 = '(None) or t2 = '(Any) or - if t2 = $OutputForm then (s1 := t1; s2 := t2) - else (s1:= equiType(t1); s2:= equiType(t2)) - - -- make sure we are trying to coerce to a legal type - -- in particular, polynomials are repeated, etc. - null isValidType(t2) => NIL - null isLegitimateMode(t2,nil,nil) => NIL - - t1 = $RationalNumber => - isEqualOrSubDomain(t2,$Integer) => NIL - canCoerce(t1,t2) or canCoerce(s1,s2) - canCoerce(s1,s2) - stopTimingProcess 'querycoerce - q - -isSubTowerOf(t1,t2) == - -- assumes RF and RN stuff has been expanded - -- tests whether t1 is somewhere inside t2 - isEqualOrSubDomain(t1,t2) => true - null (u := underDomainOf t2) => nil - isSubTowerOf(t1,u) - -canCoerceTopMatching(t1,t2,tt1,tt2) == - -- returns true, nil or maybe - -- for example, if t1 = P[x] D1 and t2 = P[y] D2 and x = y then - -- canCoerce will only be true if D1 = D2 - not EQ(tt1,tt2) => 'maybe - doms := '(Polynomial List Matrix FiniteSet Vector Stream Gaussian) - MEMQ(tt1,doms) => canCoerce(CADR t1, CADR t2) - not (MEMQ(tt1,$univariateDomains) or MEMQ(tt2,$multivariateDomains)) => - 'maybe - u2 := deconstructT t2 - 1 = #u2 => NIL - u1 := deconstructT t1 - 1 = #u1 => NIL -- no under domain - first(u1) ^= first(u2) => 'maybe - canCoerce(underDomainOf t1, underDomainOf t2) - -canCoerceExplicit2Mapping(t1,t is ['Mapping,target,:argl]) == - -- determines if there a mapping called var with the given args - -- and target - $useCoerceOrCroak: local := nil - t1 is ['Variable,var] => - null (mms :=selectMms1(var,target,argl,[NIL for a in argl],true)) => NIL - mm := CAAR mms - mm is [., targ, :.] => - targ = target => true - false - false - t1 is ['FunctionCalled,fun] => - funNode := mkAtreeNode fun - transferPropsToNode(fun,funNode) - mms := CATCH('coerceOrCroaker, selectLocalMms(funNode,fun,argl,target)) - CONSP mms => - mms is [[['interpOnly,:.],:.]] => nil - mm := CAAR mms - mm is [., targ, :.] => - targ = target => true - false - false - NIL - NIL - -canCoerceUnion(t1,t2) == - -- sees if one can coerce to or from a Union Domain - -- assumes one of t1 and t2 is one - - -- get the domains in the union, checking for tagged unions - if (isUnion1 := t1 is ['Union,:uds1]) then - unionDoms1 := - uds1 and first uds1 is [":",:.] => [t for [.,.,t] in uds1] - uds1 - if (isUnion2 := t2 is ['Union,:uds2]) then - unionDoms2 := - uds2 and first uds2 is [":",:.] => [t for [.,.,t] in uds2] - uds2 - - isUnion2 => - MEMBER(t1,unionDoms2) => true - isUnion1 => - and/[or/[canCoerce(ud1,ud2) for ud2 in unionDoms2] - for ud1 in unionDoms1] - or/[canCoerce(t1,ud) for ud in unionDoms2] - -- next, a little lie - t1 is ['Union,d1, ='"failed"] and t2 = d1 => true - isUnion1 => - and/[canCoerce(ud,t2) for ud in unionDoms1] - keyedSystemError("S2GE0016",['"canCoerceUnion", - '"called with 2 non-Unions"]) - -canCoerceByMap(t1,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 answer true - -- if canCoerceFrom(t1,t2). - u2 := deconstructT t2 - 1 = #u2 => NIL - u1 := deconstructT t1 - 1 = #u1 => NIL -- no under domain - CAR(u1) ^= CAR(u2) => NIL - top := CAAR u1 - u1 := underDomainOf t1 - u2 := underDomainOf t2 - - absolutelyCannotCoerce(u1,u2) => NIL - - -- save some time for those we know about - know := '(List Vector Segment Stream UniversalSegment Array - Polynomial UnivariatePolynomial SquareMatrix Matrix) - top in know => canCoerce(u1,u2) - - null selectMms1('map,t2,[['Mapping,u2,u1],t1], - [['Mapping,u2,u1],u1],NIL) => NIL - -- don't bother checking for Undef, so avoid instantiation - canCoerce(u1,u2) - -canCoerceTower(t1,t2) == --- tries to find a coercion between top level t2 and somewhere inside t1 --- builds new bubbled type, for which coercion is called recursively - canCoerceByMap(t1,t2) or newCanCoerceCommute(t1,t2) or - canCoerceLocal(t1,t2) or canCoercePermute(t1,t2) or - [c1,:arg1]:= deconstructT t1 - arg1 and - TL:= NIL - arg:= arg1 - until x or not arg repeat x:= - t:= last arg - [c,:arg]:= deconstructT t - TL:= [c,arg,:TL] - arg and coerceIntTest(t,t2) and - CDDR TL => - s:= constructT(c1,replaceLast(arg1,bubbleConstructor TL)) - canCoerceLocal(t1,s) and - [c2,:arg2]:= deconstructT last s - s1:= bubbleConstructor [c2,arg2,c1,arg1] - canCoerceCommute(s,s1) and canCoerceLocal(s1,t2) - s:= bubbleConstructor [c,arg,c1,arg1] - newCanCoerceCommute(t1,s) and canCoerceLocal(s,t2) - x - -canCoerceLocal(t1,t2) == - -- test for coercion on top level - p:= ASSQ(CAR t1,$CoerceTable) - p and ASSQ(CAR t2,CDR p) is [.,:[tag,fun]] => - tag='partial => NIL - tag='total => true - (functionp(fun) and - (v:=CATCH('coerceFailure,FUNCALL(fun,'_$fromCoerceable_$,t1,t2))) - and v ^= $coerceFailure) or canCoerceByFunction(t1,t2) - canCoerceByFunction(t1,t2) - -canCoerceCommute(t1,t2) == --- THIS IS OUT-MODED AND WILL GO AWAY SOON RSS 2-87 --- t1 is t2 with the two top level constructors commuted --- looks for the existence of a commuting function - CAR(t1) in (l := [$QuotientField, 'Gaussian]) and - CAR(t2) in l => true - p:= ASSQ(CAR t1,$CommuteTable) - p and ASSQ(CAR t2,CDR p) is [.,:['commute,.]] - -newCanCoerceCommute(t1,t2) == - coerceIntCommute(objNewWrap("$fromCoerceable$",t1),t2) - -canCoercePermute(t1,t2) == - -- try to generate a sequence of transpositions that will convert - -- t1 into t2 - t2 in '((Integer) (OutputForm)) => NIL - 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 - ok := canCoerce(t1,t) - if ok then t1 := t - ok - -canConvertByFunction(m1,m2) == - null $useConvertForCoercions => NIL - canCoerceByFunction1(m1,m2,'convert) - -canCoerceByFunction(m1,m2) == canCoerceByFunction1(m1,m2,'coerce) - -canCoerceByFunction1(m1,m2,fun) == - -- calls selectMms with $Coerce=NIL and tests for required target=m2 - $declaredMode:local:= NIL - $reportBottomUpFlag:local:= NIL - -- have to handle cases where we might have changed from RN to QF I - -- make 2 lists of expanded and unexpanded types - l1 := REMDUP [m1,eqType m1] - l2 := REMDUP [m2,eqType m2] - ans := NIL - for t1 in l1 while not ans repeat - for t2 in l2 while not ans repeat - l := selectMms1(fun,t2,[t1],[t1],NIL) - ans := [x for x in l | x is [sig,:.] and CADR sig=t2 and - CADDR sig=t1 and - CAR(sig) isnt ['TypeEquivalence,:.]] and true - 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] - -absolutelyCannotCoerce(t1,t2) == - -- response of true means "definitely cannot coerce" - -- this is largely an efficiency hack - ATOM(t1) or ATOM(t2) => NIL - t2 = '(None) => true - n1 := CAR t1 - n2 := CAR t2 - QFI := [$QuotientField, $Integer] - int2 := isEqualOrSubDomain(t2,$Integer) - scalars := '(BigFloat NewFloat Float DoubleFloat RationalNumber) - - MEMQ(n1,scalars) and int2 => true - (t1 = QFI) and int2 => true - - num2 := int2 or MEMQ(n2,scalars) or (t2 = QFI) - isVar1 := MEMQ(n1,'(Variable Symbol)) - - num2 and isVar1 => true - num2 and MEMQ(n1,$univariateDomains) => true - num2 and MEMQ(n1,$multivariateDomains) => true - miscpols := '(Polynomial ElementaryFunction SimpleAlgebraicExtension) - num2 and MEMQ(n1,miscpols) => true - - aggs := '( - Matrix List Vector Stream Array RectangularMatrix FiniteSet - ) - u1 := underDomainOf t1 - u2 := underDomainOf t2 - MEMQ(n1,aggs) and (u1 = t2) => true - MEMQ(n2,aggs) and (u2 = t1) => true - - algs := '( - SquareMatrix Gaussian RectangularMatrix Quaternion - ) - nonpols := append(aggs,algs) - num2 and MEMQ(n1,nonpols) => true - isVar1 and MEMQ(n2,nonpols) and - absolutelyCannotCoerce(t1,u2) => true - - (MEMQ(n1,scalars) or (t1 = QFI)) and (t2 = '(Polynomial (Integer))) => - true - - v2 := deconstructT t2 - 1 = #v2 => NIL - v1 := deconstructT t1 - 1 = #v1 => NIL - CAR(v1) ^= CAR(v2) => NIL - absolutelyCannotCoerce(u1,u2) - -typeIsASmallInteger x == (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 - -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 - -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 - -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 PAIRP(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) - -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 - -coerceImmediateSubDomain(val, tSuper, tSub, pred) == - predfn := getSubDomainPredicate(tSuper, tSub, pred) - FUNCALL(predfn, val, nil) => objNew(val, tSub) - 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 - -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 - -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 - -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 - -stripUnionTags doms == - [if dom is [":",.,dom'] then dom' else dom for dom in doms] - -isTaggedUnion u == - u is ['Union,:tl] and tl and first tl is [":",.,.] and true - -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 - -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) - -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) - -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 - -coerceIntFromUnion(object,t2) == - -- coerces from a Union type to something else - 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) - -coerceIntByMapInner(arg,[u1,:u2]) == 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 - -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 - -coerceIntSpecial(triple,t2) == - t1 := objMode triple - t2 is ['SimpleAlgebraicExtension,R,U,.] and t1 = R => - null (x := coerceInt(triple,U)) => NIL - coerceInt(x,t2) - 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) - -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)) - -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",STRINGIMAGE 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 - -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 - -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 - -decomposeTypeIntoTower t == - ATOM t => [t] - d := deconstructT t - NULL rest d => [t] - rd := REVERSE t - [reverse QCDR rd,:decomposeTypeIntoTower QCAR rd] - -reassembleTowerIntoType tower == - ATOM tower => tower - NULL rest tower => CAR tower - [:top,t,s] := tower - reassembleTowerIntoType [:top,[:t,s]] - -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)) - -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)) - -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) - -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 - -coercionFailure() == - -- does the throw on coercion failure - 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 - -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 - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/i-coerce.lisp.pamphlet b/src/interp/i-coerce.lisp.pamphlet new file mode 100644 index 0000000..2a8f6b4 --- /dev/null +++ b/src/interp/i-coerce.lisp.pamphlet @@ -0,0 +1,4412 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp i-coerce.lisp} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{Coercion conventions} +\begin{verbatim} +Coercion conventions + +Coercion involves the changing of the datatype of an object. This + can be done for conformality of operations or, for example, to + change the structure of an object into one that is understood by + the printing routines. + +The actual coercion is controlled by the function "coerce" which + takes and delivers wrapped operands. Also see the functions + interpCoerce and coerceInteractive. + +Sometimes one does not want to actually change the datatype but + rather wants to determine whether it is possible to do so. The + controlling function to do this is "canCoerceFrom". The value + passed to specific coercion routines in this case is + "$fromCoerceable$". The value returned is true or false. See + specific examples for more info. + +The special routines that do the coercions typically involve a "2" + in their names. For example, G2E converts type "Gaussian" to + type "Expression". These special routines take and deliver + unwrapped operands. The determination of which special routine + to use is often made by consulting the list $CoerceTable + (currently in COT BOOT) and this is controlled by coerceByTable. + Note that the special routines are in the file COERCEFN BOOT. +\end{verbatim} +<<*>>= +(IN-PACKAGE "BOOT" ) + +;--% Algebraic coercions using interactive code +;algCoerceInteractive(p,source,target) == +; -- now called in some groebner code +; $useConvertForCoercions : local := true +; source := devaluate source +; target := devaluate target +; u := coerceInteractive(objNewWrap(p,source),target) +; u => objValUnwrap(u) +; error ['"can't convert",p,'"of mode",source,'"to mode",target] + +(DEFUN |algCoerceInteractive| (|p| |source| |target|) + (PROG (|$useConvertForCoercions| |u|) + (DECLARE (SPECIAL |$useConvertForCoercions|)) + (RETURN + (PROGN + (SPADLET |$useConvertForCoercions| (QUOTE T)) + (SPADLET |source| (|devaluate| |source|)) + (SPADLET |target| (|devaluate| |target|)) + (SPADLET |u| (|coerceInteractive| (|objNewWrap| |p| |source|) |target|)) + (COND + (|u| (|objValUnwrap| |u|)) + ((QUOTE T) + (|error| + (CONS + "can't convert" + (CONS + |p| + (CONS + "of mode" + (CONS |source| (CONS "to mode" (CONS |target| NIL))))))))))))) + +;spad2BootCoerce(x,source,target) == +; -- x : source and we wish to coerce to target +; -- used in spad code for Any +; null isValidType source => throwKeyedMsg("S2IE0004",[source]) +; null isValidType target => throwKeyedMsg("S2IE0004",[target]) +; x' := coerceInteractive(objNewWrap(x,source),target) => +; objValUnwrap(x') +; throwKeyedMsgCannotCoerceWithValue(wrap x,source,target) + +(DEFUN |spad2BootCoerce| (|x| |source| |target|) + (PROG (|x'|) + (RETURN + (COND + ((NULL (|isValidType| |source|)) + (|throwKeyedMsg| (QUOTE S2IE0004) (CONS |source| NIL))) + ((NULL (|isValidType| |target|)) + (|throwKeyedMsg| (QUOTE S2IE0004) (CONS |target| NIL))) + ((SPADLET |x'| (|coerceInteractive| (|objNewWrap| |x| |source|) |target|)) + (|objValUnwrap| |x'|)) + ((QUOTE T) + (|throwKeyedMsgCannotCoerceWithValue| + (|wrap| |x|) |source| |target|)))))) + +;--% Functions for Coercion or Else We'll Get Rough +;coerceOrFail(triple,t,mapName) == +; -- some code generated for this is in coerceInt0 +; t = $NoValueMode => triple +; t' := coerceInteractive(triple,t) +; t' => objValUnwrap(t') +; sayKeyedMsg("S2IC0004",[mapName,objMode triple,t]) +; '"failed" + +(DEFUN |coerceOrFail| (|triple| |t| |mapName|) + (PROG (|t'|) + (RETURN + (COND + ((BOOT-EQUAL |t| |$NoValueMode|) |triple|) + ((QUOTE T) + (SPADLET |t'| (|coerceInteractive| |triple| |t|)) + (COND + (|t'| (|objValUnwrap| |t'|)) + ((QUOTE T) + (|sayKeyedMsg| 'S2IC0004 + (CONS + |mapName| + (CONS (|objMode| |triple|) (CONS |t| NIL)))) "failed"))))))) + +;coerceOrCroak(triple, t, mapName) == +; -- this does the coercion and returns the value or dies +; t = $NoValueMode => triple +; t' := coerceOrConvertOrRetract(triple,t) +; t' => objValUnwrap(t') +; mapName = 'noMapName => +; throwKeyedMsgCannotCoerceWithValue(objVal triple,objMode triple, t) +; sayKeyedMsg("S2IC0005",[mapName]) +; throwKeyedMsgCannotCoerceWithValue(objVal triple,objMode triple, t) + +(DEFUN |coerceOrCroak| (|triple| |t| |mapName|) + (PROG (|t'|) + (RETURN + (COND + ((BOOT-EQUAL |t| |$NoValueMode|) |triple|) + ((QUOTE T) + (SPADLET |t'| (|coerceOrConvertOrRetract| |triple| |t|)) + (COND + (|t'| (|objValUnwrap| |t'|)) + ((BOOT-EQUAL |mapName| (QUOTE |noMapName|)) + (|throwKeyedMsgCannotCoerceWithValue| + (|objVal| |triple|) (|objMode| |triple|) |t|)) + ((QUOTE T) + (|sayKeyedMsg| (QUOTE S2IC0005) (CONS |mapName| NIL)) + (|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 + (SPADLET |result| (|coerceOrRetract| (|objNewWrap| |value| |t1|) |t2|)) + (|coercionFailure|)) + (|objValUnwrap| |result|))))) + +;--% Retraction functions +;retract object == +; type := objMode object +; STRINGP type => 'failed +; type = $EmptyMode => 'failed +; val := objVal object +; not isWrapped val and val isnt ['MAP,:.] => 'failed +; type' := equiType(type) +; (ans := retract1 objNew(val,equiType(type))) = 'failed => ans +; objNew(objVal ans,eqType objMode ans) + +(DEFUN |retract| (|object|) + (PROG (|type| |val| |type'| |ans|) + (RETURN + (PROGN + (SPADLET |type| (|objMode| |object|)) + (COND + ((STRINGP |type|) (QUOTE |failed|)) + ((BOOT-EQUAL |type| |$EmptyMode|) (QUOTE |failed|)) + ((QUOTE T) + (SPADLET |val| (|objVal| |object|)) + (COND + ((AND (NULL (|isWrapped| |val|)) + (NULL (AND (PAIRP |val|) (EQ (QCAR |val|) (QUOTE MAP))))) + (QUOTE |failed|)) + ((QUOTE T) + (SPADLET |type'| (|equiType| |type|)) + (COND + ((BOOT-EQUAL + (SPADLET |ans| (|retract1| (|objNew| |val| (|equiType| |type|)))) + (QUOTE |failed|)) + |ans|) + ((QUOTE T) + (|objNew| (|objVal| |ans|) (|eqType| (|objMode| |ans|))))))))))))) + +;retract1 object == +; -- this function is the new version of the old "pullback" +; -- it first tries to change the datatype of an object to that of +; -- largest contained type. Examples: P RN -> RN, RN -> I +; -- This is mostly for cases such as constant polynomials or +; -- quotients with 1 in the denominator. +; type := objMode object +; STRINGP type => 'failed +; val := objVal object +; type = $PositiveInteger => objNew(val,$NonNegativeInteger) +; type = $NonNegativeInteger => objNew(val,$Integer) +; type = $Integer and SINTP unwrap val => objNew(val, $SingleInteger) +; type' := equiType(type) +; if not EQ(type,type') then object := objNew(val,type') +; (1 = #type') or (type' is ['Union,:.]) or +; (type' is ['FunctionCalled,.]) +; or (type' is ['OrderedVariableList,.]) or (type is ['Variable,.]) => +; (object' := retract2Specialization(object)) => object' +; 'failed +; null (underDomain := underDomainOf type') => 'failed +; -- try to retract the "coefficients" +; -- think of P RN -> P I or M RN -> M I +; object' := retractUnderDomain(object,type,underDomain) +; object' ^= 'failed => object' +; -- see if we can use the retract functions +; (object' := coerceRetract(object,underDomain)) => object' +; -- see if we have a special case here +; (object' := retract2Specialization(object)) => object' +; 'failed + +(DEFUN |retract1| (|object|) + (PROG (|type| |val| |type'| |ISTMP#1| |underDomain| |object'|) + (RETURN + (PROGN + (SPADLET |type| (|objMode| |object|)) + (COND + ((STRINGP |type|) (QUOTE |failed|)) + ((QUOTE T) + (SPADLET |val| (|objVal| |object|)) + (COND + ((BOOT-EQUAL |type| |$PositiveInteger|) + (|objNew| |val| |$NonNegativeInteger|)) + ((BOOT-EQUAL |type| |$NonNegativeInteger|) + (|objNew| |val| |$Integer|)) + ((AND (BOOT-EQUAL |type| |$Integer|) (SINTP (|unwrap| |val|))) + (|objNew| |val| |$SingleInteger|)) + ((QUOTE T) + (SPADLET |type'| (|equiType| |type|)) + (COND + ((NULL (EQ |type| |type'|)) + (SPADLET |object| (|objNew| |val| |type'|)))) + (COND + ((OR (EQL 1 (|#| |type'|)) + (AND (PAIRP |type'|) (EQ (QCAR |type'|) (QUOTE |Union|))) + (AND (PAIRP |type'|) + (EQ (QCAR |type'|) (QUOTE |FunctionCalled|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |type'|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL)))) + (AND (PAIRP |type'|) + (EQ (QCAR |type'|) (QUOTE |OrderedVariableList|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |type'|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL)))) + (AND (PAIRP |type|) + (EQ (QCAR |type|) (QUOTE |Variable|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |type|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL))))) + (COND + ((SPADLET |object'| (|retract2Specialization| |object|)) |object'|) + ((QUOTE T) (QUOTE |failed|)))) + ((NULL (SPADLET |underDomain| (|underDomainOf| |type'|))) + (QUOTE |failed|)) + ((QUOTE T) + (SPADLET |object'| + (|retractUnderDomain| |object| |type| |underDomain|)) + (COND + ((NEQUAL |object'| (QUOTE |failed|)) |object'|) + ((SPADLET |object'| (|coerceRetract| |object| |underDomain|)) + |object'|) + ((SPADLET |object'| (|retract2Specialization| |object|)) |object'|) + ((QUOTE T) (QUOTE |failed|))))))))))))) + +;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 (SPADLET |ud| (|underDomainOf| |underDomain|))) (QUOTE |failed|)) + ((QUOTE T) + (SPADLET |LETTMP#1| (|deconstructT| |type|)) + (SPADLET |c| (CAR |LETTMP#1|)) + (SPADLET |args| (CDR |LETTMP#1|)) + (COND + ((NEQUAL 1 (|#| |args|)) (QUOTE |failed|)) + ((NEQUAL 1 (|#| |c|)) (QUOTE |failed|)) + ((QUOTE T) + (SPADLET |type''| (|constructT| |c| (CONS |ud| NIL))) + (COND + ((SPADLET |object'| (|coerceInt| |object| |type''|)) |object'|) + ((QUOTE T) (QUOTE |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|) + (RETURN + (SEQ + (PROGN + (SPADLET |val| (|objVal| |object|)) + (SPADLET |val'| (|unwrap| |val|)) + (SPADLET |type| (|objMode| |object|)) + (COND + ((BOOT-EQUAL |type| |$Any|) + (SPADLET |dom| (CAR |val'|)) + (SPADLET |obj| (CDR |val'|)) + (|objNewWrap| |obj| |dom|)) + ((AND (PAIRP |type|) + (EQ (QCAR |type|) (QUOTE |Union|)) + (PROGN (SPADLET |unionDoms| (QCDR |type|)) (QUOTE T))) + (|coerceUnion2Branch| |object|)) + ((BOOT-EQUAL |type| |$Symbol|) + (|objNewWrap| 1 + (CONS (QUOTE |OrderedVariableList|) (CONS (CONS |val'| NIL) NIL)))) + ((AND (PAIRP |type|) + (EQ (QCAR |type|) (QUOTE |OrderedVariableList|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |type|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |var| (QCAR |ISTMP#1|)) (QUOTE T))))) + (|coerceInt| + (|objNewWrap| (ELT |var| (SPADDIFFERENCE |val'| 1)) |$Symbol|) + (QUOTE (|Polynomial| (|Integer|))))) + ((AND (PAIRP |type|) + (EQ (QCAR |type|) (QUOTE |Polynomial|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |type|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET D (QCAR |ISTMP#1|)) (QUOTE T))))) + (COND + ((AND (PAIRP |val'|) + (EQUAL (QCAR |val'|) 1) + (PROGN + (SPADLET |ISTMP#1| (QCDR |val'|)) + (AND (PAIRP |ISTMP#1|) + (PROGN (SPADLET |x| (QCAR |ISTMP#1|)) (QUOTE T))))) + (SPADLET |vl| (REMDUP (REVERSE (|varsInPoly| |val'|)))) + (COND + ((EQL 1 (|#| |vl|)) + (|coerceInt| |object| + (CONS (QUOTE |UnivariatePolynomial|) (CONS |x| (CONS D NIL))))) + ((QUOTE T) NIL))) + ((AND (PAIRP |val'|) (EQUAL (QCAR |val'|) 0)) (|coerceInt| |object| D)) + ((QUOTE T) NIL))) + ((AND (PAIRP |type|) + (EQ (QCAR |type|) (QUOTE |Matrix|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |type|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET D (QCAR |ISTMP#1|)) (QUOTE T))))) + (SPADLET |n| (|#| |val'|)) + (SPADLET |m| (|#| (ELT |val'| 0))) + (COND + ((BOOT-EQUAL |n| |m|) + (|objNew| |val| + (CONS (QUOTE |SquareMatrix|) (CONS |n| (CONS D NIL))))) + ((QUOTE T) + (|objNew| |val| + (CONS + (QUOTE |RectangularMatrix|) + (CONS |n| (CONS |m| (CONS D NIL)))))))) + ((AND + (PAIRP |type|) + (EQ (QCAR |type|) (QUOTE |RectangularMatrix|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |type|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |n| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |m| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND + (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN (SPADLET D (QCAR |ISTMP#3|)) (QUOTE T))))))))) + (COND + ((BOOT-EQUAL |n| |m|) + (|objNew| |val| + (CONS (QUOTE |SquareMatrix|) (CONS |n| (CONS D NIL))))) + ((QUOTE T) NIL))) + ((AND (PAIRP |type|) + (PROGN + (SPADLET |agg| (QCAR |type|)) + (SPADLET |ISTMP#1| (QCDR |type|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET D (QCAR |ISTMP#1|)) (QUOTE T)))) + (|member| |agg| (QUOTE (|Vector| |Segment| |UniversalSegment|)))) + (COND + ((BOOT-EQUAL D |$PositiveInteger|) + (|objNew| |val| (CONS |agg| (CONS |$NonNegativeInteger| NIL)))) + ((BOOT-EQUAL D |$NonNegativeInteger|) + (|objNew| |val| (CONS |agg| (CONS |$Integer| NIL)))) + ((QUOTE T) NIL))) + ((AND (PAIRP |type|) + (EQ (QCAR |type|) (QUOTE |Array|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |type|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |bds| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET D (QCAR |ISTMP#2|)) (QUOTE T))))))) + (COND + ((BOOT-EQUAL D |$PositiveInteger|) + (|objNew| |val| + (CONS + (QUOTE |Array|) + (CONS |bds| (CONS |$NonNegativeInteger| NIL))))) + ((BOOT-EQUAL D |$NonNegativeInteger|) + (|objNew| |val| + (CONS (QUOTE |Array|) (CONS |bds| (CONS |$Integer| NIL))))) + ((QUOTE T) NIL))) + ((AND (PAIRP |type|) + (EQ (QCAR |type|) (QUOTE |List|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |type|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET D (QCAR |ISTMP#1|)) (QUOTE T))))) + (COND + ((NULL + (AND (PAIRP D) + (EQ (QCAR D) (QUOTE |List|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR D)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |D'| (QCAR |ISTMP#1|)) (QUOTE T)))))) + (COND + ((BOOT-EQUAL D |$PositiveInteger|) + (|objNew| |val| + (CONS (QUOTE |List|) (CONS |$NonNegativeInteger| NIL)))) + ((BOOT-EQUAL D |$NonNegativeInteger|) + (|objNew| |val| (CONS (QUOTE |List|) (CONS |$Integer| NIL)))) + ((NULL |val'|) NIL) + ((QUOTE T) + (SPADLET |vl| NIL) + (SPADLET |tl| NIL) + (SPADLET |bad| NIL) + (DO ((#0=#:G166347 |val'| (CDR #0#)) (|e| NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ |e| (CAR #0#)) NIL) + (NULL (NULL |bad|))) + NIL) + (SEQ + (EXIT + (COND + ((BOOT-EQUAL (SPADLET |e'| (|retract| (|objNewWrap| |e| D))) + (QUOTE |failed|)) + (SPADLET |bad| (QUOTE T))) + ((QUOTE T) + (SPADLET |vl| (CONS (|objValUnwrap| |e'|) |vl|)) + (SPADLET |tl| (CONS (|objMode| |e'|) |tl|))))))) + (COND + (|bad| NIL) + ((BOOT-EQUAL (SPADLET |m| (|resolveTypeListAny| |tl|)) D) NIL) + ((BOOT-EQUAL D (|equiType| |m|)) NIL) + ((QUOTE T) + (SPADLET |vl'| NIL) + (DO ((#1=#:G166358 |vl| (CDR #1#)) + (|e| NIL) + (#2=#:G166359 |tl| (CDR #2#)) + (|t| NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ |e| (CAR #1#)) NIL) + (ATOM #2#) + (PROGN (SETQ |t| (CAR #2#)) NIL)) + NIL) + (SEQ + (EXIT + (COND + ((BOOT-EQUAL |t| |m|) (SPADLET |vl'| (CONS |e| |vl'|))) + ((QUOTE T) + (SPADLET |e'| (|coerceInt| (|objNewWrap| |e| |t|) |m|)) + (COND + ((NULL |e'|) (RETURN NIL)) + ((QUOTE T) + (SPADLET |vl'| (CONS (|objValUnwrap| |e'|) |vl'|))))))))) + (|objNewWrap| |vl'| (CONS (QUOTE |List|) (CONS |m| NIL)))))))) + ((BOOT-EQUAL |D'| |$PositiveInteger|) + (|objNew| |val| + (CONS + (QUOTE |List|) + (CONS (CONS (QUOTE |List|) (CONS |$NonNegativeInteger| NIL)) NIL)))) + ((BOOT-EQUAL |D'| |$NonNegativeInteger|) + (|objNew| |val| + (CONS + (QUOTE |List|) + (CONS (CONS (QUOTE |List|) (CONS |$Integer| NIL)) NIL)))) + ((OR + (AND (PAIRP |D'|) + (EQ (QCAR |D'|) (QUOTE |Variable|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |D'|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL)))) + (AND (PAIRP |D'|) + (EQ (QCAR |D'|) (QUOTE |OrderedVariableList|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |D'|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL))))) + (|coerceInt| |object| + (CONS + (QUOTE |List|) + (CONS (CONS (QUOTE |List|) (CONS |$Symbol| NIL)) NIL)))) + ((QUOTE T) + (SPADLET |n| (|#| |val'|)) + (SPADLET |m| (|#| (ELT |val'| 0))) + (COND + ((NULL (|isRectangularList| |val'| |n| |m|)) NIL) + ((QUOTE T) + (|coerceInt| |object| (CONS (QUOTE |Matrix|) (CONS |D'| NIL)))))))) + ((AND (PAIRP |type|) + (EQ (QCAR |type|) (QUOTE |Expression|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |type|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET D (QCAR |ISTMP#1|)) (QUOTE T))))) + (SPADLET |num| (CAR |val'|)) + (SPADLET |den| (CDR |val'|)) + (COND + ((NULL + (AND + (PAIRP |num|) + (EQUAL (QCAR |num|) 0) + (PROGN (SPADLET |num| (QCDR |num|)) (QUOTE T)))) + NIL) + ((NULL + (AND + (PAIRP |den|) + (EQUAL (QCAR |den|) 0) + (PROGN (SPADLET |den| (QCDR |den|)) (QUOTE T)))) + NIL) + ((QUOTE T) + (|objNewWrap| + (CONS |num| |den|) + (CONS |$QuotientField| (CONS D NIL)))))) + ((AND (PAIRP |type|) + (EQ (QCAR |type|) (QUOTE |SimpleAlgebraicExtension|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |type|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |k| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |rep| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) (EQ (QCDR |ISTMP#3|) NIL)))))))) + (SPADLET |val'| (|retract| (|objNew| |val| |rep|))) + (DO () + ((NULL + (AND + (NEQUAL |val'| (QUOTE |failed|)) + (NEQUAL (|equiType| (|objMode| |val'|)) |k|))) + NIL) + (SEQ (EXIT (SPADLET |val'| (|retract| |val'|))))) + (COND ((BOOT-EQUAL |val'| (QUOTE |failed|)) NIL) ((QUOTE T) |val'|))) + ((AND (PAIRP |type|) + (EQ (QCAR |type|) (QUOTE |UnivariatePuiseuxSeries|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |type|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |coef| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |var| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND + (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN (SPADLET |cen| (QCAR |ISTMP#3|)) (QUOTE T))))))))) + (|coerceInt| |object| + (CONS + (QUOTE |UnivariateLaurentSeries|) + (CONS |coef| (CONS |var| (CONS |cen| NIL)))))) + ((AND (PAIRP |type|) + (EQ (QCAR |type|) (QUOTE |UnivariateLaurentSeries|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |type|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |coef| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |var| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND + (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN (SPADLET |cen| (QCAR |ISTMP#3|)) (QUOTE T))))))))) + (|coerceInt| |object| + (CONS + (QUOTE |UnivariateTaylorSeries|) + (CONS |coef| (CONS |var| (CONS |cen| NIL)))))) + ((AND (PAIRP |type|) + (EQ (QCAR |type|) (QUOTE |FunctionCalled|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |type|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |name| (QCAR |ISTMP#1|)) (QUOTE T))))) + (COND + ((NULL (SPADLET |m| (|get| |name| (QUOTE |mode|) |$e|))) NIL) + ((|isPartialMode| |m|) NIL) ((QUOTE T) (|objNew| |val| |m|)))) + ((QUOTE T) NIL))))))) + +;coerceOrConvertOrRetract(T,m) == +; $useConvertForCoercions : local := true +; coerceOrRetract(T,m) + +(DEFUN |coerceOrConvertOrRetract| (T$ |m|) + (PROG (|$useConvertForCoercions|) + (DECLARE (SPECIAL |$useConvertForCoercions|)) + (RETURN + (PROGN + (SPADLET |$useConvertForCoercions| (QUOTE 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 + ((SPADLET |t'| (|coerceInteractive| T$ |m|)) |t'|) + ((QUOTE T) + (SPADLET |t| T$) + (SPADLET |ans| NIL) + (DO () + (NIL NIL) + (SEQ + (EXIT + (COND + (|ans| (RETURN |ans|)) + ((QUOTE T) + (SPADLET |t| (|retract| |t|)) + (COND + ((BOOT-EQUAL |t| (QUOTE |failed|)) (RETURN |ans|)) + ((QUOTE T) (SPADLET |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",STRINGIMAGE 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|) + (RETURN + (COND + ((BOOT-EQUAL (SPADLET |val| (|objValUnwrap| |object|)) + (QUOTE |$fromCoerceable$|)) + NIL) + ((QUOTE T) + (SPADLET |t1| (|objMode| |object|)) + (COND + ((BOOT-EQUAL |t2| |$OutputForm|) NIL) + ((AND (|isEqualOrSubDomain| |t1| |$Integer|) + (|typeIsASmallInteger| |t2|) + (SMINTP |val|)) + (|objNewWrap| |val| |t2|)) + ((BOOT-EQUAL |t1| |$Integer|) NIL) + ((BOOT-EQUAL |t1| |$Symbol|) NIL) + ((BOOT-EQUAL |t1| |$OutputForm|) NIL) + ((SPADLET |c| (|retractByFunction| |object| |t2|)) |c|) + ((AND (PAIRP |t1|) (PROGN (SPADLET D (QCAR |t1|)) (QUOTE T))) + (SPADLET |fun| + (OR (GETL D (QUOTE |retract|)) + (INTERN (STRCONC (MAKESTRING "retract") (STRINGIMAGE D))))) + (COND + ((|functionp| |fun|) + (PUT D (QUOTE |retract|) |fun|) + (SPADLET |c| + (CATCH (QUOTE |coerceFailure|) (FUNCALL |fun| |object| |t2|))) + (COND ((BOOT-EQUAL |c| |$coerceFailure|) NIL) ((QUOTE T) |c|))) + ((QUOTE T) NIL))) + ((QUOTE 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 + (SPADLET |$reportBottomUpFlag| NIL) + (SPADLET |t| (|objMode| |object|)) + (SPADLET |val| (|objValUnwrap| |object|)) + (SPADLET |target| + (CONS (QUOTE |Union|) (CONS |u| (CONS (MAKESTRING "failed") NIL)))) + (SPADLET |funName| (QUOTE |retractIfCan|)) + (COND + (|$reportBottomUpFlag| + (|sayFunctionSelection| |funName| + (CONS |t| NIL) |target| NIL "coercion facility (retraction)"))) + (COND + ((SPADLET |mms| + (APPEND + (|findFunctionInDomain| |funName| |t| |target| + (CONS |t| NIL) (CONS |t| NIL) NIL (QUOTE T)) + (|findFunctionInDomain| |funName| |u| |target| + (CONS |t| NIL) (CONS |t| NIL) NIL (QUOTE T)))) + (SPADLET |mms| + (|orderMms| |funName| |mms| (CONS |t| NIL) (CONS |t| NIL) |target|)))) + (COND + (|$reportBottomUpFlag| + (|sayFunctionSelectionResult| |funName| (CONS |t| NIL) |mms|))) + (COND + ((NULL |mms|) NIL) + ((QUOTE T) + (SPADLET |dc| (CAAAR |mms|)) + (SPADLET |slot| (CADAR |mms|)) + (SPADLET |dcVector| (|evalDomain| |dc|)) + (SPADLET |fun| + (|compiledLookup| |funName| (CONS |target| (CONS |t| NIL)) |dcVector|)) + (COND + ((NULL |fun|) NIL) + ((BOOT-EQUAL (CAR |fun|) (|function| |Undef|)) NIL) + ((QUOTE T) + (SPADLET $ |dcVector|) + (SPADLET |object'| + (|coerceUnion2Branch| (|objNewWrap| (SPADCALL |val| |fun|) |target|))) + (SPADLET |u'| (|objMode| |object'|)) + (COND + ((BOOT-EQUAL |u| |u'|) |object'|) + ((QUOTE T) NIL)))))))))) + +;--% Coercion utilities +;-- The next function extracts the structural definition of constants +;-- from a given domain. For example, getConstantFromDomain('(One),S) +;-- returns the representation of 1 in the domain S. +;constantInDomain?(form,domainForm) == +; opAlist := getOperationAlistFromLisplib first domainForm +; key := opOf form +; entryList := LASSOC(key,opAlist) +; entryList is [[., ., ., type]] and type in '(CONST ASCONST) => true +; key = "One" => constantInDomain?(["1"], domainForm) +; key = "Zero" => constantInDomain?(["0"], domainForm) +; false + +(DEFUN |constantInDomain?| (|form| |domainForm|) + (PROG (|opAlist| |key| |entryList| |ISTMP#1| |ISTMP#2| |ISTMP#3| + |ISTMP#4| |type|) + (RETURN + (PROGN + (SPADLET |opAlist| (|getOperationAlistFromLisplib| (CAR |domainForm|))) + (SPADLET |key| (|opOf| |form|)) + (SPADLET |entryList| (LASSOC |key| |opAlist|)) + (COND + ((AND (PAIRP |entryList|) + (EQ (QCDR |entryList|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |entryList|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND + (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |ISTMP#4| (QCDR |ISTMP#3|)) + (AND + (PAIRP |ISTMP#4|) + (EQ (QCDR |ISTMP#4|) NIL) + (PROGN (SPADLET |type| (QCAR |ISTMP#4|)) (QUOTE T)))))))))) + (|member| |type| (QUOTE (CONST ASCONST)))) + (QUOTE T)) + ((BOOT-EQUAL |key| (QUOTE |One|)) + (|constantInDomain?| (CONS (QUOTE |1|) NIL) |domainForm|)) + ((BOOT-EQUAL |key| (QUOTE |Zero|)) + (|constantInDomain?| (CONS (QUOTE |0|) NIL) |domainForm|)) + ((QUOTE T) NIL)))))) + +@ +\section{Function getConstantFromDomain} +[[getConstantFromDomain]] is used to look up the constants $0$ and $1$ +from the given [[domainForm]]. +\begin{enumerate} +\item if [[isPartialMode]] (see i-funsel.boot) returns true then the +domain modemap contains the constant [[$EmptyMode]] which indicates +that the domain is not fully formed. In this case we return [[NIL]]. +\end{enumerate} +<<*>>= +;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) + ((QUOTE T) + (SPADLET |opAlist| (|getOperationAlistFromLisplib| (CAR |domainForm|))) + (SPADLET |key| (|opOf| |form|)) + (SPADLET |entryList| (LASSOC |key| |opAlist|)) + (COND + ((NULL + (AND + (PAIRP |entryList|) + (EQ (QCDR |entryList|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |entryList|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |sig| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND + (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |ISTMP#4| (QCDR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) (EQ (QCDR |ISTMP#4|) NIL))))))))))) + (COND + ((BOOT-EQUAL |key| (QUOTE |One|)) + (|getConstantFromDomain| (CONS (QUOTE |1|) NIL) |domainForm|)) + ((BOOT-EQUAL |key| (QUOTE |Zero|)) + (|getConstantFromDomain| (CONS (QUOTE |0|) NIL) |domainForm|)) + ((QUOTE T) + (|throwKeyedMsg| 'S2IC0008 (CONS |form| (CONS |domainForm| NIL)))))) + ((QUOTE T) + (SPADLET |domain| (|evalDomain| |domainForm|)) + (SPADCALL (|compiledLookupCheck| |key| |sig| |domain|))))))))) + +;domainOne(domain) == getConstantFromDomain('(One),domain) + +(DEFUN |domainOne| (|domain|) + (|getConstantFromDomain| (QUOTE (|One|)) |domain|)) + +;domainZero(domain) == getConstantFromDomain('(Zero),domain) + +(DEFUN |domainZero| (|domain|) + (|getConstantFromDomain| (QUOTE (|Zero|)) |domain|)) + +;equalOne(object, domain) == +; -- tries using constant One and "=" from domain +; -- object should not be wrapped +; algEqual(object, getConstantFromDomain('(One),domain), domain) + +(DEFUN |equalOne| (|object| |domain|) + (|algEqual| |object| + (|getConstantFromDomain| (QUOTE (|One|)) |domain|) |domain|)) + +;equalZero(object, domain) == +; -- tries using constant Zero and "=" from domain +; -- object should not be wrapped +; algEqual(object, getConstantFromDomain('(Zero),domain), domain) + +(DEFUN |equalZero| (|object| |domain|) + (|algEqual| |object| + (|getConstantFromDomain| (QUOTE (|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|) + (RETURN + (PROGN + (SPADLET |eqfunc| + (|compiledLookupCheck| + (QUOTE =) + (CONS |$Boolean| (CONS (QUOTE $) (CONS (QUOTE $) NIL))) + (|evalDomain| |domain|))) + (SPADCALL |object1| |object2| |eqfunc|))))) + +@ +\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 + +Interpreter Coercion Query Functions +\end{verbatim} +<<*>>= +;canCoerce1(t1,t2) == +; -- general test for coercion +; -- the result is NIL if it fails +; t1 = t2 => true +; absolutelyCanCoerceByCheating(t1,t2) or t1 = '(None) or t2 = '(Any) or +; t1 in '((Mode) (Domain) (SubDomain (Domain))) => +; t2 = $OutputForm => true +; NIL +; -- next is for tagged union selectors for the time being +; t1 is ['Variable,=t2] or t2 is ['Variable,=t1] => true +; STRINGP t1 => +; t2 = $String => true +; t2 = $OutputForm => true +; t2 is ['Union,:.] => canCoerceUnion(t1,t2) +; t2 is ['Variable,v] and (t1 = PNAME(v)) => true +; NIL +; STRINGP t2 => +; t1 is ['Variable,v] and (t2 = PNAME(v)) => true +; NIL +; atom t1 or atom t2 => NIL +; null isValidType(t2) => NIL +; absolutelyCannotCoerce(t1,t2) => NIL +; nt1 := CAR t1 +; nt2 := CAR t2 +; EQ(nt1,'Mapping) => EQ(nt2,'Any) +; EQ(nt2,'Mapping) => +; EQ(nt1,'Variable) or EQ(nt1,'FunctionCalled) => +; canCoerceExplicit2Mapping(t1,t2) +; NIL +; EQ(nt1,'Union) or EQ(nt2,'Union) => canCoerceUnion(t1,t2) +; -- efficiency hack +; t1 is ['Segment, s1] and t2 is ['UniversalSegment, s2] and +; (isEqualOrSubDomain(s1, s2) or canCoerce(s1, s2)) => true +; t1 is ['Tuple,S] and t2 ^= '(OutputForm) => canCoerce(['List, S], t2) +; isRingT2 := ofCategory(t2,'(Ring)) +; isRingT2 and isEqualOrSubDomain(t1,$Integer) => true +; (ans := canCoerceTopMatching(t1,t2,nt1,nt2)) ^= 'maybe => ans +; t2 = $Integer => canCoerceLocal(t1,t2) -- is true +; ans := canCoerceTower(t1,t2) or +; [.,:arg]:= deconstructT t2 +; arg and +; t:= last arg +; canCoerce(t1,t) and canCoerceByFunction(t,t2) and 'T +; ans or (t1 in '((PositiveInteger) (NonNegativeInteger)) +; and canCoerce($Integer,t2)) + +(DEFUN |canCoerce1| (|t1| |t2|) + (PROG (|v| |nt1| |nt2| |s1| |s2| |ISTMP#1| S |isRingT2| |LETTMP#1| + |arg| |t| |ans|) + (RETURN + (COND + ((BOOT-EQUAL |t1| |t2|) (QUOTE T)) + ((QUOTE T) + (OR + (|absolutelyCanCoerceByCheating| |t1| |t2|) + (BOOT-EQUAL |t1| (QUOTE (|None|))) + (BOOT-EQUAL |t2| (QUOTE (|Any|))) + (COND + ((|member| |t1| (QUOTE ((|Mode|) (|Domain|) (|SubDomain| (|Domain|))))) + (COND ((BOOT-EQUAL |t2| |$OutputForm|) (QUOTE T)) ((QUOTE T) NIL))) + ((OR + (AND + (PAIRP |t1|) + (EQ (QCAR |t1|) (QUOTE |Variable|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t1|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (EQUAL (QCAR |ISTMP#1|) |t2|)))) + (AND + (PAIRP |t2|) + (EQ (QCAR |t2|) (QUOTE |Variable|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t2|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (EQUAL (QCAR |ISTMP#1|) |t1|))))) + (QUOTE T)) + ((STRINGP |t1|) + (COND + ((BOOT-EQUAL |t2| |$String|) (QUOTE T)) + ((BOOT-EQUAL |t2| |$OutputForm|) (QUOTE T)) + ((AND (PAIRP |t2|) (EQ (QCAR |t2|) (QUOTE |Union|))) + (|canCoerceUnion| |t1| |t2|)) + ((AND + (PAIRP |t2|) + (EQ (QCAR |t2|) (QUOTE |Variable|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t2|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |v| (QCAR |ISTMP#1|)) (QUOTE T)))) + (BOOT-EQUAL |t1| (PNAME |v|))) + (QUOTE T)) + ((QUOTE T) NIL))) + ((STRINGP |t2|) + (COND + ((AND + (PAIRP |t1|) + (EQ (QCAR |t1|) (QUOTE |Variable|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t1|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |v| (QCAR |ISTMP#1|)) (QUOTE T)))) + (BOOT-EQUAL |t2| (PNAME |v|))) + (QUOTE T)) + ((QUOTE T) NIL))) + ((OR (ATOM |t1|) (ATOM |t2|)) NIL) + ((NULL (|isValidType| |t2|)) NIL) + ((|absolutelyCannotCoerce| |t1| |t2|) NIL) + ((QUOTE T) + (SPADLET |nt1| (CAR |t1|)) + (SPADLET |nt2| (CAR |t2|)) + (COND + ((EQ |nt1| (QUOTE |Mapping|)) (EQ |nt2| (QUOTE |Any|))) + ((EQ |nt2| (QUOTE |Mapping|)) + (COND + ((OR + (EQ |nt1| (QUOTE |Variable|)) + (EQ |nt1| (QUOTE |FunctionCalled|))) + (|canCoerceExplicit2Mapping| |t1| |t2|)) + ((QUOTE T) NIL))) + ((OR (EQ |nt1| (QUOTE |Union|)) (EQ |nt2| (QUOTE |Union|))) + (|canCoerceUnion| |t1| |t2|)) + ((AND + (PAIRP |t1|) + (EQ (QCAR |t1|) (QUOTE |Segment|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t1|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |s1| (QCAR |ISTMP#1|)) (QUOTE T)))) + (PAIRP |t2|) + (EQ (QCAR |t2|) (QUOTE |UniversalSegment|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t2|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |s2| (QCAR |ISTMP#1|)) (QUOTE T)))) + (OR (|isEqualOrSubDomain| |s1| |s2|) (|canCoerce| |s1| |s2|))) + (QUOTE T)) + ((AND + (PAIRP |t1|) + (EQ (QCAR |t1|) (QUOTE |Tuple|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t1|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET S (QCAR |ISTMP#1|)) (QUOTE T)))) + (NEQUAL |t2| (QUOTE (|OutputForm|)))) + (|canCoerce| (CONS (QUOTE |List|) (CONS S NIL)) |t2|)) + ((QUOTE T) + (SPADLET |isRingT2| (|ofCategory| |t2| (QUOTE (|Ring|)))) + (COND + ((AND |isRingT2| (|isEqualOrSubDomain| |t1| |$Integer|)) + (QUOTE T)) + ((NEQUAL + (SPADLET |ans| (|canCoerceTopMatching| |t1| |t2| |nt1| |nt2|)) + (QUOTE |maybe|)) + |ans|) + ((BOOT-EQUAL |t2| |$Integer|) (|canCoerceLocal| |t1| |t2|)) + ((QUOTE T) + (SPADLET |ans| + (OR + (|canCoerceTower| |t1| |t2|) + (PROGN + (SPADLET |LETTMP#1| (|deconstructT| |t2|)) + (SPADLET |arg| (CDR |LETTMP#1|)) + (AND + |arg| + (PROGN + (SPADLET |t| (|last| |arg|)) + (AND + (|canCoerce| |t1| |t|) + (|canCoerceByFunction| |t| |t2|) (QUOTE T))))))) + (OR + |ans| + (AND + (|member| |t1| + (QUOTE ((|PositiveInteger|) (|NonNegativeInteger|)))) + (|canCoerce| |$Integer| |t2|))))))))))))))) + +;canCoerceFrom0(t1,t2) == +;-- top level test for coercion, which transfers all RN, RF and RR into +;-- equivalent types +; startTimingProcess 'querycoerce +; q := +; isEqualOrSubDomain(t1,t2) or t1 = '(None) or t2 = '(Any) or +; if t2 = $OutputForm then (s1 := t1; s2 := t2) +; else (s1:= equiType(t1); s2:= equiType(t2)) +; -- make sure we are trying to coerce to a legal type +; -- in particular, polynomials are repeated, etc. +; null isValidType(t2) => NIL +; null isLegitimateMode(t2,nil,nil) => NIL +; t1 = $RationalNumber => +; isEqualOrSubDomain(t2,$Integer) => NIL +; canCoerce(t1,t2) or canCoerce(s1,s2) +; canCoerce(s1,s2) +; stopTimingProcess 'querycoerce +; q + +(DEFUN |canCoerceFrom0| (|t1| |t2|) + (PROG (|s1| |s2| |q|) + (RETURN + (PROGN + (|startTimingProcess| (QUOTE |querycoerce|)) + (SPADLET |q| + (OR + (|isEqualOrSubDomain| |t1| |t2|) + (BOOT-EQUAL |t1| (QUOTE (|None|))) + (BOOT-EQUAL |t2| (QUOTE (|Any|))) + (PROGN + (COND + ((BOOT-EQUAL |t2| |$OutputForm|) + (SPADLET |s1| |t1|) + (SPADLET |s2| |t2|)) + ((QUOTE T) + (SPADLET |s1| (|equiType| |t1|)) + (SPADLET |s2| (|equiType| |t2|)))) + (COND + ((NULL (|isValidType| |t2|)) NIL) + ((NULL (|isLegitimateMode| |t2| NIL NIL)) NIL) + ((BOOT-EQUAL |t1| |$RationalNumber|) + (COND + ((|isEqualOrSubDomain| |t2| |$Integer|) NIL) + ((QUOTE T) (OR (|canCoerce| |t1| |t2|) (|canCoerce| |s1| |s2|))))) + ((QUOTE T) (|canCoerce| |s1| |s2|)))))) + (|stopTimingProcess| (QUOTE |querycoerce|)) |q|)))) + +;isSubTowerOf(t1,t2) == +; -- assumes RF and RN stuff has been expanded +; -- tests whether t1 is somewhere inside t2 +; isEqualOrSubDomain(t1,t2) => true +; null (u := underDomainOf t2) => nil +; isSubTowerOf(t1,u) + +(DEFUN |isSubTowerOf| (|t1| |t2|) + (PROG (|u|) + (RETURN + (COND + ((|isEqualOrSubDomain| |t1| |t2|) (QUOTE T)) + ((NULL (SPADLET |u| (|underDomainOf| |t2|))) NIL) + ((QUOTE T) (|isSubTowerOf| |t1| |u|)))))) + +;canCoerceTopMatching(t1,t2,tt1,tt2) == +; -- returns true, nil or maybe +; -- for example, if t1 = P[x] D1 and t2 = P[y] D2 and x = y then +; -- canCoerce will only be true if D1 = D2 +; not EQ(tt1,tt2) => 'maybe +; doms := '(Polynomial List Matrix FiniteSet Vector Stream Gaussian) +; MEMQ(tt1,doms) => canCoerce(CADR t1, CADR t2) +; not (MEMQ(tt1,$univariateDomains) or MEMQ(tt2,$multivariateDomains)) => +; 'maybe +; u2 := deconstructT t2 +; 1 = #u2 => NIL +; u1 := deconstructT t1 +; 1 = #u1 => NIL -- no under domain +; first(u1) ^= first(u2) => 'maybe +; canCoerce(underDomainOf t1, underDomainOf t2) + +(DEFUN |canCoerceTopMatching| (|t1| |t2| |tt1| |tt2|) + (PROG (|doms| |u2| |u1|) + (RETURN + (COND + ((NULL (EQ |tt1| |tt2|)) (QUOTE |maybe|)) + ((QUOTE T) + (SPADLET |doms| + (QUOTE (|Polynomial| |List| |Matrix| |FiniteSet| + |Vector| |Stream| |Gaussian|))) + (COND + ((MEMQ |tt1| |doms|) (|canCoerce| (CADR |t1|) (CADR |t2|))) + ((NULL + (OR + (MEMQ |tt1| |$univariateDomains|) + (MEMQ |tt2| |$multivariateDomains|))) + (QUOTE |maybe|)) + ((QUOTE T) + (SPADLET |u2| (|deconstructT| |t2|)) + (COND + ((EQL 1 (|#| |u2|)) NIL) + ((QUOTE T) + (SPADLET |u1| (|deconstructT| |t1|)) + (COND + ((EQL 1 (|#| |u1|)) NIL) + ((NEQUAL (CAR |u1|) (CAR |u2|)) (QUOTE |maybe|)) + ((QUOTE T) + (|canCoerce| + (|underDomainOf| |t1|) + (|underDomainOf| |t2|))))))))))))) + +;canCoerceExplicit2Mapping(t1,t is ['Mapping,target,:argl]) == +; -- determines if there a mapping called var with the given args +; -- and target +; $useCoerceOrCroak: local := nil +; t1 is ['Variable,var] => +; null (mms :=selectMms1(var,target,argl,[NIL for a in argl],true)) => NIL +; mm := CAAR mms +; mm is [., targ, :.] => +; targ = target => true +; false +; false +; t1 is ['FunctionCalled,fun] => +; funNode := mkAtreeNode fun +; transferPropsToNode(fun,funNode) +; mms := CATCH('coerceOrCroaker, selectLocalMms(funNode,fun,argl,target)) +; CONSP mms => +; mms is [[['interpOnly,:.],:.]] => nil +; mm := CAAR mms +; mm is [., targ, :.] => +; targ = target => true +; false +; false +; NIL +; NIL + +(DEFUN |canCoerceExplicit2Mapping| (|t1| |t|) + (PROG (|$useCoerceOrCroak| |target| |argl| |var| |fun| |funNode| |mms| + |ISTMP#2| |mm| |ISTMP#1| |targ|) + (DECLARE (SPECIAL |$useCoerceOrCroak|)) + (RETURN + (SEQ + (PROGN + (SPADLET |target| (CADR |t|)) + (SPADLET |argl| (CDDR |t|)) + (SPADLET |$useCoerceOrCroak| NIL) + (COND + ((AND (PAIRP |t1|) + (EQ (QCAR |t1|) (QUOTE |Variable|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t1|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |var| (QCAR |ISTMP#1|)) (QUOTE T))))) + (COND + ((NULL + (SPADLET |mms| + (|selectMms1| |var| |target| |argl| + (PROG (#0=#:G166754) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166759 |argl| (CDR #1#)) (|a| NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ |a| (CAR #1#)) NIL)) + (NREVERSE0 #0#)) + (SEQ (EXIT (SETQ #0# (CONS NIL #0#))))))) + (QUOTE T)))) + NIL) + ((QUOTE T) + (SPADLET |mm| (CAAR |mms|)) + (COND + ((AND + (PAIRP |mm|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |mm|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN (SPADLET |targ| (QCAR |ISTMP#1|)) (QUOTE T))))) + (COND + ((BOOT-EQUAL |targ| |target|) (QUOTE T)) + ((QUOTE T) NIL))) + ((QUOTE T) NIL))))) + ((AND (PAIRP |t1|) + (EQ (QCAR |t1|) (QUOTE |FunctionCalled|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t1|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |fun| (QCAR |ISTMP#1|)) (QUOTE T))))) + (SPADLET |funNode| (|mkAtreeNode| |fun|)) + (|transferPropsToNode| |fun| |funNode|) + (SPADLET |mms| + (CATCH + (QUOTE |coerceOrCroaker|) + (|selectLocalMms| |funNode| |fun| |argl| |target|))) + (COND + ((CONSP |mms|) + (COND + ((AND (PAIRP |mms|) + (EQ (QCDR |mms|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |mms|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) (QUOTE |interpOnly|))))))) + NIL) + ((QUOTE T) + (SPADLET |mm| (CAAR |mms|)) + (COND + ((AND (PAIRP |mm|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |mm|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN (SPADLET |targ| (QCAR |ISTMP#1|)) (QUOTE T))))) + (COND + ((BOOT-EQUAL |targ| |target|) (QUOTE T)) + ((QUOTE T) NIL))) + ((QUOTE T) NIL))))) + ((QUOTE T) NIL))) + ((QUOTE T) NIL))))))) + +;canCoerceUnion(t1,t2) == +; -- sees if one can coerce to or from a Union Domain +; -- assumes one of t1 and t2 is one +; -- get the domains in the union, checking for tagged unions +; if (isUnion1 := t1 is ['Union,:uds1]) then +; unionDoms1 := +; uds1 and first uds1 is [":",:.] => [t for [.,.,t] in uds1] +; uds1 +; if (isUnion2 := t2 is ['Union,:uds2]) then +; unionDoms2 := +; uds2 and first uds2 is [":",:.] => [t for [.,.,t] in uds2] +; uds2 +; isUnion2 => +; MEMBER(t1,unionDoms2) => true +; isUnion1 => +; and/[or/[canCoerce(ud1,ud2) for ud2 in unionDoms2] +; for ud1 in unionDoms1] +; or/[canCoerce(t1,ud) for ud in unionDoms2] +; -- next, a little lie +; t1 is ['Union,d1, ='"failed"] and t2 = d1 => true +; isUnion1 => +; and/[canCoerce(ud,t2) for ud in unionDoms1] +; keyedSystemError("S2GE0016",['"canCoerceUnion", +; '"called with 2 non-Unions"]) + +(DEFUN |canCoerceUnion| (|t1| |t2|) + (PROG (|uds1| |isUnion1| |unionDoms1| |uds2| |isUnion2| |t| |unionDoms2| + |ISTMP#1| |d1| |ISTMP#2|) + (RETURN + (SEQ + (PROGN + (COND + ((SPADLET |isUnion1| + (AND (PAIRP |t1|) + (EQ (QCAR |t1|) (QUOTE |Union|)) + (PROGN (SPADLET |uds1| (QCDR |t1|)) (QUOTE T)))) + (SPADLET |unionDoms1| + (COND + ((AND |uds1| + (PROGN + (SPADLET |ISTMP#1| (CAR |uds1|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) (QUOTE |:|))))) + (PROG (#0=#:G166818) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166824 |uds1| (CDR #1#)) (#2=#:G166791 NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ #2# (CAR #1#)) NIL) + (PROGN (PROGN (SPADLET |t| (CADDR #2#)) #2#) NIL)) + (NREVERSE0 #0#)) + (SEQ (EXIT (SETQ #0# (CONS |t| #0#)))))))) + ((QUOTE T) |uds1|))))) + (COND + ((SPADLET |isUnion2| + (AND + (PAIRP |t2|) + (EQ (QCAR |t2|) (QUOTE |Union|)) + (PROGN (SPADLET |uds2| (QCDR |t2|)) (QUOTE T)))) + (SPADLET |unionDoms2| + (COND + ((AND |uds2| + (PROGN + (SPADLET |ISTMP#1| (CAR |uds2|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) (QUOTE |:|))))) + (PROG (#3=#:G166836) + (SPADLET #3# NIL) + (RETURN + (DO ((#4=#:G166842 |uds2| (CDR #4#)) (#5=#:G166797 NIL)) + ((OR (ATOM #4#) + (PROGN (SETQ #5# (CAR #4#)) NIL) + (PROGN (PROGN (SPADLET |t| (CADDR #5#)) #5#) NIL)) + (NREVERSE0 #3#)) + (SEQ (EXIT (SETQ #3# (CONS |t| #3#)))))))) + ((QUOTE T) |uds2|))))) + (COND + (|isUnion2| + (COND + ((|member| |t1| |unionDoms2|) (QUOTE T)) + (|isUnion1| + (PROG (#6=#:G166849) + (SPADLET #6# (QUOTE T)) + (RETURN + (DO ((#7=#:G166855 NIL (NULL #6#)) + (#8=#:G166856 |unionDoms1| (CDR #8#)) + (|ud1| NIL)) + ((OR #7# (ATOM #8#) (PROGN (SETQ |ud1| (CAR #8#)) NIL)) #6#) + (SEQ + (EXIT + (SETQ #6# + (AND #6# + (PROG (#9=#:G166863) + (SPADLET #9# NIL) + (RETURN + (DO ((#10=#:G166869 NIL #9#) + (#11=#:G166870 |unionDoms2| (CDR #11#)) + (|ud2| NIL)) + ((OR #10# + (ATOM #11#) + (PROGN (SETQ |ud2| (CAR #11#)) NIL)) + #9#) + (SEQ + (EXIT + (SETQ #9# + (OR #9# (|canCoerce| |ud1| |ud2|)))))))))))))))) + ((QUOTE T) + (PROG (#12=#:G166877) + (SPADLET #12# NIL) + (RETURN + (DO ((#13=#:G166883 NIL #12#) + (#14=#:G166884 |unionDoms2| (CDR #14#)) + (|ud| NIL)) + ((OR #13# (ATOM #14#) (PROGN (SETQ |ud| (CAR #14#)) NIL)) #12#) + (SEQ (EXIT (SETQ #12# (OR #12# (|canCoerce| |t1| |ud|))))))))))) + ((AND (PAIRP |t1|) + (EQ (QCAR |t1|) (QUOTE |Union|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t1|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |d1| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (EQUAL (QCAR |ISTMP#2|) (QUOTE "failed")))))) + (BOOT-EQUAL |t2| |d1|)) + (QUOTE T)) + (|isUnion1| + (PROG (#15=#:G166891) + (SPADLET #15# (QUOTE T)) + (RETURN + (DO ((#16=#:G166897 NIL (NULL #15#)) + (#17=#:G166898 |unionDoms1| (CDR #17#)) + (|ud| NIL)) + ((OR #16# (ATOM #17#) (PROGN (SETQ |ud| (CAR #17#)) NIL)) #15#) + (SEQ (EXIT (SETQ #15# (AND #15# (|canCoerce| |ud| |t2|))))))))) + ((QUOTE T) + (|keyedSystemError| 'S2GE0016 + (CONS "canCoerceUnion" (CONS "called with 2 non-Unions" NIL)))))))))) + +;canCoerceByMap(t1,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 answer true +; -- if canCoerceFrom(t1,t2). +; u2 := deconstructT t2 +; 1 = #u2 => NIL +; u1 := deconstructT t1 +; 1 = #u1 => NIL -- no under domain +; CAR(u1) ^= CAR(u2) => NIL +; top := CAAR u1 +; u1 := underDomainOf t1 +; u2 := underDomainOf t2 +; absolutelyCannotCoerce(u1,u2) => NIL +; -- save some time for those we know about +; know := '(List Vector Segment Stream UniversalSegment Array +; Polynomial UnivariatePolynomial SquareMatrix Matrix) +; top in know => canCoerce(u1,u2) +; null selectMms1('map,t2,[['Mapping,u2,u1],t1], +; [['Mapping,u2,u1],u1],NIL) => NIL +; -- don't bother checking for Undef, so avoid instantiation +; canCoerce(u1,u2) + +(DEFUN |canCoerceByMap| (|t1| |t2|) + (PROG (|top| |u1| |u2| |know|) + (RETURN + (PROGN + (SPADLET |u2| (|deconstructT| |t2|)) + (COND + ((EQL 1 (|#| |u2|)) NIL) + ((QUOTE T) + (SPADLET |u1| (|deconstructT| |t1|)) + (COND + ((EQL 1 (|#| |u1|)) NIL) + ((NEQUAL (CAR |u1|) (CAR |u2|)) NIL) + ((QUOTE T) + (SPADLET |top| (CAAR |u1|)) + (SPADLET |u1| (|underDomainOf| |t1|)) + (SPADLET |u2| (|underDomainOf| |t2|)) + (COND + ((|absolutelyCannotCoerce| |u1| |u2|) NIL) + ((QUOTE T) + (SPADLET |know| + (QUOTE (|List| |Vector| |Segment| |Stream| |UniversalSegment| + |Array| |Polynomial| |UnivariatePolynomial| + |SquareMatrix| |Matrix|))) + (COND + ((|member| |top| |know|) (|canCoerce| |u1| |u2|)) + ((NULL + (|selectMms1| + (QUOTE |map|) + |t2| + (CONS + (CONS (QUOTE |Mapping|) (CONS |u2| (CONS |u1| NIL))) + (CONS |t1| NIL)) + (CONS + (CONS (QUOTE |Mapping|) (CONS |u2| (CONS |u1| NIL))) + (CONS |u1| NIL)) + NIL)) + NIL) + ((QUOTE T) (|canCoerce| |u1| |u2|))))))))))))) + +;canCoerceTower(t1,t2) == +;-- tries to find a coercion between top level t2 and somewhere inside t1 +;-- builds new bubbled type, for which coercion is called recursively +; canCoerceByMap(t1,t2) or newCanCoerceCommute(t1,t2) or +; canCoerceLocal(t1,t2) or canCoercePermute(t1,t2) or +; [c1,:arg1]:= deconstructT t1 +; arg1 and +; TL:= NIL +; arg:= arg1 +; until x or not arg repeat x:= +; t:= last arg +; [c,:arg]:= deconstructT t +; TL:= [c,arg,:TL] +; arg and coerceIntTest(t,t2) and +; CDDR TL => +; s:= constructT(c1,replaceLast(arg1,bubbleConstructor TL)) +; canCoerceLocal(t1,s) and +; [c2,:arg2]:= deconstructT last s +; s1:= bubbleConstructor [c2,arg2,c1,arg1] +; canCoerceCommute(s,s1) and canCoerceLocal(s1,t2) +; s:= bubbleConstructor [c,arg,c1,arg1] +; newCanCoerceCommute(t1,s) and canCoerceLocal(s,t2) +; x + +(DEFUN |canCoerceTower| (|t1| |t2|) + (PROG (|c1| |arg1| |t| |c| |arg| TL |LETTMP#1| |c2| |arg2| |s1| |s| |x|) + (RETURN + (SEQ + (OR + (|canCoerceByMap| |t1| |t2|) + (|newCanCoerceCommute| |t1| |t2|) + (|canCoerceLocal| |t1| |t2|) + (|canCoercePermute| |t1| |t2|) + (PROGN + (SPADLET |LETTMP#1| (|deconstructT| |t1|)) + (SPADLET |c1| (CAR |LETTMP#1|)) + (SPADLET |arg1| (CDR |LETTMP#1|)) + (AND |arg1| + (PROGN + (SPADLET TL NIL) + (SPADLET |arg| |arg1|) + (DO ((#0=#:G166978 NIL (OR |x| (NULL |arg|)))) + (#0# NIL) + (SEQ + (EXIT + (SPADLET |x| + (PROGN + (SPADLET |t| (|last| |arg|)) + (SPADLET |LETTMP#1| (|deconstructT| |t|)) + (SPADLET |c| (CAR |LETTMP#1|)) + (SPADLET |arg| (CDR |LETTMP#1|)) + (SPADLET TL (CONS |c| (CONS |arg| TL))) + (AND |arg| + (|coerceIntTest| |t| |t2|) + (COND + ((CDDR TL) + (SPADLET |s| + (|constructT| |c1| + (|replaceLast| |arg1| (|bubbleConstructor| TL)))) + (AND + (|canCoerceLocal| |t1| |s|) + (PROGN + (SPADLET |LETTMP#1| (|deconstructT| (|last| |s|))) + (SPADLET |c2| (CAR |LETTMP#1|)) + (SPADLET |arg2| (CDR |LETTMP#1|)) + (SPADLET |s1| + (|bubbleConstructor| + (CONS |c2| (CONS |arg2| (CONS |c1| (CONS |arg1| NIL)))))) + (AND + (|canCoerceCommute| |s| |s1|) + (|canCoerceLocal| |s1| |t2|))))) + ((QUOTE T) + (SPADLET |s| + (|bubbleConstructor| + (CONS |c| (CONS |arg| (CONS |c1| (CONS |arg1| NIL)))))) + (AND + (|newCanCoerceCommute| |t1| |s|) + (|canCoerceLocal| |s| |t2|)))))))))) + |x|)))))))) + +;canCoerceLocal(t1,t2) == +; -- test for coercion on top level +; p:= ASSQ(CAR t1,$CoerceTable) +; p and ASSQ(CAR t2,CDR p) is [.,:[tag,fun]] => +; tag='partial => NIL +; tag='total => true +; (functionp(fun) and +; (v:=CATCH('coerceFailure,FUNCALL(fun,'_$fromCoerceable_$,t1,t2))) +; and v ^= $coerceFailure) or canCoerceByFunction(t1,t2) +; canCoerceByFunction(t1,t2) + +(DEFUN |canCoerceLocal| (|t1| |t2|) + (PROG (|p| |ISTMP#1| |ISTMP#2| |tag| |ISTMP#3| |fun| |v|) + (RETURN + (PROGN + (SPADLET |p| (ASSQ (CAR |t1|) |$CoerceTable|)) + (COND + ((AND |p| + (PROGN + (SPADLET |ISTMP#1| (ASSQ (CAR |t2|) (CDR |p|))) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |tag| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND + (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN (SPADLET |fun| (QCAR |ISTMP#3|)) (QUOTE T))))))))) + (COND + ((BOOT-EQUAL |tag| (QUOTE |partial|)) NIL) + ((BOOT-EQUAL |tag| (QUOTE |total|)) (QUOTE T)) + ((QUOTE T) + (OR + (AND + (|functionp| |fun|) + (SPADLET |v| + (CATCH + (QUOTE |coerceFailure|) + (FUNCALL |fun| (QUOTE |$fromCoerceable$|) |t1| |t2|))) + (NEQUAL |v| |$coerceFailure|)) + (|canCoerceByFunction| |t1| |t2|))))) + ((QUOTE T) (|canCoerceByFunction| |t1| |t2|))))))) + +;canCoerceCommute(t1,t2) == +;-- THIS IS OUT-MODED AND WILL GO AWAY SOON RSS 2-87 +;-- t1 is t2 with the two top level constructors commuted +;-- looks for the existence of a commuting function +; CAR(t1) in (l := [$QuotientField, 'Gaussian]) and +; CAR(t2) in l => true +; p:= ASSQ(CAR t1,$CommuteTable) +; p and ASSQ(CAR t2,CDR p) is [.,:['commute,.]] + +(DEFUN |canCoerceCommute| (|t1| |t2|) + (PROG (|l| |p| |ISTMP#1| |ISTMP#2| |ISTMP#3|) + (RETURN + (COND + ((AND + (|member| + (CAR |t1|) + (SPADLET |l| (CONS |$QuotientField| (CONS (QUOTE |Gaussian|) NIL)))) + (|member| (CAR |t2|) |l|)) + (QUOTE T)) + ((QUOTE T) + (SPADLET |p| (ASSQ (CAR |t1|) |$CommuteTable|)) + (AND |p| + (PROGN + (SPADLET |ISTMP#1| (ASSQ (CAR |t2|) (CDR |p|))) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) (QUOTE |commute|)) + (PROGN + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) (EQ (QCDR |ISTMP#3|) NIL))))))))))))) + +;newCanCoerceCommute(t1,t2) == +; coerceIntCommute(objNewWrap("$fromCoerceable$",t1),t2) + +(DEFUN |newCanCoerceCommute| (|t1| |t2|) + (|coerceIntCommute| (|objNewWrap| (QUOTE |$fromCoerceable$|) |t1|) |t2|)) + +;canCoercePermute(t1,t2) == +; -- try to generate a sequence of transpositions that will convert +; -- t1 into t2 +; t2 in '((Integer) (OutputForm)) => NIL +; 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 +; ok := canCoerce(t1,t) +; if ok then t1 := t +; ok + +(DEFUN |canCoercePermute| (|t1| |t2|) + (PROG (|towers| |ok|) + (RETURN + (SEQ + (COND + ((|member| |t2| (QUOTE ((|Integer|) (|OutputForm|)))) NIL) + ((QUOTE T) + (SPADLET |towers| (|computeTTTranspositions| |t1| |t2|)) + (COND + ((OR (NULL |towers|) (NULL (CDR |towers|))) NIL) + ((AND (NULL (CDDR |towers|)) (BOOT-EQUAL |t2| (CADR |towers|))) NIL) + ((QUOTE T) + (SPADLET |ok| (QUOTE T)) + (DO ((#0=#:G167071 (CDR |towers|) (CDR #0#)) (|t| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |t| (CAR #0#)) NIL) (NULL |ok|)) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |ok| (|canCoerce| |t1| |t|)) + (COND (|ok| (SPADLET |t1| |t|)) ((QUOTE T) NIL)))))) + |ok|)))))))) + +;canConvertByFunction(m1,m2) == +; null $useConvertForCoercions => NIL +; canCoerceByFunction1(m1,m2,'convert) + +(DEFUN |canConvertByFunction| (|m1| |m2|) + (COND + ((NULL |$useConvertForCoercions|) NIL) + ((QUOTE T) (|canCoerceByFunction1| |m1| |m2| (QUOTE |convert|))))) + +;canCoerceByFunction(m1,m2) == canCoerceByFunction1(m1,m2,'coerce) + +(DEFUN |canCoerceByFunction| (|m1| |m2|) + (|canCoerceByFunction1| |m1| |m2| (QUOTE |coerce|))) + +;canCoerceByFunction1(m1,m2,fun) == +; -- calls selectMms with $Coerce=NIL and tests for required target=m2 +; $declaredMode:local:= NIL +; $reportBottomUpFlag:local:= NIL +; -- have to handle cases where we might have changed from RN to QF I +; -- make 2 lists of expanded and unexpanded types +; l1 := REMDUP [m1,eqType m1] +; l2 := REMDUP [m2,eqType m2] +; ans := NIL +; for t1 in l1 while not ans repeat +; for t2 in l2 while not ans repeat +; l := selectMms1(fun,t2,[t1],[t1],NIL) +; ans := [x for x in l | x is [sig,:.] and CADR sig=t2 and +; CADDR sig=t1 and +; CAR(sig) isnt ['TypeEquivalence,:.]] and true +; ans + +(DEFUN |canCoerceByFunction1| (|m1| |m2| |fun|) + (PROG (|$declaredMode| |$reportBottomUpFlag| |l1| |l2| |l| |sig| + |ISTMP#1| |ans|) + (DECLARE (SPECIAL |$declaredMode| |$reportBottomUpFlag|)) + (RETURN + (SEQ + (PROGN + (SPADLET |$declaredMode| NIL) + (SPADLET |$reportBottomUpFlag| NIL) + (SPADLET |l1| (REMDUP (CONS |m1| (CONS (|eqType| |m1|) NIL)))) + (SPADLET |l2| (REMDUP (CONS |m2| (CONS (|eqType| |m2|) NIL)))) + (SPADLET |ans| NIL) + (DO ((#0=#:G167106 |l1| (CDR #0#)) (|t1| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |t1| (CAR #0#)) NIL) (NULL (NULL |ans|))) + NIL) + (SEQ + (EXIT + (DO ((#1=#:G167123 |l2| (CDR #1#)) (|t2| NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ |t2| (CAR #1#)) NIL) + (NULL (NULL |ans|))) + NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |l| + (|selectMms1| |fun| |t2| (CONS |t1| NIL) (CONS |t1| NIL) NIL)) + (SPADLET |ans| + (AND + (PROG (#2=#:G167135) + (SPADLET #2# NIL) + (RETURN + (DO ((#3=#:G167141 |l| (CDR #3#)) (|x| NIL)) + ((OR (ATOM #3#) + (PROGN (SETQ |x| (CAR #3#)) NIL)) + (NREVERSE0 #2#)) + (SEQ + (EXIT + (COND + ((AND + (PAIRP |x|) + (PROGN (SPADLET |sig| (QCAR |x|)) (QUOTE T)) + (BOOT-EQUAL (CADR |sig|) |t2|) + (BOOT-EQUAL (CADDR |sig|) |t1|) + (NULL + (PROGN + (SPADLET |ISTMP#1| (CAR |sig|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) (QUOTE |TypeEquivalence|)))))) + (SETQ #2# (CONS |x| #2#))))))))) + (QUOTE T)))))))))) + |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|) + (RETURN + (SEQ + (COND + ((|isEqualOrSubDomain| |t1| |t2|) + (QUOTE T)) + ((AND (|typeIsASmallInteger| |t1|) (BOOT-EQUAL |t2| |$Integer|)) + (QUOTE T)) + ((OR (ATOM |t1|) (ATOM |t2|)) NIL) + ((QUOTE T) + (SPADLET |LETTMP#1| (|deconstructT| |t1|)) + (SPADLET |tl1| (CAR |LETTMP#1|)) + (SPADLET |u1| (CDR |LETTMP#1|)) + (SPADLET |LETTMP#1| (|deconstructT| |t2|)) + (SPADLET |tl2| (CAR |LETTMP#1|)) + (SPADLET |u2| (CDR |LETTMP#1|)) + (COND + ((AND + (BOOT-EQUAL |tl1| (QUOTE (|Stream|))) + (BOOT-EQUAL |tl2| (QUOTE (|InfiniteTuple|)))) + (COND + ((NEQUAL (|#| |u1|) (|#| |u2|)) NIL) + ((QUOTE T) + (PROG (#0=#:G167180) + (SPADLET #0# (QUOTE T)) + (RETURN + (DO ((#1=#:G167187 NIL (NULL #0#)) + (#2=#:G167188 |u1| (CDR #2#)) + (|x1| NIL) + (#3=#:G167189 |u2| (CDR #3#)) + (|x2| NIL)) + ((OR #1# + (ATOM #2#) + (PROGN (SETQ |x1| (CAR #2#)) NIL) + (ATOM #3#) + (PROGN (SETQ |x2| (CAR #3#)) NIL)) + #0#) + (SEQ + (EXIT + (SETQ #0# + (AND #0# (|absolutelyCanCoerceByCheating| |x1| |x2|))))))))))) + ((NEQUAL |tl1| |tl2|) NIL) + ((NEQUAL (|#| |u1|) (|#| |u2|)) NIL) + ((QUOTE T) + (PROG (#4=#:G167199) + (SPADLET #4# (QUOTE T)) + (RETURN + (DO ((#5=#:G167206 NIL (NULL #4#)) + (#6=#:G167207 |u1| (CDR #6#)) + (|x1| NIL) + (#7=#:G167208 |u2| (CDR #7#)) + (|x2| NIL)) + ((OR #5# + (ATOM #6#) + (PROGN (SETQ |x1| (CAR #6#)) NIL) + (ATOM #7#) + (PROGN (SETQ |x2| (CAR #7#)) NIL)) + #4#) + (SEQ + (EXIT + (SETQ #4# + (AND #4# + (|absolutelyCanCoerceByCheating| |x1| |x2|)))))))))))))))) + +;absolutelyCannotCoerce(t1,t2) == +; -- response of true means "definitely cannot coerce" +; -- this is largely an efficiency hack +; ATOM(t1) or ATOM(t2) => NIL +; t2 = '(None) => true +; n1 := CAR t1 +; n2 := CAR t2 +; QFI := [$QuotientField, $Integer] +; int2 := isEqualOrSubDomain(t2,$Integer) +; scalars := '(BigFloat NewFloat Float DoubleFloat RationalNumber) +; MEMQ(n1,scalars) and int2 => true +; (t1 = QFI) and int2 => true +; num2 := int2 or MEMQ(n2,scalars) or (t2 = QFI) +; isVar1 := MEMQ(n1,'(Variable Symbol)) +; num2 and isVar1 => true +; num2 and MEMQ(n1,$univariateDomains) => true +; num2 and MEMQ(n1,$multivariateDomains) => true +; miscpols := '(Polynomial ElementaryFunction SimpleAlgebraicExtension) +; num2 and MEMQ(n1,miscpols) => true +; aggs := '( +; Matrix List Vector Stream Array RectangularMatrix FiniteSet +; ) +; u1 := underDomainOf t1 +; u2 := underDomainOf t2 +; MEMQ(n1,aggs) and (u1 = t2) => true +; MEMQ(n2,aggs) and (u2 = t1) => true +; algs := '( +; SquareMatrix Gaussian RectangularMatrix Quaternion +; ) +; nonpols := append(aggs,algs) +; num2 and MEMQ(n1,nonpols) => true +; isVar1 and MEMQ(n2,nonpols) and +; absolutelyCannotCoerce(t1,u2) => true +; (MEMQ(n1,scalars) or (t1 = QFI)) and (t2 = '(Polynomial (Integer))) => +; true +; v2 := deconstructT t2 +; 1 = #v2 => NIL +; v1 := deconstructT t1 +; 1 = #v1 => NIL +; CAR(v1) ^= CAR(v2) => NIL +; absolutelyCannotCoerce(u1,u2) + +(DEFUN |absolutelyCannotCoerce| (|t1| |t2|) + (PROG (|n1| |n2| QFI |int2| |scalars| |num2| |isVar1| |miscpols| |aggs| + |u1| |u2| |algs| |nonpols| |v2| |v1|) + (RETURN + (COND + ((OR (ATOM |t1|) (ATOM |t2|)) NIL) + ((BOOT-EQUAL |t2| (QUOTE (|None|))) (QUOTE T)) + ((QUOTE T) + (SPADLET |n1| (CAR |t1|)) + (SPADLET |n2| (CAR |t2|)) + (SPADLET QFI (CONS |$QuotientField| (CONS |$Integer| NIL))) + (SPADLET |int2| (|isEqualOrSubDomain| |t2| |$Integer|)) + (SPADLET |scalars| + (QUOTE (|BigFloat| |NewFloat| |Float| |DoubleFloat| |RationalNumber|))) + (COND + ((AND (MEMQ |n1| |scalars|) |int2|) (QUOTE T)) + ((AND (BOOT-EQUAL |t1| QFI) |int2|) (QUOTE T)) + ((QUOTE T) + (SPADLET |num2| (OR |int2| (MEMQ |n2| |scalars|) (BOOT-EQUAL |t2| QFI))) + (SPADLET |isVar1| (MEMQ |n1| (QUOTE (|Variable| |Symbol|)))) + (COND + ((AND |num2| |isVar1|) (QUOTE T)) + ((AND |num2| (MEMQ |n1| |$univariateDomains|)) (QUOTE T)) + ((AND |num2| (MEMQ |n1| |$multivariateDomains|)) (QUOTE T)) + ((QUOTE T) + (SPADLET |miscpols| + (QUOTE + (|Polynomial| |ElementaryFunction| |SimpleAlgebraicExtension|))) + (COND + ((AND |num2| (MEMQ |n1| |miscpols|)) (QUOTE T)) + ((QUOTE T) + (SPADLET |aggs| + (QUOTE (|Matrix| |List| |Vector| |Stream| |Array| + |RectangularMatrix| |FiniteSet|))) + (SPADLET |u1| (|underDomainOf| |t1|)) + (SPADLET |u2| (|underDomainOf| |t2|)) + (COND + ((AND (MEMQ |n1| |aggs|) (BOOT-EQUAL |u1| |t2|)) (QUOTE T)) + ((AND (MEMQ |n2| |aggs|) (BOOT-EQUAL |u2| |t1|)) (QUOTE T)) + ((QUOTE T) + (SPADLET |algs| + (QUOTE + (|SquareMatrix| |Gaussian| |RectangularMatrix| |Quaternion|))) + (SPADLET |nonpols| (APPEND |aggs| |algs|)) + (COND + ((AND |num2| (MEMQ |n1| |nonpols|)) (QUOTE T)) + ((AND |isVar1| + (MEMQ |n2| |nonpols|) + (|absolutelyCannotCoerce| |t1| |u2|)) + (QUOTE T)) + ((AND + (OR (MEMQ |n1| |scalars|) (BOOT-EQUAL |t1| QFI)) + (BOOT-EQUAL |t2| (QUOTE (|Polynomial| (|Integer|))))) + (QUOTE T)) + ((QUOTE T) + (SPADLET |v2| (|deconstructT| |t2|)) + (COND + ((EQL 1 (|#| |v2|)) NIL) + ((QUOTE T) + (SPADLET |v1| (|deconstructT| |t1|)) + (COND + ((EQL 1 (|#| |v1|)) NIL) + ((NEQUAL (CAR |v1|) (CAR |v2|)) NIL) + ((QUOTE T) + (|absolutelyCannotCoerce| |u1| |u2|)))))))))))))))))))) + +;typeIsASmallInteger x == (x = $SingleInteger) + +(DEFUN |typeIsASmallInteger| (|x|) (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|)) + (RETURN + (PROGN + (SPADLET |t1| (|objMode| |triple|)) + (SPADLET |val| (|objVal| |triple|)) + (COND + ((OR (NULL |t2|) (BOOT-EQUAL |t2| |$EmptyMode|)) NIL) + ((BOOT-EQUAL |t2| |t1|) |triple|) + ((BOOT-EQUAL |t2| (QUOTE |$NoValueMode|)) (|objNew| |val| |t2|)) + ((QUOTE T) + (COND + ((AND (PAIRP |t2|) + (EQ (QCAR |t2|) (QUOTE |SubDomain|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t2|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |x| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL)))))) + (SPADLET |t2| |x|))) + (COND + ((|member| |t1| + (QUOTE ((|Category|) (|Mode|) (|Domain|) (|SubDomain| (|Domain|))))) + (COND + ((BOOT-EQUAL |t2| |$OutputForm|) (|objNew| |val| |t2|)) + ((QUOTE T) NIL))) + ((BOOT-EQUAL |t1| (QUOTE |$NoValueMode|)) + (COND (|$compilingMap| (|clearDependentMaps| |$mapName| NIL))) + (|throwKeyedMsg| (QUOTE S2IC0009) (CONS |t2| (CONS |$mapName| NIL)))) + ((QUOTE T) + (SPADLET |$insideCoerceInteractive| (QUOTE T)) + (SPADLET |expr2| (BOOT-EQUAL |t2| |$OutputForm|)) + (COND + (|expr2| (|startTimingProcess| (QUOTE |print|))) + ((QUOTE T) (|startTimingProcess| (QUOTE |coercion|)))) + (SPADLET |result| + (COND + ((AND |expr2| (BOOT-EQUAL |t1| |val|)) + (|objNew| |val| |$OutputForm|)) + ((AND + |expr2| + (PAIRP |t1|) + (EQ (QCAR |t1|) (QUOTE |Variable|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t1|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |var| (QCAR |ISTMP#1|)) (QUOTE T))))) + (|objNewWrap| |var| |$OutputForm|)) + ((QUOTE T) + (|coerceInt0| |triple| |t2|)))) + (COND + (|expr2| (|stopTimingProcess| (QUOTE |print|))) + ((QUOTE T) (|stopTimingProcess| (QUOTE |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|) + (RETURN + (PROGN + (SPADLET |val| (|objVal| |triple|)) + (SPADLET |t1| (|objMode| |triple|)) + (COND + ((BOOT-EQUAL |val| (QUOTE |$fromCoerceable$|)) + (|canCoerceFrom| |t1| |t2|)) + ((BOOT-EQUAL |t1| |t2|) + |triple|) + ((QUOTE T) + (COND + ((BOOT-EQUAL |t2| |$OutputForm|) + (SPADLET |s1| |t1|) + (SPADLET |s2| |t2|)) + ((QUOTE T) + (SPADLET |s1| (|equiType| |t1|)) + (SPADLET |s2| (|equiType| |t2|)) + (COND ((BOOT-EQUAL |s1| |s2|) (RETURN (|objNew| |val| |t2|)))))) + (COND + ((AND + (NULL (|isWrapped| |val|)) + (OR + (NULL (AND (PAIRP |t1|) (EQ (QCAR |t1|) (QUOTE |FunctionCalled|)))) + (NULL |$genValue|))) + (|intCodeGenCOERCE| |triple| |t2|)) + ((AND + (BOOT-EQUAL |t1| |$Any|) + (NEQUAL |t2| |$OutputForm|) + (PROGN + (SPADLET |LETTMP#1| (|unwrap| |val|)) + (SPADLET |t1'| (CAR |LETTMP#1|)) + (SPADLET |val'| (CDR |LETTMP#1|)) + |LETTMP#1|) + (SPADLET |ans| (|coerceInt0| (|objNewWrap| |val'| |t1'|) |t2|))) + |ans|) + ((QUOTE T) + (COND ((NULL (EQ |s1| |t1|)) (SPADLET |triple| (|objNew| |val| |s1|)))) + (COND + ((SPADLET |x| (|coerceInt| |triple| |s2|)) + (COND ((EQ |s2| |t2|) |x|) ((QUOTE T) (|objSetMode| |x| |t2|) |x|))) + ((QUOTE 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 + ((SPADLET |val| (|coerceInt1| |triple| |t2|)) |val|) + ((QUOTE T) + (SPADLET |t1| (|objMode| |triple|)) + (COND + ((AND (PAIRP |t1|) (EQ (QCAR |t1|) (QUOTE |Variable|))) + (SPADLET |newMode| + (|getMinimalVarMode| (|unwrap| (|objVal| |triple|)) NIL)) + (SPADLET |newVal| (|coerceInt| |triple| |newMode|)) + (|coerceInt| |newVal| |t2|)) + ((QUOTE 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 PAIRP(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) + +(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|)) + (RETURN + (SEQ + (PROGN + (SPADLET |$useCoerceOrCroak| (QUOTE T)) + (COND + ((BOOT-EQUAL |t2| |$EmptyMode|) NIL) + ((QUOTE T) + (SPADLET |t1| (|objMode| |triple|)) + (COND + ((BOOT-EQUAL |t1| |t2|) |triple|) + ((QUOTE T) + (SPADLET |val| (|objVal| |triple|)) + (COND + ((|absolutelyCanCoerceByCheating| |t1| |t2|) (|objNew| |val| |t2|)) + ((|isSubDomain| |t2| |t1|) (|coerceSubDomain| |val| |t1| |t2|)) + ((QUOTE T) + (COND + ((|typeIsASmallInteger| |t1|) + (COND + ((OR (BOOT-EQUAL |t2| |$Integer|) (|typeIsASmallInteger| |t2|)) + (RETURN (|objNew| |val| |t2|))) + ((QUOTE T) + (SPADLET |sintp| (SINTP |val|)) + (COND + ((AND |sintp| (BOOT-EQUAL |t2| |$PositiveInteger|) (> |val| 0)) + (RETURN (|objNew| |val| |t2|))) + ((AND |sintp| + (BOOT-EQUAL |t2| |$NonNegativeInteger|) + (>= |val| 0)) + (RETURN (|objNew| |val| |t2|)))))))) + (COND + ((AND + (|typeIsASmallInteger| |t2|) + (|isEqualOrSubDomain| |t1| |$Integer|) + (INTP |val|)) + (COND ((SINTP |val|) (|objNew| |val| |t2|)) ((QUOTE T) NIL))) + ((BOOT-EQUAL |t2| |$Void|) + (|objNew| (|voidValue|) |$Void|)) + ((BOOT-EQUAL |t2| |$Any|) + (|objNewWrap| (CONS |t1| (|unwrap| |val|)) (QUOTE (|Any|)))) + ((AND + (BOOT-EQUAL |t1| |$Any|) + (NEQUAL |t2| |$OutputForm|) + (PROGN + (SPADLET |LETTMP#1| (|unwrap| |val|)) + (SPADLET |t1'| (CAR |LETTMP#1|)) + (SPADLET |val'| (CDR |LETTMP#1|)) + |LETTMP#1|) + (SPADLET |ans| (|coerceInt| (|objNewWrap| |val'| |t1'|) |t2|))) + |ans|) + ((OR + (AND + (PAIRP |t1|) + (EQ (QCAR |t1|) (QUOTE |Variable|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t1|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (EQUAL (QCAR |ISTMP#1|) |t2|)))) + (AND + (PAIRP |t2|) + (EQ (QCAR |t2|) (QUOTE |Variable|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t2|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (EQUAL (QCAR |ISTMP#1|) |t1|))))) + (|objNew| |val| |t2|)) + ((STRINGP |t2|) + (COND + ((AND + (PAIRP |t1|) + (EQ (QCAR |t1|) (QUOTE |Variable|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t1|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |v| (QCAR |ISTMP#1|)) (QUOTE T)))) + (BOOT-EQUAL |t2| (PNAME |v|))) + (|objNewWrap| |t2| |t2|)) + ((QUOTE T) + (SPADLET |val'| (|unwrap| |val|)) + (COND + ((AND + (BOOT-EQUAL |t2| |val'|) + (OR (BOOT-EQUAL |val'| |t1|) (BOOT-EQUAL |t1| |$String|))) + (|objNew| |val| |t2|)) + ((QUOTE T) NIL))))) + ((AND + (PAIRP |t1|) + (EQ (QCAR |t1|) (QUOTE |Tuple|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t1|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET S (QCAR |ISTMP#1|)) (QUOTE T))))) + (|coerceInt1| + (|objNewWrap| + (|asTupleAsList| (|unwrap| |val|)) + (CONS (QUOTE |List|) (CONS S NIL))) + |t2|)) + ((AND (PAIRP |t1|) (EQ (QCAR |t1|) (QUOTE |Union|))) + (|coerceIntFromUnion| |triple| |t2|)) + ((AND (PAIRP |t2|) (EQ (QCAR |t2|) (QUOTE |Union|))) + (|coerceInt2Union| |triple| |t2|)) + ((AND (STRINGP |t1|) (BOOT-EQUAL |t2| |$String|)) + (|objNew| |val| |$String|)) + ((AND + (STRINGP |t1|) + (PAIRP |t2|) + (EQ (QCAR |t2|) (QUOTE |Variable|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t2|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |v| (QCAR |ISTMP#1|)) (QUOTE T))))) + (COND + ((BOOT-EQUAL |t1| (PNAME |v|)) (|objNewWrap| |v| |t2|)) + ((QUOTE T) NIL))) + ((AND (STRINGP |t1|) (BOOT-EQUAL |t1| (|unwrap| |val|))) + (COND + ((BOOT-EQUAL |t2| |$OutputForm|) (|objNew| |t1| |$OutputForm|)) + ((QUOTE T) NIL))) + ((ATOM |t1|) + NIL) + ((QUOTE T) + (COND + ((AND + (BOOT-EQUAL |t1| |$AnonymousFunction|) + (PAIRP |t2|) + (EQ (QCAR |t2|) (QUOTE |Mapping|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t2|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |target| (QCAR |ISTMP#1|)) + (SPADLET |margl| (QCDR |ISTMP#1|)) + (QUOTE T))))) + (SPADLET |$useCoerceOrCroak| NIL) + (SPADLET |LETTMP#1| (|unwrap| |val|)) + (SPADLET |vars| (CADR |LETTMP#1|)) + (SPADLET |body| (CDDR |LETTMP#1|)) + (SPADLET |vars| + (COND + ((ATOM |vars|) (CONS |vars| NIL)) + ((AND (PAIRP |vars|) (EQ (QCAR |vars|) (QUOTE |Tuple|))) + (CDR |vars|)) + ((QUOTE T) |vars|))) + (COND + ((NEQUAL (|#| |margl|) (|#| |vars|)) (QUOTE |continue|)) + ((QUOTE T) + (SPADLET |tree| + (|mkAtree| + (CONS (QUOTE ADEF) + (CONS |vars| + (CONS (CONS |target| |margl|) + (CONS + (PROG (#0=#:G167455) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G167460 (CDR |t2|) (CDR #1#)) (|x| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL)) + (NREVERSE0 #0#)) + (SEQ (EXIT (SETQ #0# (CONS NIL #0#))))))) + |body|)))))) + (COND + ((BOOT-EQUAL + (CATCH (QUOTE |coerceOrCroaker|) (|bottomUp| |tree|)) + (QUOTE |croaked|)) + NIL) + ((QUOTE T) (RETURN (|getValue| |tree|)))))))) + (COND + ((AND + (BOOT-EQUAL |t1| |$Symbol|) + (PAIRP |t2|) + (EQ (QCAR |t2|) (QUOTE |Mapping|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t2|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |target| (QCAR |ISTMP#1|)) + (SPADLET |margl| (QCDR |ISTMP#1|)) + (QUOTE T))))) + (COND + ((NULL + (SPADLET |mms| + (|selectMms1| + (|unwrap| |val|) NIL |margl| |margl| |target|))) + NIL) + ((QUOTE T) + (SPADLET |LETTMP#1| (CAAR |mms|)) + (SPADLET |dc| (CAR |LETTMP#1|)) + (SPADLET |targ| (CADR |LETTMP#1|)) + (SPADLET |argl| (CDDR |LETTMP#1|)) + (COND + ((NEQUAL |targ| |target|) NIL) + (|$genValue| + (SPADLET |fun| + (|getFunctionFromDomain| (|unwrap| |val|) |dc| |argl|)) + (|objNewWrap| |fun| |t2|)) + ((QUOTE T) + (SPADLET |val| + (|NRTcompileEvalForm| + (|unwrap| |val|) + (CDR (CAAR |mms|)) + (|evalDomain| |dc|))) + (|objNew| |val| |t2|)))))) + ((AND + (PAIRP |t1|) + (EQ (QCAR |t1|) (QUOTE |Variable|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t1|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |sym| (QCAR |ISTMP#1|)) (QUOTE T)))) + (PAIRP |t2|) + (EQ (QCAR |t2|) (QUOTE |Mapping|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t2|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |target| (QCAR |ISTMP#1|)) + (SPADLET |margl| (QCDR |ISTMP#1|)) + (QUOTE T))))) + (SEQ + (COND + ((NULL + (SPADLET |mms| + (|selectMms1| |sym| |target| |margl| |margl| NIL))) + (EXIT + (COND + ((NULL + (SPADLET |mms| + (|selectMms1| |sym| |target| |margl| |margl| T))) + (EXIT NIL)))))) + (SPADLET |LETTMP#1| (CAAR |mms|)) + (SPADLET |dc| (CAR |LETTMP#1|)) + (SPADLET |targ| (CADR |LETTMP#1|)) + (SPADLET |argl| (CDDR |LETTMP#1|)) + (COND + ((NEQUAL |targ| |target|) (EXIT NIL)) + ((AND + (PAIRP |dc|) + (EQ (QCAR |dc|) (QUOTE |_FreeFunction_|)) + (PROGN (SPADLET |freeFun| (QCDR |dc|)) (QUOTE T))) + (EXIT (|objNew| |freeFun| |t2|)))) + (COND + (|$genValue| + (EXIT + (|objNewWrap| + (|getFunctionFromDomain| |sym| |dc| |argl|) |t2|)))) + (SPADLET |val| + (|NRTcompileEvalForm| |sym| (CDR (CAAR |mms|)) + (|evalDomain| |dc|))) + (|objNew| |val| |t2|))) + ((AND + (PAIRP |t1|) + (EQ (QCAR |t1|) (QUOTE |FunctionCalled|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t1|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |sym| (QCAR |ISTMP#1|)) (QUOTE T)))) + (PAIRP |t2|) + (EQ (QCAR |t2|) (QUOTE |Mapping|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t2|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |target| (QCAR |ISTMP#1|)) + (SPADLET |margl| (QCDR |ISTMP#1|)) + (QUOTE T))))) + (SPADLET |symNode| (|mkAtreeNode| |sym|)) + (|transferPropsToNode| |sym| |symNode|) + (COND + ((NULL + (SPADLET |mms| + (|selectLocalMms| |symNode| |sym| |margl| |target|))) + NIL) + ((QUOTE T) + (SPADLET |LETTMP#1| (CAAR |mms|)) + (SPADLET |dc| (CAR |LETTMP#1|)) + (SPADLET |targ| (CADR |LETTMP#1|)) + (SPADLET |argl| (CDDR |LETTMP#1|)) + (COND + ((NEQUAL |targ| |target|) NIL) + ((QUOTE T) + (SPADLET |ml| (CONS |target| |margl|)) + (SPADLET |intName| + (COND + ((PROG (#2=#:G167466) + (SPADLET #2# NIL) + (RETURN + (DO ((#3=#:G167473 NIL #2#) + (#4=#:G167474 |mms| (CDR #4#)) + (|mm| NIL)) + ((OR #3# + (ATOM #4#) + (PROGN (SETQ |mm| (CAR #4#)) NIL)) + #2#) + (SEQ + (EXIT + (COND + ((AND + (PAIRP |mm|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |mm|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ml1| (QCDR |ISTMP#1|)) + (QUOTE T)))) + (PROGN + (SPADLET |ISTMP#2| (QCDR |mm|)) + (AND + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |oldName| (QCAR |ISTMP#2|)) + (QUOTE T)))) + (|compareTypeLists| |ml1| |ml|)) + (SETQ #2# (OR #2# |mm|))))))))) + (CONS |oldName| NIL)) + ((QUOTE T) NIL))) + (COND + ((NULL |intName|) NIL) + ((QUOTE T) (|objNewWrap| |intName| |t2|)))))))) + ((AND + (PAIRP |t1|) + (EQ (QCAR |t1|) (QUOTE |FunctionCalled|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t1|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |sym| (QCAR |ISTMP#1|)) (QUOTE T))))) + (COND + ((AND + (SPADLET |t3| (|get| |sym| (QUOTE |mode|) |$e|)) + (PAIRP |t3|) + (EQ (QCAR |t3|) (QUOTE |Mapping|))) + (COND + ((SPADLET |triple'| (|coerceInt| |triple| |t3|)) + (|coerceInt| |triple'| |t2|)) + ((QUOTE T) NIL))) + ((QUOTE T) NIL))) + ((AND + (EQ (CAR |t1|) (QUOTE |Variable|)) + (PAIRP |t2|) + (OR + (|isEqualOrSubDomain| |t2| |$Integer|) + (BOOT-EQUAL |t2| + (CONS |$QuotientField| (CONS |$Integer| NIL))) + (MEMQ (CAR |t2|) + (QUOTE (|RationalNumber| |BigFloat| |NewFloat| + |Float| |DoubleFloat|))))) + NIL) + ((QUOTE T) + (SPADLET |ans| + (OR + (|coerceRetract| |triple| |t2|) + (|coerceIntTower| |triple| |t2|) + (PROGN + (SPADLET |LETTMP#1| (|deconstructT| |t2|)) + (SPADLET |arg| (CDR |LETTMP#1|)) + (AND |arg| + (PROGN + (SPADLET |t| (|coerceInt| |triple| (|last| |arg|))) + (AND |t| (|coerceByFunction| |t| |t2|))))))) + (OR + |ans| + (AND + (|isSubDomain| |t1| |$Integer|) + (|coerceInt| (|objNew| |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| (QUOTE |$fromCoerceable$|)) NIL) + ((QUOTE T) + (SPADLET |super| (GETDATABASE (CAR |tSub|) (QUOTE SUPERDOMAIN))) + (SPADLET |superDomain| (CAR |super|)) + (COND + ((BOOT-EQUAL |superDomain| |tSuper|) + (|coerceImmediateSubDomain| |val| |tSuper| |tSub| (CADR |super|))) + ((|coerceSubDomain| |val| |tSuper| |superDomain|) + (|coerceImmediateSubDomain| |val| |superDomain| |tSub| (CADR |super|))) + ((QUOTE 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 + (SPADLET |predfn| (|getSubDomainPredicate| |tSuper| |tSub| |pred|)) + (COND + ((FUNCALL |predfn| |val| NIL) (|objNew| |val| |tSub|)) + ((QUOTE 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|)) + (RETURN + (PROGN + (SPADLET |$env| |$InteractiveFrame|) + (COND + ((SPADLET |predfn| (HGET |$superHash| (CONS |tSuper| |tSub|))) |predfn|) + ((QUOTE T) + (SPADLET |name| (GENSYM)) + (SPADLET |decl| + (CONS (QUOTE |:|) + (CONS |name| + (CONS + (CONS (QUOTE |Mapping|) (CONS |$Boolean| (CONS |tSuper| NIL))) + NIL)))) + (|interpret| |decl| NIL) + (SPADLET |arg| (GENSYM)) + (SPADLET |pred'| (MSUBST |arg| (QUOTE |#1|) |pred|)) + (SPADLET |defn| + (CONS (QUOTE DEF) + (CONS + (CONS |name| (CONS |arg| NIL)) + (CONS + (QUOTE (NIL NIL)) + (CONS (QUOTE (NIL NIL)) (CONS (|removeZeroOne| |pred'|) NIL)))))) + (|interpret| |defn| NIL) + (SPADLET |op| (|mkAtree| |name|)) + (|transferPropsToNode| |name| |op|) + (SPADLET |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| (QUOTE (|List| (|None|)))) + (COND + ((NULL (|unwrap| |val|)) + (COND + ((NULL (SPADLET |t0| (|underDomainOf| |t2|))) NIL) + ((QUOTE T) + (|coerceInt| + (|objNewWrap| |val| (CONS (QUOTE |List|) (CONS |t0| NIL))) + |t2|)))) + ((QUOTE T) NIL))) + ((QUOTE 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 NIL + (RETURN + (SEQ + (DO ((#0=#:G167600 |tl1| (CDR #0#)) + (|t1| NIL) + (#1=#:G167601 |tl2| (CDR #1#)) + (|t2| NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ |t1| (CAR #0#)) NIL) + (ATOM #1#) + (PROGN (SETQ |t2| (CAR #1#)) NIL)) + NIL) + (SEQ + (EXIT + (COND + ((NULL (|isEqualOrSubDomain| |t1| |t2|)) + (EXIT (RETURN NIL))))))) + (QUOTE 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 + (SPADLET |t1| (|objMode| |object|)) + (SPADLET |val| (|objValUnwrap| |object|)) + (COND + ((AND + (|ofCategory| |t1| (QUOTE (|Monoid|))) + (|ofCategory| |t2| (QUOTE (|Monoid|))) + (BOOT-EQUAL |val| (|getConstantFromDomain| (QUOTE (|One|)) |t1|))) + (|objNewWrap| (|getConstantFromDomain| (QUOTE (|One|)) |t2|) |t2|)) + ((AND + (|ofCategory| |t1| (QUOTE (|AbelianMonoid|))) + (|ofCategory| |t2| (QUOTE (|AbelianMonoid|))) + (BOOT-EQUAL |val| (|getConstantFromDomain| (QUOTE (|Zero|)) |t1|))) + (|objNewWrap| (|getConstantFromDomain| (QUOTE (|Zero|)) |t2|) |t2|)) + ((QUOTE 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 (#0=#:G167639) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G167650 |doms| (CDR #1#)) (|dom| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |dom| (CAR #1#)) NIL)) (NREVERSE0 #0#)) + (SEQ + (EXIT + (SETQ #0# + (CONS + (COND + ((AND + (PAIRP |dom|) + (EQ (QCAR |dom|) (QUOTE |:|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |dom|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |dom'| (QCAR |ISTMP#2|)) (QUOTE T))))))) + |dom'|) + ((QUOTE T) |dom|)) + #0#))))))))))) + +;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 + (PAIRP |u|) + (EQ (QCAR |u|) (QUOTE |Union|)) + (PROGN (SPADLET |tl| (QCDR |u|)) (QUOTE T)) + |tl| + (PROGN + (SPADLET |ISTMP#1| (CAR |tl|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) (QUOTE |:|)) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) (EQ (QCDR |ISTMP#3|) NIL))))))) + (QUOTE 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 + (SPADLET |tags| NIL) + (COND + ((OR + (AND + (PAIRP |u|) + (EQ (QCAR |u|) (QUOTE |Union|)) + (PROGN (SPADLET |tl| (QCDR |u|)) (QUOTE T))) + (AND + (PAIRP |u|) + (EQ (QCAR |u|) (QUOTE |Record|)) + (PROGN (SPADLET |tl| (QCDR |u|)) (QUOTE T)))) + (DO ((#0=#:G167701 |tl| (CDR #0#)) (|t| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |t| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (COND + ((AND + (PAIRP |t|) + (EQ (QCAR |t|) (QUOTE |:|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |tag| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL)))))) + (SPADLET |tags| (CONS |tag| |tags|))) + ((QUOTE 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 |coerceUnion2Branch| (|object|) + (PROG (|LETTMP#1| |unionDoms| |predList| |doms| |val'| |predicate| + |targetType| |ISTMP#1| |ISTMP#2| |p|) + (RETURN + (SEQ + (PROGN + (SPADLET |LETTMP#1| (|objMode| |object|)) + (SPADLET |unionDoms| (CDR |LETTMP#1|)) + (SPADLET |doms| (|orderUnionEntries| |unionDoms|)) + (SPADLET |predList| (|mkPredList| |doms|)) + (SPADLET |doms| (|stripUnionTags| |doms|)) + (SPADLET |val'| (|objValUnwrap| |object|)) + (SPADLET |predicate| NIL) + (SPADLET |targetType| NIL) + (SEQ + (DO ((#0=#:G167741 |doms| (CDR #0#)) + (|typ| NIL) + (#1=#:G167742 |predList| (CDR #1#)) + (|pred| NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ |typ| (CAR #0#)) NIL) + (ATOM #1#) + (PROGN (SETQ |pred| (CAR #1#)) NIL) + (NULL (NULL |targetType|))) + NIL) + (SEQ + (EXIT + (COND + ((|evalSharpOne| |pred| |val'|) + (EXIT + (PROGN + (SPADLET |predicate| |pred|) + (SPADLET |targetType| |typ|)))))))) + (COND + ((NULL |targetType|) (|keyedSystemError| (QUOTE S2IC0013) NIL)) + ((AND + (PAIRP |predicate|) + (EQ (QCAR |predicate|) (QUOTE EQCAR)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |predicate|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |p| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (|objNewWrap| (CDR |val'|) |targetType|)) + ((QUOTE T) (|objNew| (|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 + (SPADLET |unionDoms| (CDR |union|)) + (SPADLET |doms| (|orderUnionEntries| |unionDoms|)) + (SPADLET |predList| (|mkPredList| |doms|)) + (SPADLET |doms| (|stripUnionTags| |doms|)) + (SPADLET |p| (|position| (|objMode| |object|) |doms|)) + (COND + ((BOOT-EQUAL |p| (SPADDIFFERENCE 1)) + (|keyedSystemError| 'S2IC0014 + (CONS (|objMode| |object|) (CONS |union| NIL)))) + ((QUOTE T) + (SPADLET |val| (|objVal| |object|)) + (COND + ((PROGN + (SPADLET |ISTMP#1| (ELT |predList| |p|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) (QUOTE EQCAR)) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND + (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN (SPADLET |tag| (QCAR |ISTMP#3|)) (QUOTE T)))))))) + (|objNewWrap| (CONS (|removeQuote| |tag|) (|unwrap| |val|)) |union|)) + ((QUOTE T) (|objNew| |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|) + (RETURN + (SEQ + (PROGN + (SPADLET |unionDoms| (|stripUnionTags| (CDR |union|))) + (SPADLET |t1| (|objMode| |object|)) + (COND + ((|member| |t1| |unionDoms|) (|coerceBranch2Union| |object| |union|)) + ((QUOTE T) + (SPADLET |val| (|objVal| |object|)) + (SPADLET |val'| (|unwrap| |val|)) + (COND + ((AND (BOOT-EQUAL |t1| |$String|) (|member| |val'| |unionDoms|)) + (|coerceBranch2Union| (|objNew| |val| |val'|) |union|)) + ((QUOTE T) + (SPADLET |noCoerce| (QUOTE T)) + (SPADLET |val'| NIL) + (SEQ + (DO ((#0=#:G167805 |unionDoms| (CDR #0#)) (|d| NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ |d| (CAR #0#)) NIL) + (NULL |noCoerce|)) + NIL) + (SEQ + (EXIT + (COND + ((SPADLET |val'| (|coerceInt| |object| |d|)) + (EXIT (SPADLET |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|) + (RETURN + (PROGN + (SPADLET |t1| (|objMode| |triple|)) + (COND + ((BOOT-EQUAL |t2| |t1|) |triple|) + ((QUOTE T) + (SPADLET |u2| (|deconstructT| |t2|)) + (COND + ((EQL 1 (|#| |u2|)) NIL) + ((QUOTE T) + (SPADLET |u1| (|deconstructT| |t1|)) + (COND + ((EQL 1 (|#| |u1|)) NIL) + ((NEQUAL (CAAR |u1|) (CAAR |u2|)) NIL) + ((NULL (|valueArgsEqual?| |t1| |t2|)) NIL) + ((QUOTE T) + (SPADLET |top| (CAAR |u1|)) + (SPADLET |u1| (|underDomainOf| |t1|)) + (SPADLET |u2| (|underDomainOf| |t2|)) + (COND + ((AND (|member| |top| + (QUOTE (|List| |Vector| |Segment| |Stream| + |UniversalSegment| |Array|))) + (|isSubDomain| |u1| |u2|)) + (|objNew| (|objVal| |triple|) |t2|)) + ((QUOTE T) + (SPADLET |args| + (CONS + (CONS (QUOTE |Mapping|) (CONS |u2| (CONS |u1| NIL))) + (CONS |t1| NIL))) + (COND + (|$reportBottomUpFlag| + (|sayFunctionSelection| (QUOTE |map|) |args| |t2| NIL + (MAKESTRING "coercion facility (map)")))) + (SPADLET |mms| (|selectMms1| (QUOTE |map|) |t2| |args| |args| NIL)) + (COND + (|$reportBottomUpFlag| + (|sayFunctionSelectionResult| (QUOTE |map|) |args| |mms|))) + (COND + ((NULL |mms|) NIL) + ((QUOTE T) + (SPADLET |LETTMP#1| (CAR |mms|)) + (SPADLET |dc| (CAAR |LETTMP#1|)) + (SPADLET |sig| (CDAR |LETTMP#1|)) + (SPADLET |slot| (CADR |LETTMP#1|)) + (SPADLET |fun| + (|compiledLookup| (QUOTE |map|) |sig| (|evalDomain| |dc|))) + (COND + ((NULL |fun|) NIL) + ((QUOTE T) + (SPADLET |fn| (CAR |fun|)) + (SPADLET |d| (CDR |fun|)) + (COND + ((BOOT-EQUAL |fn| (|function| |Undef|)) NIL) + ((QUOTE T) + (SPADLET |code| + (CONS + (QUOTE SPADCALL) + (CONS + (CONS + (QUOTE CONS) + (CONS + (CONS + (QUOTE |function|) + (CONS (QUOTE |coerceIntByMapInner|) NIL)) + (CONS (MKQ (CONS |u1| |u2|)) NIL))) + (CONS + (|wrapped2Quote| (|objVal| |triple|)) + (CONS (MKQ |fun|) NIL))))) + (SPADLET |val| + (CATCH (QUOTE |coerceFailure|) (|timedEvaluate| |code|))) + (COND + ((BOOT-EQUAL |val| |$coerceFailure|) NIL) + ((QUOTE T) (|objNewWrap| |val| |t2|))))))))))))))))))))) + +;coerceIntByMapInner(arg,[u1,:u2]) == coerceOrThrowFailure(arg,u1,u2) + +(DEFUN |coerceIntByMapInner| (|arg| #0=#:G167859) + (PROG (|u1| |u2|) + (RETURN + (PROGN + (SPADLET |u1| (CAR #0#)) + (SPADLET |u2| (CDR #0#)) + (|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 + (SPADLET |coSig| (CDR (GETDATABASE (CAR |t1|) (QUOTE COSIG)))) + (SPADLET |constrSig| (CDR (|getConstructorSignature| (CAR |t1|)))) + (SPADLET |tl1| (|replaceSharps| |constrSig| |t1|)) + (SPADLET |tl2| (|replaceSharps| |constrSig| |t2|)) + (COND + ((NULL (MEMQ NIL |coSig|)) (QUOTE T)) + ((QUOTE T) + (SPADLET |done| NIL) + (SPADLET |value| (QUOTE T)) + (SEQ + (DO ((#0=#:G167888 (CDR |t1|) (CDR #0#)) + (|a1| NIL) + (#1=#:G167889 (CDR |t2|) (CDR #1#)) + (|a2| NIL) + (#2=#:G167890 |coSig| (CDR #2#)) + (|cs| NIL) + (#3=#:G167891 |tl1| (CDR #3#)) + (|m1| NIL) + (#4=#:G167892 |tl2| (CDR #4#)) + (|m2| NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ |a1| (CAR #0#)) NIL) + (ATOM #1#) + (PROGN (SETQ |a2| (CAR #1#)) NIL) + (ATOM #2#) + (PROGN (SETQ |cs| (CAR #2#)) NIL) + (ATOM #3#) + (PROGN (SETQ |m1| (CAR #3#)) NIL) + (ATOM #4#) + (PROGN (SETQ |m2| (CAR #4#)) NIL) + (NULL (NULL |done|))) + NIL) + (SEQ + (EXIT + (COND + ((NULL |cs|) + (EXIT + (PROGN + (SPADLET |trip| (|objNewWrap| |a1| |m1|)) + (SPADLET |newVal| (|coerceInt| |trip| |m2|)) + (COND + ((NULL |newVal|) + (SPADLET |done| (QUOTE T)) + (SPADLET |value| NIL)) + ((NULL (|algEqual| |a2| (|objValUnwrap| |newVal|) |m2|)) + (SPADLET |done| (QUOTE T)) + (SPADLET |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 + ((SPADLET |x| (|coerceIntByMap| |triple| |t2|)) |x|) + ((SPADLET |x| (|coerceIntCommute| |triple| |t2|)) |x|) + ((SPADLET |x| (|coerceIntPermute| |triple| |t2|)) |x|) + ((SPADLET |x| (|coerceIntSpecial| |triple| |t2|)) |x|) + ((SPADLET |x| (|coerceIntTableOrFunction| |triple| |t2|)) |x|) + ((QUOTE T) + (SPADLET |t1| (|objMode| |triple|)) + (SPADLET |LETTMP#1| (|deconstructT| |t1|)) + (SPADLET |c1| (CAR |LETTMP#1|)) + (SPADLET |arg1| (CDR |LETTMP#1|)) + (AND + |arg1| + (PROGN + (SPADLET TL NIL) + (SPADLET |arg| |arg1|) + (DO ((#0=#:G167962 NIL (OR |x| (NULL |arg|)))) + (#0# NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |t| (|last| |arg|)) + (SPADLET |LETTMP#1| (|deconstructT| |t|)) + (SPADLET |c| (CAR |LETTMP#1|)) + (SPADLET |arg| (CDR |LETTMP#1|)) + (SPADLET TL (CONS |c| (CONS |arg| TL))) + (COND + ((SPADLET |x| (AND |arg| (|coerceIntTest| |t| |t2|))) + (COND + ((CDDR TL) + (SPADLET |s| + (|constructT| |c1| + (|replaceLast| |arg1| (|bubbleConstructor| TL)))) + (COND + ((NULL (|isValidType| |s|)) (SPADLET |x| NIL)) + ((SPADLET |x| + (OR + (|coerceIntByMap| |triple| |s|) + (|coerceIntTableOrFunction| |triple| |s|))) + (SPADLET |LETTMP#1| (|deconstructT| (|last| |s|))) + (SPADLET |c2| (CAR |LETTMP#1|)) + (SPADLET |arg2| (CDR |LETTMP#1|)) + (SPADLET |s| + (|bubbleConstructor| + (CONS |c2| (CONS |arg2| (CONS |c1| (CONS |arg1| NIL)))))) + (COND + ((NULL (|isValidType| |s|)) (SPADLET |x| NIL)) + ((SPADLET |x| (|coerceIntCommute| |x| |s|)) + (SPADLET |x| + (OR + (|coerceIntByMap| |x| |t2|) + (|coerceIntTableOrFunction| |x| |t2|)))))))) + ((QUOTE T) + (SPADLET |s| + (|bubbleConstructor| + (CONS |c| (CONS |arg| (CONS |c1| (CONS |arg1| NIL)))))) + (COND + ((NULL (|isValidType| |s|)) (SPADLET |x| NIL)) + ((SPADLET |x| (|coerceIntCommute| |triple| |s|)) + (SPADLET |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 + (SPADLET |t1| (|objMode| |triple|)) + (COND + ((AND (PAIRP |t2|) + (EQ (QCAR |t2|) (QUOTE |SimpleAlgebraicExtension|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t2|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET R (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET U (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) (EQ (QCDR |ISTMP#3|) NIL))))))) + (BOOT-EQUAL |t1| R)) + (COND + ((NULL (SPADLET |x| (|coerceInt| |triple| U))) NIL) + ((QUOTE T) (|coerceInt| |x| |t2|)))) + ((QUOTE 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|) + (RETURN + (COND + ((NULL (|isValidType| |t2|)) NIL) + ((NULL (|isLegitimateMode| |t2| NIL NIL)) NIL) + ((QUOTE T) + (SPADLET |t1| (|objMode| |triple|)) + (SPADLET |p| (ASSQ (CAR |t1|) |$CoerceTable|)) + (COND + ((AND + |p| + (PROGN + (SPADLET |ISTMP#1| (ASSQ (CAR |t2|) (CDR |p|))) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |tag| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND + (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN (SPADLET |fun| (QCAR |ISTMP#3|)) (QUOTE T))))))))) + (SPADLET |val| (|objVal| |triple|)) + (COND + ((BOOT-EQUAL |fun| (QUOTE |Identity|)) (|objNew| |val| |t2|)) + ((BOOT-EQUAL |tag| (QUOTE |total|)) + (OR + (|coerceByTable| |fun| |val| |t1| |t2| (QUOTE T)) + (|coerceByFunction| |triple| |t2|))) + ((QUOTE T) + (OR + (|coerceByTable| |fun| |val| |t1| |t2| NIL) + (|coerceByFunction| |triple| |t2|))))) + ((QUOTE 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 (SPADLET |u1| (|underDomainOf| |t1|))) NIL) + ((NULL (SPADLET |u2| (|underDomainOf| |t2|))) NIL) + ((NULL (SPADLET |v1| (|underDomainOf| |u1|))) NIL) + ((NULL (SPADLET |v2| (|underDomainOf| |u2|))) NIL) + ((QUOTE 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",STRINGIMAGE 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|) + (RETURN + (PROGN + (SPADLET |source| (|objMode| |obj|)) + (COND + ((NULL (|coerceCommuteTest| |source| |target|)) NIL) + ((QUOTE T) + (SPADLET S (|underDomainOf| |source|)) + (SPADLET T$ (|underDomainOf| |target|)) + (COND + ((BOOT-EQUAL |source| T$) NIL) + ((AND (PAIRP |source|) (PROGN (SPADLET D (QCAR |source|)) (QUOTE T))) + (SPADLET |fun| + (OR + (GETL D (QUOTE |coerceCommute|)) + (INTERN (STRCONC (MAKESTRING "commute") (STRINGIMAGE D))))) + (COND + ((|functionp| |fun|) + (PUT D (QUOTE |coerceCommute|) |fun|) + (SPADLET |u| (|objValUnwrap| |obj|)) + (SPADLET |c| + (CATCH + (QUOTE |coerceFailure|) + (FUNCALL |fun| |u| |source| S |target| T$))) + (COND + ((BOOT-EQUAL |c| |$coerceFailure|) NIL) + ((BOOT-EQUAL |u| (QUOTE |$fromCoerceable$|)) |c|) + ((QUOTE T) (|objNewWrap| |c| |target|)))) + ((QUOTE T) NIL))) + ((QUOTE 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| (QUOTE ((|Integer|) (|OutputForm|)))) NIL) + ((QUOTE T) + (SPADLET |t1| (|objMode| |object|)) + (SPADLET |towers| (|computeTTTranspositions| |t1| |t2|)) + (COND + ((OR (NULL |towers|) (NULL (CDR |towers|))) NIL) + ((AND (NULL (CDDR |towers|)) (BOOT-EQUAL |t2| (CADR |towers|))) NIL) + ((QUOTE T) + (SPADLET |ok| (QUOTE T)) + (SEQ + (DO ((#0=#:G168100 (CDR |towers|) (CDR #0#)) (|t| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |t| (CAR #0#)) NIL) (NULL |ok|)) NIL) + (SEQ + (EXIT + (COND + ((NULL (SPADLET |object| (|coerceInt| |object| |t|))) + (EXIT (SPADLET |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 NIL + (RETURN + (SEQ + (IF (>= |start| |len|) (EXIT |l|)) + (IF (|member| |start| |l|) + (EXIT + (|computeTTTranspositions,compress| |l| (PLUS |start| 1) |len|))) + (EXIT + (|computeTTTranspositions,compress| + (PROG (#0=#:G168121) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G168126 |l| (CDR #1#)) (|i| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |i| (CAR #1#)) NIL)) (NREVERSE0 #0#)) + (SEQ + (EXIT + (SETQ #0# + (CONS + (SEQ + (IF (> |start| |i|) (EXIT |i|)) + (EXIT (SPADDIFFERENCE |i| 1))) + #0#))))))) + |start| |len|)))))) + +(DEFUN |computeTTTranspositions| (|t1| |t2|) + (PROG (|tl1| |tl2| |p2'| |n1| |p2| |perms| |tower| |t| |towers|) + (RETURN + (SEQ + (PROGN + (SPADLET |tl1| (|decomposeTypeIntoTower| |t1|)) + (SPADLET |tl2| (|decomposeTypeIntoTower| |t2|)) + (COND + ((NULL (AND (CDR |tl1|) (CDR |tl2|))) NIL) + ((QUOTE T) + (SPADLET |p2| + (PROG (#0=#:G168143) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G168148 |tl1| (CDR #1#)) (|d1| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |d1| (CAR #1#)) NIL)) + (NREVERSE0 #0#)) + (SEQ (EXIT (SETQ #0# (CONS (|position| |d1| |tl2|) #0#)))))))) + (COND + ((|member| (SPADDIFFERENCE 1) |p2|) NIL) + ((QUOTE T) + (SPADLET |p2'| (MSORT |p2|)) + (COND + ((BOOT-EQUAL |p2| |p2'|) NIL) + ((NEQUAL |p2'| (MSORT (REMDUP |p2'|))) NIL) + ((QUOTE T) + (SPADLET |n1| (|#| |tl1|)) + (SPADLET |p2| + (LIST2VEC + (|computeTTTranspositions,compress| |p2| 0 (|#| (REMDUP |tl1|))))) + (SPADLET |perms| (|permuteToOrder| |p2| (SPADDIFFERENCE |n1| 1) 0)) + (SPADLET |towers| (CONS |tl1| NIL)) + (SPADLET |tower| (LIST2VEC |tl1|)) + (DO ((#2=#:G168161 |perms| (CDR #2#)) (|perm| NIL)) + ((OR (ATOM #2#) (PROGN (SETQ |perm| (CAR #2#)) NIL)) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |t| (ELT |tower| (CAR |perm|))) + (SETELT |tower| (CAR |perm|) (ELT |tower| (CDR |perm|))) + (SETELT |tower| (CDR |perm|) |t|) + (SPADLET |towers| (CONS (VEC2LIST |tower|) |towers|)))))) + (SPADLET |towers| + (PROG (#3=#:G168171) + (SPADLET #3# NIL) + (RETURN + (DO ((#4=#:G168176 |towers| (CDR #4#)) (|tower| NIL)) + ((OR (ATOM #4#) (PROGN (SETQ |tower| (CAR #4#)) NIL)) + (NREVERSE0 #3#)) + (SEQ + (EXIT + (SETQ #3# + (CONS (|reassembleTowerIntoType| |tower|) #3#)))))))) + (COND + ((NEQUAL (CAR |towers|) |t2|) + (SPADLET |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)) + ((QUOTE T) + (SPADLET |d| (|deconstructT| |t|)) + (COND + ((NULL (CDR |d|)) (CONS |t| NIL)) + ((QUOTE T) + (SPADLET |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|)) + ((QUOTE T) + (SPADLET |LETTMP#1| (REVERSE |tower|)) + (SPADLET |s| (CAR |LETTMP#1|)) + (SPADLET |t| (CADR |LETTMP#1|)) + (SPADLET |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 + (SPADLET |r| (SPADDIFFERENCE |n| |start|)) + (COND + ((<= |r| 0) NIL) + ((EQL |r| 1) + (COND + ((> (ELT |p| (PLUS |r| 1)) (ELT |p| |r|)) NIL) + ((QUOTE T) (CONS (CONS |r| (PLUS |r| 1)) NIL)))) + ((BOOT-EQUAL (ELT |p| |start|) |start|) + (|permuteToOrder| |p| |n| (PLUS |start| 1))) + ((QUOTE T) + (SPADLET |stpos| NIL) + (DO ((|i| (PLUS |start| 1) (+ |i| 1))) + ((OR (> |i| |n|) (NULL (NULL |stpos|))) NIL) + (SEQ + (EXIT + (COND + ((BOOT-EQUAL (ELT |p| |i|) |start|) (SPADLET |stpos| |i|)) + ((QUOTE T) NIL))))) + (SPADLET |perms| NIL) + (DO () + ((NULL (NEQUAL |stpos| |start|)) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |x| (SPADDIFFERENCE |stpos| 1)) + (SPADLET |perms| (CONS (CONS |x| |stpos|) |perms|)) + (SPADLET |t| (ELT |p| |stpos|)) + (SETELT |p| |stpos| (ELT |p| |x|)) + (SETELT |p| |x| |t|) (SPADLET |stpos| |x|))))) + (APPEND + (NREVERSE |perms|) + (|permuteToOrder| |p| |n| (PLUS |start| 1)))))))))) + +;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|) + (RETURN + (OR + (BOOT-EQUAL |t1| |t2|) + (PROGN + (SPADLET |b| + (PROGN + (SPADLET |p| (ASSQ (CAR |t1|) |$CoerceTable|)) + (AND |p| (ASSQ (CAR |t2|) (CDR |p|))))) + (OR |b| + (|coerceConvertMmSelection| (QUOTE |coerce|) |t1| |t2|) + (AND + |$useConvertForCoercions| + (|coerceConvertMmSelection| (QUOTE |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|) + (RETURN + (COND + ((AND (BOOT-EQUAL |t2| |$OutputForm|) (NULL (|newType?| |t1|))) NIL) + ((|isWrapped| |x|) + (SPADLET |x| (|unwrap| |x|)) + (SPADLET |c| (CATCH (QUOTE |coerceFailure|) (FUNCALL |fn| |x| |t1| |t2|))) + (COND + ((BOOT-EQUAL |c| |$coerceFailure|) NIL) + ((QUOTE T) (|objNewWrap| |c| |t2|)))) + (|isTotalCoerce| + (|objNew| + (CONS |fn| (CONS |x| (CONS (MKQ |t1|) (CONS (MKQ |t2|) NIL)))) + |t2|)) + ((QUOTE T) + (|objNew| + (CONS + (QUOTE |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|) + (RETURN + (PROGN + (SPADLET |c| (CATCH (QUOTE |coerceFailure|) (FUNCALL |fn| |x| |t1| |t2|))) + (COND + ((BOOT-EQUAL |c| |$coerceFailure|) + (|throwKeyedMsgCannotCoerceWithValue| (|wrap| (|unwrap| |x|)) |t1| |t2|)) + ((QUOTE T) |c|)))))) + +;coercionFailure() == +; -- does the throw on coercion failure +; THROW('coerceFailure,$coerceFailure) + +(DEFUN |coercionFailure| () + (THROW (QUOTE |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 $)) + (RETURN + (PROGN + (SPADLET |x| (|objVal| T$)) + (COND + ((BOOT-EQUAL |x| (QUOTE |$fromCoerceable$|)) NIL) + ((AND (PAIRP |m2|) (EQ (QCAR |m2|) (QUOTE |Union|))) NIL) + ((QUOTE T) + (SPADLET |m1| (|objMode| T$)) + (COND + ((AND (PAIRP |m2|) + (EQ (QCAR |m2|) (QUOTE |Boolean|)) + (PAIRP |m1|) + (EQ (QCAR |m1|) (QUOTE |Equation|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |m1|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |ud| (QCAR |ISTMP#1|)) (QUOTE T))))) + (SPADLET |dcVector| (|evalDomain| |ud|)) + (SPADLET |fun| + (COND + ((|isWrapped| |x|) + (|NRTcompiledLookup| + (QUOTE =) + (CONS |$Boolean| + (CONS (QUOTE $) (CONS (QUOTE $) NIL))) |dcVector|)) + ((QUOTE T) + (|NRTcompileEvalForm| + (QUOTE =) + (CONS |$Boolean| + (CONS (QUOTE $) (CONS (QUOTE $) NIL))) |dcVector|)))) + (SPADLET |fn| (CAR |fun|)) + (SPADLET |d| (CDR |fun|)) + (COND + ((|isWrapped| |x|) + (SPADLET |x| (|unwrap| |x|)) + (|mkObjWrap| (SPADCALL (CAR |x|) (CDR |x|) |fun|) |m2|)) + ((NULL + (AND + (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE SPADCALL)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (PROGN (SPADLET |b| (QCAR |ISTMP#2|)) (QUOTE T)))))))) + (|keyedSystemError| (QUOTE S2IC0015) NIL)) + ((QUOTE T) + (SPADLET |code| + (CONS (QUOTE SPADCALL) (CONS |a| (CONS |b| (CONS |fun| NIL))))) + (|objNew| |code| |$Boolean|)))) + ((QUOTE T) + (COND + ((NULL + (SPADLET |mm| (|coerceConvertMmSelection| + (SPADLET |funName| (QUOTE |coerce|)) |m1| |m2|))) + (SPADLET |mm| + (|coerceConvertMmSelection| + (SPADLET |funName| (QUOTE |convert|)) |m1| |m2|)))) + (COND + (|mm| + (SPADLET |dc| (CAAR |mm|)) + (SPADLET |tar| (CADAR |mm|)) + (SPADLET |args| (CDDAR |mm|)) + (SPADLET |slot| (CADR |mm|)) + (SPADLET |dcVector| (|evalDomain| |dc|)) + (SPADLET |fun| + (COND + ((|isWrapped| |x|) + (|NRTcompiledLookup| |funName| |slot| |dcVector|)) + ((QUOTE T) + (|NRTcompileEvalForm| |funName| |slot| |dcVector|)))) + (SPADLET |fn| (CAR |fun|)) + (SPADLET |d| (CDR |fun|)) + (COND + ((BOOT-EQUAL |fn| (|function| |Undef|)) NIL) + ((|isWrapped| |x|) + (SPADLET $ |dcVector|) + (SPADLET |val| + (CATCH (QUOTE |coerceFailure|) (SPADCALL (|unwrap| |x|) |fun|))) + (COND + ((BOOT-EQUAL |val| |$coerceFailure|) NIL) + ((QUOTE T) (|objNewWrap| |val| |m2|)))) + ((QUOTE T) + (SPADLET |env| |fun|) + (SPADLET |code| + (CONS + (QUOTE |failCheck|) + (CONS (CONS (QUOTE SPADCALL) (CONS |x| (CONS |env| NIL))) NIL))) + (|objNew| |code| |m2|)))) + ((QUOTE T) + (SPADLET |m1'| (|eqType| |m1|)) + (SPADLET |m2'| (|eqType| |m2|)) + (COND + ((OR (NEQUAL |m1| |m1'|) (NEQUAL |m2| |m2'|)) + (|coerceByFunction| (|objNew| |x| |m1'|) |m2'|)) + ((QUOTE 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 + (SPADLET |dc| (CAR |sig|)) + (SPADLET |tar| (CADR |sig|)) + (COND + ((AND (PAIRP |dc|) (EQ (QCAR |dc|) (QUOTE |TypeEquivalence|))) NIL) + ((BOOT-EQUAL |m| |tar|) (QUOTE T)) + ((AND + (PAIRP |tar|) + (EQ (QCAR |tar|) (QUOTE |Union|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |tar|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |t| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (EQ (QCAR |ISTMP#2|) (QUOTE |failed|))))))) + (BOOT-EQUAL |t| |m|)) + ((QUOTE T) + (AND + (PAIRP |tar|) + (EQ (QCAR |tar|) (QUOTE |Union|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |tar|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) (QUOTE |failed|)) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |t| (QCAR |ISTMP#2|)) (QUOTE T)))))) + (BOOT-EQUAL |t| |m|)))))))) + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document}