Initial population.

1 files changed, 1454 insertions, 0 deletions

diff --git a/src/interp/i-coerce.boot.pamphlet b/src/interp/i-coerce.boot.pamphlet
new file mode 100644
index 00000000..e69d13b2
--- /dev/null
+++ b/src/interp/i-coerce.boot.pamphlet
@@ -0,0 +1,1454 @@
+\documentclass{article}
+\usepackage{axiom}
+
+\title{\File{src/interp/i-coerce.boot} Pamphlet}
+\author{The Axiom Team}
+
+\begin{document}
+\maketitle
+\begin{abstract}
+\end{abstract}
+\eject
+\tableofcontents
+\eject
+
+\section{Coercion conventions}
+
+\begin{verbatim}
+Coercion conventions
+
+Coercion involves the  changing of the datatype of an  object.  This
+   can be  done for conformality of  operations or, for  example, to
+   change the structure of an object  into one that is understood by
+   the printing routines.
+
+The actual coercion  is controlled  by the  function "coerce"  which
+   takes  and delivers  wrapped operands.   Also  see the  functions
+   interpCoerce and coerceInteractive.
+
+Sometimes one  does not  want to  actually change  the datatype  but
+   rather wants to determine  whether it is possible to do  so.  The
+   controlling function  to do this  is "canCoerceFrom".   The value
+   passed   to  specific   coercion  routines   in   this  case   is
+   "$fromCoerceable$".   The value returned is  true or false.   See
+   specific examples for more info.
+
+The special routines that  do the coercions typically  involve a "2"
+   in their  names.   For example, G2E  converts type  "Gaussian" to
+   type  "Expression".   These  special  routines take  and  deliver
+   unwrapped operands.   The determination of which  special routine
+   to  use  is  often  made  by  consulting  the  list  $CoerceTable
+   (currently in COT BOOT) and  this is controlled by coerceByTable.
+   Note that the special routines are in the file COERCEFN BOOT.
+\end{verbatim}
+\section{Function getConstantFromDomain}
+[[getConstantFromDomain]] is used to look up the constants $0$ and $1$
+from the given [[domainForm]].
+\begin{enumerate}
+\item if [[isPartialMode]] (see i-funsel.boot) returns true then the
+domain modemap contains the constant [[$EmptyMode]] which indicates
+that the domain is not fully formed. In this case we return [[NIL]].
+\end{enumerate}
+<<getConstantFromDomain>>=
+getConstantFromDomain(form,domainForm) ==
+    isPartialMode domainForm => NIL
+    opAlist := getOperationAlistFromLisplib first domainForm
+    key := opOf form
+    entryList := LASSOC(key,opAlist)
+    entryList isnt [[sig, ., ., .]] =>
+        key = "One" => getConstantFromDomain(["1"], domainForm)
+        key = "Zero" => getConstantFromDomain(["0"], domainForm)
+        throwKeyedMsg("S2IC0008",[form,domainForm])
+    -- i.e., there should be exactly one item under this key of that form
+    domain := evalDomain domainForm
+    SPADCALL compiledLookupCheck(key,sig,domain)
+
+@
+\section{License}
+<<license>>=
+-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
+-- All rights reserved.
+--
+-- Redistribution and use in source and binary forms, with or without
+-- modification, are permitted provided that the following conditions are
+-- met:
+--
+--     - Redistributions of source code must retain the above copyright
+--       notice, this list of conditions and the following disclaimer.
+--
+--     - Redistributions in binary form must reproduce the above copyright
+--       notice, this list of conditions and the following disclaimer in
+--       the documentation and/or other materials provided with the
+--       distribution.
+--
+--     - Neither the name of The Numerical ALgorithms Group Ltd. nor the
+--       names of its contributors may be used to endorse or promote products
+--       derived from this software without specific prior written permission.
+--
+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
+-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
+-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
+-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+@
+<<*>>=
+<<license>>
+--%  Algebraic coercions using interactive code
+
+algCoerceInteractive(p,source,target) ==
+  -- now called in some groebner code
+  $useConvertForCoercions : local := true
+  source := devaluate source
+  target := devaluate target
+  u := coerceInteractive(objNewWrap(p,source),target)
+  u => objValUnwrap(u)
+  error ['"can't convert",p,'"of mode",source,'"to mode",target]
+
+spad2BootCoerce(x,source,target) ==
+  -- x : source and we wish to coerce to target
+  -- used in spad code for Any
+  null isValidType source => throwKeyedMsg("S2IE0004",[source])
+  null isValidType target => throwKeyedMsg("S2IE0004",[target])
+  x' := coerceInteractive(objNewWrap(x,source),target) =>
+    objValUnwrap(x')
+  throwKeyedMsgCannotCoerceWithValue(wrap x,source,target)
+
+--%  Functions for Coercion or Else We'll Get Rough
+
+coerceOrFail(triple,t,mapName) ==
+  -- some code generated for this is in coerceInt0
+  t = $NoValueMode => triple
+  t' := coerceInteractive(triple,t)
+  t' => objValUnwrap(t')
+  sayKeyedMsg("S2IC0004",[mapName,objMode triple,t])
+  '"failed"
+
+coerceOrCroak(triple, t, mapName) ==
+  -- this does the coercion and returns the value or dies
+  t = $NoValueMode => triple
+  t' := coerceOrConvertOrRetract(triple,t)
+  t' => objValUnwrap(t')
+  mapName = 'noMapName =>
+    throwKeyedMsgCannotCoerceWithValue(objVal triple,objMode triple, t)
+  sayKeyedMsg("S2IC0005",[mapName])
+  throwKeyedMsgCannotCoerceWithValue(objVal triple,objMode triple, t)
+
+coerceOrThrowFailure(value, t1, t2) ==
+  (result := coerceOrRetract(objNewWrap(value, t1), t2)) or
+    coercionFailure()
+  objValUnwrap(result)
+
+--%  Retraction functions
+
+retract object ==
+  type := objMode object
+  STRINGP type => 'failed
+  type = $EmptyMode => 'failed
+  val := objVal object
+  not isWrapped val and val isnt ['MAP,:.] => 'failed
+  type' := equiType(type)
+  (ans := retract1 objNew(val,equiType(type))) = 'failed => ans
+  objNew(objVal ans,eqType objMode ans)
+
+retract1 object ==
+  -- this function is the new version of the old "pullback"
+  -- it first tries to change the datatype of an object to that of
+  -- largest contained type. Examples: P RN -> RN, RN -> I
+  -- This is mostly for cases such as constant polynomials or
+  -- quotients with 1 in the denominator.
+  type := objMode object
+  STRINGP type => 'failed
+  val := objVal object
+  type = $PositiveInteger =>    objNew(val,$NonNegativeInteger)
+  type = $NonNegativeInteger => objNew(val,$Integer)
+  type = $Integer and SINTP unwrap val => objNew(val, $SingleInteger)
+  type' := equiType(type)
+  if not EQ(type,type') then object := objNew(val,type')
+  (1 = #type') or (type' is ['Union,:.]) or
+    (type' is ['FunctionCalled,.])
+     or (type' is ['OrderedVariableList,.]) or (type is ['Variable,.]) =>
+      (object' := retract2Specialization(object)) => object'
+      'failed
+  null (underDomain := underDomainOf type') => 'failed
+  -- try to retract the "coefficients"
+  -- think of P RN -> P I or M RN -> M I
+  object' := retractUnderDomain(object,type,underDomain)
+  object' ^= 'failed => object'
+  -- see if we can use the retract functions
+  (object' := coerceRetract(object,underDomain)) => object'
+  -- see if we have a special case here
+  (object' := retract2Specialization(object)) => object'
+  'failed
+
+retractUnderDomain(object,type,underDomain) ==
+  null (ud := underDomainOf underDomain) => 'failed
+  [c,:args] := deconstructT type
+  1 ^= #args => 'failed
+  1 ^= #c => 'failed
+  type'' := constructT(c,[ud])
+  (object' := coerceInt(object,type'')) => object'
+  'failed
+
+retract2Specialization object ==
+  -- handles some specialization retraction cases, like matrices
+  val := objVal object
+  val' := unwrap val
+  type := objMode object
+
+  type = $Any =>
+    [dom,:obj] := val'
+    objNewWrap(obj,dom)
+  type is ['Union,:unionDoms] => coerceUnion2Branch object
+  type = $Symbol =>
+    objNewWrap(1,['OrderedVariableList,[val']])
+  type is ['OrderedVariableList,var] =>
+    coerceInt(objNewWrap(var.(val'-1),$Symbol), '(Polynomial (Integer)))
+-- !! following retract seems wrong and breaks ug13.input
+--  type is ['Variable,var] =>
+--    coerceInt(object,$Symbol)
+  type is ['Polynomial,D] =>
+    val' is [ =1,x,:.] =>
+      vl := REMDUP reverse varsInPoly val'
+      1 = #vl => coerceInt(object,['UnivariatePolynomial,x,D])
+      NIL
+    val' is [ =0,:.] => coerceInt(object, D)
+    NIL
+  type is ['Matrix,D] =>
+    n := # val'
+    m := # val'.0
+    n = m => objNew(val,['SquareMatrix,n,D])
+    objNew(val,['RectangularMatrix,n,m,D])
+  type is ['RectangularMatrix,n,m,D] =>
+    n = m => objNew(val,['SquareMatrix,n,D])
+    NIL
+  (type is [agg,D]) and (agg in '(Vector Segment UniversalSegment)) =>
+    D = $PositiveInteger => objNew(val,[agg,$NonNegativeInteger])
+    D = $NonNegativeInteger => objNew(val,[agg,$Integer])
+    NIL
+  type is ['Array,bds,D] =>
+    D = $PositiveInteger => objNew(val,['Array,bds,$NonNegativeInteger])
+    D = $NonNegativeInteger => objNew(val,['Array,bds,$Integer])
+    NIL
+  type is ['List,D] =>
+    D isnt ['List,D'] =>
+      -- try to retract elements
+      D = $PositiveInteger => objNew(val,['List,$NonNegativeInteger])
+      D = $NonNegativeInteger => objNew(val,['List,$Integer])
+      null val' => nil
+--        null (um := underDomainOf D) => nil
+--        objNewWrap(nil,['List,um])
+      vl := nil
+      tl := nil
+      bad := nil
+      for e in val' while not bad repeat
+        (e' := retract objNewWrap(e,D)) = 'failed => bad := true
+        vl := [objValUnwrap e',:vl]
+        tl := [objMode e',:tl]
+      bad => NIL
+      (m := resolveTypeListAny tl) = D => NIL
+      D = equiType(m) => NIL
+      vl' := nil
+      for e in vl for t in tl repeat
+        t = m => vl' := [e,:vl']
+        e' := coerceInt(objNewWrap(e,t),m)
+        null e' => return NIL
+        vl' := [objValUnwrap e',:vl']
+      objNewWrap(vl',['List,m])
+    D' = $PositiveInteger =>
+      objNew(val,['List,['List,$NonNegativeInteger]])
+    D' = $NonNegativeInteger =>
+      objNew(val,['List,['List,$Integer]])
+    D' is ['Variable,.] or D' is ['OrderedVariableList,.] =>
+        coerceInt(object,['List,['List,$Symbol]])
+
+    n := # val'
+    m := # val'.0
+    null isRectangularList(val',n,m) => NIL
+    coerceInt(object,['Matrix,D'])
+  type is ['Expression,D] =>
+    [num,:den] := val'
+    -- coerceRetract already handles case where den = 1
+    num isnt [0,:num] => NIL
+    den isnt [0,:den] => NIL
+    objNewWrap([num,:den],[$QuotientField, D])
+  type is ['SimpleAlgebraicExtension,k,rep,.] =>
+    -- try to retract as an element of rep and see if we can get an
+    -- element of k
+    val' := retract objNew(val,rep)
+    while (val' ^= 'failed) and
+      (equiType(objMode val') ^= k) repeat
+        val' := retract val'
+    val' = 'failed => NIL
+    val'
+
+  type is ['UnivariatePuiseuxSeries, coef, var, cen] =>
+    coerceInt(object, ['UnivariateLaurentSeries, coef, var, cen])
+  type is ['UnivariateLaurentSeries, coef, var, cen] =>
+    coerceInt(object, ['UnivariateTaylorSeries, coef, var, cen])
+
+  type is ['FunctionCalled,name] =>
+    null (m := get(name,'mode,$e)) => NIL
+    isPartialMode m => NIL
+    objNew(val,m)
+  NIL
+
+coerceOrConvertOrRetract(T,m) ==
+  $useConvertForCoercions : local := true
+  coerceOrRetract(T,m)
+
+coerceOrRetract(T,m) ==
+  (t' := coerceInteractive(T,m)) => t'
+  t := T
+  ans := nil
+  repeat
+    ans => return ans
+    t := retract t   -- retract is new name for pullback
+    t = 'failed => return ans
+    ans := coerceInteractive(t,m)
+  ans
+
+coerceRetract(object,t2) ==
+  -- tries to handle cases such as P I -> I
+  (val := objValUnwrap(object)) = "$fromCoerceable$" => NIL
+  t1 := objMode object
+  t2 = $OutputForm => NIL
+  isEqualOrSubDomain(t1,$Integer) and typeIsASmallInteger(t2) and SMINTP(val) =>
+    objNewWrap(val,t2)
+  t1 = $Integer    => NIL
+  t1 = $Symbol     => NIL
+  t1 = $OutputForm => NIL
+  (c := retractByFunction(object, t2)) => c
+  t1 is [D,:.] =>
+    fun := GETL(D,'retract) or
+           INTERN STRCONC('"retract",STRINGIMAGE D)
+    functionp fun =>
+      PUT(D,'retract,fun)
+      c := CATCH('coerceFailure,FUNCALL(fun,object,t2))
+      (c = $coerceFailure) => NIL
+      c
+    NIL
+  NIL
+
+retractByFunction(object,u) ==
+  -- tries to retract by using function "retractIfCan"
+  -- if the type belongs to the correct category.
+  $reportBottomUpFlag: local := NIL
+  t := objMode object
+  -- JHD/CRF not ofCategory(t,['RetractableTo,u]) => NIL
+  val := objValUnwrap object
+
+  -- try to get and apply the function "retractable?"
+  target := ['Union,u,'"failed"]
+  funName := 'retractIfCan
+  if $reportBottomUpFlag then
+    sayFunctionSelection(funName,[t],target,NIL,
+      '"coercion facility (retraction)")
+  -- JHD/CRF if (mms := findFunctionInDomain(funName,t,target,[t],[t],'T,'T))
+  -- MCD: changed penultimate variable to NIL.
+  if (mms := append(findFunctionInDomain(funName,t,target,[t],[t],NIL,'T),
+                    findFunctionInDomain(funName,u,target,[t],[t],NIL,'T)))
+-- The above two lines were:      (RDJ/BMT 6/95)
+--  if (mms := append(findFunctionInDomain(funName,t,target,[t],[t],'T,'T),
+--                    findFunctionInDomain(funName,u,target,[t],[t],'T,'T)))
+    then mms := orderMms(funName,mms,[t],[t],target)
+  if $reportBottomUpFlag then
+    sayFunctionSelectionResult(funName,[t],mms)
+  null mms => NIL
+
+  -- [[dc,:.],slot,.]:= CAR mms
+  dc := CAAAR mms
+  slot := CADAR mms
+  dcVector:= evalDomain dc
+  fun :=
+--+
+    compiledLookup(funName,[target,t],dcVector)
+  NULL fun => NIL
+  CAR(fun) = function Undef => NIL
+--+
+  $: fluid := dcVector
+  object' := coerceUnion2Branch objNewWrap(SPADCALL(val,fun),target)
+  u' := objMode object'
+  u = u' => object'
+  NIL
+
+--% Coercion utilities
+
+-- The next function extracts the structural definition of constants
+-- from a given domain. For example, getConstantFromDomain('(One),S)
+-- returns the representation of 1 in the domain S.
+
+constantInDomain?(form,domainForm) ==
+    opAlist := getOperationAlistFromLisplib first domainForm
+    key := opOf form
+    entryList := LASSOC(key,opAlist)
+    entryList is [[., ., ., type]] and type in '(CONST ASCONST) => true
+    key = "One" => constantInDomain?(["1"], domainForm)
+    key = "Zero" => constantInDomain?(["0"], domainForm)
+    false
+
+<<getConstantFromDomain>>
+
+domainOne(domain) == getConstantFromDomain('(One),domain)
+
+domainZero(domain) == getConstantFromDomain('(Zero),domain)
+
+--------------------> NEW DEFINITION (override in xrun.boot.pamphlet)
+equalOne(object, domain) ==
+  -- tries using constant One and "=" from domain
+  -- object should not be wrapped
+  eqfunc := getFunctionFromDomain("=",domain,[domain,domain])
+  SPADCALL(object,getConstantFromDomain('(One),domain),eqfunc)
+
+--------------------> NEW DEFINITION (override in xrun.boot.pamphlet)
+equalZero(object, domain) ==
+  -- tries using constant Zero and "=" from domain
+  -- object should not be wrapped
+  eqfunc := getFunctionFromDomain("=",domain,[domain,domain])
+  SPADCALL(object,getConstantFromDomain('(Zero),domain),eqfunc)
+
+--------------------> NEW DEFINITION (override in xrun.boot.pamphlet)
+algEqual(object1, object2, domain) ==
+  -- sees if 2 objects of the same domain are equal by using the
+  -- "=" from the domain
+  -- objects should not be wrapped
+--  eqfunc := getFunctionFromDomain("=",domain,[domain,domain])
+  eqfunc := compiledLookupCheck("=",[$Boolean,domain,domain],evalDomain domain)
+  SPADCALL(object1,object2, eqfunc)
+
+--%  main algorithms for canCoerceFrom and coerceInteractive
+
+-- coerceInteractive and canCoerceFrom are the two coercion functions
+-- for $InteractiveMode. They translate RN, RF and RR to QF I, QF P
+-- and RE RN, respectively, and call coerceInt or canCoerce, which
+-- both work in the same way (e.g. coercion from t1 to t2):
+
+-- 1. they try to coerce t1 to t2 directly (tower coercion), and, if
+--   this fails, to coerce t1 to the last argument of t2 and embed
+--   this last argument into t2. These embedding functions are now only
+--   defined in the algebra code. (RSS 2-27-87)
+
+-- 2. the tower coercion looks whether there is any applicable local
+--   coercion, which means, one defined in boot or in algebra code.
+--   If there is an applicable function from a constructor, which is
+--   inside the type tower of t1, to the top level constructor of t2,
+--   then this constructor is bubbled up inside t1. This means,
+--   special coercion functions (defined in boot) are called, which
+--   commute two constructors in a tower. Then the local coercion is
+--   called on these constructors, which both are on top level now.
+
+-- example:
+-- let t1 = A B C D E (short for (A (B (C (D (E))))), where A ... E are
+--   type constructors), and t2 = F D G H I J
+-- there is no coercion from t1 to t2 directly, so we try to coerce
+--   t1 to s1 = D G H I J, the last argument of t2
+-- we create the type s2 = A D B C E and call a local coercion A2A
+--   from t1 to s2, which, by recursively calling coerce, bubbles up
+--   the constructor D
+-- then we call a commute coerce from s2 to s3 = D A B C E and a local
+--   coerce D2D from s3 to s1
+-- finally we embed s1 into t2, which completes the coercion t1 to t2
+
+-- the result of canCoerceFrom is TRUE or NIL
+-- the result of coerceInteractive is a object or NIL (=failed)
+-- all boot coercion functions have the following result:
+-- 1. if u=$fromCoerceable$, then TRUE or NIL
+-- 2. if the coercion succeeds, the coerced value (this may be NIL)
+-- 3. if the coercion fails, they throw to a catch point in
+--      coerceByFunction
+
+--% Interpreter Coercion Query Functions
+
+canCoerce1(t1,t2) ==
+  -- general test for coercion
+  -- the result is NIL if it fails
+  t1 = t2 => true
+  absolutelyCanCoerceByCheating(t1,t2) or t1 = '(None) or t2 = '(Any) or
+    t1 in '((Mode)  (Domain) (SubDomain (Domain))) =>
+      t2 = $OutputForm => true
+      NIL
+    -- next is for tagged union selectors for the time being
+    t1 is ['Variable,=t2] or t2 is ['Variable,=t1] => true
+    STRINGP t1 =>
+      t2 = $String => true
+      t2 = $OutputForm => true
+      t2 is ['Union,:.] => canCoerceUnion(t1,t2)
+      t2 is ['Variable,v] and (t1 = PNAME(v)) => true
+      NIL
+    STRINGP t2 =>
+      t1 is ['Variable,v] and (t2 = PNAME(v)) => true
+      NIL
+    atom t1 or atom t2 => NIL
+    null isValidType(t2) => NIL
+
+    absolutelyCannotCoerce(t1,t2) => NIL
+
+    nt1 := CAR t1
+    nt2 := CAR t2
+
+    EQ(nt1,'Mapping) => EQ(nt2,'Any)
+    EQ(nt2,'Mapping) =>
+      EQ(nt1,'Variable) or EQ(nt1,'FunctionCalled) =>
+        canCoerceExplicit2Mapping(t1,t2)
+      NIL
+    EQ(nt1,'Union) or EQ(nt2,'Union) => canCoerceUnion(t1,t2)
+
+    -- efficiency hack
+    t1 is ['Segment, s1] and t2 is ['UniversalSegment, s2] and
+        (isEqualOrSubDomain(s1, s2) or canCoerce(s1, s2)) => true
+
+    t1 is ['Tuple,S] and t2 ^= '(OutputForm) => canCoerce(['List, S], t2)
+
+    isRingT2 := ofCategory(t2,'(Ring))
+    isRingT2 and isEqualOrSubDomain(t1,$Integer) => true
+    (ans := canCoerceTopMatching(t1,t2,nt1,nt2)) ^= 'maybe => ans
+    t2 = $Integer => canCoerceLocal(t1,t2)   -- is true
+    ans := canCoerceTower(t1,t2) or
+      [.,:arg]:= deconstructT t2
+      arg and
+        t:= last arg
+        canCoerce(t1,t) and canCoerceByFunction(t,t2) and 'T
+    ans or (t1 in '((PositiveInteger) (NonNegativeInteger))
+      and canCoerce($Integer,t2))
+
+canCoerceFrom0(t1,t2) ==
+-- top level test for coercion, which transfers all RN, RF and RR into
+-- equivalent types
+  startTimingProcess 'querycoerce
+  q :=
+    isEqualOrSubDomain(t1,t2) or t1 = '(None) or t2 = '(Any) or
+      if t2 = $OutputForm then (s1 := t1; s2 := t2)
+      else (s1:= equiType(t1); s2:= equiType(t2))
+
+      -- make sure we are trying to coerce to a legal type
+      -- in particular, polynomials are repeated, etc.
+      null isValidType(t2) => NIL
+      null isLegitimateMode(t2,nil,nil) => NIL
+
+      t1 = $RationalNumber =>
+        isEqualOrSubDomain(t2,$Integer) => NIL
+        canCoerce(t1,t2) or canCoerce(s1,s2)
+      canCoerce(s1,s2)
+  stopTimingProcess 'querycoerce
+  q
+
+isSubTowerOf(t1,t2) ==
+  -- assumes RF and RN stuff has been expanded
+  -- tests whether t1 is somewhere inside t2
+  isEqualOrSubDomain(t1,t2) => true
+  null (u := underDomainOf t2) => nil
+  isSubTowerOf(t1,u)
+
+canCoerceTopMatching(t1,t2,tt1,tt2) ==
+  -- returns true, nil or maybe
+  -- for example, if t1 = P[x] D1 and t2 = P[y] D2 and x = y then
+  -- canCoerce will only be true if D1 = D2
+  not EQ(tt1,tt2) => 'maybe
+  doms := '(Polynomial List Matrix FiniteSet Vector Stream Gaussian)
+  MEMQ(tt1,doms) => canCoerce(CADR t1, CADR t2)
+  not (MEMQ(tt1,$univariateDomains) or MEMQ(tt2,$multivariateDomains)) =>
+    'maybe
+  u2 := deconstructT t2
+  1 = #u2 => NIL
+  u1 := deconstructT t1
+  1 = #u1 => NIL                             -- no under domain
+  first(u1) ^= first(u2) => 'maybe
+  canCoerce(underDomainOf t1, underDomainOf t2)
+
+canCoerceExplicit2Mapping(t1,t is ['Mapping,target,:argl]) ==
+  -- determines if there a mapping called var with the given args
+  -- and target
+  $useCoerceOrCroak: local := nil
+  t1 is ['Variable,var] =>
+    null (mms :=selectMms1(var,target,argl,[NIL for a in argl],true)) => NIL
+    mm := CAAR mms
+    mm is [., targ, :.] =>
+      targ = target => true
+      false
+    false
+  t1 is ['FunctionCalled,fun] =>
+    funNode := mkAtreeNode fun
+    transferPropsToNode(fun,funNode)
+    mms := CATCH('coerceOrCroaker, selectLocalMms(funNode,fun,argl,target))
+    CONSP mms =>
+      mms is [[['interpOnly,:.],:.]] => nil
+      mm := CAAR mms
+      mm is [., targ, :.] =>
+        targ = target => true
+        false
+      false
+    NIL
+  NIL
+
+canCoerceUnion(t1,t2) ==
+  -- sees if one can coerce to or from a Union Domain
+  -- assumes one of t1 and t2 is one
+
+  -- get the domains in the union, checking for tagged unions
+  if (isUnion1 := t1 is ['Union,:uds1]) then
+    unionDoms1 :=
+      uds1 and first uds1 is [":",:.] => [t for [.,.,t] in uds1]
+      uds1
+  if (isUnion2 := t2 is ['Union,:uds2]) then
+    unionDoms2 :=
+      uds2 and first uds2 is [":",:.] => [t for [.,.,t] in uds2]
+      uds2
+
+  isUnion2 =>
+    member(t1,unionDoms2) => true
+    isUnion1 =>
+      and/[or/[canCoerce(ud1,ud2) for ud2 in unionDoms2]
+        for ud1 in unionDoms1]
+    or/[canCoerce(t1,ud) for ud in unionDoms2]
+  -- next, a little lie
+  t1 is ['Union,d1, ='"failed"] and t2 = d1 => true
+  isUnion1 =>
+    and/[canCoerce(ud,t2) for ud in unionDoms1]
+  keyedSystemError("S2GE0016",['"canCoerceUnion",
+     '"called with 2 non-Unions"])
+
+canCoerceByMap(t1,t2) ==
+  -- idea is this: if t1 is D U1 and t2 is D U2, then look for
+  -- map: (U1 -> U2, D U1) -> D U2.  If it exists, then answer true
+  -- if canCoerceFrom(t1,t2).
+  u2 := deconstructT t2
+  1 = #u2 => NIL
+  u1 := deconstructT t1
+  1 = #u1 => NIL                             -- no under domain
+  CAR(u1) ^= CAR(u2) => NIL
+  top := CAAR u1
+  u1 := underDomainOf t1
+  u2 := underDomainOf t2
+
+  absolutelyCannotCoerce(u1,u2) => NIL
+
+  -- save some time for those we know about
+  know := '(List Vector Segment Stream UniversalSegment Array
+    Polynomial UnivariatePolynomial SquareMatrix Matrix)
+  top in know => canCoerce(u1,u2)
+
+  null selectMms1('map,t2,[['Mapping,u2,u1],t1],
+    [['Mapping,u2,u1],u1],NIL) => NIL
+  -- don't bother checking for Undef, so avoid instantiation
+  canCoerce(u1,u2)
+
+canCoerceTower(t1,t2) ==
+-- tries to find a coercion between top level t2 and somewhere inside t1
+-- builds new bubbled type, for which coercion is called recursively
+  canCoerceByMap(t1,t2) or newCanCoerceCommute(t1,t2) or
+   canCoerceLocal(t1,t2) or canCoercePermute(t1,t2) or
+    [c1,:arg1]:= deconstructT t1
+    arg1 and
+      TL:= NIL
+      arg:= arg1
+      until x or not arg repeat x:=
+        t:= last arg
+        [c,:arg]:= deconstructT t
+        TL:= [c,arg,:TL]
+        arg and coerceIntTest(t,t2) and
+          CDDR TL =>
+            s:= constructT(c1,replaceLast(arg1,bubbleConstructor TL))
+            canCoerceLocal(t1,s) and
+              [c2,:arg2]:= deconstructT last s
+              s1:= bubbleConstructor [c2,arg2,c1,arg1]
+              canCoerceCommute(s,s1) and canCoerceLocal(s1,t2)
+          s:= bubbleConstructor [c,arg,c1,arg1]
+          newCanCoerceCommute(t1,s) and canCoerceLocal(s,t2)
+      x
+
+canCoerceLocal(t1,t2) ==
+  -- test for coercion on top level
+  p:= ASSQ(CAR t1,$CoerceTable)
+  p and ASSQ(CAR t2,CDR p) is [.,:[tag,fun]] =>
+    tag='partial => NIL
+    tag='total   => true
+    (functionp(fun) and
+       (v:=CATCH('coerceFailure,FUNCALL(fun,'_$fromCoerceable_$,t1,t2)))
+         and v ^= $coerceFailure)  or  canCoerceByFunction(t1,t2)
+  canCoerceByFunction(t1,t2)
+
+canCoerceCommute(t1,t2) ==
+-- THIS IS OUT-MODED AND WILL GO AWAY SOON  RSS 2-87
+-- t1 is t2 with the two top level constructors commuted
+-- looks for the existence of a commuting function
+  CAR(t1) in (l := [$QuotientField, 'Gaussian]) and
+    CAR(t2) in l => true
+  p:= ASSQ(CAR t1,$CommuteTable)
+  p and ASSQ(CAR t2,CDR p) is [.,:['commute,.]]
+
+newCanCoerceCommute(t1,t2) ==
+  coerceIntCommute(objNewWrap("$fromCoerceable$",t1),t2)
+
+canCoercePermute(t1,t2) ==
+  -- try to generate a sequence of transpositions that will convert
+  -- t1 into t2
+  t2 in '((Integer) (OutputForm)) => NIL
+  towers := computeTTTranspositions(t1,t2)
+  -- at this point, CAR towers = t1 and last towers should be similar
+  -- to t2 in the sense that the components of t1 are in the same order
+  -- as in t2. If length towers = 2 and t2 = last towers, we quit to
+  -- avoid an infinte loop.
+  NULL towers or NULL CDR towers => NIL
+  NULL CDDR towers and t2 = CADR towers => NIL
+  -- do the coercions successively, quitting if any fail
+  ok := true
+  for t in CDR towers while ok repeat
+    ok := canCoerce(t1,t)
+    if ok then t1 := t
+  ok
+
+canConvertByFunction(m1,m2) ==
+  null $useConvertForCoercions => NIL
+  canCoerceByFunction1(m1,m2,'convert)
+
+canCoerceByFunction(m1,m2) == canCoerceByFunction1(m1,m2,'coerce)
+
+canCoerceByFunction1(m1,m2,fun) ==
+  -- calls selectMms with $Coerce=NIL and tests for required target=m2
+  $declaredMode:local:= NIL
+  $reportBottomUpFlag:local:= NIL
+  -- have to handle cases where we might have changed from RN to QF I
+  -- make 2 lists of expanded and unexpanded types
+  l1 := REMDUP [m1,eqType m1]
+  l2 := REMDUP [m2,eqType m2]
+  ans  := NIL
+  for t1 in l1 while not ans repeat
+    for t2 in l2 while not ans repeat
+      l := selectMms1(fun,t2,[t1],[t1],NIL)
+      ans := [x for x in l | x is [sig,:.] and CADR sig=t2 and
+       CADDR sig=t1 and
+        CAR(sig) isnt ['TypeEquivalence,:.]] and true
+  ans
+
+absolutelyCanCoerceByCheating(t1,t2) ==
+  -- this typically involves subdomains and towers where the only
+  -- difference is a subdomain
+  isEqualOrSubDomain(t1,t2) => true
+  typeIsASmallInteger(t1) and t2 = $Integer => true
+  ATOM(t1) or ATOM(t2) => false
+  [tl1,:u1] := deconstructT t1
+  [tl2,:u2] := deconstructT t2
+  tl1 = '(Stream) and tl2 = '(InfiniteTuple) =>
+    #u1 ^= #u2 => false
+    "and"/[absolutelyCanCoerceByCheating(x1,x2) for x1 in u1 for x2 in u2]
+  tl1 ^= tl2 => false
+  #u1 ^= #u2 => false
+  "and"/[absolutelyCanCoerceByCheating(x1,x2) for x1 in u1 for x2 in u2]
+
+absolutelyCannotCoerce(t1,t2) ==
+  -- response of true means "definitely cannot coerce"
+  -- this is largely an efficiency hack
+  ATOM(t1) or ATOM(t2) => NIL
+  t2 = '(None) => true
+  n1   := CAR t1
+  n2   := CAR t2
+  QFI  := [$QuotientField, $Integer]
+  int2 := isEqualOrSubDomain(t2,$Integer)
+  scalars := '(BigFloat NewFloat Float DoubleFloat RationalNumber)
+
+  MEMQ(n1,scalars) and int2 => true
+  (t1 = QFI) and int2       => true
+
+  num2 := int2 or MEMQ(n2,scalars) or (t2 = QFI)
+  isVar1 := MEMQ(n1,'(Variable Symbol))
+
+  num2 and isVar1 => true
+  num2 and MEMQ(n1,$univariateDomains) => true
+  num2 and MEMQ(n1,$multivariateDomains) => true
+  miscpols :=  '(Polynomial ElementaryFunction SimpleAlgebraicExtension)
+  num2 and MEMQ(n1,miscpols) => true
+
+  aggs :=  '(
+    Matrix List Vector Stream Array RectangularMatrix FiniteSet
+       )
+  u1 := underDomainOf t1
+  u2 := underDomainOf t2
+  MEMQ(n1,aggs) and (u1 = t2) => true
+  MEMQ(n2,aggs) and (u2 = t1) => true
+
+  algs :=  '(
+    SquareMatrix Gaussian RectangularMatrix Quaternion
+       )
+  nonpols := append(aggs,algs)
+  num2 and MEMQ(n1,nonpols) => true
+  isVar1 and MEMQ(n2,nonpols) and
+    absolutelyCannotCoerce(t1,u2) => true
+
+  (MEMQ(n1,scalars) or (t1 = QFI)) and (t2 = '(Polynomial (Integer))) =>
+    true
+
+  v2 := deconstructT t2
+  1 = #v2 => NIL
+  v1 := deconstructT t1
+  1 = #v1 => NIL
+  CAR(v1) ^= CAR(v2) => NIL
+  absolutelyCannotCoerce(u1,u2)
+
+typeIsASmallInteger x == (x = $SingleInteger)
+
+
+--% Interpreter Coercion Functions
+
+coerceInteractive(triple,t2) ==
+  -- bind flag for recording/reporting instantiations
+  -- (see recordInstantiation)
+  t1 := objMode triple
+  val := objVal triple
+  null(t2) or t2 = $EmptyMode => NIL
+  t2 = t1 => triple
+  t2 = '$NoValueMode => objNew(val,t2)
+  if t2 is ['SubDomain,x,.] then t2:= x
+  -- JHD added category Aug 1996 for BasicMath
+  t1 in '((Category) (Mode) (Domain) (SubDomain (Domain))) =>
+    t2 = $OutputForm => objNew(val,t2)
+    NIL
+  t1 = '$NoValueMode =>
+    if $compilingMap then clearDependentMaps($mapName,nil)
+    throwKeyedMsg("S2IC0009",[t2,$mapName])
+  $insideCoerceInteractive: local := true
+  expr2 := EQUAL(t2,$OutputForm)
+  if expr2 then startTimingProcess 'print
+  else startTimingProcess 'coercion
+  -- next 2 lines handle cases like '"failed"
+  result :=
+    expr2 and (t1 = val) => objNew(val,$OutputForm)
+    expr2 and t1 is ['Variable,var] => objNewWrap(var,$OutputForm)
+    coerceInt0(triple,t2)
+  if expr2 then stopTimingProcess 'print
+  else stopTimingProcess 'coercion
+  result
+
+coerceInt0(triple,t2) ==
+  -- top level interactive coercion, which transfers all RN, RF and RR
+  -- into equivalent types
+  val := objVal triple
+  t1  := objMode triple
+
+  val='_$fromCoerceable_$ => canCoerceFrom(t1,t2)
+  t1 = t2 => triple
+  if t2 = $OutputForm then
+    s1 := t1
+    s2 := t2
+  else
+    s1 := equiType(t1)
+    s2 := equiType(t2)
+    s1 = s2 => return objNew(val,t2)
+  -- t1 is ['Mapping,:.] and t2 ^= '(Any) => NIL
+  -- note: may be able to coerce TO mapping
+  -- treat Exit like Any
+  -- handle case where we must generate code
+  null(isWrapped val) and
+    (t1 isnt ['FunctionCalled,:.] or not $genValue)=>
+      intCodeGenCOERCE(triple,t2)
+  t1 = $Any and t2 ^= $OutputForm and ([t1',:val'] := unwrap val) and
+    (ans := coerceInt0(objNewWrap(val',t1'),t2)) => ans
+  if not EQ(s1,t1) then triple := objNew(val,s1)
+  x := coerceInt(triple,s2) =>
+    EQ(s2,t2) => x
+    objSetMode(x,t2)
+    x
+  NIL
+
+coerceInt(triple, t2) ==
+  val := coerceInt1(triple, t2) => val
+  t1 := objMode triple
+  t1 is ['Variable, :.] =>
+    newMode := getMinimalVarMode(unwrap objVal triple, nil)
+    newVal := coerceInt(triple, newMode)
+    coerceInt(newVal, t2)
+  nil
+
+coerceInt1(triple,t2) ==
+  -- general interactive coercion
+  -- the result is a new triple with type m2 or NIL (= failed)
+  $useCoerceOrCroak: local := true
+  t2 = $EmptyMode => NIL
+  t1 := objMode triple
+  t1=t2 => triple
+  val := objVal triple
+  absolutelyCanCoerceByCheating(t1,t2) => objNew(val,t2)
+  isSubDomain(t2, t1) => coerceSubDomain(val, t1, t2)
+
+  if typeIsASmallInteger(t1) then
+    (t2 = $Integer) or typeIsASmallInteger(t2) => return objNew(val,t2)
+    sintp := SINTP val
+    sintp and (t2 = $PositiveInteger) and val > 0 => return objNew(val,t2)
+    sintp and (t2 = $NonNegativeInteger) and val >= 0 => return objNew(val,t2)
+
+  typeIsASmallInteger(t2) and isEqualOrSubDomain(t1, $Integer) and INTP val =>
+    SINTP val => objNew(val,t2)
+    NIL
+
+  t2 = $Void => objNew(voidValue(),$Void)
+  t2 = $Any => objNewWrap([t1,:unwrap val],'(Any))
+
+  t1 = $Any and t2 ^= $OutputForm and ([t1',:val'] := unwrap val) and
+    (ans := coerceInt(objNewWrap(val',t1'),t2)) => ans
+
+  -- next is for tagged union selectors for the time being
+  t1 is ['Variable,=t2] or t2 is ['Variable,=t1] => objNew(val,t2)
+
+  STRINGP t2 =>
+    t1 is ['Variable,v] and (t2 = PNAME(v)) => objNewWrap(t2,t2)
+    val' := unwrap val
+    (t2 = val') and ((val' = t1) or (t1 = $String)) => objNew(val,t2)
+    NIL
+  --  t1 is ['Tuple,S] and t2 ^= '(OutputForm) =>
+  t1 is ['Tuple,S]  =>
+    coerceInt1(objNewWrap(asTupleAsList unwrap val, ['List, S]), t2)
+  t1 is ['Union,:.] => coerceIntFromUnion(triple,t2)
+  t2 is ['Union,:.] => coerceInt2Union(triple,t2)
+  (STRINGP t1) and (t2 = $String) => objNew(val,$String)
+  (STRINGP t1) and (t2 is ['Variable,v]) =>
+    t1 = PNAME(v) => objNewWrap(v,t2)
+    NIL
+  (STRINGP t1) and (t1 = unwrap val) =>
+    t2 = $OutputForm => objNew(t1,$OutputForm)
+    NIL
+  atom t1 => NIL
+
+  if t1 = $AnonymousFunction and (t2 is ['Mapping,target,:margl]) then
+    $useCoerceOrCroak := nil
+    [.,vars,:body] := unwrap val
+    vars :=
+      atom vars => [vars]
+      vars is ['Tuple,:.] => rest vars
+      vars
+    #margl ^= #vars => 'continue
+    tree := mkAtree ['ADEF,vars,[target,:margl],[NIL for x in rest t2],:body]
+    CATCH('coerceOrCroaker, bottomUp tree) = 'croaked => nil
+    return getValue tree
+
+  (t1 = $Symbol) and (t2 is ['Mapping,target,:margl]) =>
+    null (mms := selectMms1(unwrap val,nil,margl,margl,target)) => NIL
+    [dc,targ,:argl] := CAAR mms
+    targ ^= target => NIL
+    $genValue =>
+      fun := getFunctionFromDomain(unwrap val,dc,argl)
+      objNewWrap(fun,t2)
+    val := NRTcompileEvalForm(unwrap val, CDR CAAR mms, evalDomain dc)
+    objNew(val, t2)
+  (t1 is ['Variable,sym]) and (t2 is ['Mapping,target,:margl]) =>
+    null (mms := selectMms1(sym,target,margl,margl,NIL)) => 
+       null (mms := selectMms1(sym,target,margl,margl,true)) => NIL
+    [dc,targ,:argl] := CAAR mms
+    targ ^= target => NIL
+    dc is ["__FreeFunction__",:freeFun] => objNew( freeFun, t2 )
+    $genValue => objNewWrap( getFunctionFromDomain(sym,dc,argl), t2 )
+    val := NRTcompileEvalForm(sym, CDR CAAR mms, evalDomain dc)
+    objNew(val, t2)
+  (t1 is ['FunctionCalled,sym]) and (t2 is ['Mapping,target,:margl]) =>
+    symNode := mkAtreeNode sym
+    transferPropsToNode(sym,symNode)
+    null (mms := selectLocalMms(symNode,sym,margl,target)) => NIL
+    [dc,targ,:argl] := CAAR mms
+    targ ^= target => NIL
+    ml := [target,:margl]
+    intName :=
+      or/[mm for mm in mms | (mm is [[., :ml1],oldName,:.]
+        and compareTypeLists(ml1,ml))] => [oldName]
+      NIL
+    null intName => NIL
+    objNewWrap(intName,t2)
+  (t1 is ['FunctionCalled,sym]) =>
+    (t3 := get(sym,'mode,$e)) and t3 is ['Mapping,:.] =>
+      (triple' := coerceInt(triple,t3)) => coerceInt(triple',t2)
+      NIL
+    NIL
+
+  EQ(CAR(t1),'Variable) and PAIRP(t2) and
+    (isEqualOrSubDomain(t2,$Integer) or
+      (t2 = [$QuotientField, $Integer]) or MEMQ(CAR(t2),
+        '(RationalNumber BigFloat NewFloat Float DoubleFloat))) => NIL
+
+  ans := coerceRetract(triple,t2) or coerceIntTower(triple,t2) or
+    [.,:arg]:= deconstructT t2
+    arg and
+      t:= coerceInt(triple,last arg)
+      t and coerceByFunction(t,t2)
+  ans or (isSubDomain(t1,$Integer) and
+    coerceInt(objNew(val,$Integer),t2)) or
+      coerceIntAlgebraicConstant(triple,t2) or
+        coerceIntX(val,t1,t2)
+
+coerceSubDomain(val, tSuper, tSub) ==
+  -- Try to coerce from a sub domain to a super domain
+  val = '_$fromCoerceable_$ => nil
+  super := GETDATABASE(first tSub, 'SUPERDOMAIN)
+  superDomain := first super
+  superDomain = tSuper =>
+    coerceImmediateSubDomain(val, tSuper, tSub, CADR super)
+  coerceSubDomain(val, tSuper, superDomain) =>
+    coerceImmediateSubDomain(val, superDomain, tSub, CADR super)
+  nil
+
+coerceImmediateSubDomain(val, tSuper, tSub, pred) ==
+  predfn := getSubDomainPredicate(tSuper, tSub, pred)
+  FUNCALL(predfn, val, nil) => objNew(val, tSub)
+  nil
+
+getSubDomainPredicate(tSuper, tSub, pred) ==
+  $env: local := $InteractiveFrame
+  predfn := HGET($superHash, CONS(tSuper, tSub)) => predfn
+  name := GENSYM()
+  decl := ['_:, name, ['Mapping, $Boolean, tSuper]]
+  interpret(decl, nil)
+  arg := GENSYM()
+  pred' := SUBST(arg, "#1", pred)
+  defn := ['DEF, [name, arg], '(NIL NIL), '(NIL NIL), removeZeroOne pred']
+  interpret(defn, nil)
+  op := mkAtree name
+  transferPropsToNode(name, op)
+  predfn := CADAR selectLocalMms(op, name, [tSuper],$Boolean)
+  HPUT($superHash, CONS(tSuper, tSub), predfn)
+  predfn
+
+coerceIntX(val,t1, t2) ==
+  -- some experimental things
+  t1 = '(List (None)) =>
+    -- this will almost always be an empty list
+    null unwrap val =>
+      -- try getting a better flavor of List
+      null (t0 := underDomainOf(t2)) => NIL
+      coerceInt(objNewWrap(val,['List,t0]),t2)
+    NIL
+  NIL
+
+compareTypeLists(tl1,tl2) ==
+  -- returns true if every type in tl1 is = or is a subdomain of
+  -- the corresponding type in tl2
+  for t1 in tl1 for t2 in tl2 repeat
+    null isEqualOrSubDomain(t1,t2) => return NIL
+  true
+
+coerceIntAlgebraicConstant(object,t2) ==
+  -- should use = from domain, but have to check on defaults code
+  t1 := objMode object
+  val := objValUnwrap object
+  ofCategory(t1,'(Monoid)) and ofCategory(t2,'(Monoid)) and
+    val = getConstantFromDomain('(One),t1) =>
+      objNewWrap(getConstantFromDomain('(One),t2),t2)
+  ofCategory(t1,'(AbelianMonoid)) and ofCategory(t2,'(AbelianMonoid)) and
+    val = getConstantFromDomain('(Zero),t1) =>
+      objNewWrap(getConstantFromDomain('(Zero),t2),t2)
+  NIL
+
+stripUnionTags doms ==
+  [if dom is [":",.,dom'] then dom' else dom for dom in doms]
+
+isTaggedUnion u ==
+  u is ['Union,:tl] and tl and first tl is [":",.,.] and true
+
+getUnionOrRecordTags u ==
+  tags := nil
+  if u is ['Union, :tl] or u is ['Record, :tl] then
+      for t in tl repeat
+         if t is [":",tag,.] then tags := cons(tag, tags)
+  tags
+
+coerceUnion2Branch(object) ==
+  [.,:unionDoms] := objMode object
+  doms := orderUnionEntries unionDoms
+  predList:= mkPredList doms
+  doms := stripUnionTags doms
+  val' := objValUnwrap object
+  predicate := NIL
+  targetType:= NIL
+  for typ in doms for pred in predList while ^targetType repeat
+    evalSharpOne(pred,val') =>
+      predicate := pred
+      targetType := typ
+  null targetType => keyedSystemError("S2IC0013",NIL)
+  predicate is ['EQCAR,.,p] => objNewWrap(CDR val',targetType)
+  objNew(objVal object,targetType)
+
+coerceBranch2Union(object,union) ==
+  -- assumes type is a member of unionDoms
+  unionDoms := CDR union
+  doms := orderUnionEntries unionDoms
+  predList:= mkPredList doms
+  doms := stripUnionTags doms
+  p := position(objMode object,doms)
+  p = -1 => keyedSystemError("S2IC0014",[objMode object,union])
+  val := objVal object
+  predList.p is ['EQCAR,.,tag] =>
+    objNewWrap([removeQuote tag,:unwrap val],union)
+  objNew(val,union)
+
+coerceInt2Union(object,union) ==
+  -- coerces to a Union type, adding numeric tags
+  -- first cut
+  unionDoms := stripUnionTags CDR union
+  t1 := objMode object
+  member(t1,unionDoms) => coerceBranch2Union(object,union)
+  val := objVal object
+  val' := unwrap val
+  (t1 = $String) and member(val',unionDoms) =>
+    coerceBranch2Union(objNew(val,val'),union)
+  noCoerce := true
+  val' := nil
+  for d in unionDoms while noCoerce repeat
+    (val' := coerceInt(object,d)) => noCoerce := nil
+  val' => coerceBranch2Union(val',union)
+  NIL
+
+coerceIntFromUnion(object,t2) ==
+  -- coerces from a Union type to something else
+  coerceInt(coerceUnion2Branch object,t2)
+
+coerceIntByMap(triple,t2) ==
+  -- idea is this: if t1 is D U1 and t2 is D U2, then look for
+  -- map: (U1 -> U2, D U1) -> D U2.  If it exists, then create a
+  -- function to do the coercion on the element level and call the
+  -- map function.
+  t1 := objMode triple
+  t2 = t1 => triple
+  u2 := deconstructT t2    -- compute t2 first because of Expression
+  1 = #u2 => NIL           -- no under domain
+  u1 := deconstructT t1
+  1 = #u1 => NIL
+  CAAR u1 ^= CAAR u2 => nil  -- constructors not equal
+  ^valueArgsEqual?(t1, t2) => NIL
+--  CAR u1 ^= CAR u2 => NIL
+  top := CAAR u1
+  u1 := underDomainOf t1
+  u2 := underDomainOf t2
+
+  -- handle a couple of special cases for subdomains of Integer
+  top in '(List Vector Segment Stream UniversalSegment Array)
+    and isSubDomain(u1,u2) => objNew(objVal triple, t2)
+
+  args := [['Mapping,u2,u1],t1]
+  if $reportBottomUpFlag then
+    sayFunctionSelection('map,args,t2,NIL,
+      '"coercion facility (map)")
+  mms := selectMms1('map,t2,args,args,NIL)
+  if $reportBottomUpFlag then
+    sayFunctionSelectionResult('map,args,mms)
+  null mms => NIL
+
+  [[dc,:sig],slot,.]:= CAR mms
+  fun := compiledLookup('map,sig,evalDomain(dc))
+  NULL fun => NIL
+  [fn,:d]:= fun
+  fn = function Undef => NIL
+  -- now compile a function to do the coercion
+  code := ['SPADCALL,['CONS,["function","coerceIntByMapInner"],MKQ [u1,:u2]],
+    wrapped2Quote objVal triple,MKQ fun]
+  -- and apply the function
+  val := CATCH('coerceFailure,timedEvaluate code)
+  (val = $coerceFailure) => NIL
+  objNewWrap(val,t2)
+
+coerceIntByMapInner(arg,[u1,:u2]) == coerceOrThrowFailure(arg,u1,u2)
+-- [u1,:u2] gets passed as the "environment", which is why we have this
+-- slightly clumsy locution  JHD 31.July,1990
+
+valueArgsEqual?(t1, t2) ==
+  -- returns true if the object-valued arguments to t1 and t2 are the same
+  -- under coercion
+  coSig := CDR GETDATABASE(CAR t1, 'COSIG)
+  constrSig := CDR getConstructorSignature CAR t1
+  tl1 := replaceSharps(constrSig, t1)
+  tl2 := replaceSharps(constrSig, t2)
+  not MEMQ(NIL, coSig) => true
+  done := false
+  value := true
+  for a1 in CDR t1 for a2 in CDR t2 for cs in coSig
+    for m1 in tl1 for m2 in tl2 while not done repeat
+          ^cs =>
+            trip := objNewWrap(a1, m1)
+            newVal := coerceInt(trip, m2)
+            null newVal => (done := true; value := false)
+            ^algEqual(a2, objValUnwrap newVal, m2) =>
+              (done := true; value := false)
+  value
+
+coerceIntTower(triple,t2) ==
+  -- tries to find a coercion from top level t2 to somewhere inside t1
+  -- builds new argument type, for which coercion is called recursively
+  x := coerceIntByMap(triple,t2) => x
+  x := coerceIntCommute(triple,t2) => x
+  x := coerceIntPermute(triple,t2) => x
+  x := coerceIntSpecial(triple,t2) => x
+  x := coerceIntTableOrFunction(triple,t2) => x
+  t1 := objMode triple
+  [c1,:arg1]:= deconstructT t1
+  arg1 and
+    TL:= NIL
+    arg:= arg1
+    until x or not arg repeat
+      t:= last arg
+      [c,:arg]:= deconstructT t
+      TL:= [c,arg,:TL]
+      x := arg and coerceIntTest(t,t2) =>
+        CDDR TL =>
+          s := constructT(c1,replaceLast(arg1,bubbleConstructor TL))
+          (null isValidType(s)) => (x := NIL)
+          x := (coerceIntByMap(triple,s) or
+            coerceIntTableOrFunction(triple,s)) =>
+              [c2,:arg2]:= deconstructT last s
+              s:= bubbleConstructor [c2,arg2,c1,arg1]
+              (null isValidType(s)) => (x := NIL)
+              x:= coerceIntCommute(x,s) =>
+                x := (coerceIntByMap(x,t2) or
+                  coerceIntTableOrFunction(x,t2))
+        s:= bubbleConstructor [c,arg,c1,arg1]
+        (null isValidType(s)) => (x := NIL)
+        x:= coerceIntCommute(triple,s) =>
+          x:= (coerceIntByMap(x,t2) or
+            coerceIntTableOrFunction(x,t2))
+    x
+
+coerceIntSpecial(triple,t2) ==
+  t1 := objMode triple
+  t2 is ['SimpleAlgebraicExtension,R,U,.] and t1 = R =>
+    null (x := coerceInt(triple,U)) => NIL
+    coerceInt(x,t2)
+  NIL
+
+coerceIntTableOrFunction(triple,t2) ==
+  -- this function does the actual coercion to t2, but not to an
+  -- argument type of t2
+  null isValidType t2 => NIL  -- added 9-18-85 by RSS
+  null isLegitimateMode(t2,NIL,NIL) => NIL  -- added 6-28-87 by RSS
+  t1 := objMode triple
+  p:= ASSQ(CAR t1,$CoerceTable)
+  p and ASSQ(CAR t2,CDR p) is [.,:[tag,fun]] =>
+    val := objVal triple
+    fun='Identity => objNew(val,t2)
+    tag='total =>
+      coerceByTable(fun,val,t1,t2,'T) or coerceByFunction(triple,t2)
+    coerceByTable(fun,val,t1,t2,NIL) or coerceByFunction(triple,t2)
+  coerceByFunction(triple,t2)
+
+coerceCommuteTest(t1,t2) ==
+  null isLegitimateMode(t2,NIL,NIL) => NIL
+
+  -- sees whether t1 = D1 D2 R and t2 = D2 D1 S
+  null (u1 := underDomainOf t1) => NIL
+  null (u2 := underDomainOf t2) => NIL
+
+  -- must have underdomains (ie, R and S must be there)
+
+  null (v1 := underDomainOf u1) => NIL
+  null (v2 := underDomainOf u2) => NIL
+
+  -- now check that cross of constructors is correct
+  (CAR(deconstructT t1) = CAR(deconstructT u2)) and
+    (CAR(deconstructT t2) = CAR(deconstructT u1))
+
+coerceIntCommute(obj,target) ==
+  -- note that the value in obj may be $fromCoerceable$, for canCoerce
+  source := objMode obj
+  null coerceCommuteTest(source,target) => NIL
+  S := underDomainOf source
+  T := underDomainOf target
+  source = T => NIL      -- handle in other ways
+
+  source is [D,:.] =>
+    fun := GETL(D,'coerceCommute) or
+           INTERN STRCONC('"commute",STRINGIMAGE D)
+    functionp fun =>
+      PUT(D,'coerceCommute,fun)
+      u := objValUnwrap obj
+      c := CATCH('coerceFailure,FUNCALL(fun,u,source,S,target,T))
+      (c = $coerceFailure) => NIL
+      u = "$fromCoerceable$" => c
+      objNewWrap(c,target)
+    NIL
+  NIL
+
+coerceIntPermute(object,t2) ==
+  t2 in '((Integer) (OutputForm)) => NIL
+  t1 := objMode object
+  towers := computeTTTranspositions(t1,t2)
+  -- at this point, CAR towers = t1 and last towers should be similar
+  -- to t2 in the sense that the components of t1 are in the same order
+  -- as in t2. If length towers = 2 and t2 = last towers, we quit to
+  -- avoid an infinte loop.
+  NULL towers or NULL CDR towers => NIL
+  NULL CDDR towers and t2 = CADR towers => NIL
+  -- do the coercions successively, quitting if any fail
+  ok := true
+  for t in CDR towers while ok repeat
+    null (object := coerceInt(object,t)) => ok := NIL
+  ok => object
+  NIL
+
+computeTTTranspositions(t1,t2) ==
+  -- decompose t1 into its tower parts
+  tl1 := decomposeTypeIntoTower t1
+  tl2 := decomposeTypeIntoTower t2
+  -- if not at least 2 parts, don't bother working here
+  null (rest tl1 and rest tl2) => NIL
+  -- determine the relative order of the parts of t1 in t2
+  p2 := [position(d1,tl2) for d1 in tl1]
+  member(-1,p2) => NIL            -- something not present
+  -- if they are all ascending, this function will do nothing
+  p2' := MSORT p2
+  p2 = p2' => NIL
+  -- if anything is repeated twice, leave
+  p2' ^= MSORT REMDUP p2' => NIL
+  -- create a list of permutations that transform the tower parts
+  -- of t1 into the order they are in in t2
+  n1 := #tl1
+  p2 := LIST2VEC compress(p2,0,# REMDUP tl1) where
+    compress(l,start,len) ==
+      start >= len => l
+      member(start,l) => compress(l,start+1,len)
+      compress([(i < start => i; i - 1) for i in l],start,len)
+  -- p2 now has the same position numbers as p1, we need to determine
+  -- a list of permutations that takes p1 into p2.
+  -- them
+  perms := permuteToOrder(p2,n1-1,0)
+  towers := [tl1]
+  tower := LIST2VEC tl1
+  for perm in perms repeat
+    t := tower.(CAR perm)
+    tower.(CAR perm) := tower.(CDR perm)
+    tower.(CDR perm) := t
+    towers := CONS(VEC2LIST tower,towers)
+  towers := [reassembleTowerIntoType tower for tower in towers]
+  if CAR(towers) ^= t2 then towers := cons(t2,towers)
+  NREVERSE towers
+
+decomposeTypeIntoTower t ==
+  ATOM t => [t]
+  d := deconstructT t
+  NULL rest d => [t]
+  rd := REVERSE t
+  [reverse QCDR rd,:decomposeTypeIntoTower QCAR rd]
+
+reassembleTowerIntoType tower ==
+  ATOM tower => tower
+  NULL rest tower => CAR tower
+  [:top,t,s] := tower
+  reassembleTowerIntoType [:top,[:t,s]]
+
+permuteToOrder(p,n,start) ==
+  -- p is a vector of the numbers 0..n. This function returns a list
+  -- of swaps of adjacent elements so that p will be in order. We only
+  -- begin looking at index start
+  r := n - start
+  r <= 0 => NIL
+  r = 1 =>
+    p.r < p.(r+1) => NIL
+    [[r,:(r+1)]]
+  p.start = start => permuteToOrder(p,n,start+1)
+  -- bubble up element start to the top. Find out where it is
+  stpos := NIL
+  for i in start+1..n while not stpos repeat
+    if p.i = start then stpos := i
+  perms := NIL
+  while stpos ^= start repeat
+    x := stpos - 1
+    perms := [[x,:stpos],:perms]
+    t := p.stpos
+    p.stpos := p.x
+    p.x := t
+    stpos := x
+  APPEND(NREVERSE perms,permuteToOrder(p,n,start+1))
+
+coerceIntTest(t1,t2) ==
+  -- looks whether there exists a table entry or a coercion function
+  -- thus the type can be bubbled before coerceIntTableOrFunction is called
+  t1=t2 or
+    b:=
+      p:= ASSQ(CAR t1,$CoerceTable)
+      p and ASSQ(CAR t2,CDR p)
+    b or coerceConvertMmSelection('coerce,t1,t2) or
+      ($useConvertForCoercions and
+        coerceConvertMmSelection('convert,t1,t2))
+
+coerceByTable(fn,x,t1,t2,isTotalCoerce) ==
+  -- catch point for 'failure in boot coercions
+  t2 = $OutputForm and ^(newType? t1) => NIL
+  isWrapped x =>
+    x:= unwrap x
+    c:= CATCH('coerceFailure,FUNCALL(fn,x,t1,t2))
+    c=$coerceFailure => NIL
+    objNewWrap(c,t2)
+  isTotalCoerce => objNew([fn,x,MKQ t1,MKQ t2],t2)
+  objNew(['catchCoerceFailure,MKQ fn,x,MKQ t1,MKQ t2],t2)
+
+catchCoerceFailure(fn,x,t1,t2) ==
+  -- compiles a catchpoint for compiling boot coercions
+  c:= CATCH('coerceFailure,FUNCALL(fn,x,t1,t2))
+  c = $coerceFailure =>
+    throwKeyedMsgCannotCoerceWithValue(wrap unwrap x,t1,t2)
+  c
+
+coercionFailure() ==
+  -- does the throw on coercion failure
+  THROW('coerceFailure,$coerceFailure)
+
+--------------------> NEW DEFINITION (override in xrun.boot.pamphlet)
+coerceByFunction(T,m2) ==
+  -- using the new modemap selection without coercions
+  -- should not be called by canCoerceFrom
+  x := objVal T
+  x = '_$fromCoerceable_$ => NIL
+  m2 is ['Union,:.] => NIL
+  m1 := objMode T
+  m2 is ['Boolean,:.] and m1 is ['Equation,ud] =>
+    dcVector := evalDomain ud
+    fun :=
+      isWrapped x =>
+        NRTcompiledLookup("=", [$Boolean, ud, ud], dcVector)
+      NRTcompileEvalForm("=", [$Boolean, ud, ud], dcVector)
+    [fn,:d]:= fun
+    isWrapped x =>
+      x:= unwrap x
+      objNewWrap(SPADCALL(CAR x,CDR x,fun),m2)
+    x isnt ['SPADCALL,a,b,:.] => keyedSystemError("S2IC0015",NIL)
+    code := ['SPADCALL, a, b, fun]
+    objNew(code,$Boolean)
+  -- If more than one function is found, any should suffice, I think -scm
+  if not (mm := coerceConvertMmSelection(funName := 'coerce,m1,m2)) then
+    mm := coerceConvertMmSelection(funName := 'convert,m1,m2)
+  mm =>
+    [[dc,tar,:args],slot,.]:= mm
+    dcVector := evalDomain(dc)
+    fun:=
+      isWrapped x =>
+        NRTcompiledLookup(funName,[tar,:args],dcVector)
+      NRTcompileEvalForm(funName,[tar,:args],dcVector)
+    [fn,:d]:= fun
+    fn = function Undef => NIL
+    isWrapped x =>
+      $: fluid := dcVector
+      val := CATCH('coerceFailure, SPADCALL(unwrap x,fun))
+      (val = $coerceFailure) => NIL
+      objNewWrap(val,m2)
+    env := fun
+    code := ['failCheck, ['SPADCALL, x, env]]
+--  tar is ['Union,:.] => objNew(['failCheck,code],m2)
+    objNew(code,m2)
+  -- try going back to types like RN instead of QF I
+  m1' := eqType m1
+  m2' := eqType m2
+  (m1 ^= m1') or (m2 ^= m2') => coerceByFunction(objNew(x,m1'),m2')
+  NIL
+
+hasCorrectTarget(m,sig is [dc,tar,:.]) ==
+  -- tests whether the target of signature sig is either m or a union
+  -- containing m. It also discards TEQ as it is not meant to be
+  -- used at top-level
+  dc is ['TypeEquivalence,:.] => NIL
+  m=tar => 'T
+  tar is ['Union,t,'failed] => t=m
+  tar is ['Union,'failed,t] and t=m
+
+@
+\eject
+\begin{thebibliography}{99}
+\bibitem{1} nothing
+\end{thebibliography}
+\end{document}