diff --git a/changelog b/changelog index abeeb4c..0f478d6 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,5 @@ +20091006 tpd src/axiom-website/patches.html 20091006.01.tpd.patch +20091006 tpd src/interp/i-coerce.lisp cleanup 20091005 tpd src/axiom-website/patches.html 20091005.03.tpd.patch 20091005 tpd src/interp/i-coerfn.lisp cleanup 20091005 tpd src/axiom-website/patches.html 20091005.02.tpd.patch diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 409d082..e4be008 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -2107,5 +2107,7 @@ src/interp/i-eval.lisp cleanup
src/interp/i-funsel.lisp cleanup
20091005.03.tpd.patch src/interp/i-coerfn.lisp cleanup
+20091006.01.tpd.patch +src/interp/i-coerce.lisp cleanup
diff --git a/src/interp/i-coerce.lisp.pamphlet b/src/interp/i-coerce.lisp.pamphlet index 2a8f6b4..ce6199d 100644 --- a/src/interp/i-coerce.lisp.pamphlet +++ b/src/interp/i-coerce.lisp.pamphlet @@ -51,25 +51,26 @@ The special routines that do the coercions typically involve a "2" ; 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))))))))))))) + (PROG (|$useConvertForCoercions| |u|) + (DECLARE (SPECIAL |$useConvertForCoercions|)) + (RETURN + (PROGN + (SPADLET |$useConvertForCoercions| 'T) + (SPADLET |source| (|devaluate| |source|)) + (SPADLET |target| (|devaluate| |target|)) + (SPADLET |u| + (|coerceInteractive| (|objNewWrap| |p| |source|) + |target|)) + (COND + (|u| (|objValUnwrap| |u|)) + ('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 @@ -81,18 +82,20 @@ The special routines that do the coercions typically involve a "2" ; 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|)))))) + (PROG (|x'|) + (RETURN + (COND + ((NULL (|isValidType| |source|)) + (|throwKeyedMsg| 'S2IE0004 (CONS |source| NIL))) + ((NULL (|isValidType| |target|)) + (|throwKeyedMsg| 'S2IE0004 (CONS |target| NIL))) + ((SPADLET |x'| + (|coerceInteractive| (|objNewWrap| |x| |source|) + |target|)) + (|objValUnwrap| |x'|)) + ('T + (|throwKeyedMsgCannotCoerceWithValue| (|wrap| |x|) |source| + |target|)))))) ;--% Functions for Coercion or Else We'll Get Rough ;coerceOrFail(triple,t,mapName) == @@ -104,19 +107,19 @@ The special routines that do the coercions typically involve a "2" ; '"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"))))))) + (PROG (|t'|) + (DECLARE (SPECIAL |$NoValueMode|)) + (RETURN + (COND + ((BOOT-EQUAL |t| |$NoValueMode|) |triple|) + ('T (SPADLET |t'| (|coerceInteractive| |triple| |t|)) + (COND + (|t'| (|objValUnwrap| |t'|)) + ('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 @@ -129,21 +132,20 @@ The special routines that do the coercions typically involve a "2" ; 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|)))))))) + (PROG (|t'|) + (DECLARE (SPECIAL |$NoValueMode|)) + (RETURN + (COND + ((BOOT-EQUAL |t| |$NoValueMode|) |triple|) + ('T (SPADLET |t'| (|coerceOrConvertOrRetract| |triple| |t|)) + (COND + (|t'| (|objValUnwrap| |t'|)) + ((BOOT-EQUAL |mapName| '|noMapName|) + (|throwKeyedMsgCannotCoerceWithValue| (|objVal| |triple|) + (|objMode| |triple|) |t|)) + ('T (|sayKeyedMsg| 'S2IC0005 (CONS |mapName| NIL)) + (|throwKeyedMsgCannotCoerceWithValue| (|objVal| |triple|) + (|objMode| |triple|) |t|)))))))) ;coerceOrThrowFailure(value, t1, t2) == ; (result := coerceOrRetract(objNewWrap(value, t1), t2)) or @@ -151,13 +153,14 @@ The special routines that do the coercions typically involve a "2" ; objValUnwrap(result) (DEFUN |coerceOrThrowFailure| (|value| |t1| |t2|) - (PROG (|result|) - (RETURN - (PROGN - (OR - (SPADLET |result| (|coerceOrRetract| (|objNewWrap| |value| |t1|) |t2|)) - (|coercionFailure|)) - (|objValUnwrap| |result|))))) + (PROG (|result|) + (RETURN + (PROGN + (OR (SPADLET |result| + (|coerceOrRetract| (|objNewWrap| |value| |t1|) + |t2|)) + (|coercionFailure|)) + (|objValUnwrap| |result|))))) ;--% Retraction functions ;retract object == @@ -171,28 +174,30 @@ The special routines that do the coercions typically involve a "2" ; 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|)) + (PROG (|type| |val| |type'| |ans|) + (DECLARE (SPECIAL |$EmptyMode|)) + (RETURN + (PROGN + (SPADLET |type| (|objMode| |object|)) (COND - ((BOOT-EQUAL - (SPADLET |ans| (|retract1| (|objNew| |val| (|equiType| |type|)))) - (QUOTE |failed|)) - |ans|) - ((QUOTE T) - (|objNew| (|objVal| |ans|) (|eqType| (|objMode| |ans|))))))))))))) + ((STRINGP |type|) '|failed|) + ((BOOT-EQUAL |type| |$EmptyMode|) '|failed|) + ('T (SPADLET |val| (|objVal| |object|)) + (COND + ((AND (NULL (|isWrapped| |val|)) + (NULL (AND (PAIRP |val|) (EQ (QCAR |val|) 'MAP)))) + '|failed|) + ('T (SPADLET |type'| (|equiType| |type|)) + (COND + ((BOOT-EQUAL + (SPADLET |ans| + (|retract1| + (|objNew| |val| (|equiType| |type|)))) + '|failed|) + |ans|) + ('T + (|objNew| (|objVal| |ans|) + (|eqType| (|objMode| |ans|))))))))))))) ;retract1 object == ; -- this function is the new version of the old "pullback" @@ -225,58 +230,68 @@ The special routines that do the coercions typically involve a "2" ; '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'|)))) + (PROG (|type| |val| |type'| |ISTMP#1| |underDomain| |object'|) + (DECLARE (SPECIAL |$SingleInteger| |$Integer| |$NonNegativeInteger| + |$PositiveInteger|)) + (RETURN + (PROGN + (SPADLET |type| (|objMode| |object|)) (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|))))))))))))) + ((STRINGP |type|) '|failed|) + ('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|)) + ('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'|) '|Union|)) + (AND (PAIRP |type'|) + (EQ (QCAR |type'|) '|FunctionCalled|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |type'|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL)))) + (AND (PAIRP |type'|) + (EQ (QCAR |type'|) '|OrderedVariableList|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |type'|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL)))) + (AND (PAIRP |type|) (EQ (QCAR |type|) '|Variable|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |type|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL))))) + (COND + ((SPADLET |object'| + (|retract2Specialization| |object|)) + |object'|) + ('T '|failed|))) + ((NULL (SPADLET |underDomain| + (|underDomainOf| |type'|))) + '|failed|) + ('T + (SPADLET |object'| + (|retractUnderDomain| |object| |type| + |underDomain|)) + (COND + ((NEQUAL |object'| '|failed|) |object'|) + ((SPADLET |object'| + (|coerceRetract| |object| |underDomain|)) + |object'|) + ((SPADLET |object'| + (|retract2Specialization| |object|)) + |object'|) + ('T '|failed|)))))))))))) ;retractUnderDomain(object,type,underDomain) == ; null (ud := underDomainOf underDomain) => 'failed @@ -288,22 +303,22 @@ The special routines that do the coercions typically involve a "2" ; '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|)))))))))) + (PROG (|ud| |LETTMP#1| |c| |args| |type''| |object'|) + (RETURN + (COND + ((NULL (SPADLET |ud| (|underDomainOf| |underDomain|))) + '|failed|) + ('T (SPADLET |LETTMP#1| (|deconstructT| |type|)) + (SPADLET |c| (CAR |LETTMP#1|)) + (SPADLET |args| (CDR |LETTMP#1|)) + (COND + ((NEQUAL 1 (|#| |args|)) '|failed|) + ((NEQUAL 1 (|#| |c|)) '|failed|) + ('T (SPADLET |type''| (|constructT| |c| (CONS |ud| NIL))) + (COND + ((SPADLET |object'| (|coerceInt| |object| |type''|)) + |object'|) + ('T '|failed|))))))))) ;retract2Specialization object == ; -- handles some specialization retraction cases, like matrices @@ -405,354 +420,365 @@ The special routines that do the coercions typically involve a "2" ; 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 + (PROG (|val| |type| |dom| |obj| |unionDoms| |x| |agg| |bds| |D'| + |bad| |vl| |tl| |e'| |vl'| |n| D |num| |den| |k| |rep| + |val'| |coef| |ISTMP#2| |var| |ISTMP#3| |cen| |ISTMP#1| + |name| |m|) + (DECLARE (SPECIAL |$e| |$QuotientField| |$Symbol| |$Integer| |$Any| + |$NonNegativeInteger| |$PositiveInteger|)) + (RETURN + (SEQ (PROGN + (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|) '|Union|) + (PROGN (SPADLET |unionDoms| (QCDR |type|)) 'T)) + (|coerceUnion2Branch| |object|)) + ((BOOT-EQUAL |type| |$Symbol|) + (|objNewWrap| 1 + (CONS '|OrderedVariableList| + (CONS (CONS |val'| NIL) NIL)))) + ((AND (PAIRP |type|) + (EQ (QCAR |type|) '|OrderedVariableList|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |type|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |var| (QCAR |ISTMP#1|)) + 'T)))) + (|coerceInt| + (|objNewWrap| (ELT |var| (SPADDIFFERENCE |val'| 1)) + |$Symbol|) + '(|Polynomial| (|Integer|)))) + ((AND (PAIRP |type|) (EQ (QCAR |type|) '|Polynomial|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |type|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET D (QCAR |ISTMP#1|)) 'T)))) (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))))))) + ((AND (PAIRP |val'|) (EQUAL (QCAR |val'|) 1) + (PROGN + (SPADLET |ISTMP#1| (QCDR |val'|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |x| (QCAR |ISTMP#1|)) + 'T)))) + (SPADLET |vl| + (REMDUP (REVERSE (|varsInPoly| |val'|)))) + (COND + ((EQL 1 (|#| |vl|)) + (|coerceInt| |object| + (CONS '|UnivariatePolynomial| + (CONS |x| (CONS D NIL))))) + ('T NIL))) + ((AND (PAIRP |val'|) (EQUAL (QCAR |val'|) 0)) + (|coerceInt| |object| D)) + ('T NIL))) + ((AND (PAIRP |type|) (EQ (QCAR |type|) '|Matrix|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |type|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET D (QCAR |ISTMP#1|)) 'T)))) + (SPADLET |n| (|#| |val'|)) + (SPADLET |m| (|#| (ELT |val'| 0))) + (COND + ((BOOT-EQUAL |n| |m|) + (|objNew| |val| + (CONS '|SquareMatrix| (CONS |n| (CONS D NIL))))) + ('T + (|objNew| |val| + (CONS '|RectangularMatrix| + (CONS |n| (CONS |m| (CONS D NIL)))))))) + ((AND (PAIRP |type|) + (EQ (QCAR |type|) '|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|)) + 'T)))))))) + (COND + ((BOOT-EQUAL |n| |m|) + (|objNew| |val| + (CONS '|SquareMatrix| (CONS |n| (CONS D NIL))))) + ('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|)) 'T))) + (|member| |agg| + '(|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)))) + ('T NIL))) + ((AND (PAIRP |type|) (EQ (QCAR |type|) '|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|)) + 'T)))))) + (COND + ((BOOT-EQUAL D |$PositiveInteger|) + (|objNew| |val| + (CONS '|Array| + (CONS |bds| + (CONS |$NonNegativeInteger| NIL))))) + ((BOOT-EQUAL D |$NonNegativeInteger|) + (|objNew| |val| + (CONS '|Array| + (CONS |bds| (CONS |$Integer| NIL))))) + ('T NIL))) + ((AND (PAIRP |type|) (EQ (QCAR |type|) '|List|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |type|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET D (QCAR |ISTMP#1|)) 'T)))) + (COND + ((NULL (AND (PAIRP D) (EQ (QCAR D) '|List|) + (PROGN + (SPADLET |ISTMP#1| (QCDR D)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |D'| (QCAR |ISTMP#1|)) + 'T))))) + (COND + ((BOOT-EQUAL D |$PositiveInteger|) + (|objNew| |val| + (CONS '|List| + (CONS |$NonNegativeInteger| NIL)))) + ((BOOT-EQUAL D |$NonNegativeInteger|) + (|objNew| |val| + (CONS '|List| (CONS |$Integer| NIL)))) + ((NULL |val'|) NIL) + ('T (SPADLET |vl| NIL) (SPADLET |tl| NIL) + (SPADLET |bad| NIL) + (DO ((G166347 |val'| (CDR G166347)) + (|e| NIL)) + ((OR (ATOM G166347) + (PROGN (SETQ |e| (CAR G166347)) NIL) + (NULL (NULL |bad|))) + NIL) + (SEQ (EXIT (COND + ((BOOT-EQUAL + (SPADLET |e'| + (|retract| + (|objNewWrap| |e| D))) + '|failed|) + (SPADLET |bad| 'T)) + ('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) + ('T (SPADLET |vl'| NIL) + (DO ((G166358 |vl| (CDR G166358)) + (|e| NIL) + (G166359 |tl| (CDR G166359)) + (|t| NIL)) + ((OR (ATOM G166358) + (PROGN + (SETQ |e| (CAR G166358)) + NIL) + (ATOM G166359) + (PROGN + (SETQ |t| (CAR G166359)) + NIL)) + NIL) + (SEQ (EXIT (COND + ((BOOT-EQUAL |t| |m|) + (SPADLET |vl'| + (CONS |e| |vl'|))) + ('T + (SPADLET |e'| + (|coerceInt| + (|objNewWrap| |e| |t|) |m|)) + (COND + ((NULL |e'|) (RETURN NIL)) + ('T + (SPADLET |vl'| + (CONS + (|objValUnwrap| |e'|) + |vl'|))))))))) + (|objNewWrap| |vl'| + (CONS '|List| (CONS |m| NIL)))))))) + ((BOOT-EQUAL |D'| |$PositiveInteger|) + (|objNew| |val| + (CONS '|List| + (CONS (CONS '|List| + (CONS |$NonNegativeInteger| NIL)) + NIL)))) + ((BOOT-EQUAL |D'| |$NonNegativeInteger|) + (|objNew| |val| + (CONS '|List| + (CONS (CONS '|List| (CONS |$Integer| NIL)) + NIL)))) + ((OR (AND (PAIRP |D'|) (EQ (QCAR |D'|) '|Variable|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |D'|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL)))) + (AND (PAIRP |D'|) + (EQ (QCAR |D'|) '|OrderedVariableList|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |D'|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL))))) + (|coerceInt| |object| + (CONS '|List| + (CONS (CONS '|List| (CONS |$Symbol| NIL)) + NIL)))) + ('T (SPADLET |n| (|#| |val'|)) + (SPADLET |m| (|#| (ELT |val'| 0))) + (COND + ((NULL (|isRectangularList| |val'| |n| |m|)) NIL) + ('T + (|coerceInt| |object| + (CONS '|Matrix| (CONS |D'| NIL)))))))) + ((AND (PAIRP |type|) (EQ (QCAR |type|) '|Expression|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |type|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET D (QCAR |ISTMP#1|)) 'T)))) + (SPADLET |num| (CAR |val'|)) + (SPADLET |den| (CDR |val'|)) + (COND + ((NULL (AND (PAIRP |num|) (EQUAL (QCAR |num|) 0) + (PROGN (SPADLET |num| (QCDR |num|)) 'T))) + NIL) + ((NULL (AND (PAIRP |den|) (EQUAL (QCAR |den|) 0) + (PROGN (SPADLET |den| (QCDR |den|)) 'T))) + NIL) + ('T + (|objNewWrap| (CONS |num| |den|) + (CONS |$QuotientField| (CONS D NIL)))))) + ((AND (PAIRP |type|) + (EQ (QCAR |type|) '|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'| '|failed|) + (NEQUAL (|equiType| (|objMode| |val'|)) + |k|))) + NIL) + (SEQ (EXIT (SPADLET |val'| (|retract| |val'|))))) + (COND ((BOOT-EQUAL |val'| '|failed|) NIL) ('T |val'|))) + ((AND (PAIRP |type|) + (EQ (QCAR |type|) '|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|)) + 'T)))))))) + (|coerceInt| |object| + (CONS '|UnivariateLaurentSeries| + (CONS |coef| (CONS |var| (CONS |cen| NIL)))))) + ((AND (PAIRP |type|) + (EQ (QCAR |type|) '|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|)) + 'T)))))))) + (|coerceInt| |object| + (CONS '|UnivariateTaylorSeries| + (CONS |coef| (CONS |var| (CONS |cen| NIL)))))) + ((AND (PAIRP |type|) + (EQ (QCAR |type|) '|FunctionCalled|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |type|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |name| (QCAR |ISTMP#1|)) + 'T)))) + (COND + ((NULL (SPADLET |m| (|get| |name| '|mode| |$e|))) + NIL) + ((|isPartialMode| |m|) NIL) + ('T (|objNew| |val| |m|)))) + ('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|))))) + (PROG (|$useConvertForCoercions|) + (DECLARE (SPECIAL |$useConvertForCoercions|)) + (RETURN + (PROGN + (SPADLET |$useConvertForCoercions| 'T) + (|coerceOrRetract| T$ |m|))))) ;coerceOrRetract(T,m) == ; (t' := coerceInteractive(T,m)) => t' @@ -766,26 +792,22 @@ The special routines that do the coercions typically involve a "2" ; 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|)))))) + (PROG (|t'| |t| |ans|) + (RETURN + (SEQ (COND + ((SPADLET |t'| (|coerceInteractive| T$ |m|)) |t'|) + ('T (SPADLET |t| T$) (SPADLET |ans| NIL) + (DO () (NIL NIL) + (SEQ (EXIT (COND + (|ans| (RETURN |ans|)) + ('T (SPADLET |t| (|retract| |t|)) + (COND + ((BOOT-EQUAL |t| '|failed|) + (RETURN |ans|)) + ('T + (SPADLET |ans| + (|coerceInteractive| |t| |m|))))))))) + |ans|)))))) ;coerceRetract(object,t2) == ; -- tries to handle cases such as P I -> I @@ -810,36 +832,37 @@ The special routines that do the coercions typically involve a "2" ; 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))))))) + (PROG (|val| |t1| D |fun| |c|) + (DECLARE (SPECIAL |$coerceFailure| |$OutputForm| |$Symbol| + |$Integer|)) + (RETURN + (COND + ((BOOT-EQUAL (SPADLET |val| (|objValUnwrap| |object|)) + '|$fromCoerceable$|) + NIL) + ('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|)) 'T)) + (SPADLET |fun| + (OR (GETL D '|retract|) + (INTERN (STRCONC (MAKESTRING "retract") + (STRINGIMAGE D))))) + (COND + ((|functionp| |fun|) (PUT D '|retract| |fun|) + (SPADLET |c| + (CATCH '|coerceFailure| + (FUNCALL |fun| |object| |t2|))) + (COND ((BOOT-EQUAL |c| |$coerceFailure|) NIL) ('T |c|))) + ('T NIL))) + ('T NIL))))))) ;retractByFunction(object,u) == ; -- tries to retract by using function "retractIfCan" @@ -882,52 +905,55 @@ The special routines that do the coercions typically involve a "2" ; 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'|)) + (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 '|Union| + (CONS |u| (CONS (MAKESTRING "failed") NIL)))) + (SPADLET |funName| '|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 'T) + (|findFunctionInDomain| |funName| |u| + |target| (CONS |t| NIL) (CONS |t| NIL) + NIL 'T))) + (SPADLET |mms| + (|orderMms| |funName| |mms| (CONS |t| NIL) + (CONS |t| NIL) |target|)))) (COND - ((BOOT-EQUAL |u| |u'|) |object'|) - ((QUOTE T) NIL)))))))))) + (|$reportBottomUpFlag| + (|sayFunctionSelectionResult| |funName| (CONS |t| NIL) + |mms|))) + (COND + ((NULL |mms|) NIL) + ('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) + ('T (SPADLET $ |dcVector|) + (SPADLET |object'| + (|coerceUnion2Branch| + (|objNewWrap| (SPADCALL |val| |fun|) + |target|))) + (SPADLET |u'| (|objMode| |object'|)) + (COND ((BOOT-EQUAL |u| |u'|) |object'|) ('T NIL)))))))))) ;--% Coercion utilities ;-- The next function extracts the structural definition of constants @@ -943,41 +969,42 @@ The special routines that do the coercions typically involve a "2" ; 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)))))) + (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|)) + 'T))))))))) + (|member| |type| '(CONST ASCONST))) + 'T) + ((BOOT-EQUAL |key| '|One|) + (|constantInDomain?| (CONS '|1| NIL) |domainForm|)) + ((BOOT-EQUAL |key| '|Zero|) + (|constantInDomain?| (CONS '|0| NIL) |domainForm|)) + ('T NIL)))))) + @ \section{Function getConstantFromDomain} @@ -1003,56 +1030,54 @@ that the domain is not fully formed. In this case we return [[NIL]]. ; 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|))))))))) + (PROG (|opAlist| |key| |entryList| |ISTMP#1| |sig| |ISTMP#2| + |ISTMP#3| |ISTMP#4| |domain|) + (RETURN + (COND + ((|isPartialMode| |domainForm|) NIL) + ('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| '|One|) + (|getConstantFromDomain| (CONS '|1| NIL) |domainForm|)) + ((BOOT-EQUAL |key| '|Zero|) + (|getConstantFromDomain| (CONS '|0| NIL) |domainForm|)) + ('T + (|throwKeyedMsg| 'S2IC0008 + (CONS |form| (CONS |domainForm| NIL)))))) + ('T (SPADLET |domain| (|evalDomain| |domainForm|)) + (SPADCALL (|compiledLookupCheck| |key| |sig| |domain|))))))))) ;domainOne(domain) == getConstantFromDomain('(One),domain) (DEFUN |domainOne| (|domain|) - (|getConstantFromDomain| (QUOTE (|One|)) |domain|)) + (|getConstantFromDomain| '(|One|) |domain|)) ;domainZero(domain) == getConstantFromDomain('(Zero),domain) (DEFUN |domainZero| (|domain|) - (|getConstantFromDomain| (QUOTE (|Zero|)) |domain|)) + (|getConstantFromDomain| '(|Zero|) |domain|)) ;equalOne(object, domain) == ; -- tries using constant One and "=" from domain @@ -1060,8 +1085,8 @@ that the domain is not fully formed. In this case we return [[NIL]]. ; algEqual(object, getConstantFromDomain('(One),domain), domain) (DEFUN |equalOne| (|object| |domain|) - (|algEqual| |object| - (|getConstantFromDomain| (QUOTE (|One|)) |domain|) |domain|)) + (|algEqual| |object| (|getConstantFromDomain| '(|One|) |domain|) + |domain|)) ;equalZero(object, domain) == ; -- tries using constant Zero and "=" from domain @@ -1069,8 +1094,8 @@ that the domain is not fully formed. In this case we return [[NIL]]. ; algEqual(object, getConstantFromDomain('(Zero),domain), domain) (DEFUN |equalZero| (|object| |domain|) - (|algEqual| |object| - (|getConstantFromDomain| (QUOTE (|Zero|)) |domain|) |domain|)) + (|algEqual| |object| (|getConstantFromDomain| '(|Zero|) |domain|) + |domain|)) ;algEqual(object1, object2, domain) == ; -- sees if 2 objects of the same domain are equal by using the @@ -1081,15 +1106,15 @@ that the domain is not fully formed. In this case we return [[NIL]]. ; 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|))))) + (PROG (|eqfunc|) + (DECLARE (SPECIAL |$Boolean|)) + (RETURN + (PROGN + (SPADLET |eqfunc| + (|compiledLookupCheck| '= + (CONS |$Boolean| (CONS '$ (CONS '$ NIL))) + (|evalDomain| |domain|))) + (SPADCALL |object1| |object2| |eqfunc|))))) @ \begin{verbatim} @@ -1180,148 +1205,137 @@ Interpreter Coercion Query Functions ; 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|))) + (PROG (|v| |nt1| |nt2| |s1| |s2| |ISTMP#1| S |isRingT2| |LETTMP#1| + |arg| |t| |ans|) + (DECLARE (SPECIAL |$Integer| |$OutputForm| |$String|)) + (RETURN (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|))))))))))))))) + ((BOOT-EQUAL |t1| |t2|) 'T) + ('T + (OR (|absolutelyCanCoerceByCheating| |t1| |t2|) + (BOOT-EQUAL |t1| '(|None|)) (BOOT-EQUAL |t2| '(|Any|)) + (COND + ((|member| |t1| + '((|Mode|) (|Domain|) (|SubDomain| (|Domain|)))) + (COND ((BOOT-EQUAL |t2| |$OutputForm|) 'T) ('T NIL))) + ((OR (AND (PAIRP |t1|) (EQ (QCAR |t1|) '|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|) '|Variable|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t2|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (EQUAL (QCAR |ISTMP#1|) |t1|))))) + 'T) + ((STRINGP |t1|) + (COND + ((BOOT-EQUAL |t2| |$String|) 'T) + ((BOOT-EQUAL |t2| |$OutputForm|) 'T) + ((AND (PAIRP |t2|) (EQ (QCAR |t2|) '|Union|)) + (|canCoerceUnion| |t1| |t2|)) + ((AND (PAIRP |t2|) (EQ (QCAR |t2|) '|Variable|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t2|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |v| (QCAR |ISTMP#1|)) + 'T))) + (BOOT-EQUAL |t1| (PNAME |v|))) + 'T) + ('T NIL))) + ((STRINGP |t2|) + (COND + ((AND (PAIRP |t1|) (EQ (QCAR |t1|) '|Variable|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t1|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |v| (QCAR |ISTMP#1|)) + 'T))) + (BOOT-EQUAL |t2| (PNAME |v|))) + 'T) + ('T NIL))) + ((OR (ATOM |t1|) (ATOM |t2|)) NIL) + ((NULL (|isValidType| |t2|)) NIL) + ((|absolutelyCannotCoerce| |t1| |t2|) NIL) + ('T (SPADLET |nt1| (CAR |t1|)) + (SPADLET |nt2| (CAR |t2|)) + (COND + ((EQ |nt1| '|Mapping|) (EQ |nt2| '|Any|)) + ((EQ |nt2| '|Mapping|) + (COND + ((OR (EQ |nt1| '|Variable|) + (EQ |nt1| '|FunctionCalled|)) + (|canCoerceExplicit2Mapping| |t1| |t2|)) + ('T NIL))) + ((OR (EQ |nt1| '|Union|) (EQ |nt2| '|Union|)) + (|canCoerceUnion| |t1| |t2|)) + ((AND (PAIRP |t1|) (EQ (QCAR |t1|) '|Segment|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t1|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |s1| (QCAR |ISTMP#1|)) + 'T))) + (PAIRP |t2|) + (EQ (QCAR |t2|) '|UniversalSegment|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t2|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |s2| (QCAR |ISTMP#1|)) + 'T))) + (OR (|isEqualOrSubDomain| |s1| |s2|) + (|canCoerce| |s1| |s2|))) + 'T) + ((AND (PAIRP |t1|) (EQ (QCAR |t1|) '|Tuple|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t1|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET S (QCAR |ISTMP#1|)) 'T))) + (NEQUAL |t2| '(|OutputForm|))) + (|canCoerce| (CONS '|List| (CONS S NIL)) |t2|)) + ('T + (SPADLET |isRingT2| (|ofCategory| |t2| '(|Ring|))) + (COND + ((AND |isRingT2| + (|isEqualOrSubDomain| |t1| |$Integer|)) + 'T) + ((NEQUAL (SPADLET |ans| + (|canCoerceTopMatching| |t1| + |t2| |nt1| |nt2|)) + '|maybe|) + |ans|) + ((BOOT-EQUAL |t2| |$Integer|) + (|canCoerceLocal| |t1| |t2|)) + ('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|) + 'T)))))) + (OR |ans| + (AND (|member| |t1| + '((|PositiveInteger|) + (|NonNegativeInteger|))) + (|canCoerce| |$Integer| |t2|))))))))))))))) ;canCoerceFrom0(t1,t2) == ;-- top level test for coercion, which transfers all RN, RF and RR into @@ -1343,32 +1357,34 @@ Interpreter Coercion Query Functions ; 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|))) + (PROG (|s1| |s2| |q|) + (DECLARE (SPECIAL |$Integer| |$RationalNumber| |$OutputForm|)) + (RETURN (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|)))) + (|startTimingProcess| '|querycoerce|) + (SPADLET |q| + (OR (|isEqualOrSubDomain| |t1| |t2|) + (BOOT-EQUAL |t1| '(|None|)) + (BOOT-EQUAL |t2| '(|Any|)) + (PROGN + (COND + ((BOOT-EQUAL |t2| |$OutputForm|) + (SPADLET |s1| |t1|) (SPADLET |s2| |t2|)) + ('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) + ('T + (OR (|canCoerce| |t1| |t2|) + (|canCoerce| |s1| |s2|))))) + ('T (|canCoerce| |s1| |s2|)))))) + (|stopTimingProcess| '|querycoerce|) + |q|)))) ;isSubTowerOf(t1,t2) == ; -- assumes RF and RN stuff has been expanded @@ -1378,12 +1394,12 @@ Interpreter Coercion Query Functions ; 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|)))))) + (PROG (|u|) + (RETURN + (COND + ((|isEqualOrSubDomain| |t1| |t2|) 'T) + ((NULL (SPADLET |u| (|underDomainOf| |t2|))) NIL) + ('T (|isSubTowerOf| |t1| |u|)))))) ;canCoerceTopMatching(t1,t2,tt1,tt2) == ; -- returns true, nil or maybe @@ -1402,34 +1418,30 @@ Interpreter Coercion Query Functions ; 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|)) + (PROG (|doms| |u2| |u1|) + (DECLARE (SPECIAL |$multivariateDomains| |$univariateDomains|)) + (RETURN + (COND + ((NULL (EQ |tt1| |tt2|)) '|maybe|) + ('T + (SPADLET |doms| + '(|Polynomial| |List| |Matrix| |FiniteSet| |Vector| + |Stream| |Gaussian|)) (COND - ((EQL 1 (|#| |u1|)) NIL) - ((NEQUAL (CAR |u1|) (CAR |u2|)) (QUOTE |maybe|)) - ((QUOTE T) - (|canCoerce| - (|underDomainOf| |t1|) - (|underDomainOf| |t2|))))))))))))) + ((MEMQ |tt1| |doms|) (|canCoerce| (CADR |t1|) (CADR |t2|))) + ((NULL (OR (MEMQ |tt1| |$univariateDomains|) + (MEMQ |tt2| |$multivariateDomains|))) + '|maybe|) + ('T (SPADLET |u2| (|deconstructT| |t2|)) + (COND + ((EQL 1 (|#| |u2|)) NIL) + ('T (SPADLET |u1| (|deconstructT| |t1|)) + (COND + ((EQL 1 (|#| |u1|)) NIL) + ((NEQUAL (CAR |u1|) (CAR |u2|)) '|maybe|) + ('T + (|canCoerce| (|underDomainOf| |t1|) + (|underDomainOf| |t2|))))))))))))) ;canCoerceExplicit2Mapping(t1,t is ['Mapping,target,:argl]) == ; -- determines if there a mapping called var with the given args @@ -1457,96 +1469,100 @@ Interpreter Coercion Query Functions ; 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))))) + (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 - ((BOOT-EQUAL |targ| |target|) (QUOTE T)) - ((QUOTE T) NIL))) - ((QUOTE T) NIL))))) - ((QUOTE T) NIL))) - ((QUOTE T) NIL))))))) + ((AND (PAIRP |t1|) (EQ (QCAR |t1|) '|Variable|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t1|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |var| (QCAR |ISTMP#1|)) + 'T)))) + (COND + ((NULL (SPADLET |mms| + (|selectMms1| |var| |target| |argl| + (PROG (G166754) + (SPADLET G166754 NIL) + (RETURN + (DO + ((G166759 |argl| + (CDR G166759)) + (|a| NIL)) + ((OR (ATOM G166759) + (PROGN + (SETQ |a| + (CAR G166759)) + NIL)) + (NREVERSE0 G166754)) + (SEQ + (EXIT + (SETQ G166754 + (CONS NIL G166754))))))) + 'T))) + NIL) + ('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|)) + 'T)))) + (COND + ((BOOT-EQUAL |targ| |target|) 'T) + ('T NIL))) + ('T NIL))))) + ((AND (PAIRP |t1|) (EQ (QCAR |t1|) '|FunctionCalled|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t1|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |fun| (QCAR |ISTMP#1|)) + 'T)))) + (SPADLET |funNode| (|mkAtreeNode| |fun|)) + (|transferPropsToNode| |fun| |funNode|) + (SPADLET |mms| + (CATCH '|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|) + '|interpOnly|)))))) + NIL) + ('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|)) + 'T)))) + (COND + ((BOOT-EQUAL |targ| |target|) 'T) + ('T NIL))) + ('T NIL))))) + ('T NIL))) + ('T NIL))))))) ;canCoerceUnion(t1,t2) == ; -- sees if one can coerce to or from a Union Domain @@ -1574,120 +1590,161 @@ Interpreter Coercion Query Functions ; '"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)))))))))) + (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|) '|Union|) + (PROGN (SPADLET |uds1| (QCDR |t1|)) 'T))) + (SPADLET |unionDoms1| + (COND + ((AND |uds1| + (PROGN + (SPADLET |ISTMP#1| (CAR |uds1|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|:|)))) + (PROG (G166818) + (SPADLET G166818 NIL) + (RETURN + (DO ((G166824 |uds1| (CDR G166824)) + (G166791 NIL)) + ((OR (ATOM G166824) + (PROGN + (SETQ G166791 + (CAR G166824)) + NIL) + (PROGN + (PROGN + (SPADLET |t| + (CADDR G166791)) + G166791) + NIL)) + (NREVERSE0 G166818)) + (SEQ (EXIT + (SETQ G166818 + (CONS |t| G166818)))))))) + ('T |uds1|))))) + (COND + ((SPADLET |isUnion2| + (AND (PAIRP |t2|) (EQ (QCAR |t2|) '|Union|) + (PROGN (SPADLET |uds2| (QCDR |t2|)) 'T))) + (SPADLET |unionDoms2| + (COND + ((AND |uds2| + (PROGN + (SPADLET |ISTMP#1| (CAR |uds2|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|:|)))) + (PROG (G166836) + (SPADLET G166836 NIL) + (RETURN + (DO ((G166842 |uds2| (CDR G166842)) + (G166797 NIL)) + ((OR (ATOM G166842) + (PROGN + (SETQ G166797 + (CAR G166842)) + NIL) + (PROGN + (PROGN + (SPADLET |t| + (CADDR G166797)) + G166797) + NIL)) + (NREVERSE0 G166836)) + (SEQ (EXIT + (SETQ G166836 + (CONS |t| G166836)))))))) + ('T |uds2|))))) + (COND + (|isUnion2| + (COND + ((|member| |t1| |unionDoms2|) 'T) + (|isUnion1| + (PROG (G166849) + (SPADLET G166849 'T) + (RETURN + (DO ((G166855 NIL (NULL G166849)) + (G166856 |unionDoms1| + (CDR G166856)) + (|ud1| NIL)) + ((OR G166855 (ATOM G166856) + (PROGN + (SETQ |ud1| (CAR G166856)) + NIL)) + G166849) + (SEQ (EXIT + (SETQ G166849 + (AND G166849 + (PROG (G166863) + (SPADLET G166863 NIL) + (RETURN + (DO + ((G166869 NIL G166863) + (G166870 |unionDoms2| + (CDR G166870)) + (|ud2| NIL)) + ((OR G166869 + (ATOM G166870) + (PROGN + (SETQ |ud2| + (CAR G166870)) + NIL)) + G166863) + (SEQ + (EXIT + (SETQ G166863 + (OR G166863 + (|canCoerce| |ud1| + |ud2|)))))))))))))))) + ('T + (PROG (G166877) + (SPADLET G166877 NIL) + (RETURN + (DO ((G166883 NIL G166877) + (G166884 |unionDoms2| (CDR G166884)) + (|ud| NIL)) + ((OR G166883 (ATOM G166884) + (PROGN + (SETQ |ud| (CAR G166884)) + NIL)) + G166877) + (SEQ (EXIT (SETQ G166877 + (OR G166877 + (|canCoerce| |t1| |ud|))))))))))) + ((AND (PAIRP |t1|) (EQ (QCAR |t1|) '|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|) '"failed"))))) + (BOOT-EQUAL |t2| |d1|)) + 'T) + (|isUnion1| + (PROG (G166891) + (SPADLET G166891 'T) + (RETURN + (DO ((G166897 NIL (NULL G166891)) + (G166898 |unionDoms1| (CDR G166898)) + (|ud| NIL)) + ((OR G166897 (ATOM G166898) + (PROGN + (SETQ |ud| (CAR G166898)) + NIL)) + G166891) + (SEQ (EXIT (SETQ G166891 + (AND G166891 + (|canCoerce| |ud| |t2|))))))))) + ('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 @@ -1712,43 +1769,39 @@ Interpreter Coercion Query Functions ; 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|)) + (PROG (|top| |u1| |u2| |know|) + (RETURN + (PROGN + (SPADLET |u2| (|deconstructT| |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|))))))))))))) + ((EQL 1 (|#| |u2|)) NIL) + ('T (SPADLET |u1| (|deconstructT| |t1|)) + (COND + ((EQL 1 (|#| |u1|)) NIL) + ((NEQUAL (CAR |u1|) (CAR |u2|)) NIL) + ('T (SPADLET |top| (CAAR |u1|)) + (SPADLET |u1| (|underDomainOf| |t1|)) + (SPADLET |u2| (|underDomainOf| |t2|)) + (COND + ((|absolutelyCannotCoerce| |u1| |u2|) NIL) + ('T + (SPADLET |know| + '(|List| |Vector| |Segment| |Stream| + |UniversalSegment| |Array| + |Polynomial| |UnivariatePolynomial| + |SquareMatrix| |Matrix|)) + (COND + ((|member| |top| |know|) (|canCoerce| |u1| |u2|)) + ((NULL (|selectMms1| '|map| |t2| + (CONS (CONS '|Mapping| + (CONS |u2| (CONS |u1| NIL))) + (CONS |t1| NIL)) + (CONS (CONS '|Mapping| + (CONS |u2| (CONS |u1| NIL))) + (CONS |u1| NIL)) + NIL)) + NIL) + ('T (|canCoerce| |u1| |u2|))))))))))))) ;canCoerceTower(t1,t2) == ;-- tries to find a coercion between top level t2 and somewhere inside t1 @@ -1775,60 +1828,76 @@ Interpreter Coercion Query Functions ; 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|)))))))) + (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 ((G166978 NIL (OR |x| (NULL |arg|)))) + (G166978 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|))))) + ('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 @@ -1842,40 +1911,39 @@ Interpreter Coercion Query Functions ; 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| + (PROG (|p| |ISTMP#1| |ISTMP#2| |tag| |ISTMP#3| |fun| |v|) + (DECLARE (SPECIAL |$coerceFailure| |$CoerceTable|)) + (RETURN (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|))))))) + (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|)) + 'T)))))))) + (COND + ((BOOT-EQUAL |tag| '|partial|) NIL) + ((BOOT-EQUAL |tag| '|total|) 'T) + ('T + (OR (AND (|functionp| |fun|) + (SPADLET |v| + (CATCH '|coerceFailure| + (FUNCALL |fun| '|$fromCoerceable$| + |t1| |t2|))) + (NEQUAL |v| |$coerceFailure|)) + (|canCoerceByFunction| |t1| |t2|))))) + ('T (|canCoerceByFunction| |t1| |t2|))))))) ;canCoerceCommute(t1,t2) == ;-- THIS IS OUT-MODED AND WILL GO AWAY SOON RSS 2-87 @@ -1887,36 +1955,35 @@ Interpreter Coercion Query Functions ; 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))))))))))))) + (PROG (|l| |p| |ISTMP#1| |ISTMP#2| |ISTMP#3|) + (DECLARE (SPECIAL |$CommuteTable| |$QuotientField|)) + (RETURN + (COND + ((AND (|member| (CAR |t1|) + (SPADLET |l| + (CONS |$QuotientField| + (CONS '|Gaussian| NIL)))) + (|member| (CAR |t2|) |l|)) + 'T) + ('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|) '|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|)) + (|coerceIntCommute| (|objNewWrap| '|$fromCoerceable$| |t1|) |t2|)) ;canCoercePermute(t1,t2) == ; -- try to generate a sequence of transpositions that will convert @@ -1937,40 +2004,45 @@ Interpreter Coercion Query Functions ; 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|)))))))) + (PROG (|towers| |ok|) + (RETURN + (SEQ (COND + ((|member| |t2| '((|Integer|) (|OutputForm|))) NIL) + ('T + (SPADLET |towers| (|computeTTTranspositions| |t1| |t2|)) + (COND + ((OR (NULL |towers|) (NULL (CDR |towers|))) NIL) + ((AND (NULL (CDDR |towers|)) + (BOOT-EQUAL |t2| (CADR |towers|))) + NIL) + ('T (SPADLET |ok| 'T) + (DO ((G167071 (CDR |towers|) (CDR G167071)) + (|t| NIL)) + ((OR (ATOM G167071) + (PROGN (SETQ |t| (CAR G167071)) NIL) + (NULL |ok|)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |ok| (|canCoerce| |t1| |t|)) + (COND + (|ok| (SPADLET |t1| |t|)) + ('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|))))) + (DECLARE (SPECIAL |$useConvertForCoercions|)) + (COND + ((NULL |$useConvertForCoercions|) NIL) + ('T (|canCoerceByFunction1| |m1| |m2| '|convert|)))) ;canCoerceByFunction(m1,m2) == canCoerceByFunction1(m1,m2,'coerce) (DEFUN |canCoerceByFunction| (|m1| |m2|) - (|canCoerceByFunction1| |m1| |m2| (QUOTE |coerce|))) + (|canCoerceByFunction1| |m1| |m2| '|coerce|)) ;canCoerceByFunction1(m1,m2,fun) == ; -- calls selectMms with $Coerce=NIL and tests for required target=m2 @@ -1990,58 +2062,83 @@ Interpreter Coercion Query Functions ; 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|))))) + (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 ((G167106 |l1| (CDR G167106)) (|t1| NIL)) + ((OR (ATOM G167106) + (PROGN (SETQ |t1| (CAR G167106)) NIL) + (NULL (NULL |ans|))) + NIL) + (SEQ (EXIT (DO ((G167123 |l2| (CDR G167123)) + (|t2| NIL)) + ((OR (ATOM G167123) + (PROGN + (SETQ |t2| (CAR G167123)) + NIL) + (NULL (NULL |ans|))) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |l| + (|selectMms1| |fun| |t2| + (CONS |t1| NIL) + (CONS |t1| NIL) NIL)) + (SPADLET |ans| + (AND + (PROG (G167135) + (SPADLET G167135 NIL) + (RETURN + (DO + ((G167141 |l| + (CDR G167141)) + (|x| NIL)) + ((OR (ATOM G167141) + (PROGN + (SETQ |x| + (CAR G167141)) + NIL)) + (NREVERSE0 G167135)) + (SEQ + (EXIT + (COND + ((AND (PAIRP |x|) + (PROGN + (SPADLET |sig| + (QCAR |x|)) + '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|) + '|TypeEquivalence|))))) + (SETQ G167135 + (CONS |x| + G167135))))))))) + 'T))))))))) + |ans|))))) + ;absolutelyCanCoerceByCheating(t1,t2) == ; -- this typically involves subdomains and towers where the only @@ -2059,69 +2156,66 @@ Interpreter Coercion Query Functions ; "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|)))))))))))))))) + (PROG (|tl1| |u1| |LETTMP#1| |tl2| |u2|) + (DECLARE (SPECIAL |$Integer|)) + (RETURN + (SEQ (COND + ((|isEqualOrSubDomain| |t1| |t2|) 'T) + ((AND (|typeIsASmallInteger| |t1|) + (BOOT-EQUAL |t2| |$Integer|)) + 'T) + ((OR (ATOM |t1|) (ATOM |t2|)) NIL) + ('T (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| '(|Stream|)) + (BOOT-EQUAL |tl2| '(|InfiniteTuple|))) + (COND + ((NEQUAL (|#| |u1|) (|#| |u2|)) NIL) + ('T + (PROG (G167180) + (SPADLET G167180 'T) + (RETURN + (DO ((G167187 NIL (NULL G167180)) + (G167188 |u1| (CDR G167188)) + (|x1| NIL) + (G167189 |u2| (CDR G167189)) + (|x2| NIL)) + ((OR G167187 (ATOM G167188) + (PROGN + (SETQ |x1| (CAR G167188)) + NIL) + (ATOM G167189) + (PROGN + (SETQ |x2| (CAR G167189)) + NIL)) + G167180) + (SEQ (EXIT (SETQ G167180 + (AND G167180 + (|absolutelyCanCoerceByCheating| + |x1| |x2|))))))))))) + ((NEQUAL |tl1| |tl2|) NIL) + ((NEQUAL (|#| |u1|) (|#| |u2|)) NIL) + ('T + (PROG (G167199) + (SPADLET G167199 'T) + (RETURN + (DO ((G167206 NIL (NULL G167199)) + (G167207 |u1| (CDR G167207)) (|x1| NIL) + (G167208 |u2| (CDR G167208)) (|x2| NIL)) + ((OR G167206 (ATOM G167207) + (PROGN (SETQ |x1| (CAR G167207)) NIL) + (ATOM G167208) + (PROGN (SETQ |x2| (CAR G167208)) NIL)) + G167199) + (SEQ (EXIT (SETQ G167199 + (AND G167199 + (|absolutelyCanCoerceByCheating| + |x1| |x2|)))))))))))))))) ;absolutelyCannotCoerce(t1,t2) == ; -- response of true means "definitely cannot coerce" @@ -2166,74 +2260,78 @@ Interpreter Coercion Query Functions ; 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|))) + (PROG (|n1| |n2| QFI |int2| |scalars| |num2| |isVar1| |miscpols| + |aggs| |u1| |u2| |algs| |nonpols| |v2| |v1|) + (DECLARE (SPECIAL |$multivariateDomains| |$univariateDomains| + |$Integer| |$QuotientField|)) + (RETURN + (COND + ((OR (ATOM |t1|) (ATOM |t2|)) NIL) + ((BOOT-EQUAL |t2| '(|None|)) 'T) + ('T (SPADLET |n1| (CAR |t1|)) (SPADLET |n2| (CAR |t2|)) + (SPADLET QFI (CONS |$QuotientField| (CONS |$Integer| NIL))) + (SPADLET |int2| (|isEqualOrSubDomain| |t2| |$Integer|)) + (SPADLET |scalars| + '(|BigFloat| |NewFloat| |Float| |DoubleFloat| + |RationalNumber|)) (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|)) + ((AND (MEMQ |n1| |scalars|) |int2|) 'T) + ((AND (BOOT-EQUAL |t1| QFI) |int2|) 'T) + ('T + (SPADLET |num2| + (OR |int2| (MEMQ |n2| |scalars|) + (BOOT-EQUAL |t2| QFI))) + (SPADLET |isVar1| (MEMQ |n1| '(|Variable| |Symbol|))) + (COND + ((AND |num2| |isVar1|) 'T) + ((AND |num2| (MEMQ |n1| |$univariateDomains|)) 'T) + ((AND |num2| (MEMQ |n1| |$multivariateDomains|)) 'T) + ('T + (SPADLET |miscpols| + '(|Polynomial| |ElementaryFunction| + |SimpleAlgebraicExtension|)) (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|)))))))))))))))))))) + ((AND |num2| (MEMQ |n1| |miscpols|)) 'T) + ('T + (SPADLET |aggs| + '(|Matrix| |List| |Vector| |Stream| |Array| + |RectangularMatrix| |FiniteSet|)) + (SPADLET |u1| (|underDomainOf| |t1|)) + (SPADLET |u2| (|underDomainOf| |t2|)) + (COND + ((AND (MEMQ |n1| |aggs|) (BOOT-EQUAL |u1| |t2|)) + 'T) + ((AND (MEMQ |n2| |aggs|) (BOOT-EQUAL |u2| |t1|)) + 'T) + ('T + (SPADLET |algs| + '(|SquareMatrix| |Gaussian| + |RectangularMatrix| |Quaternion|)) + (SPADLET |nonpols| (APPEND |aggs| |algs|)) + (COND + ((AND |num2| (MEMQ |n1| |nonpols|)) 'T) + ((AND |isVar1| (MEMQ |n2| |nonpols|) + (|absolutelyCannotCoerce| |t1| |u2|)) + 'T) + ((AND (OR (MEMQ |n1| |scalars|) + (BOOT-EQUAL |t1| QFI)) + (BOOT-EQUAL |t2| + '(|Polynomial| (|Integer|)))) + 'T) + ('T (SPADLET |v2| (|deconstructT| |t2|)) + (COND + ((EQL 1 (|#| |v2|)) NIL) + ('T (SPADLET |v1| (|deconstructT| |t1|)) + (COND + ((EQL 1 (|#| |v1|)) NIL) + ((NEQUAL (CAR |v1|) (CAR |v2|)) NIL) + ('T (|absolutelyCannotCoerce| |u1| |u2|)))))))))))))))))))) ;typeIsASmallInteger x == (x = $SingleInteger) -(DEFUN |typeIsASmallInteger| (|x|) (BOOT-EQUAL |x| |$SingleInteger|)) +(DEFUN |typeIsASmallInteger| (|x|) + (DECLARE (SPECIAL |$SingleInteger|)) + (BOOT-EQUAL |x| |$SingleInteger|)) ;--% Interpreter Coercion Functions ;coerceInteractive(triple,t2) == @@ -2266,66 +2364,68 @@ Interpreter Coercion Query Functions ; 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|)))) + (PROG (|$insideCoerceInteractive| |t1| |val| |x| |ISTMP#2| |expr2| + |ISTMP#1| |var| |result|) + (DECLARE (SPECIAL |$insideCoerceInteractive| |$OutputForm| + |$mapName| |$compilingMap| |$NoValueMode| + |$EmptyMode|)) + (RETURN + (PROGN + (SPADLET |t1| (|objMode| |triple|)) + (SPADLET |val| (|objVal| |triple|)) (COND - (|expr2| (|stopTimingProcess| (QUOTE |print|))) - ((QUOTE T) (|stopTimingProcess| (QUOTE |coercion|)))) - |result|)))))))) + ((OR (NULL |t2|) (BOOT-EQUAL |t2| |$EmptyMode|)) NIL) + ((BOOT-EQUAL |t2| |t1|) |triple|) + ((BOOT-EQUAL |t2| '|$NoValueMode|) (|objNew| |val| |t2|)) + ('T + (COND + ((AND (PAIRP |t2|) (EQ (QCAR |t2|) '|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| + '((|Category|) (|Mode|) (|Domain|) + (|SubDomain| (|Domain|)))) + (COND + ((BOOT-EQUAL |t2| |$OutputForm|) (|objNew| |val| |t2|)) + ('T NIL))) + ((BOOT-EQUAL |t1| '|$NoValueMode|) + (COND + (|$compilingMap| (|clearDependentMaps| |$mapName| NIL))) + (|throwKeyedMsg| 'S2IC0009 + (CONS |t2| (CONS |$mapName| NIL)))) + ('T (SPADLET |$insideCoerceInteractive| 'T) + (SPADLET |expr2| (BOOT-EQUAL |t2| |$OutputForm|)) + (COND + (|expr2| (|startTimingProcess| '|print|)) + ('T (|startTimingProcess| '|coercion|))) + (SPADLET |result| + (COND + ((AND |expr2| (BOOT-EQUAL |t1| |val|)) + (|objNew| |val| |$OutputForm|)) + ((AND |expr2| (PAIRP |t1|) + (EQ (QCAR |t1|) '|Variable|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t1|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |var| + (QCAR |ISTMP#1|)) + 'T)))) + (|objNewWrap| |var| |$OutputForm|)) + ('T (|coerceInt0| |triple| |t2|)))) + (COND + (|expr2| (|stopTimingProcess| '|print|)) + ('T (|stopTimingProcess| '|coercion|))) + |result|)))))))) ;coerceInt0(triple,t2) == ; -- top level interactive coercion, which transfers all RN, RF and RR @@ -2358,48 +2458,50 @@ Interpreter Coercion Query Functions ; 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|)))) + (PROG (|val| |t1| |s1| |s2| |LETTMP#1| |t1'| |val'| |ans| |x|) + (DECLARE (SPECIAL |$OutputForm| |$Any| |$genValue|)) + (RETURN + (PROGN + (SPADLET |val| (|objVal| |triple|)) + (SPADLET |t1| (|objMode| |triple|)) (COND - ((SPADLET |x| (|coerceInt| |triple| |s2|)) - (COND ((EQ |s2| |t2|) |x|) ((QUOTE T) (|objSetMode| |x| |t2|) |x|))) - ((QUOTE T) NIL)))))))))) + ((BOOT-EQUAL |val| '|$fromCoerceable$|) + (|canCoerceFrom| |t1| |t2|)) + ((BOOT-EQUAL |t1| |t2|) |triple|) + ('T + (COND + ((BOOT-EQUAL |t2| |$OutputForm|) (SPADLET |s1| |t1|) + (SPADLET |s2| |t2|)) + ('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|) '|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|) + ('T + (COND + ((NULL (EQ |s1| |t1|)) + (SPADLET |triple| (|objNew| |val| |s1|)))) + (COND + ((SPADLET |x| (|coerceInt| |triple| |s2|)) + (COND + ((EQ |s2| |t2|) |x|) + ('T (|objSetMode| |x| |t2|) |x|))) + ('T NIL)))))))))) ;coerceInt(triple, t2) == ; val := coerceInt1(triple, t2) => val @@ -2411,19 +2513,19 @@ Interpreter Coercion Query Functions ; 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))))))) + (PROG (|val| |t1| |newMode| |newVal|) + (RETURN + (COND + ((SPADLET |val| (|coerceInt1| |triple| |t2|)) |val|) + ('T (SPADLET |t1| (|objMode| |triple|)) + (COND + ((AND (PAIRP |t1|) (EQ (QCAR |t1|) '|Variable|)) + (SPADLET |newMode| + (|getMinimalVarMode| + (|unwrap| (|objVal| |triple|)) NIL)) + (SPADLET |newVal| (|coerceInt| |triple| |newMode|)) + (|coerceInt| |newVal| |t2|)) + ('T NIL))))))) ;coerceInt1(triple,t2) == ; -- general interactive coercion @@ -2529,397 +2631,461 @@ Interpreter Coercion Query Functions ; 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|) + (PROG (|$useCoerceOrCroak| |t1| |sintp| |t1'| |val'| S |v| |body| + |vars| |tree| |fun| |freeFun| |val| |target| |margl| + |symNode| |mms| |dc| |targ| |argl| |ml| |ml1| |ISTMP#2| + |oldName| |intName| |ISTMP#1| |sym| |t3| |triple'| + |LETTMP#1| |arg| |t| |ans|) + (DECLARE (SPECIAL |$useCoerceOrCroak| |$Integer| |$QuotientField| + |$e| |$genValue| |$Symbol| |$AnonymousFunction| + |$OutputForm| |$String| |$Any| |$Void| + |$NonNegativeInteger| |$PositiveInteger| + |$EmptyMode|)) + (RETURN + (SEQ (PROGN + (SPADLET |$useCoerceOrCroak| 'T) (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 + ((BOOT-EQUAL |t2| |$EmptyMode|) NIL) + ('T (SPADLET |t1| (|objMode| |triple|)) (COND - ((NULL - (SPADLET |mms| - (|selectMms1| |sym| |target| |margl| |margl| NIL))) - (EXIT + ((BOOT-EQUAL |t1| |t2|) |triple|) + ('T (SPADLET |val| (|objVal| |triple|)) (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|) + ((|absolutelyCanCoerceByCheating| |t1| |t2|) + (|objNew| |val| |t2|)) + ((|isSubDomain| |t2| |t1|) + (|coerceSubDomain| |val| |t1| |t2|)) + ('T + (COND + ((|typeIsASmallInteger| |t1|) + (COND + ((OR (BOOT-EQUAL |t2| |$Integer|) + (|typeIsASmallInteger| |t2|)) + (RETURN (|objNew| |val| |t2|))) + ('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|)) + ('T NIL))) + ((BOOT-EQUAL |t2| |$Void|) + (|objNew| (|voidValue|) |$Void|)) + ((BOOT-EQUAL |t2| |$Any|) + (|objNewWrap| (CONS |t1| (|unwrap| |val|)) + '(|Any|))) + ((AND (BOOT-EQUAL |t1| |$Any|) + (NEQUAL |t2| |$OutputForm|) (PROGN - (SPADLET |ISTMP#1| (QCAR |mm|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ml1| (QCDR |ISTMP#1|)) - (QUOTE T)))) + (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|) '|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|) '|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|) '|Variable|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t1|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |v| (QCAR |ISTMP#1|)) + 'T))) + (BOOT-EQUAL |t2| (PNAME |v|))) + (|objNewWrap| |t2| |t2|)) + ('T (SPADLET |val'| (|unwrap| |val|)) + (COND + ((AND (BOOT-EQUAL |t2| |val'|) + (OR (BOOT-EQUAL |val'| |t1|) + (BOOT-EQUAL |t1| |$String|))) + (|objNew| |val| |t2|)) + ('T NIL))))) + ((AND (PAIRP |t1|) (EQ (QCAR |t1|) '|Tuple|) (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|))))))))))))))))) + (SPADLET |ISTMP#1| (QCDR |t1|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET S (QCAR |ISTMP#1|)) + 'T)))) + (|coerceInt1| + (|objNewWrap| + (|asTupleAsList| (|unwrap| |val|)) + (CONS '|List| (CONS S NIL))) + |t2|)) + ((AND (PAIRP |t1|) (EQ (QCAR |t1|) '|Union|)) + (|coerceIntFromUnion| |triple| |t2|)) + ((AND (PAIRP |t2|) (EQ (QCAR |t2|) '|Union|)) + (|coerceInt2Union| |triple| |t2|)) + ((AND (STRINGP |t1|) + (BOOT-EQUAL |t2| |$String|)) + (|objNew| |val| |$String|)) + ((AND (STRINGP |t1|) (PAIRP |t2|) + (EQ (QCAR |t2|) '|Variable|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t2|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |v| (QCAR |ISTMP#1|)) + 'T)))) + (COND + ((BOOT-EQUAL |t1| (PNAME |v|)) + (|objNewWrap| |v| |t2|)) + ('T NIL))) + ((AND (STRINGP |t1|) + (BOOT-EQUAL |t1| (|unwrap| |val|))) + (COND + ((BOOT-EQUAL |t2| |$OutputForm|) + (|objNew| |t1| |$OutputForm|)) + ('T NIL))) + ((ATOM |t1|) NIL) + ('T + (COND + ((AND (BOOT-EQUAL |t1| |$AnonymousFunction|) + (PAIRP |t2|) + (EQ (QCAR |t2|) '|Mapping|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t2|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |target| + (QCAR |ISTMP#1|)) + (SPADLET |margl| + (QCDR |ISTMP#1|)) + '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|) '|Tuple|)) + (CDR |vars|)) + ('T |vars|))) + (COND + ((NEQUAL (|#| |margl|) (|#| |vars|)) + '|continue|) + ('T + (SPADLET |tree| + (|mkAtree| + (CONS 'ADEF + (CONS |vars| + (CONS + (CONS |target| |margl|) + (CONS + (PROG (G167455) + (SPADLET G167455 NIL) + (RETURN + (DO + ((G167460 + (CDR |t2|) + (CDR G167460)) + (|x| NIL)) + ((OR (ATOM G167460) + (PROGN + (SETQ |x| + (CAR G167460)) + NIL)) + (NREVERSE0 + G167455)) + (SEQ + (EXIT + (SETQ G167455 + (CONS NIL + G167455))))))) + |body|)))))) + (COND + ((BOOT-EQUAL + (CATCH '|coerceOrCroaker| + (|bottomUp| |tree|)) + '|croaked|) + NIL) + ('T (RETURN (|getValue| |tree|)))))))) + (COND + ((AND (BOOT-EQUAL |t1| |$Symbol|) + (PAIRP |t2|) + (EQ (QCAR |t2|) '|Mapping|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t2|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |target| + (QCAR |ISTMP#1|)) + (SPADLET |margl| + (QCDR |ISTMP#1|)) + 'T)))) + (COND + ((NULL (SPADLET |mms| + (|selectMms1| (|unwrap| |val|) + NIL |margl| |margl| |target|))) + NIL) + ('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|)) + ('T + (SPADLET |val| + (|NRTcompileEvalForm| + (|unwrap| |val|) + (CDR (CAAR |mms|)) + (|evalDomain| |dc|))) + (|objNew| |val| |t2|)))))) + ((AND (PAIRP |t1|) + (EQ (QCAR |t1|) '|Variable|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t1|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |sym| (QCAR |ISTMP#1|)) + 'T))) + (PAIRP |t2|) + (EQ (QCAR |t2|) '|Mapping|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t2|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |target| + (QCAR |ISTMP#1|)) + (SPADLET |margl| + (QCDR |ISTMP#1|)) + '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|) '|_FreeFunction_|) + (PROGN + (SPADLET |freeFun| (QCDR |dc|)) + '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|) '|FunctionCalled|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t1|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |sym| (QCAR |ISTMP#1|)) + 'T))) + (PAIRP |t2|) + (EQ (QCAR |t2|) '|Mapping|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t2|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |target| + (QCAR |ISTMP#1|)) + (SPADLET |margl| + (QCDR |ISTMP#1|)) + 'T)))) + (SPADLET |symNode| (|mkAtreeNode| |sym|)) + (|transferPropsToNode| |sym| |symNode|) + (COND + ((NULL (SPADLET |mms| + (|selectLocalMms| |symNode| |sym| + |margl| |target|))) + NIL) + ('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) + ('T + (SPADLET |ml| + (CONS |target| |margl|)) + (SPADLET |intName| + (COND + ((PROG (G167466) + (SPADLET G167466 NIL) + (RETURN + (DO + ((G167473 NIL + G167466) + (G167474 |mms| + (CDR G167474)) + (|mm| NIL)) + ((OR G167473 + (ATOM G167474) + (PROGN + (SETQ |mm| + (CAR G167474)) + NIL)) + G167466) + (SEQ + (EXIT + (COND + ((AND + (PAIRP |mm|) + (PROGN + (SPADLET + |ISTMP#1| + (QCAR + |mm|)) + (AND + (PAIRP + |ISTMP#1|) + (PROGN + (SPADLET + |ml1| + (QCDR + |ISTMP#1|)) + 'T))) + (PROGN + (SPADLET + |ISTMP#2| + (QCDR + |mm|)) + (AND + (PAIRP + |ISTMP#2|) + (PROGN + (SPADLET + |oldName| + (QCAR + |ISTMP#2|)) + 'T))) + (|compareTypeLists| + |ml1| |ml|)) + (SETQ + G167466 + (OR G167466 + |mm|))))))))) + (CONS |oldName| NIL)) + ('T NIL))) + (COND + ((NULL |intName|) NIL) + ('T (|objNewWrap| |intName| |t2|)))))))) + ((AND (PAIRP |t1|) + (EQ (QCAR |t1|) '|FunctionCalled|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t1|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |sym| (QCAR |ISTMP#1|)) + 'T)))) + (COND + ((AND (SPADLET |t3| + (|get| |sym| '|mode| |$e|)) + (PAIRP |t3|) + (EQ (QCAR |t3|) '|Mapping|)) + (COND + ((SPADLET |triple'| + (|coerceInt| |triple| |t3|)) + (|coerceInt| |triple'| |t2|)) + ('T NIL))) + ('T NIL))) + ((AND (EQ (CAR |t1|) '|Variable|) + (PAIRP |t2|) + (OR (|isEqualOrSubDomain| |t2| + |$Integer|) + (BOOT-EQUAL |t2| + (CONS |$QuotientField| + (CONS |$Integer| NIL))) + (MEMQ (CAR |t2|) + '(|RationalNumber| |BigFloat| + |NewFloat| |Float| + |DoubleFloat|)))) + NIL) + ('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 @@ -2933,19 +3099,20 @@ Interpreter Coercion Query Functions ; 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))))))) + (PROG (|super| |superDomain|) + (RETURN + (COND + ((BOOT-EQUAL |val| '|$fromCoerceable$|) NIL) + ('T (SPADLET |super| (GETDATABASE (CAR |tSub|) '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|))) + ('T NIL))))))) ;coerceImmediateSubDomain(val, tSuper, tSub, pred) == ; predfn := getSubDomainPredicate(tSuper, tSub, pred) @@ -2953,13 +3120,14 @@ Interpreter Coercion Query Functions ; 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)))))) + (PROG (|predfn|) + (RETURN + (PROGN + (SPADLET |predfn| + (|getSubDomainPredicate| |tSuper| |tSub| |pred|)) + (COND + ((FUNCALL |predfn| |val| NIL) (|objNew| |val| |tSub|)) + ('T NIL)))))) ;getSubDomainPredicate(tSuper, tSub, pred) == ; $env: local := $InteractiveFrame @@ -2978,38 +3146,40 @@ Interpreter Coercion Query Functions ; 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|)))))) + (PROG (|$env| |name| |decl| |arg| |pred'| |defn| |op| |predfn|) + (DECLARE (SPECIAL |$env| |$superHash| |$Boolean| + |$InteractiveFrame|)) + (RETURN + (PROGN + (SPADLET |$env| |$InteractiveFrame|) + (COND + ((SPADLET |predfn| + (HGET |$superHash| (CONS |tSuper| |tSub|))) + |predfn|) + ('T (SPADLET |name| (GENSYM)) + (SPADLET |decl| + (CONS '|:| + (CONS |name| + (CONS (CONS '|Mapping| + (CONS |$Boolean| + (CONS |tSuper| NIL))) + NIL)))) + (|interpret| |decl| NIL) (SPADLET |arg| (GENSYM)) + (SPADLET |pred'| (MSUBST |arg| '|#1| |pred|)) + (SPADLET |defn| + (CONS 'DEF + (CONS (CONS |name| (CONS |arg| NIL)) + (CONS '(NIL NIL) + (CONS '(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 @@ -3023,20 +3193,20 @@ Interpreter Coercion Query Functions ; 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))))) + (PROG (|t0|) + (RETURN + (COND + ((BOOT-EQUAL |t1| '(|List| (|None|))) + (COND + ((NULL (|unwrap| |val|)) + (COND + ((NULL (SPADLET |t0| (|underDomainOf| |t2|))) NIL) + ('T + (|coerceInt| + (|objNewWrap| |val| (CONS '|List| (CONS |t0| NIL))) + |t2|)))) + ('T NIL))) + ('T NIL))))) ;compareTypeLists(tl1,tl2) == ; -- returns true if every type in tl1 is = or is a subdomain of @@ -3046,24 +3216,19 @@ Interpreter Coercion Query Functions ; 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))))) + (PROG () + (RETURN + (SEQ (DO ((G167600 |tl1| (CDR G167600)) (|t1| NIL) + (G167601 |tl2| (CDR G167601)) (|t2| NIL)) + ((OR (ATOM G167600) + (PROGN (SETQ |t1| (CAR G167600)) NIL) + (ATOM G167601) + (PROGN (SETQ |t2| (CAR G167601)) NIL)) + NIL) + (SEQ (EXIT (COND + ((NULL (|isEqualOrSubDomain| |t1| |t2|)) + (EXIT (RETURN NIL))))))) + 'T)))) ;coerceIntAlgebraicConstant(object,t2) == ; -- should use = from domain, but have to check on defaults code @@ -3078,82 +3243,78 @@ Interpreter Coercion Query Functions ; 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)))))) + (PROG (|t1| |val|) + (RETURN + (PROGN + (SPADLET |t1| (|objMode| |object|)) + (SPADLET |val| (|objValUnwrap| |object|)) + (COND + ((AND (|ofCategory| |t1| '(|Monoid|)) + (|ofCategory| |t2| '(|Monoid|)) + (BOOT-EQUAL |val| + (|getConstantFromDomain| '(|One|) |t1|))) + (|objNewWrap| (|getConstantFromDomain| '(|One|) |t2|) |t2|)) + ((AND (|ofCategory| |t1| '(|AbelianMonoid|)) + (|ofCategory| |t2| '(|AbelianMonoid|)) + (BOOT-EQUAL |val| + (|getConstantFromDomain| '(|Zero|) |t1|))) + (|objNewWrap| (|getConstantFromDomain| '(|Zero|) |t2|) |t2|)) + ('T NIL)))))) ;stripUnionTags doms == ; [if dom is [":",.,dom'] then dom' else dom for dom in doms] (DEFUN |stripUnionTags| (|doms|) - (PROG (|ISTMP#1| |ISTMP#2| |dom'|) - (RETURN - (SEQ - (PROG (#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#))))))))))) + (PROG (|ISTMP#1| |ISTMP#2| |dom'|) + (RETURN + (SEQ (PROG (G167639) + (SPADLET G167639 NIL) + (RETURN + (DO ((G167650 |doms| (CDR G167650)) (|dom| NIL)) + ((OR (ATOM G167650) + (PROGN (SETQ |dom| (CAR G167650)) NIL)) + (NREVERSE0 G167639)) + (SEQ (EXIT (SETQ G167639 + (CONS (COND + ((AND (PAIRP |dom|) + (EQ (QCAR |dom|) '|:|) + (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|)) + 'T)))))) + |dom'|) + ('T |dom|)) + G167639))))))))))) ;isTaggedUnion u == ; u is ['Union,:tl] and tl and first tl is [":",.,.] and true (DEFUN |isTaggedUnion| (|u|) - (PROG (|tl| |ISTMP#1| |ISTMP#2| |ISTMP#3|) - (RETURN - (AND - (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))))) + (PROG (|tl| |ISTMP#1| |ISTMP#2| |ISTMP#3|) + (RETURN + (AND (PAIRP |u|) (EQ (QCAR |u|) '|Union|) + (PROGN (SPADLET |tl| (QCDR |u|)) 'T) |tl| + (PROGN + (SPADLET |ISTMP#1| (CAR |tl|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) '|:|) + (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))))))) + 'T)))) ;getUnionOrRecordTags u == ; tags := nil @@ -3163,40 +3324,34 @@ Interpreter Coercion Query Functions ; 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|))))) + (PROG (|tl| |ISTMP#1| |tag| |ISTMP#2| |tags|) + (RETURN + (SEQ (PROGN + (SPADLET |tags| NIL) + (COND + ((OR (AND (PAIRP |u|) (EQ (QCAR |u|) '|Union|) + (PROGN (SPADLET |tl| (QCDR |u|)) 'T)) + (AND (PAIRP |u|) (EQ (QCAR |u|) '|Record|) + (PROGN (SPADLET |tl| (QCDR |u|)) 'T))) + (DO ((G167701 |tl| (CDR G167701)) (|t| NIL)) + ((OR (ATOM G167701) + (PROGN (SETQ |t| (CAR G167701)) NIL)) + NIL) + (SEQ (EXIT (COND + ((AND (PAIRP |t|) (EQ (QCAR |t|) '|:|) + (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|))) + ('T NIL))))))) + |tags|))))) ;coerceUnion2Branch(object) == ; [.,:unionDoms] := objMode object @@ -3215,55 +3370,49 @@ Interpreter Coercion Query Functions ; 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|))))))))) + (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 ((G167741 |doms| (CDR G167741)) (|typ| NIL) + (G167742 |predList| (CDR G167742)) + (|pred| NIL)) + ((OR (ATOM G167741) + (PROGN (SETQ |typ| (CAR G167741)) NIL) + (ATOM G167742) + (PROGN (SETQ |pred| (CAR G167742)) NIL) + (NULL (NULL |targetType|))) + NIL) + (SEQ (EXIT (COND + ((|evalSharpOne| |pred| |val'|) + (EXIT (PROGN + (SPADLET |predicate| |pred|) + (SPADLET |targetType| |typ|)))))))) + (COND + ((NULL |targetType|) + (|keyedSystemError| 'S2IC0013 NIL)) + ((AND (PAIRP |predicate|) + (EQ (QCAR |predicate|) '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|)) + 'T)))))) + (|objNewWrap| (CDR |val'|) |targetType|)) + ('T (|objNew| (|objVal| |object|) |targetType|))))))))) ;coerceBranch2Union(object,union) == ; -- assumes type is a member of unionDoms @@ -3279,39 +3428,38 @@ Interpreter Coercion Query Functions ; 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|))))))))) + (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)))) + ('T (SPADLET |val| (|objVal| |object|)) + (COND + ((PROGN + (SPADLET |ISTMP#1| (ELT |predList| |p|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) '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|)) + 'T))))))) + (|objNewWrap| + (CONS (|removeQuote| |tag|) (|unwrap| |val|)) + |union|)) + ('T (|objNew| |val| |union|))))))))) ;coerceInt2Union(object,union) == ; -- coerces to a Union type, adding numeric tags @@ -3331,43 +3479,46 @@ Interpreter Coercion Query Functions ; 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 + (PROG (|unionDoms| |t1| |val| |val'| |noCoerce|) + (DECLARE (SPECIAL |$String|)) + (RETURN + (SEQ (PROGN + (SPADLET |unionDoms| (|stripUnionTags| (CDR |union|))) + (SPADLET |t1| (|objMode| |object|)) (COND - ((SPADLET |val'| (|coerceInt| |object| |d|)) - (EXIT (SPADLET |noCoerce| NIL))))))) - (COND (|val'| (EXIT (|coerceBranch2Union| |val'| |union|)))) - NIL)))))))))) + ((|member| |t1| |unionDoms|) + (|coerceBranch2Union| |object| |union|)) + ('T (SPADLET |val| (|objVal| |object|)) + (SPADLET |val'| (|unwrap| |val|)) + (COND + ((AND (BOOT-EQUAL |t1| |$String|) + (|member| |val'| |unionDoms|)) + (|coerceBranch2Union| (|objNew| |val| |val'|) + |union|)) + ('T (SPADLET |noCoerce| 'T) (SPADLET |val'| NIL) + (SEQ (DO ((G167805 |unionDoms| (CDR G167805)) + (|d| NIL)) + ((OR (ATOM G167805) + (PROGN + (SETQ |d| (CAR G167805)) + NIL) + (NULL |noCoerce|)) + NIL) + (SEQ (EXIT (COND + ((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|)) + (|coerceInt| (|coerceUnion2Branch| |object|) |t2|)) ;coerceIntByMap(triple,t2) == ; -- idea is this: if t1 is D U1 and t2 is D U2, then look for @@ -3411,92 +3562,96 @@ Interpreter Coercion Query Functions ; 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|)) + (PROG (|t1| |top| |u1| |u2| |args| |mms| |LETTMP#1| |dc| |sig| |slot| + |fun| |fn| |d| |code| |val|) + (DECLARE (SPECIAL |$coerceFailure| |$reportBottomUpFlag|)) + (RETURN + (PROGN + (SPADLET |t1| (|objMode| |triple|)) (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|))) + ((BOOT-EQUAL |t2| |t1|) |triple|) + ('T (SPADLET |u2| (|deconstructT| |t2|)) + (COND + ((EQL 1 (|#| |u2|)) NIL) + ('T (SPADLET |u1| (|deconstructT| |t1|)) (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|))))))))))))))))))))) + ((EQL 1 (|#| |u1|)) NIL) + ((NEQUAL (CAAR |u1|) (CAAR |u2|)) NIL) + ((NULL (|valueArgsEqual?| |t1| |t2|)) NIL) + ('T (SPADLET |top| (CAAR |u1|)) + (SPADLET |u1| (|underDomainOf| |t1|)) + (SPADLET |u2| (|underDomainOf| |t2|)) + (COND + ((AND (|member| |top| + '(|List| |Vector| |Segment| |Stream| + |UniversalSegment| |Array|)) + (|isSubDomain| |u1| |u2|)) + (|objNew| (|objVal| |triple|) |t2|)) + ('T + (SPADLET |args| + (CONS (CONS '|Mapping| + (CONS |u2| (CONS |u1| NIL))) + (CONS |t1| NIL))) + (COND + (|$reportBottomUpFlag| + (|sayFunctionSelection| '|map| |args| |t2| + NIL + (MAKESTRING "coercion facility (map)")))) + (SPADLET |mms| + (|selectMms1| '|map| |t2| |args| |args| + NIL)) + (COND + (|$reportBottomUpFlag| + (|sayFunctionSelectionResult| '|map| |args| + |mms|))) + (COND + ((NULL |mms|) NIL) + ('T (SPADLET |LETTMP#1| (CAR |mms|)) + (SPADLET |dc| (CAAR |LETTMP#1|)) + (SPADLET |sig| (CDAR |LETTMP#1|)) + (SPADLET |slot| (CADR |LETTMP#1|)) + (SPADLET |fun| + (|compiledLookup| '|map| |sig| + (|evalDomain| |dc|))) + (COND + ((NULL |fun|) NIL) + ('T (SPADLET |fn| (CAR |fun|)) + (SPADLET |d| (CDR |fun|)) + (COND + ((BOOT-EQUAL |fn| (|function| |Undef|)) + NIL) + ('T + (SPADLET |code| + (CONS 'SPADCALL + (CONS + (CONS 'CONS + (CONS + (CONS '|function| + (CONS '|coerceIntByMapInner| + NIL)) + (CONS (MKQ (CONS |u1| |u2|)) + NIL))) + (CONS + (|wrapped2Quote| + (|objVal| |triple|)) + (CONS (MKQ |fun|) NIL))))) + (SPADLET |val| + (CATCH '|coerceFailure| + (|timedEvaluate| |code|))) + (COND + ((BOOT-EQUAL |val| |$coerceFailure|) + NIL) + ('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|))))) +(DEFUN |coerceIntByMapInner| (|arg| G167859) + (PROG (|u1| |u2|) + (RETURN + (PROGN + (SPADLET |u1| (CAR G167859)) + (SPADLET |u2| (CDR G167859)) + (|coerceOrThrowFailure| |arg| |u1| |u2|))))) ;-- [u1,:u2] gets passed as the "environment", which is why we have this ;-- slightly clumsy locution JHD 31.July,1990 @@ -3521,58 +3676,57 @@ Interpreter Coercion Query Functions ; 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|))))))))) + (PROG (|coSig| |constrSig| |tl1| |tl2| |trip| |newVal| |done| + |value|) + (RETURN + (SEQ (PROGN + (SPADLET |coSig| (CDR (GETDATABASE (CAR |t1|) 'COSIG))) + (SPADLET |constrSig| + (CDR (|getConstructorSignature| (CAR |t1|)))) + (SPADLET |tl1| (|replaceSharps| |constrSig| |t1|)) + (SPADLET |tl2| (|replaceSharps| |constrSig| |t2|)) + (COND + ((NULL (MEMQ NIL |coSig|)) 'T) + ('T (SPADLET |done| NIL) (SPADLET |value| 'T) + (SEQ (DO ((G167888 (CDR |t1|) (CDR G167888)) + (|a1| NIL) + (G167889 (CDR |t2|) (CDR G167889)) + (|a2| NIL) + (G167890 |coSig| (CDR G167890)) + (|cs| NIL) (G167891 |tl1| (CDR G167891)) + (|m1| NIL) (G167892 |tl2| (CDR G167892)) + (|m2| NIL)) + ((OR (ATOM G167888) + (PROGN (SETQ |a1| (CAR G167888)) NIL) + (ATOM G167889) + (PROGN (SETQ |a2| (CAR G167889)) NIL) + (ATOM G167890) + (PROGN (SETQ |cs| (CAR G167890)) NIL) + (ATOM G167891) + (PROGN (SETQ |m1| (CAR G167891)) NIL) + (ATOM G167892) + (PROGN (SETQ |m2| (CAR G167892)) NIL) + (NULL (NULL |done|))) + NIL) + (SEQ (EXIT (COND + ((NULL |cs|) + (EXIT + (PROGN + (SPADLET |trip| + (|objNewWrap| |a1| |m1|)) + (SPADLET |newVal| + (|coerceInt| |trip| |m2|)) + (COND + ((NULL |newVal|) + (SPADLET |done| 'T) + (SPADLET |value| NIL)) + ((NULL + (|algEqual| |a2| + (|objValUnwrap| |newVal|) + |m2|)) + (SPADLET |done| 'T) + (SPADLET |value| NIL)))))))))) + (EXIT |value|))))))))) ;coerceIntTower(triple,t2) == ; -- tries to find a coercion from top level t2 to somewhere inside t1 @@ -3611,73 +3765,99 @@ Interpreter Coercion Query Functions ; 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|)))))))) + (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|) + ('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 ((G167962 NIL (OR |x| (NULL |arg|)))) + (G167962 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|)))))))) + ('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 @@ -3687,31 +3867,30 @@ Interpreter Coercion Query Functions ; 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)))))) + (PROG (|t1| |ISTMP#1| R |ISTMP#2| U |ISTMP#3| |x|) + (RETURN + (PROGN + (SPADLET |t1| (|objMode| |triple|)) + (COND + ((AND (PAIRP |t2|) + (EQ (QCAR |t2|) '|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) + ('T (|coerceInt| |x| |t2|)))) + ('T NIL)))))) ;coerceIntTableOrFunction(triple,t2) == ; -- this function does the actual coercion to t2, but not to an @@ -3729,44 +3908,41 @@ Interpreter Coercion Query Functions ; 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|)))))))) + (PROG (|t1| |p| |ISTMP#1| |ISTMP#2| |tag| |ISTMP#3| |fun| |val|) + (DECLARE (SPECIAL |$CoerceTable|)) + (RETURN + (COND + ((NULL (|isValidType| |t2|)) NIL) + ((NULL (|isLegitimateMode| |t2| NIL NIL)) NIL) + ('T (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|)) + 'T)))))))) + (SPADLET |val| (|objVal| |triple|)) + (COND + ((BOOT-EQUAL |fun| '|Identity|) (|objNew| |val| |t2|)) + ((BOOT-EQUAL |tag| '|total|) + (OR (|coerceByTable| |fun| |val| |t1| |t2| 'T) + (|coerceByFunction| |triple| |t2|))) + ('T + (OR (|coerceByTable| |fun| |val| |t1| |t2| NIL) + (|coerceByFunction| |triple| |t2|))))) + ('T (|coerceByFunction| |triple| |t2|)))))))) ;coerceCommuteTest(t1,t2) == ; null isLegitimateMode(t2,NIL,NIL) => NIL @@ -3781,22 +3957,19 @@ Interpreter Coercion Query Functions ; (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|))))))))) + (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) + ('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 @@ -3819,36 +3992,35 @@ Interpreter Coercion Query Functions ; 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))))) + (PROG (|source| S T$ D |fun| |u| |c|) + (DECLARE (SPECIAL |$coerceFailure|)) + (RETURN + (PROGN + (SPADLET |source| (|objMode| |obj|)) (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)))))))) + ((NULL (|coerceCommuteTest| |source| |target|)) NIL) + ('T (SPADLET S (|underDomainOf| |source|)) + (SPADLET T$ (|underDomainOf| |target|)) + (COND + ((BOOT-EQUAL |source| T$) NIL) + ((AND (PAIRP |source|) + (PROGN (SPADLET D (QCAR |source|)) 'T)) + (SPADLET |fun| + (OR (GETL D '|coerceCommute|) + (INTERN (STRCONC (MAKESTRING "commute") + (STRINGIMAGE D))))) + (COND + ((|functionp| |fun|) (PUT D '|coerceCommute| |fun|) + (SPADLET |u| (|objValUnwrap| |obj|)) + (SPADLET |c| + (CATCH '|coerceFailure| + (FUNCALL |fun| |u| |source| S |target| T$))) + (COND + ((BOOT-EQUAL |c| |$coerceFailure|) NIL) + ((BOOT-EQUAL |u| '|$fromCoerceable$|) |c|) + ('T (|objNewWrap| |c| |target|)))) + ('T NIL))) + ('T NIL)))))))) ;coerceIntPermute(object,t2) == ; t2 in '((Integer) (OutputForm)) => NIL @@ -3868,28 +4040,30 @@ Interpreter Coercion Query Functions ; 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))))))))) + (PROG (|t1| |towers| |ok|) + (RETURN + (SEQ (COND + ((|member| |t2| '((|Integer|) (|OutputForm|))) NIL) + ('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) + ('T (SPADLET |ok| 'T) + (SEQ (DO ((G168100 (CDR |towers|) (CDR G168100)) + (|t| NIL)) + ((OR (ATOM G168100) + (PROGN (SETQ |t| (CAR G168100)) NIL) + (NULL |ok|)) + NIL) + (SEQ (EXIT (COND + ((NULL + (SPADLET |object| + (|coerceInt| |object| |t|))) + (EXIT (SPADLET |ok| NIL))))))) + (COND (|ok| (EXIT |object|))) NIL))))))))) ;computeTTTranspositions(t1,t2) == ; -- decompose t1 into its tower parts @@ -3929,87 +4103,112 @@ Interpreter Coercion Query Functions ; 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|)))))) + (PROG () + (RETURN + (SEQ (IF (>= |start| |len|) (EXIT |l|)) + (IF (|member| |start| |l|) + (EXIT (|computeTTTranspositions,compress| |l| + (PLUS |start| 1) |len|))) + (EXIT (|computeTTTranspositions,compress| + (PROG (G168121) + (SPADLET G168121 NIL) + (RETURN + (DO ((G168126 |l| (CDR G168126)) + (|i| NIL)) + ((OR (ATOM G168126) + (PROGN + (SETQ |i| (CAR G168126)) + NIL)) + (NREVERSE0 G168121)) + (SEQ (EXIT (SETQ G168121 + (CONS + (SEQ + (IF (> |start| |i|) + (EXIT |i|)) + (EXIT (SPADDIFFERENCE |i| 1))) + G168121))))))) + |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|)))))))))))) + (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) + ('T + (SPADLET |p2| + (PROG (G168143) + (SPADLET G168143 NIL) + (RETURN + (DO ((G168148 |tl1| (CDR G168148)) + (|d1| NIL)) + ((OR (ATOM G168148) + (PROGN + (SETQ |d1| (CAR G168148)) + NIL)) + (NREVERSE0 G168143)) + (SEQ (EXIT + (SETQ G168143 + (CONS (|position| |d1| |tl2|) + G168143)))))))) + (COND + ((|member| (SPADDIFFERENCE 1) |p2|) NIL) + ('T (SPADLET |p2'| (MSORT |p2|)) + (COND + ((BOOT-EQUAL |p2| |p2'|) NIL) + ((NEQUAL |p2'| (MSORT (REMDUP |p2'|))) NIL) + ('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 ((G168161 |perms| (CDR G168161)) + (|perm| NIL)) + ((OR (ATOM G168161) + (PROGN + (SETQ |perm| (CAR G168161)) + 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 (G168171) + (SPADLET G168171 NIL) + (RETURN + (DO + ((G168176 |towers| + (CDR G168176)) + (|tower| NIL)) + ((OR (ATOM G168176) + (PROGN + (SETQ |tower| (CAR G168176)) + NIL)) + (NREVERSE0 G168171)) + (SEQ + (EXIT + (SETQ G168171 + (CONS + (|reassembleTowerIntoType| + |tower|) + G168171)))))))) + (COND + ((NEQUAL (CAR |towers|) |t2|) + (SPADLET |towers| (CONS |t2| |towers|)))) + (NREVERSE |towers|)))))))))))) ;decomposeTypeIntoTower t == ; ATOM t => [t] @@ -4019,19 +4218,16 @@ Interpreter Coercion Query Functions ; [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|)))))))))) + (PROG (|d| |rd|) + (RETURN + (COND + ((ATOM |t|) (CONS |t| NIL)) + ('T (SPADLET |d| (|deconstructT| |t|)) + (COND + ((NULL (CDR |d|)) (CONS |t| NIL)) + ('T (SPADLET |rd| (REVERSE |t|)) + (CONS (REVERSE (QCDR |rd|)) + (|decomposeTypeIntoTower| (QCAR |rd|)))))))))) ;reassembleTowerIntoType tower == ; ATOM tower => tower @@ -4040,18 +4236,16 @@ Interpreter Coercion Query Functions ; 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)))))))) + (PROG (|LETTMP#1| |s| |t| |top|) + (RETURN + (COND + ((ATOM |tower|) |tower|) + ((NULL (CDR |tower|)) (CAR |tower|)) + ('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 @@ -4078,42 +4272,38 @@ Interpreter Coercion Query Functions ; 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)))))))))) + (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) + ('T (CONS (CONS |r| (PLUS |r| 1)) NIL)))) + ((BOOT-EQUAL (ELT |p| |start|) |start|) + (|permuteToOrder| |p| |n| (PLUS |start| 1))) + ('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|)) + ('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 @@ -4127,20 +4317,18 @@ Interpreter Coercion Query Functions ; 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|)))))))) + (PROG (|p| |b|) + (DECLARE (SPECIAL |$useConvertForCoercions| |$CoerceTable|)) + (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| '|coerce| |t1| |t2|) + (AND |$useConvertForCoercions| + (|coerceConvertMmSelection| '|convert| |t1| |t2|)))))))) ;coerceByTable(fn,x,t1,t2,isTotalCoerce) == ; -- catch point for 'failure in boot coercions @@ -4154,26 +4342,32 @@ Interpreter Coercion Query Functions ; 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|)))))) + (PROG (|c|) + (DECLARE (SPECIAL |$coerceFailure| |$OutputForm|)) + (RETURN + (COND + ((AND (BOOT-EQUAL |t2| |$OutputForm|) (NULL (|newType?| |t1|))) + NIL) + ((|isWrapped| |x|) (SPADLET |x| (|unwrap| |x|)) + (SPADLET |c| + (CATCH '|coerceFailure| + (FUNCALL |fn| |x| |t1| |t2|))) + (COND + ((BOOT-EQUAL |c| |$coerceFailure|) NIL) + ('T (|objNewWrap| |c| |t2|)))) + (|isTotalCoerce| + (|objNew| + (CONS |fn| + (CONS |x| + (CONS (MKQ |t1|) (CONS (MKQ |t2|) NIL)))) + |t2|)) + ('T + (|objNew| + (CONS '|catchCoerceFailure| + (CONS (MKQ |fn|) + (CONS |x| + (CONS (MKQ |t1|) (CONS (MKQ |t2|) NIL))))) + |t2|)))))) ;catchCoerceFailure(fn,x,t1,t2) == ; -- compiles a catchpoint for compiling boot coercions @@ -4183,21 +4377,25 @@ Interpreter Coercion Query Functions ; 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|)))))) + (PROG (|c|) + (DECLARE (SPECIAL |$coerceFailure|)) + (RETURN + (PROGN + (SPADLET |c| + (CATCH '|coerceFailure| (FUNCALL |fn| |x| |t1| |t2|))) + (COND + ((BOOT-EQUAL |c| |$coerceFailure|) + (|throwKeyedMsgCannotCoerceWithValue| + (|wrap| (|unwrap| |x|)) |t1| |t2|)) + ('T |c|)))))) ;coercionFailure() == ; -- does the throw on coercion failure ; THROW('coerceFailure,$coerceFailure) -(DEFUN |coercionFailure| () - (THROW (QUOTE |coerceFailure|) |$coerceFailure|)) +(DEFUN |coercionFailure| () + (DECLARE (SPECIAL |$coerceFailure|)) + (THROW '|coerceFailure| |$coerceFailure|)) ;coerceByFunction(T,m2) == ; -- using the new modemap selection without coercions @@ -4247,112 +4445,106 @@ Interpreter Coercion Query Functions ; 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|)))) + (PROG ($ |m1| |ud| |x| |ISTMP#1| |a| |ISTMP#2| |b| |funName| |mm| + |dc| |tar| |args| |slot| |dcVector| |fun| |fn| |d| |val| + |env| |code| |m1'| |m2'|) + (DECLARE (SPECIAL $ |$coerceFailure| |$Boolean|)) + (RETURN + (PROGN + (SPADLET |x| (|objVal| T$)) (COND - (|mm| - (SPADLET |dc| (CAAR |mm|)) - (SPADLET |tar| (CADAR |mm|)) - (SPADLET |args| (CDDAR |mm|)) - (SPADLET |slot| (CADR |mm|)) - (SPADLET |dcVector| (|evalDomain| |dc|)) - (SPADLET |fun| + ((BOOT-EQUAL |x| '|$fromCoerceable$|) NIL) + ((AND (PAIRP |m2|) (EQ (QCAR |m2|) '|Union|)) NIL) + ('T (SPADLET |m1| (|objMode| T$)) (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)))))))))))) + ((AND (PAIRP |m2|) (EQ (QCAR |m2|) '|Boolean|) + (PAIRP |m1|) (EQ (QCAR |m1|) '|Equation|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |m1|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |ud| (QCAR |ISTMP#1|)) 'T)))) + (SPADLET |dcVector| (|evalDomain| |ud|)) + (SPADLET |fun| + (COND + ((|isWrapped| |x|) + (|NRTcompiledLookup| '= + (CONS |$Boolean| (CONS '$ (CONS '$ NIL))) + |dcVector|)) + ('T + (|NRTcompileEvalForm| '= + (CONS |$Boolean| (CONS '$ (CONS '$ 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|) '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|)) + 'T))))))) + (|keyedSystemError| 'S2IC0015 NIL)) + ('T + (SPADLET |code| + (CONS 'SPADCALL + (CONS |a| (CONS |b| (CONS |fun| NIL))))) + (|objNew| |code| |$Boolean|)))) + ('T + (COND + ((NULL (SPADLET |mm| + (|coerceConvertMmSelection| + (SPADLET |funName| '|coerce|) |m1| + |m2|))) + (SPADLET |mm| + (|coerceConvertMmSelection| + (SPADLET |funName| '|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|)) + ('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 '|coerceFailure| + (SPADCALL (|unwrap| |x|) |fun|))) + (COND + ((BOOT-EQUAL |val| |$coerceFailure|) NIL) + ('T (|objNewWrap| |val| |m2|)))) + ('T (SPADLET |env| |fun|) + (SPADLET |code| + (CONS '|failCheck| + (CONS + (CONS 'SPADCALL + (CONS |x| (CONS |env| NIL))) + NIL))) + (|objNew| |code| |m2|)))) + ('T (SPADLET |m1'| (|eqType| |m1|)) + (SPADLET |m2'| (|eqType| |m2|)) + (COND + ((OR (NEQUAL |m1| |m1'|) (NEQUAL |m2| |m2'|)) + (|coerceByFunction| (|objNew| |x| |m1'|) |m2'|)) + ('T NIL)))))))))))) ;hasCorrectTarget(m,sig is [dc,tar,:.]) == ; -- tests whether the target of signature sig is either m or a union @@ -4364,45 +4556,40 @@ Interpreter Coercion Query Functions ; 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|)))))))) + (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|) '|TypeEquivalence|)) NIL) + ((BOOT-EQUAL |m| |tar|) 'T) + ((AND (PAIRP |tar|) (EQ (QCAR |tar|) '|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|) '|failed|)))))) + (BOOT-EQUAL |t| |m|)) + ('T + (AND (PAIRP |tar|) (EQ (QCAR |tar|) '|Union|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |tar|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|failed|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |t| (QCAR |ISTMP#2|)) + 'T))))) + (BOOT-EQUAL |t| |m|)))))))) + @ \eject