path: root/src/interp/i-coerce.boot

-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
-- All rights reserved.
-- Copyright (C) 2007-2008, Gabriel Dos Reis.
-- 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.


import i_-analy
import i_-resolv
namespace BOOT

$useCoerceOrCroak := true
$useConvertForCoercions := false

--%  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] =>
    atom val' => nil          -- certainly not a fraction
    [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(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)


domainOne(domain) == getConstantFromDomain('(One),domain)

domainZero(domain) == getConstantFromDomain('(Zero),domain)

equalOne(object, domain) ==
  -- tries using constant One and "=" from domain
  -- object should not be wrapped
  algEqual(object, getConstantFromDomain('(One),domain), domain)

equalZero(object, domain) ==
  -- tries using constant Zero and "=" from domain
  -- object should not be wrapped
  algEqual(object, getConstantFromDomain('(Zero),domain), domain)

algEqual(object1, object2, domain) ==
  -- sees if 2 objects of the same domain are equal by using the
  -- "=" from the domain
  -- objects should not be wrapped
--  eqfunc := getFunctionFromDomain("=",domain,[domain,domain])
  eqfunc := compiledLookupCheck("=",[$Boolean,'$,'$],evalDomain domain)
  SPADCALL(object1,object2, eqfunc)

--%  main algorithms for canCoerceFrom and coerceInteractive

-- coerceInteractive and canCoerceFrom are the two coercion functions
-- for $InteractiveMode. They translate RN, RF and RR to QF I, QF P
-- and RE RN, respectively, and call coerceInt or canCoerce, which
-- both work in the same way (e.g. coercion from t1 to t2):

-- 1. they try to coerce t1 to t2 directly (tower coercion), and, if
--   this fails, to coerce t1 to the last argument of t2 and embed
--   this last argument into t2. These embedding functions are now only
--   defined in the algebra code. (RSS 2-27-87)

-- 2. the tower coercion looks whether there is any applicable local
--   coercion, which means, one defined in boot or in algebra code.
--   If there is an applicable function from a constructor, which is
--   inside the type tower of t1, to the top level constructor of t2,
--   then this constructor is bubbled up inside t1. This means,
--   special coercion functions (defined in boot) are called, which
--   commute two constructors in a tower. Then the local coercion is
--   called on these constructors, which both are on top level now.

-- example:
-- let t1 = A B C D E (short for (A (B (C (D (E))))), where A ... E are
--   type constructors), and t2 = F D G H I J
-- there is no coercion from t1 to t2 directly, so we try to coerce
--   t1 to s1 = D G H I J, the last argument of t2
-- we create the type s2 = A D B C E and call a local coercion A2A
--   from t1 to s2, which, by recursively calling coerce, bubbles up
--   the constructor D
-- then we call a commute coerce from s2 to s3 = D A B C E and a local
--   coerce D2D from s3 to s1
-- finally we embed s1 into t2, which completes the coercion t1 to t2

-- the result of canCoerceFrom is TRUE or NIL
-- the result of coerceInteractive is a object or NIL (=failed)
-- all boot coercion functions have the following result:
-- 1. if u=$fromCoerceable$, then TRUE or NIL
-- 2. if the coercion succeeds, the coerced value (this may be NIL)
-- 3. if the coercion fails, they throw to a catch point in
--      coerceByFunction

--% Interpreter Coercion Query Functions

canCoerce1(t1,t2) ==
  -- general test for coercion
  -- the result is NIL if it fails
  t1 = t2 => true
  absolutelyCanCoerceByCheating(t1,t2) or t1 = $None or t2 = $Any or
    member(t1,'((Mode) (Category))) =>
      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 member(t1,'((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
  member(t2,'((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
  member(t1,$LangSupportTypes) =>
    t2 = $OutputForm => objNew(val,t2)
    t1 = $Domain and conceptualType t2 = $Category 
      and ofCategory(val,t2)=> objNew(val,t2)
    conceptualType t1 = t2 => 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 ['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 := getSuperDomainFromDB first tSub
  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' := substitute(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

++ returns true if `val' belongs to the Union branch guarded by `pred'.
thisUnionBranch?: (%Code,%Thing) -> %Boolean
thisUnionBranch?(pred,val) ==
  eval ["LET",[["#1",MKQ val]],pred]

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
    thisUnionBranch?(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]],
    getValueNormalForm 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 := rest getDualSignatureFromDB first t1
  constrSig := rest getConstructorSignature first t1
  tl1 := replaceSharps(constrSig, t1)
  tl2 := replaceSharps(constrSig, t2)
  not MEMQ(NIL, coSig) => true
  done := false
  value := true
  for a1 in rest t1 for a2 in rest t2 for cs in coSig
    for m1 in tl1 for m2 in tl2 while not done repeat
          not cs =>
            trip := objNewWrap(a1, m1)
            newVal := coerceInt(trip, m2)
            null newVal => (done := true; value := false)
            not 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) ==
  member(t2,'((Integer) (OutputForm))) => NIL
  t1 := objMode object
  towers := computeTTTranspositions(t1,t2)
  -- at this point, CAR towers = t1 and last towers should be similar
  -- to t2 in the sense that the components of t1 are in the same order
  -- as in t2. If length towers = 2 and t2 = last towers, we quit to
  -- avoid an infinte loop.
  NULL towers or NULL CDR towers => NIL
  NULL CDDR towers and t2 = CADR towers => NIL
  -- do the coercions successively, quitting if any fail
  ok := true
  for t in CDR towers while ok repeat
    null (object := coerceInt(object,t)) => ok := NIL
  ok => object
  NIL

computeTTTranspositions(t1,t2) ==
  -- decompose t1 into its tower parts
  tl1 := decomposeTypeIntoTower t1
  tl2 := decomposeTypeIntoTower t2
  -- if not at least 2 parts, don't bother working here
  null (rest tl1 and rest tl2) => NIL
  -- determine the relative order of the parts of t1 in t2
  p2 := [position(d1,tl2) for d1 in tl1]
  member(-1,p2) => NIL            -- something not present
  -- if they are all ascending, this function will do nothing
  p2' := MSORT p2
  p2 = p2' => NIL
  -- if anything is repeated twice, leave
  p2' ^= MSORT REMDUP p2' => NIL
  -- create a list of permutations that transform the tower parts
  -- of t1 into the order they are in in t2
  n1 := #tl1
  p2 := LIST2VEC compress(p2,0,# REMDUP tl1) where
    compress(l,start,len) ==
      start >= len => l
      member(start,l) => compress(l,start+1,len)
      compress([(i < start => i; i - 1) for i in l],start,len)
  -- p2 now has the same position numbers as p1, we need to determine
  -- a list of permutations that takes p1 into p2.
  -- them
  perms := permuteToOrder(p2,n1-1,0)
  towers := [tl1]
  tower := LIST2VEC tl1
  for perm in perms repeat
    t := tower.(CAR perm)
    tower.(CAR perm) := tower.(CDR perm)
    tower.(CDR perm) := t
    towers := CONS(VEC2LIST tower,towers)
  towers := [reassembleTowerIntoType tower for tower in towers]
  if CAR(towers) ^= t2 then towers := cons(t2,towers)
  NREVERSE towers

decomposeTypeIntoTower t ==
  ATOM t => [t]
  d := deconstructT t
  NULL rest d => [t]
  rd := REVERSE t
  [reverse QCDR rd,:decomposeTypeIntoTower QCAR rd]

reassembleTowerIntoType tower ==
  ATOM tower => tower
  NULL rest tower => CAR tower
  [:top,t,s] := tower
  reassembleTowerIntoType [:top,[:t,s]]

permuteToOrder(p,n,start) ==
  -- p is a vector of the numbers 0..n. This function returns a list
  -- of swaps of adjacent elements so that p will be in order. We only
  -- begin looking at index start
  r := n - start
  r <= 0 => NIL
  r = 1 =>
    p.r < p.(r+1) => NIL
    [[r,:(r+1)]]
  p.start = start => permuteToOrder(p,n,start+1)
  -- bubble up element start to the top. Find out where it is
  stpos := NIL
  for i in start+1..n while not stpos repeat
    if p.i = start then stpos := i
  perms := NIL
  while stpos ^= start repeat
    x := stpos - 1
    perms := [[x,:stpos],:perms]
    t := p.stpos
    p.stpos := p.x
    p.x := t
    stpos := x
  APPEND(NREVERSE perms,permuteToOrder(p,n,start+1))

coerceIntTest(t1,t2) ==
  -- looks whether there exists a table entry or a coercion function
  -- thus the type can be bubbled before coerceIntTableOrFunction is called
  t1=t2 or
    b:=
      p:= ASSQ(CAR t1,$CoerceTable)
      p and ASSQ(CAR t2,CDR p)
    b or coerceConvertMmSelection('coerce,t1,t2) or
      ($useConvertForCoercions and
        coerceConvertMmSelection('convert,t1,t2))

coerceByTable(fn,x,t1,t2,isTotalCoerce) ==
  -- catch point for 'failure in boot coercions
  t2 = $OutputForm and ^(newType? t1) => NIL
  isWrapped x =>
    x:= unwrap x
    c:= CATCH('coerceFailure,FUNCALL(fn,x,t1,t2))
    c=$coerceFailure => NIL
    objNewWrap(c,t2)
  isTotalCoerce => objNew([fn,x,MKQ t1,MKQ t2],t2)
  objNew(['catchCoerceFailure,MKQ fn,x,MKQ t1,MKQ t2],t2)

catchCoerceFailure(fn,x,t1,t2) ==
  -- compiles a catchpoint for compiling boot coercions
  c:= CATCH('coerceFailure,FUNCALL(fn,x,t1,t2))
  c = $coerceFailure =>
    throwKeyedMsgCannotCoerceWithValue(wrap unwrap x,t1,t2)
  c

coercionFailure() ==
  -- does the throw on coercion failure
  THROW('coerceFailure,$coerceFailure)

coerceByFunction(T,m2) ==
  -- using the new modemap selection without coercions
  -- should not be called by canCoerceFrom
  x := objVal T
  x = '_$fromCoerceable_$ => NIL
  m2 is ['Union,:.] => NIL
  m1 := objMode T
  m2 is ['Boolean,:.] and m1 is ['Equation,ud] =>
    dcVector := evalDomain ud
    fun :=
      isWrapped x =>
        NRTcompiledLookup("=", [$Boolean, '$, '$], dcVector)
      NRTcompileEvalForm("=", [$Boolean, '$, '$], dcVector)
    [fn,:d]:= fun
    isWrapped x =>
      x:= unwrap x
      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,slot,dcVector)
      NRTcompileEvalForm(funName,slot,dcVector)
    [fn,:d]:= fun
    fn = function Undef => NIL
    isWrapped x =>
--+
      $: fluid := dcVector
      val := CATCH('coerceFailure, SPADCALL(unwrap x,fun))
      (val = $coerceFailure) => NIL
      objNewWrap(val,m2)
    env := fun
    code := ['failCheck, ['SPADCALL, x, env]]
--  tar is ['Union,:.] => objNew(['failCheck,code],m2)
    objNew(code,m2)
  -- try going back to types like RN instead of QF I
  m1' := eqType m1
  m2' := eqType m2
  (m1 ^= m1') or (m2 ^= m2') => coerceByFunction(objNew(x,m1'),m2')
  NIL

hasCorrectTarget(m,sig is [dc,tar,:.]) ==
  -- tests whether the target of signature sig is either m or a union
  -- containing m. It also discards TEQ as it is not meant to be
  -- used at top-level
  dc is ['TypeEquivalence,:.] => NIL
  m=tar => 'T
  tar is ['Union,t,'failed] => t=m
  tar is ['Union,'failed,t] and t=m