1-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
2-- All rights reserved.
3--
4-- Redistribution and use in source and binary forms, with or without
5-- modification, are permitted provided that the following conditions are
6-- met:
7--
8--     - Redistributions of source code must retain the above copyright
9--       notice, this list of conditions and the following disclaimer.
10--
11--     - Redistributions in binary form must reproduce the above copyright
12--       notice, this list of conditions and the following disclaimer in
13--       the documentation and/or other materials provided with the
14--       distribution.
15--
16--     - Neither the name of The Numerical ALgorithms Group Ltd. nor the
17--       names of its contributors may be used to endorse or promote products
18--       derived from this software without specific prior written permission.
19--
20-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
21-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
22-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
23-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
24-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
25-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
26-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
27-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
28-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
29-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
30-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31
32)package "BOOT"
33
34)if false
35Coercion conventions
36
37Coercion involves the  changing of the datatype of an  object.  This
38   can be  done for conformality of  operations or, for  example, to
39   change the structure of an object  into one that is understood by
40   the printing routines.
41
42The actual coercion  is controlled  by the  function "coerce"  which
43   takes  and delivers  wrapped operands.   Also  see the  functions
44   interpCoerce and coerceInteractive.
45
46Sometimes one  does not  want to  actually change  the datatype  but
47   rather wants to determine  whether it is possible to do  so.  The
48   controlling function  to do this  is "canCoerceFrom".   The value
49   passed   to  specific   coercion  routines   in   this  case   is
50   "$fromCoerceable$".   The value returned is  true or false.   See
51   specific examples for more info.
52
53The special routines that  do the coercions typically  involve a "2"
54   in their  names.   For example, G2E  converts type  "Gaussian" to
55   type  "Expression".   These  special  routines take  and  deliver
56   unwrapped operands.   The determination of which  special routine
57   to  use  is  often  made  by  consulting  the  list  $CoerceTable
58   (currently in COT BOOT) and  this is controlled by coerceByTable.
59   Note that the special routines are in the file COERCEFN BOOT.
60)endif
61
62--%  Algebraic coercions using interactive code
63
64algCoerceInteractive(p,source,target) ==
65  -- now called in some groebner code
66  $useConvertForCoercions : local := true
67  source := devaluate source
68  target := devaluate target
69  u := coerceInteractive(objNewWrap(p,source),target)
70  u => objValUnwrap(u)
71  error ['"can't convert",p,'"of mode",source,'"to mode",target]
72
73spad2BootCoerce(x,source,target) ==
74  -- x : source and we wish to coerce to target
75  -- used in spad code for Any
76  null isValidType source => throwKeyedMsg("S2IE0004",[source])
77  null isValidType target => throwKeyedMsg("S2IE0004",[target])
78  x' := coerceInteractive(objNewWrap(x,source),target) =>
79    objValUnwrap(x')
80  throwKeyedMsgCannotCoerceWithValue(wrap x,source,target)
81
82--%  Functions for Coercion or Else We'll Get Rough
83
84coerceOrFail(triple,t,mapName) ==
85  -- some code generated for this is in coerceInt0
86  t = $NoValueMode => triple
87  t' := coerceInteractive(triple,t)
88  t' => objValUnwrap(t')
89  sayKeyedMsg("S2IC0004",[mapName,objMode triple,t])
90  '"failed"
91
92coerceOrCroak(triple, t, mapName) ==
93  -- this does the coercion and returns the value or dies
94  t = $NoValueMode => triple
95  t' := coerceOrConvertOrRetract(triple,t)
96  t' => objValUnwrap(t')
97  mapName = 'noMapName =>
98    throwKeyedMsgCannotCoerceWithValue(objVal triple,objMode triple, t)
99  sayKeyedMsg("S2IC0005",[mapName])
100  throwKeyedMsgCannotCoerceWithValue(objVal triple,objMode triple, t)
101
102coerceOrThrowFailure(value, t1, t2) ==
103  (result := coerceOrRetract(objNewWrap(value, t1), t2)) or
104    coercionFailure()
105  objValUnwrap(result)
106
107--%  Retraction functions
108
109retract object ==
110  type := objMode object
111  STRINGP type => 'failed
112  type = $EmptyMode => 'failed
113  val := objVal object
114  not isWrapped val and val isnt ['SPADMAP, :.] => 'failed
115  (ans := retract1 objNew(val, type)) = 'failed => ans
116  objNew(objVal ans, objMode ans)
117
118retract1 object ==
119  -- this function is the new version of the old "pullback"
120  -- it first tries to change the datatype of an object to that of
121  -- largest contained type. Examples: P RN -> RN, RN -> I
122  -- This is mostly for cases such as constant polynomials or
123  -- quotients with 1 in the denominator.
124  type := objMode object
125  STRINGP type => 'failed
126  val := objVal object
127  type = $PositiveInteger =>    objNew(val,$NonNegativeInteger)
128  type = $NonNegativeInteger => objNew(val,$Integer)
129  type = $Integer and SINTP unwrap val => objNew(val, $SingleInteger)
130  (1 = #type) or (type is ['Union,:.]) or
131    (type is ['FunctionCalled,.])
132     or (type is ['OrderedVariableList,.]) or (type is ['Variable,.]) =>
133      (object' := retract2Specialization(object)) => object'
134      'failed
135  null (underDomain := underDomainOf type) => 'failed
136  -- try to retract the "coefficients"
137  -- think of P RN -> P I or M RN -> M I
138  object' := retractUnderDomain(object,type,underDomain)
139  object' ~= 'failed => object'
140  -- see if we can use the retract functions
141  (object' := coerceRetract(object,underDomain)) => object'
142  -- see if we have a special case here
143  (object' := retract2Specialization(object)) => object'
144  'failed
145
146retractUnderDomain(object,type,underDomain) ==
147  null (ud := underDomainOf underDomain) => 'failed
148  [c,:args] := deconstructT type
149  1 ~= #args => 'failed
150  1 ~= #c => 'failed
151  type'' := constructT(c,[ud])
152  (object' := coerceInt(object,type'')) => object'
153  'failed
154
155retract2Specialization object ==
156  -- handles some specialization retraction cases, like matrices
157  val := objVal object
158  val' := unwrap val
159  type := objMode object
160
161  type = $Any =>
162    [dom,:obj] := val'
163    objNewWrap(obj,dom)
164  type is ['Union,:unionDoms] => coerceUnion2Branch object
165  type = $Symbol =>
166    objNewWrap(1,['OrderedVariableList,[val']])
167  type is ['OrderedVariableList,var] =>
168    coerceInt(objNewWrap(var.(val'-1),$Symbol), '(Polynomial (Integer)))
169-- !! following retract seems wrong and breaks ug13.input
170--  type is ['Variable,var] =>
171--    coerceInt(object,$Symbol)
172  type is ['Polynomial,D] =>
173    val' is [ =1,x,:.] =>
174      vl := REMDUP reverse varsInPoly val'
175      1 = #vl => coerceInt(object,['UnivariatePolynomial,x,D])
176      NIL
177    val' is [ =0,:.] => coerceInt(object, D)
178    NIL
179  type is ['Matrix,D] =>
180    n := ANROWS(val')
181    m := ANCOLS(val')
182    n = m => objNew(val,['SquareMatrix,n,D])
183    objNew(val,['RectangularMatrix,n,m,D])
184  type is ['RectangularMatrix,n,m,D] =>
185    n = m => objNew(val,['SquareMatrix,n,D])
186    NIL
187  (type is [agg,D]) and (agg in '(Vector Segment UniversalSegment)) =>
188    D = $PositiveInteger => objNew(val,[agg,$NonNegativeInteger])
189    D = $NonNegativeInteger => objNew(val,[agg,$Integer])
190    NIL
191  type is ['Array,bds,D] =>
192    D = $PositiveInteger => objNew(val,['Array,bds,$NonNegativeInteger])
193    D = $NonNegativeInteger => objNew(val,['Array,bds,$Integer])
194    NIL
195  type is ['List,D] =>
196    D isnt ['List,D'] =>
197      -- try to retract elements
198      D = $PositiveInteger => objNew(val,['List,$NonNegativeInteger])
199      D = $NonNegativeInteger => objNew(val,['List,$Integer])
200      null val' => nil
201--        null (um := underDomainOf D) => nil
202--        objNewWrap(nil,['List,um])
203      vl := nil
204      tl := nil
205      bad := nil
206      for e in val' while not bad repeat
207        (e' := retract objNewWrap(e,D)) = 'failed => bad := true
208        vl := [objValUnwrap e',:vl]
209        tl := [objMode e',:tl]
210      bad => NIL
211      (m := resolveTypeListAny tl) = D => NIL
212      vl' := nil
213      for e in vl for t in tl repeat
214        t = m => vl' := [e,:vl']
215        e' := coerceInt(objNewWrap(e,t),m)
216        null e' => return NIL
217        vl' := [objValUnwrap e',:vl']
218      objNewWrap(vl',['List,m])
219    D' = $PositiveInteger =>
220      objNew(val,['List,['List,$NonNegativeInteger]])
221    D' = $NonNegativeInteger =>
222      objNew(val,['List,['List,$Integer]])
223    D' is ['Variable,.] or D' is ['OrderedVariableList,.] =>
224        coerceInt(object,['List,['List,$Symbol]])
225
226    n := # val'
227    m := # val'.0
228    null isRectangularList(val',n,m) => NIL
229    coerceInt(object,['Matrix,D'])
230  type is ['Expression,D] =>
231    ofCategory(type, '(Field)) =>
232      [num,:den] := val'
233      -- coerceRetract already handles case where den = 1
234      num isnt [0,:num] => NIL
235      den isnt [0,:den] => NIL
236      objNewWrap([num,:den],[$QuotientField, D])
237    NIL
238  type is ['SimpleAlgebraicExtension,k,rep,.] =>
239    -- try to retract as an element of rep and see if we can get an
240    -- element of k
241    val' := retract objNew(val,rep)
242    while (val' ~= 'failed) and
243      (objMode(val') ~= k) repeat
244        val' := retract val'
245    val' = 'failed => NIL
246    val'
247
248  type is ['UnivariatePuiseuxSeries, coef, var, cen] =>
249    coerceInt(object, ['UnivariateLaurentSeries, coef, var, cen])
250  type is ['UnivariateLaurentSeries, coef, var, cen] =>
251    coerceInt(object, ['UnivariateTaylorSeries, coef, var, cen])
252
253  type is ['FunctionCalled,name] =>
254    null (m := get(name,'mode,$e)) => NIL
255    isPartialMode m => NIL
256    objNew(val,m)
257  NIL
258
259coerceOrConvertOrRetract(T,m) ==
260  $useConvertForCoercions : local := true
261  coerceOrRetract(T,m)
262
263coerceOrRetract(T,m) ==
264  (t' := coerceInteractive(T,m)) => t'
265  t := T
266  ans := nil
267  repeat
268    ans => return ans
269    t := retract t   -- retract is new name for pullback
270    t = 'failed => return ans
271    ans := coerceInteractive(t,m)
272  ans
273
274coerceRetract(object,t2) ==
275  -- tries to handle cases such as P I -> I
276  (val := objValUnwrap(object)) = "$fromCoerceable$" => NIL
277  t1 := objMode object
278  t2 = $OutputForm => NIL
279  isEqualOrSubDomain(t1,$Integer) and typeIsASmallInteger(t2) and SINTP(val) =>
280    objNewWrap(val,t2)
281  t1 = $Integer    => NIL
282  t1 = $Symbol     => NIL
283  t1 = $OutputForm => NIL
284  (c := retractByFunction(object, t2)) => c
285  NIL
286
287findRetractMms1(st, tt) ==
288    target := ['Union, tt, '"failed"]
289    fn := 'retractIfCan
290    mms := append(findFunctionInDomain(fn, tt, target, [st], [st], NIL, 'T),
291                  findFunctionInDomain(fn, st, target, [st],[st], NIL, 'T))
292    mms => orderMms(fn, mms, [st], [st], target)
293    mms
294
295retractByFunction(object,u) ==
296  -- tries to retract by using function "retractIfCan"
297  -- if the type belongs to the correct category.
298  $reportBottomUpFlag: local := NIL
299  t := objMode object
300  -- JHD/CRF not ofCategory(t,['RetractableTo,u]) => NIL
301  val := objValUnwrap object
302  -- try to get and apply the function "retractable?"
303  target := ['Union,u,'"failed"]
304  funName := 'retractIfCan
305  if $reportBottomUpFlag then
306    sayFunctionSelection(funName,[t],target,NIL,
307      '"coercion facility (retraction)")
308  mms := findRetractMms(t, u)
309  if $reportBottomUpFlag then
310    sayFunctionSelectionResult(funName,[t],mms)
311  null mms => NIL
312
313  -- [[dc, :.], slot, .] := first mms
314  dc := CAAAR mms
315  slot := CADAR mms
316  fun := interpLookup(funName, [target,t], dc)
317--+
318  NULL fun => NIL
319  first(fun) = function Undef => NIL
320--+
321  object' := coerceUnion2Branch objNewWrap(SPADCALL(val,fun),target)
322  u' := objMode object'
323  u = u' => object'
324  NIL
325
326--% Coercion utilities
327
328-- The next function extracts the structural definition of constants
329-- from a given domain. For example, getConstantFromDomain('(One),S)
330-- returns the representation of 1 in the domain S.
331
332constantInDomain?(form,domainForm) ==
333    opAlist := getOperationAlistFromLisplib first domainForm
334    key := opOf form
335    entryList := LASSOC(key,opAlist)
336    entryList is [[., ., ., type]] and type in '(CONST ASCONST) => true
337    key = "One" => constantInDomain?(["1"], domainForm)
338    key = "Zero" => constantInDomain?(["0"], domainForm)
339    false
340
341-- [[getConstantFromDomain]] is used to look up the constants $0$ and $1$
342-- from the given [[domainForm]].
343-- if [[isPartialMode]] (see i-funsel.boot) returns true then the
344-- domain modemap contains the constant [[$EmptyMode]] which indicates
345-- that the domain is not fully formed. In this case we return [[NIL]].
346getConstantFromDomain1(form,domainForm) ==
347    isPartialMode domainForm => NIL
348    opAlist := getOperationAlistFromLisplib first domainForm
349    key := opOf form
350    entryList := LASSOC(key,opAlist)
351    entryList isnt [[sig, ., ., .]] =>
352        key = "One" => getConstantFromDomain(["1"], domainForm)
353        key = "Zero" => getConstantFromDomain(["0"], domainForm)
354        throwKeyedMsg("S2IC0008",[form,domainForm])
355    -- i.e., there should be exactly one item under this key of that form
356    domain := evalDomain domainForm
357    SPADCALL compiledLookupCheck(key,sig,domain)
358
359
360domainOne(domain) == getConstantFromDomain('(One),domain)
361
362domainZero(domain) == getConstantFromDomain('(Zero),domain)
363
364equalOne(object, domain) ==
365  -- tries using constant One and "=" from domain
366  -- object should not be wrapped
367  algEqual(object, getConstantFromDomain('(One),domain), domain)
368
369equalZero(object, domain) ==
370  -- tries using constant Zero and "=" from domain
371  -- object should not be wrapped
372  algEqual(object, getConstantFromDomain('(Zero),domain), domain)
373
374algEqual(object1, object2, domain) ==
375  -- sees if 2 objects of the same domain are equal by using the
376  -- "=" from the domain
377  -- objects should not be wrapped
378--  eqfunc := getFunctionFromDomain("=",domain,[domain,domain])
379  eqfunc := compiledLookupCheck("=",[$Boolean,'$,'$],evalDomain domain)
380  SPADCALL(object1,object2, eqfunc)
381
382--%  main algorithms for canCoerceFrom and coerceInteractive
383
384-- coerceInteractive and canCoerceFrom are the two coercion functions
385-- for $InteractiveMode. They translate RN, RF and RR to QF I, QF P
386-- and RE RN, respectively, and call coerceInt or canCoerce, which
387-- both work in the same way (e.g. coercion from t1 to t2):
388
389-- 1. they try to coerce t1 to t2 directly (tower coercion), and, if
390--   this fails, to coerce t1 to the last argument of t2 and embed
391--   this last argument into t2. These embedding functions are now only
392--   defined in the algebra code. (RSS 2-27-87)
393
394-- 2. the tower coercion looks whether there is any applicable local
395--   coercion, which means, one defined in boot or in algebra code.
396--   If there is an applicable function from a constructor, which is
397--   inside the type tower of t1, to the top level constructor of t2,
398--   then this constructor is bubbled up inside t1. This means,
399--   special coercion functions (defined in boot) are called, which
400--   commute two constructors in a tower. Then the local coercion is
401--   called on these constructors, which both are on top level now.
402
403-- example:
404-- let t1 = A B C D E (short for (A (B (C (D (E))))), where A ... E are
405--   type constructors), and t2 = F D G H I J
406-- there is no coercion from t1 to t2 directly, so we try to coerce
407--   t1 to s1 = D G H I J, the last argument of t2
408-- we create the type s2 = A D B C E and call a local coercion A2A
409--   from t1 to s2, which, by recursively calling coerce, bubbles up
410--   the constructor D
411-- then we call a commute coerce from s2 to s3 = D A B C E and a local
412--   coerce D2D from s3 to s1
413-- finally we embed s1 into t2, which completes the coercion t1 to t2
414
415-- the result of canCoerceFrom is TRUE or NIL
416-- the result of coerceInteractive is a object or NIL (=failed)
417-- all boot coercion functions have the following result:
418-- 1. if u=$fromCoerceable$, then TRUE or NIL
419-- 2. if the coercion succeeds, the coerced value (this may be NIL)
420-- 3. if the coercion fails, they throw to a catch point in
421--      coerceByFunction
422
423--% Interpreter Coercion Query Functions
424
425canCoerce1(t1,t2) ==
426  -- general test for coercion
427  -- the result is NIL if it fails
428  t1 = t2 => true
429  absolutelyCanCoerceByCheating(t1,t2) or t1 = '(None) or t2 = '(Any) or
430    t1 in '((Mode) (Type) (Category)) =>
431      t2 = $OutputForm => true
432      NIL
433    -- next is for tagged union selectors for the time being
434    t1 is ['Variable,=t2] or t2 is ['Variable,=t1] => true
435    STRINGP t1 =>
436      t2 = $String => true
437      t2 = $OutputForm => true
438      t2 is ['Union,:.] => canCoerceUnion(t1,t2)
439      t2 is ['Variable,v] and (t1 = PNAME(v)) => true
440      NIL
441    STRINGP t2 =>
442      t1 is ['Variable,v] and (t2 = PNAME(v)) => true
443      NIL
444    atom t1 or atom t2 => NIL
445    null isValidType(t2) => NIL
446
447    absolutelyCannotCoerce(t1,t2) => NIL
448
449    nt1 := first t1
450    nt2 := first t2
451
452    EQ(nt1,'Mapping) => EQ(nt2,'Any)
453    EQ(nt2,'Mapping) =>
454      EQ(nt1,'Variable) or EQ(nt1,'FunctionCalled) =>
455        canCoerceExplicit2Mapping(t1,t2)
456      NIL
457    EQ(nt1,'Union) or EQ(nt2,'Union) => canCoerceUnion(t1,t2)
458
459    -- efficiency hack
460    t1 is ['Segment, s1] and t2 is ['UniversalSegment, s2] and
461        (isEqualOrSubDomain(s1, s2) or canCoerce(s1, s2)) => true
462
463    t1 is ['Tuple,S] and t2 ~= '(OutputForm) => canCoerce(['List, S], t2)
464
465    isRingT2 := ofCategory(t2,'(Ring))
466    isRingT2 and isEqualOrSubDomain(t1,$Integer) => true
467    (ans := canCoerceTopMatching(t1,t2,nt1,nt2)) ~= 'maybe => ans
468    t2 = $Integer => canCoerceLocal(t1,t2)   -- is true
469    ans := canCoerceTower(t1,t2) or
470      [.,:arg]:= deconstructT t2
471      arg and
472        t:= last arg
473        canCoerce(t1,t) and canCoerceByFunction(t,t2) and 'T
474    ans or (t1 in '((PositiveInteger) (NonNegativeInteger))
475      and canCoerce($Integer,t2))
476
477canCoerceFrom0(t1,t2) ==
478-- top level test for coercion, which transfers all RN, RF and RR into
479-- equivalent types
480  startTimingProcess 'querycoerce
481  q :=
482    isEqualOrSubDomain(t1,t2) or t1 = '(None) or t2 = '(Any) or
483
484      -- make sure we are trying to coerce to a legal type
485      -- in particular, polynomials are repeated, etc.
486      null isValidType(t2) => NIL
487      null isLegitimateMode(t2,nil,nil) => NIL
488
489      t1 = $RationalNumber =>
490        isEqualOrSubDomain(t2,$Integer) => NIL
491        canCoerce(t1, t2)
492      canCoerce(t1, t2)
493  stopTimingProcess 'querycoerce
494  q
495
496isSubTowerOf(t1,t2) ==
497  -- assumes RF and RN stuff has been expanded
498  -- tests whether t1 is somewhere inside t2
499  isEqualOrSubDomain(t1,t2) => true
500  null (u := underDomainOf t2) => nil
501  isSubTowerOf(t1,u)
502
503canCoerceTopMatching(t1,t2,tt1,tt2) ==
504  -- returns true, nil or maybe
505  -- for example, if t1 = P[x] D1 and t2 = P[y] D2 and x = y then
506  -- canCoerce will only be true if D1 = D2
507  not EQ(tt1,tt2) => 'maybe
508  doms := '(Polynomial List Matrix FiniteSet Vector Stream)
509  MEMQ(tt1,doms) => canCoerce(CADR t1, CADR t2)
510  not (MEMQ(tt1,$univariateDomains) or MEMQ(tt2,$multivariateDomains)) =>
511    'maybe
512  u2 := deconstructT t2
513  1 = #u2 => NIL
514  u1 := deconstructT t1
515  1 = #u1 => NIL                             -- no under domain
516  first(u1) ~= first(u2) => 'maybe
517  canCoerce(underDomainOf t1, underDomainOf t2)
518
519canCoerceExplicit2Mapping(t1,t is ['Mapping,target,:argl]) ==
520  -- determines if there a mapping called var with the given args
521  -- and target
522  $useCoerceOrCroak: local := nil
523  t1 is ['Variable,var] =>
524    null (mms :=selectMms1(var,target,argl,[NIL for a in argl],true)) => NIL
525    mm := CAAR mms
526    mm is [., targ, :.] =>
527      targ = target => true
528      false
529    false
530  t1 is ['FunctionCalled,fun] =>
531    funNode := mkAtreeNode fun
532    transferPropsToNode(fun,funNode)
533    mms := CATCH('coerceOrCroaker, selectLocalMms(funNode,fun,argl,target))
534    CONSP mms =>
535      mms is [[['interpOnly,:.],:.]] => nil
536      mm := CAAR mms
537      mm is [., targ, :.] =>
538        targ = target => true
539        false
540      false
541    NIL
542  NIL
543
544canCoerceUnion(t1,t2) ==
545  -- sees if one can coerce to or from a Union Domain
546  -- assumes one of t1 and t2 is one
547
548  -- get the domains in the union, checking for tagged unions
549  if (isUnion1 := t1 is ['Union,:uds1]) then
550    unionDoms1 :=
551      uds1 and first uds1 is [":",:.] => [t for [.,.,t] in uds1]
552      uds1
553  if (isUnion2 := t2 is ['Union,:uds2]) then
554    unionDoms2 :=
555      uds2 and first uds2 is [":",:.] => [t for [.,.,t] in uds2]
556      uds2
557
558  isUnion2 =>
559    member(t1,unionDoms2) => true
560    isUnion1 =>
561      and/[or/[canCoerce(ud1,ud2) for ud2 in unionDoms2]
562        for ud1 in unionDoms1]
563    or/[canCoerce(t1,ud) for ud in unionDoms2]
564  -- next, a little lie
565  t1 is ['Union,d1, ='"failed"] and t2 = d1 => true
566  isUnion1 =>
567    and/[canCoerce(ud,t2) for ud in unionDoms1]
568  keyedSystemError("S2GE0016",['"canCoerceUnion",
569     '"called with 2 non-Unions"])
570
571canCoerceByMap(t1,t2) ==
572  -- idea is this: if t1 is D U1 and t2 is D U2, then look for
573  -- map: (U1 -> U2, D U1) -> D U2.  If it exists, then answer true
574  -- if canCoerceFrom(t1,t2).
575  u2 := deconstructT t2
576  1 = #u2 => NIL
577  u1 := deconstructT t1
578  1 = #u1 => NIL                             -- no under domain
579  first(u1) ~= first(u2) => NIL
580  top := CAAR u1
581  u1 := underDomainOf t1
582  u2 := underDomainOf t2
583
584  absolutelyCannotCoerce(u1,u2) => NIL
585
586  -- save some time for those we know about
587  know := '(List Vector Segment Stream UniversalSegment Array
588    Polynomial UnivariatePolynomial SquareMatrix Matrix)
589  top in know => canCoerce(u1,u2)
590
591  null selectMms1('map,t2,[['Mapping,u2,u1],t1],
592    [['Mapping,u2,u1],u1],NIL) => NIL
593  -- don't bother checking for Undef, so avoid instantiation
594  canCoerce(u1,u2)
595
596canCoerceTower(t1,t2) ==
597-- tries to find a coercion between top level t2 and somewhere inside t1
598-- builds new bubbled type, for which coercion is called recursively
599  canCoerceByMap(t1,t2) or newCanCoerceCommute(t1,t2) or
600   canCoerceLocal(t1,t2) or canCoercePermute(t1,t2) or
601    [c1,:arg1]:= deconstructT t1
602    arg1 and
603      TL:= NIL
604      arg:= arg1
605      until x or not arg repeat x:=
606        t:= last arg
607        [c,:arg]:= deconstructT t
608        TL:= [c,arg,:TL]
609        arg and coerceIntTest(t,t2) and
610          CDDR TL =>
611            s := constructM(c1, replaceLast(arg1, bubbleConstructor TL))
612            canCoerceLocal(t1,s) and
613              [c2,:arg2]:= deconstructT last s
614              s1:= bubbleConstructor [c2,arg2,c1,arg1]
615              canCoerceCommute(s,s1) and canCoerceLocal(s1,t2)
616          s:= bubbleConstructor [c,arg,c1,arg1]
617          newCanCoerceCommute(t1,s) and canCoerceLocal(s,t2)
618      x
619
620canCoerceLocal(t1,t2) ==
621  -- test for coercion on top level
622  p := ASSQ(first t1, $CoerceTable)
623  p and ASSQ(first t2, rest p) is [., :[tag, fun]] =>
624    tag='partial => NIL
625    tag='total   => true
626    (functionp(fun) and
627       (v:=CATCH('coerceFailure,FUNCALL(fun,'_$fromCoerceable_$,t1,t2)))
628         and v ~= $coerceFailure)  or  canCoerceByFunction(t1,t2)
629  canCoerceByFunction(t1,t2)
630
631canCoerceCommute(t1,t2) ==
632-- THIS IS OUT-MODED AND WILL GO AWAY SOON  RSS 2-87
633-- t1 is t2 with the two top level constructors commuted
634-- looks for the existence of a commuting function
635  p := ASSQ(first t1, $CommuteTable)
636  p and ASSQ(first t2, rest p) is [., :['commute, .]]
637
638newCanCoerceCommute(t1,t2) ==
639  coerceIntCommute(objNewWrap("$fromCoerceable$",t1),t2)
640
641canCoercePermute(t1,t2) ==
642  -- try to generate a sequence of transpositions that will convert
643  -- t1 into t2
644  t2 in '((Integer) (OutputForm)) => NIL
645  towers := computeTTTranspositions(t1,t2)
646  -- at this point, first towers = t1 and last towers should be similar
647  -- to t2 in the sense that the components of t1 are in the same order
648  -- as in t2. If length towers = 2 and t2 = last towers, we quit to
649  -- avoid an infinite loop.
650  NULL towers or NULL rest towers => NIL
651  NULL CDDR towers and t2 = CADR towers => NIL
652  -- do the coercions successively, quitting if any fail
653  ok := true
654  for t in rest towers while ok repeat
655    ok := canCoerce(t1,t)
656    if ok then t1 := t
657  ok
658
659canConvertByFunction(m1,m2) ==
660  null $useConvertForCoercions => NIL
661  canCoerceByFunction1(m1,m2,'convert)
662
663canCoerceByFunction(m1,m2) == canCoerceByFunction1(m1,m2,'coerce)
664
665canCoerceByFunction1(m1,m2,fun) ==
666  -- calls selectMms with $Coerce=NIL and tests for required target=m2
667  $declaredMode:local:= NIL
668  $reportBottomUpFlag:local:= NIL
669  l := selectMms1(fun, m2, [m1], [m1], NIL)
670  [x for x in l | x is [sig,:.] and CADR sig = m2 and
671      CADDR sig = m1] and true
672
673absolutelyCanCoerceByCheating(t1,t2) ==
674  -- this typically involves subdomains and towers where the only
675  -- difference is a subdomain
676  isEqualOrSubDomain(t1,t2) => true
677  typeIsASmallInteger(t1) and t2 = $Integer => true
678  ATOM(t1) or ATOM(t2) => false
679  [tl1,:u1] := deconstructT t1
680  [tl2,:u2] := deconstructT t2
681  tl1 = '(Stream) and tl2 = '(InfiniteTuple) =>
682    #u1 ~= #u2 => false
683    "and"/[absolutelyCanCoerceByCheating(x1,x2) for x1 in u1 for x2 in u2]
684  tl1 ~= tl2 => false
685  #u1 ~= #u2 => false
686  "and"/[absolutelyCanCoerceByCheating(x1,x2) for x1 in u1 for x2 in u2]
687
688absolutelyCannotCoerce(t1,t2) ==
689  -- response of true means "definitely cannot coerce"
690  -- this is largely an efficiency hack
691  ATOM(t1) or ATOM(t2) => NIL
692  t2 = '(None) => true
693  n1   := first t1
694  n2   := first t2
695  QFI  := [$QuotientField, $Integer]
696  int2 := isEqualOrSubDomain(t2,$Integer)
697  scalars := '(Float DoubleFloat)
698
699  MEMQ(n1,scalars) and int2 => true
700  (t1 = QFI) and int2       => true
701
702  num2 := int2 or MEMQ(n2,scalars) or (t2 = QFI)
703  isVar1 := MEMQ(n1,'(Variable Symbol))
704
705  num2 and isVar1 => true
706  num2 and MEMQ(n1,$univariateDomains) => true
707  num2 and MEMQ(n1,$multivariateDomains) => true
708  miscpols :=  '(Polynomial SimpleAlgebraicExtension)
709  num2 and MEMQ(n1,miscpols) => true
710
711  aggs :=  '(
712    Matrix List Vector Stream Array RectangularMatrix FiniteSet
713       )
714  u1 := underDomainOf t1
715  u2 := underDomainOf t2
716  MEMQ(n1,aggs) and (u1 = t2) => true
717  MEMQ(n2,aggs) and (u2 = t1) => true
718
719  algs :=  '(
720    SquareMatrix RectangularMatrix Quaternion
721       )
722  nonpols := append(aggs,algs)
723  num2 and MEMQ(n1,nonpols) => true
724  isVar1 and MEMQ(n2,nonpols) and
725    absolutelyCannotCoerce(t1,u2) => true
726
727  (MEMQ(n1,scalars) or (t1 = QFI)) and (t2 = '(Polynomial (Integer))) =>
728    true
729
730  v2 := deconstructT t2
731  1 = #v2 => NIL
732  v1 := deconstructT t1
733  1 = #v1 => NIL
734  first(v1) ~= first(v2) => NIL
735  absolutelyCannotCoerce(u1,u2)
736
737typeIsASmallInteger x == (x = $SingleInteger)
738
739
740--% Interpreter Coercion Functions
741
742typeToInputForm(t) == typeToForm(t, '(InputForm))
743
744typeToOutputForm(t) == typeToForm(t, $OutputForm)
745
746typeToForm(t, toForm) ==
747    t0 := devaluate(t)
748    [op,:argl] := t0
749    coSig := rest GETDATABASE(op, 'COSIG)
750    sig := getConstructorSignature t0
751    ml := replaceSharps(rest sig, t0)
752    nl := [fn(x, t1, c, toForm) for x in argl for t1 in ml_
753                                for c in coSig] where
754        fn(x, t1, c, toForm) ==
755            c => typeToForm(x, toForm)
756            algCoerceInteractive(x, t1, toForm)
757    [op, :nl]
758
759coerceInteractive(triple,t2) ==
760  -- bind flag for recording/reporting instantiations
761  -- (see recordInstantiation)
762  t1 := objMode triple
763  val := objVal triple
764  null(t2) or t2 = $EmptyMode => NIL
765  t2 = t1 => triple
766  t2 = '$NoValueMode => objNew(val,t2)
767  if t2 is ['SubDomain,x,.] then t2:= x
768  -- JHD added category Aug 1996 for BasicMath
769  t1 in '((Category) (Mode) (Type)) =>
770    t2 = $OutputForm => objNewWrap(typeToOutputForm(val), t2)
771    t2 = '(InputForm) => objNewWrap(typeToInputForm(val), t2)
772    NIL
773  t1 = '$NoValueMode =>
774    if $compilingMap then clearDependentMaps($mapName,nil)
775    throwKeyedMsg("S2IC0009",[t2,$mapName])
776  $insideCoerceInteractive: local := true
777  expr2 := EQUAL(t2,$OutputForm)
778  if expr2 then startTimingProcess 'print
779  else startTimingProcess 'coercion
780  -- next 2 lines handle cases like '"failed"
781  result :=
782    expr2 and t1 is ['Variable,var] => objNewWrap(var,$OutputForm)
783    coerceInt0(triple,t2)
784  if expr2 then stopTimingProcess 'print
785  else stopTimingProcess 'coercion
786  result
787
788coerceInt0(triple,t2) ==
789  -- top level interactive coercion, which transfers all RN, RF and RR
790  -- into equivalent types
791  val := objVal triple
792  t1  := objMode triple
793
794  val='_$fromCoerceable_$ => canCoerceFrom(t1,t2)
795  t1 = t2 => triple
796  -- t1 is ['Mapping,:.] and t2 ~= '(Any) => NIL
797  -- note: may be able to coerce TO mapping
798  -- treat Exit like Any
799  -- handle case where we must generate code
800  null(isWrapped val) and
801    (t1 isnt ['FunctionCalled,:.] or not $genValue)=>
802      intCodeGenCOERCE(triple,t2)
803  t1 = $Any and t2 ~= $OutputForm and ([t1',:val'] := unwrap val) and
804    (ans := coerceInt0(objNewWrap(val',t1'),t2)) => ans
805  x := coerceInt(triple, t2) => x
806  NIL
807
808coerceInt(triple, t2) ==
809  val := coerceInt1(triple, t2) => val
810  t1 := objMode triple
811  t1 is ['Variable, :.] =>
812    newMode := getMinimalVarMode(unwrap objVal triple, nil)
813    newVal := coerceInt(triple, newMode)
814    coerceInt(newVal, t2)
815  nil
816
817coerceInt1(triple,t2) ==
818  -- general interactive coercion
819  -- the result is a new triple with type m2 or NIL (= failed)
820  $useCoerceOrCroak: local := true
821  t2 = $EmptyMode => NIL
822  t1 := objMode triple
823  t1=t2 => triple
824  val := objVal triple
825  absolutelyCanCoerceByCheating(t1,t2) => objNew(val,t2)
826  isSubDomain(t2, t1) => coerceSubDomain(val, t1, t2)
827
828  if typeIsASmallInteger(t1) then
829    (t2 = $Integer) or typeIsASmallInteger(t2) => return objNew(val,t2)
830    sintp := SINTP val
831    sintp and (t2 = $PositiveInteger) and val > 0 => return objNew(val,t2)
832    sintp and (t2 = $NonNegativeInteger) and val >= 0 => return objNew(val,t2)
833
834  typeIsASmallInteger(t2) and isEqualOrSubDomain(t1, $Integer)_
835      and INTEGERP val =>
836    SINTP val => objNew(val,t2)
837    NIL
838
839  t2 = $Void => objNew(voidValue(),$Void)
840  t2 = $Any => objNewWrap([t1,:unwrap val],'(Any))
841
842  t1 = $Any and t2 ~= $OutputForm and ([t1',:val'] := unwrap val) and
843    (ans := coerceInt(objNewWrap(val',t1'),t2)) => ans
844
845  -- next is for tagged union selectors for the time being
846  t1 is ['Variable,=t2] or t2 is ['Variable,=t1] => objNew(val,t2)
847
848  STRINGP t2 =>
849    t1 is ['Variable,v] and (t2 = PNAME(v)) => objNewWrap(t2,t2)
850    val' := unwrap val
851    (t2 = val') and ((val' = t1) or (t1 = $String)) => objNew(val,t2)
852    NIL
853  --  t1 is ['Tuple,S] and t2 ~= '(OutputForm) =>
854  t1 is ['Tuple,S]  =>
855    coerceInt1(objNewWrap(asTupleAsList unwrap val, ['List, S]), t2)
856  t1 is ['Union,:.] => coerceIntFromUnion(triple,t2)
857  t2 is ['Union,:.] => coerceInt2Union(triple,t2)
858  (STRINGP t1) and (t2 = $String) => objNew(val,$String)
859  (STRINGP t1) and (t2 is ['Variable,v]) =>
860    t1 = PNAME(v) => objNewWrap(v,t2)
861    NIL
862  (STRINGP t1) and (t1 = unwrap val) =>
863    t2 = $OutputForm => objNew(STRCONC('"_"", t1, '"_""), $OutputForm)
864    NIL
865  atom t1 => NIL
866
867  if t1 = $AnonymousFunction and (t2 is ['Mapping,target,:margl]) then
868    $useCoerceOrCroak := nil
869    [.,vars,:body] := unwrap val
870    vars :=
871      atom vars => [vars]
872      vars is ['Tuple,:.] => rest vars
873      vars
874    #margl ~= #vars => 'continue
875    tree := mkAtree ['ADEF,vars,[target,:margl],[NIL for x in rest t2],:body]
876    CATCH('coerceOrCroaker, bottomUp tree) = 'croaked => nil
877    return getValue tree
878
879  (t1 = $Symbol) and (t2 is ['Mapping,target,:margl]) =>
880    null (mms := selectMms1(unwrap val,nil,margl,margl,target)) => NIL
881    [dc,targ,:argl] := CAAR mms
882    targ ~= target => NIL
883    $genValue =>
884      fun := getFunctionFromDomain1(unwrap val, dc, targ, argl)
885      objNewWrap(fun,t2)
886    val := NRTcompileEvalForm(unwrap val, rest CAAR mms, evalDomain dc)
887    objNew(val, t2)
888  (t1 is ['Variable,sym]) and (t2 is ['Mapping,target,:margl]) =>
889    null (mms := selectMms1(sym,target,margl,margl,NIL)) =>
890       null (mms := selectMms1(sym,target,margl,margl,true)) => NIL
891    [dc,targ,:argl] := CAAR mms
892    targ ~= target => NIL
893    dc is ["__FreeFunction__",:freeFun] => objNew( freeFun, t2 )
894    $genValue => objNewWrap(getFunctionFromDomain1(sym, dc, targ, argl), t2)
895    val := NRTcompileEvalForm(sym, rest CAAR mms, evalDomain dc)
896    objNew(val, t2)
897  (t1 is ['FunctionCalled,sym]) and (t2 is ['Mapping,target,:margl]) =>
898    symNode := mkAtreeNode sym
899    transferPropsToNode(sym,symNode)
900    null (mms := selectLocalMms(symNode,sym,margl,target)) => NIL
901    [dc,targ,:argl] := CAAR mms
902    targ ~= target => NIL
903    ml := [target,:margl]
904    intName :=
905      or/[mm for mm in mms | (mm is [[., :ml1],oldName,:.]
906        and compareTypeLists(ml1,ml))] => [COERCE(oldName, 'FUNCTION)]
907      NIL
908    null intName => NIL
909    objNewWrap(intName,t2)
910  (t1 is ['FunctionCalled,sym]) =>
911    t2 = $OutputForm => coerceByFunction(objNewWrap(val, t1), t2)
912    (t3 := get(sym,'mode,$e)) and t3 is ['Mapping,:.] =>
913      (triple' := coerceInt(triple,t3)) => coerceInt(triple',t2)
914      NIL
915    NIL
916
917  EQ(first(t1), 'Variable) and PAIRP(t2) and
918    (isEqualOrSubDomain(t2,$Integer) or
919      (t2 = [$QuotientField, $Integer]) or MEMQ(first(t2),
920        '(Float DoubleFloat))) => NIL
921
922  ans := coerceRetract(triple,t2) or coerceIntTower(triple,t2) or
923    [.,:arg]:= deconstructT t2
924    arg and
925      t:= coerceInt(triple,last arg)
926      t and coerceByFunction(t,t2)
927  ans or (isSubDomain(t1,$Integer) and
928    coerceInt(objNew(val,$Integer),t2)) or
929      coerceIntAlgebraicConstant(triple,t2) or
930        coerceIntX(val,t1,t2)
931
932coerceSubDomain(val, tSuper, tSub) ==
933  -- Try to coerce from a sub domain to a super domain
934  val = '_$fromCoerceable_$ => nil
935  super := GETDATABASE(first tSub, 'SUPERDOMAIN)
936  superDomain := first super
937  superDomain = tSuper =>
938    coerceImmediateSubDomain(val, tSuper, tSub, CADR super)
939  coerceSubDomain(val, tSuper, superDomain) =>
940    coerceImmediateSubDomain(val, superDomain, tSub, CADR super)
941  nil
942
943coerceImmediateSubDomain(val, tSuper, tSub, pred) ==
944  predfn := getSubDomainPredicate(tSuper, tSub, pred)
945  FUNCALL(predfn, val, nil) => objNew(val, tSub)
946  nil
947
948getSubDomainPredicate(tSuper, tSub, pred) ==
949  $env: local := $InteractiveFrame
950  predfn := HGET($superHash, CONS(tSuper, tSub)) => predfn
951  name := GENSYM()
952  decl := ['_:, name, ['Mapping, $Boolean, tSuper]]
953  interpret(decl, nil)
954  arg := GENSYM()
955  pred' := SUBST(arg, "#1", pred)
956  defn := ['DEF, [name, arg], '(NIL NIL), '(NIL NIL), removeZeroOne pred']
957  interpret(defn, nil)
958  op := mkAtree name
959  transferPropsToNode(name, op)
960  predfn := CADAR selectLocalMms(op, name, [tSuper],$Boolean)
961  HPUT($superHash, CONS(tSuper, tSub), predfn)
962  predfn
963
964coerceIntX(val,t1, t2) ==
965  -- some experimental things
966  t1 = '(List (None)) =>
967    -- this will almost always be an empty list
968    null unwrap val =>
969      -- try getting a better flavor of List
970      null (t0 := underDomainOf(t2)) => NIL
971      coerceInt(objNewWrap(val,['List,t0]),t2)
972    NIL
973  NIL
974
975compareTypeLists(tl1,tl2) ==
976  -- returns true if every type in tl1 is = or is a subdomain of
977  -- the corresponding type in tl2
978  for t1 in tl1 for t2 in tl2 repeat
979    null isEqualOrSubDomain(t1,t2) => return NIL
980  true
981
982coerceIntAlgebraicConstant(object,t2) ==
983  -- should use = from domain, but have to check on defaults code
984  t1 := objMode object
985  val := objValUnwrap object
986  ofCategory(t1,'(Monoid)) and ofCategory(t2,'(Monoid)) and
987    val = getConstantFromDomain('(One),t1) =>
988      objNewWrap(getConstantFromDomain('(One),t2),t2)
989  ofCategory(t1,'(AbelianMonoid)) and ofCategory(t2,'(AbelianMonoid)) and
990    val = getConstantFromDomain('(Zero),t1) =>
991      objNewWrap(getConstantFromDomain('(Zero),t2),t2)
992  NIL
993
994stripUnionTags doms ==
995  [if dom is [":",.,dom'] then dom' else dom for dom in doms]
996
997isTaggedUnion u ==
998  u is ['Union,:tl] and tl and first tl is [":",.,.] and true
999
1000getUnionOrRecordTags u ==
1001  tags := nil
1002  if u is ['Union, :tl] or u is ['Record, :tl] then
1003      for t in tl repeat
1004         if t is [":",tag,.] then tags := cons(tag, tags)
1005  tags
1006
1007coerceUnion2Branch(object) ==
1008  [.,:unionDoms] := objMode object
1009  doms := unionDoms
1010  predList:= mkPredList doms
1011  doms := stripUnionTags doms
1012  val' := objValUnwrap object
1013  predicate := NIL
1014  targetType:= NIL
1015  for typ in doms for pred in predList while not targetType repeat
1016      predicate := pred
1017      pred is ["EQCAR", "#1", i] =>
1018          if EQCAR(val', i) then targetType := typ
1019      evalSharpOne(pred,val') =>
1020          targetType := typ
1021  null targetType => keyedSystemError("S2IC0013",NIL)
1022  predicate is ['EQCAR, ., p] => objNewWrap(rest val', targetType)
1023  objNew(objVal object,targetType)
1024
1025coerceBranch2Union(object,union) ==
1026  -- assumes type is a member of unionDoms
1027  doms := rest union
1028  predList:= mkPredList doms
1029  doms := stripUnionTags doms
1030  p := position(objMode object,doms)
1031  p = -1 => keyedSystemError("S2IC0014",[objMode object,union])
1032  val := objVal object
1033  predList.p is ['EQCAR,.,tag] =>
1034    objNewWrap([removeQuote tag,:unwrap val],union)
1035  objNew(val,union)
1036
1037coerceInt2Union(object,union) ==
1038  -- coerces to a Union type, adding numeric tags
1039  -- first cut
1040  unionDoms := stripUnionTags rest union
1041  t1 := objMode object
1042  member(t1,unionDoms) => coerceBranch2Union(object,union)
1043  val := objVal object
1044  val' := unwrap val
1045  (t1 = $String) and member(val',unionDoms) =>
1046    coerceBranch2Union(objNew(val,val'),union)
1047  noCoerce := true
1048  val' := nil
1049  for d in unionDoms while noCoerce repeat
1050    (val' := coerceInt(object,d)) => noCoerce := nil
1051  val' => coerceBranch2Union(val',union)
1052  NIL
1053
1054coerceIntFromUnion(object,t2) ==
1055  -- coerces from a Union type to something else
1056  coerceInt(coerceUnion2Branch object,t2)
1057
1058coerceIntByMap(triple,t2) ==
1059  -- idea is this: if t1 is D U1 and t2 is D U2, then look for
1060  -- map: (U1 -> U2, D U1) -> D U2.  If it exists, then create a
1061  -- function to do the coercion on the element level and call the
1062  -- map function.
1063  t1 := objMode triple
1064  t2 = t1 => triple
1065  u2 := deconstructT t2    -- compute t2 first because of Expression
1066  1 = #u2 => NIL           -- no under domain
1067  u1 := deconstructT t1
1068  1 = #u1 => NIL
1069  CAAR u1 ~= CAAR u2 => nil  -- constructors not equal
1070  not valueArgsEqual?(t1, t2) => NIL
1071--  first u1 ~= first u2 => NIL
1072  top := CAAR u1
1073  u1 := underDomainOf t1
1074  u2 := underDomainOf t2
1075
1076  -- handle a couple of special cases for subdomains of Integer
1077  top in '(List Vector Segment Stream UniversalSegment Array)
1078    and isSubDomain(u1,u2) => objNew(objVal triple, t2)
1079
1080  args := [['Mapping,u2,u1],t1]
1081  if $reportBottomUpFlag then
1082    sayFunctionSelection('map,args,t2,NIL,
1083      '"coercion facility (map)")
1084  mms := selectMms1('map,t2,args,args,NIL)
1085  if $reportBottomUpFlag then
1086    sayFunctionSelectionResult('map,args,mms)
1087  null mms => NIL
1088
1089  [[dc, :sig], slot, .] := first mms
1090  fun := compiledLookup('map,sig,evalDomain(dc))
1091  NULL fun => NIL
1092  [fn,:d]:= fun
1093  fn = function Undef => NIL
1094  -- now compile a function to do the coercion
1095  code := ['SPADCALL,['CONS,["function","coerceIntByMapInner"],MKQ [u1,:u2]],
1096    wrapped2Quote objVal triple,MKQ fun]
1097  -- and apply the function
1098  val := CATCH('coerceFailure,timedEvaluate code)
1099  (val = $coerceFailure) => NIL
1100  objNewWrap(val,t2)
1101
1102coerceIntByMapInner(arg,[u1,:u2]) == coerceOrThrowFailure(arg,u1,u2)
1103-- [u1,:u2] gets passed as the "environment", which is why we have this
1104-- slightly clumsy locution  JHD 31.July,1990
1105
1106valueArgsEqual?(t1, t2) ==
1107  -- returns true if the object-valued arguments to t1 and t2 are the same
1108  -- under coercion
1109  coSig := rest GETDATABASE(first t1, 'COSIG)
1110  constrSig := rest getConstructorSignature first t1
1111  tl1 := replaceSharps(constrSig, t1)
1112  tl2 := replaceSharps(constrSig, t2)
1113  not MEMQ(NIL, coSig) => true
1114  done := false
1115  value := true
1116  for a1 in rest t1 for a2 in rest t2 for cs in coSig
1117    for m1 in tl1 for m2 in tl2 while not done repeat
1118          not cs =>
1119            trip := objNewWrap(a1, m1)
1120            newVal := coerceInt(trip, m2)
1121            null newVal => (done := true; value := false)
1122            not algEqual(a2, objValUnwrap newVal, m2) =>
1123              (done := true; value := false)
1124  value
1125
1126coerceIntTower(triple,t2) ==
1127  -- tries to find a coercion from top level t2 to somewhere inside t1
1128  -- builds new argument type, for which coercion is called recursively
1129  x := coerceIntByMap(triple,t2) => x
1130  x := coerceIntCommute(triple,t2) => x
1131  x := coerceIntPermute(triple,t2) => x
1132  x := coerceIntSpecial(triple,t2) => x
1133  x := coerceIntTableOrFunction(triple,t2) => x
1134  t1 := objMode triple
1135  [c1,:arg1]:= deconstructT t1
1136  arg1 and
1137    TL:= NIL
1138    arg:= arg1
1139    until x or not arg repeat
1140      t:= last arg
1141      [c,:arg]:= deconstructT t
1142      TL:= [c,arg,:TL]
1143      x := arg and coerceIntTest(t,t2) =>
1144        CDDR TL =>
1145          s := constructM(c1, replaceLast(arg1, bubbleConstructor TL))
1146          (null isValidType(s)) => (x := NIL)
1147          x := (coerceIntByMap(triple,s) or
1148            coerceIntTableOrFunction(triple,s)) =>
1149              [c2,:arg2]:= deconstructT last s
1150              s:= bubbleConstructor [c2,arg2,c1,arg1]
1151              (null isValidType(s)) => (x := NIL)
1152              x:= coerceIntCommute(x,s) =>
1153                x := (coerceIntByMap(x,t2) or
1154                  coerceIntTableOrFunction(x,t2))
1155        s:= bubbleConstructor [c,arg,c1,arg1]
1156        (null isValidType(s)) => (x := NIL)
1157        x:= coerceIntCommute(triple,s) =>
1158          x:= (coerceIntByMap(x,t2) or
1159            coerceIntTableOrFunction(x,t2))
1160    x
1161
1162coerceIntSpecial(triple,t2) ==
1163  t1 := objMode triple
1164  t2 is ['SimpleAlgebraicExtension,R,U,.] and t1 = R =>
1165    null (x := coerceInt(triple,U)) => NIL
1166    coerceInt(x,t2)
1167  NIL
1168
1169coerceIntTableOrFunction(triple,t2) ==
1170  -- this function does the actual coercion to t2, but not to an
1171  -- argument type of t2
1172  null isValidType t2 => NIL  -- added 9-18-85 by RSS
1173  null isLegitimateMode(t2,NIL,NIL) => NIL  -- added 6-28-87 by RSS
1174  t1 := objMode triple
1175  p := ASSQ(first t1, $CoerceTable)
1176  p and ASSQ(first t2, rest p) is [., :[tag, fun]] =>
1177    val := objVal triple
1178    fun='Identity => objNew(val,t2)
1179    tag='total =>
1180      coerceByTable(fun,val,t1,t2,'T) or coerceByFunction(triple,t2)
1181    coerceByTable(fun,val,t1,t2,NIL) or coerceByFunction(triple,t2)
1182  coerceByFunction(triple,t2)
1183
1184coerceCommuteTest(t1,t2) ==
1185  null isLegitimateMode(t2,NIL,NIL) => NIL
1186
1187  -- sees whether t1 = D1 D2 R and t2 = D2 D1 S
1188  null (u1 := underDomainOf t1) => NIL
1189  null (u2 := underDomainOf t2) => NIL
1190
1191  -- must have underdomains (ie, R and S must be there)
1192
1193  null (v1 := underDomainOf u1) => NIL
1194  null (v2 := underDomainOf u2) => NIL
1195
1196  -- now check that cross of constructors is correct
1197  (first(deconstructT t1) = first(deconstructT u2)) and
1198    (first(deconstructT t2) = first(deconstructT u1))
1199
1200coerceIntCommute(obj,target) ==
1201  -- note that the value in obj may be $fromCoerceable$, for canCoerce
1202  source := objMode obj
1203  null coerceCommuteTest(source,target) => NIL
1204  S := underDomainOf source
1205  T := underDomainOf target
1206  source = T => NIL      -- handle in other ways
1207
1208  source is [D,:.] =>
1209    fun := GETL(D,'coerceCommute) or
1210           INTERN STRCONC('"commute",STRINGIMAGE D)
1211    functionp fun =>
1212      PUT(D,'coerceCommute,fun)
1213      u := objValUnwrap obj
1214      c := CATCH('coerceFailure,FUNCALL(fun,u,source,S,target,T))
1215      (c = $coerceFailure) => NIL
1216      u = "$fromCoerceable$" => c
1217      objNewWrap(c,target)
1218    NIL
1219  NIL
1220
1221coerceIntPermute(object,t2) ==
1222  t2 in '((Integer) (OutputForm)) => NIL
1223  t1 := objMode object
1224  towers := computeTTTranspositions(t1,t2)
1225  -- at this point, first towers = t1 and last towers should be similar
1226  -- to t2 in the sense that the components of t1 are in the same order
1227  -- as in t2. If length towers = 2 and t2 = last towers, we quit to
1228  -- avoid an infinite loop.
1229  NULL towers or NULL rest towers => NIL
1230  NULL CDDR towers and t2 = CADR towers => NIL
1231  -- do the coercions successively, quitting if any fail
1232  ok := true
1233  for t in rest towers while ok repeat
1234    null (object := coerceInt(object,t)) => ok := NIL
1235  ok => object
1236  NIL
1237
1238computeTTTranspositions(t1,t2) ==
1239  -- decompose t1 into its tower parts
1240  tl1 := decomposeTypeIntoTower t1
1241  tl2 := decomposeTypeIntoTower t2
1242  -- if not at least 2 parts, don't bother working here
1243  null (rest tl1 and rest tl2) => NIL
1244  -- determine the relative order of the parts of t1 in t2
1245  p2 := [position(d1,tl2) for d1 in tl1]
1246  member(-1,p2) => NIL            -- something not present
1247  -- if they are all ascending, this function will do nothing
1248  p2' := MSORT p2
1249  p2 = p2' => NIL
1250  -- if anything is repeated twice, leave
1251  p2' ~= MSORT REMDUP p2' => NIL
1252  -- create a list of permutations that transform the tower parts
1253  -- of t1 into the order they are in in t2
1254  n1 := #tl1
1255  p2 := LIST2VEC compress(p2,0,# REMDUP tl1) where
1256    compress(l,start,len) ==
1257      start >= len => l
1258      member(start,l) => compress(l,start+1,len)
1259      compress([(i < start => i; i - 1) for i in l],start,len)
1260  -- p2 now has the same position numbers as p1, we need to determine
1261  -- a list of permutations that takes p1 into p2.
1262  -- them
1263  perms := permuteToOrder(p2,n1-1,0)
1264  towers := [tl1]
1265  tower := LIST2VEC tl1
1266  for perm in perms repeat
1267    t := tower.(first perm)
1268    tower.(first perm) := tower.(rest perm)
1269    tower.(rest perm) := t
1270    towers := CONS(VEC2LIST tower,towers)
1271  towers := [reassembleTowerIntoType tower for tower in towers]
1272  if first(towers) ~= t2 then towers := cons(t2, towers)
1273  NREVERSE towers
1274
1275decomposeTypeIntoTower t ==
1276  ATOM t => [t]
1277  d := deconstructT t
1278  NULL rest d => [t]
1279  rd := REVERSE t
1280  [reverse QCDR rd,:decomposeTypeIntoTower QCAR rd]
1281
1282reassembleTowerIntoType tower ==
1283  ATOM tower => tower
1284  NULL rest tower => first tower
1285  [:top,t,s] := tower
1286  reassembleTowerIntoType [:top,[:t,s]]
1287
1288permuteToOrder(p,n,start) ==
1289  -- p is a vector of the numbers 0..n. This function returns a list
1290  -- of swaps of adjacent elements so that p will be in order. We only
1291  -- begin looking at index start
1292  r := n - start
1293  r <= 0 => NIL
1294  r = 1 =>
1295    p.r < p.(r+1) => NIL
1296    [[r,:(r+1)]]
1297  p.start = start => permuteToOrder(p,n,start+1)
1298  -- bubble up element start to the top. Find out where it is
1299  stpos := NIL
1300  for i in start+1..n while not stpos repeat
1301    if p.i = start then stpos := i
1302  perms := NIL
1303  while stpos ~= start repeat
1304    x := stpos - 1
1305    perms := [[x,:stpos],:perms]
1306    t := p.stpos
1307    p.stpos := p.x
1308    p.x := t
1309    stpos := x
1310  APPEND(NREVERSE perms,permuteToOrder(p,n,start+1))
1311
1312coerceIntTest(t1,t2) ==
1313  -- looks whether there exists a table entry or a coercion function
1314  -- thus the type can be bubbled before coerceIntTableOrFunction is called
1315  t1=t2 or
1316    b:=
1317      p := ASSQ(first t1, $CoerceTable)
1318      p and ASSQ(first t2, rest p)
1319    b or coerceConvertMmSelection('coerce,t1,t2) or
1320      ($useConvertForCoercions and
1321        coerceConvertMmSelection('convert,t1,t2))
1322
1323coerceByTable(fn,x,t1,t2,isTotalCoerce) ==
1324  -- catch point for 'failure in boot coercions
1325  t2 = $OutputForm => NIL
1326  isWrapped x =>
1327    x:= unwrap x
1328    c:= CATCH('coerceFailure,FUNCALL(fn,x,t1,t2))
1329    c=$coerceFailure => NIL
1330    objNewWrap(c,t2)
1331  isTotalCoerce => objNew([fn,x,MKQ t1,MKQ t2],t2)
1332  objNew(['catchCoerceFailure,MKQ fn,x,MKQ t1,MKQ t2],t2)
1333
1334catchCoerceFailure(fn,x,t1,t2) ==
1335  -- compiles a catchpoint for compiling boot coercions
1336  c:= CATCH('coerceFailure,FUNCALL(fn,x,t1,t2))
1337  c = $coerceFailure =>
1338    throwKeyedMsgCannotCoerceWithValue(wrap unwrap x,t1,t2)
1339  c
1340
1341coercionFailure() ==
1342  -- does the throw on coercion failure
1343  THROW('coerceFailure,$coerceFailure)
1344
1345coerceByFunction(T,m2) ==
1346  -- using the new modemap selection without coercions
1347  -- should not be called by canCoerceFrom
1348  x := objVal T
1349  x = '_$fromCoerceable_$ => NIL
1350  m2 is ['Union,:.] => NIL
1351  m1 := objMode T
1352  m2 is ['Boolean,:.] and m1 is ['Equation,ud] =>
1353      isWrapped x =>
1354          dcVector := evalDomain ud
1355          fun := NRTcompiledLookup("=", [$Boolean, '$, '$], dcVector)
1356          [fn, :d]:= fun
1357          x := unwrap x
1358          mkObjWrap(SPADCALL(first x, rest x, fun), m2)
1359      dcVector := evalDomain m1
1360      fun := NRTcompileEvalForm("coerce", [$Boolean, '$], dcVector)
1361      code := ['SPADCALL, x, fun]
1362      objNew(code, $Boolean)
1363  -- If more than one function is found, any should suffice, I think -scm
1364  if not (mm := coerceConvertMmSelection(funName := 'coerce,m1,m2)) then
1365    mm := coerceConvertMmSelection(funName := 'convert,m1,m2)
1366  mm =>
1367    [[dc,tar,:args],slot,.]:= mm
1368    fun:=
1369      isWrapped x =>
1370        interpLookup(funName, slot, dc)
1371      NRTcompileEvalForm(funName, slot, evalDomain(dc))
1372    [fn,:d]:= fun
1373    fn = function Undef => NIL
1374    isWrapped x =>
1375      val := CATCH('coerceFailure, SPADCALL(unwrap x,fun))
1376      (val = $coerceFailure) => NIL
1377      objNewWrap(val,m2)
1378    env := fun
1379    code := ['SPADCALL, x, env]
1380--  tar is ['Union,:.] => objNew(['failCheck,code],m2)
1381    objNew(code,m2)
1382  NIL
1383
1384hasCorrectTarget(m,sig is [dc,tar,:.]) ==
1385  -- tests whether the target of signature sig is either m or a union
1386  -- containing m. It also discards TEQ as it is not meant to be
1387  -- used at top-level
1388  dc is ['TypeEquivalence,:.] => NIL
1389  m=tar => 'T
1390  tar is ['Union,t,'failed] => t=m
1391  tar is ['Union,'failed,t] and t=m
1392
1393
1394--% Interpreter Code Generation Routines
1395
1396--Modified by JHD 9/9/93 to fix a problem with coerces inside
1397--interpreter functions being used as mappings. They were being
1398--handled with $useCoerceOrCroak being NIL, and therefore internal
1399--coercions were not correctly handled. Fix: remove dependence
1400--on $useCoerceOrCroak, and test explicitly for Mapping types.
1401
1402--% COERCE
1403
1404intCodeGenCOERCE(triple,t2) ==
1405  -- NOTE: returns a triple
1406  t1 := objMode triple
1407  t1 = $EmptyMode => NIL
1408  t1 = t2 => triple
1409  val := objVal triple
1410
1411  val is ['THROW,label,code] =>
1412    if label is ['QUOTE, l] then label := l
1413    null($compilingMap) or (label ~= mapCatchName($mapName)) =>
1414      objNew(['THROW,label,wrapped2Quote objVal
1415        intCodeGenCOERCE(objNew(code,t1),t2)],t2)
1416    -- we have a return statement. just send it back as is
1417    objNew(val,t2)
1418
1419  val is ['PROGN,:code,lastCode] =>
1420    objNew(['PROGN,:code,wrapped2Quote objVal
1421      intCodeGenCOERCE(objNew(lastCode,t1),t2)],t2)
1422
1423  val is ['COND,:conds] =>
1424    objNew(['COND,
1425      :[[p,wrapped2Quote objVal intCodeGenCOERCE(objNew(v,t1),t2)]
1426        for [p,v] in conds]],t2)
1427
1428  -- specially handle subdomain
1429  absolutelyCanCoerceByCheating(t1,t2) => objNew(val,t2)
1430
1431  -- specially handle coerce to Any
1432  t2 = '(Any) => objNew(['CONS,MKQ t1,val],t2)
1433
1434  -- optimize coerces from Any
1435  (t1 = '(Any)) and (val is [ ='CONS,t1',val']) =>
1436    intCodeGenCOERCE(objNew(val',removeQuote t1'),t2)
1437
1438  -- specially handle coerce from Equation to Boolean
1439  (t1 is ['Equation,:.]) and (t2 = $Boolean) =>
1440    coerceByFunction(triple,t2)
1441
1442  -- next is hack for if-then-elses
1443  (t1 = '$NoValueMode) and (val is ['COND,pred]) =>
1444    code :=
1445      ['COND,pred,
1446        [MKQ true,['throwKeyedMsg,MKQ "S2IM0016",MKQ $mapName]]]
1447    objNew(code,t2)
1448
1449  -- optimize coerces to OutputForm
1450  t2 = $OutputForm =>
1451    coerceByFunction(triple,t2)
1452
1453  isSubDomain(t1, $Integer) =>
1454    intCodeGenCOERCE(objNew(val, $Integer), t2)
1455
1456  -- generate code
1457  -- 1. See if the coercion will go through (absolutely)
1458  --    Must be careful about variables or else things like
1459  --    P I --> P[x] P I might not have the x in the original polynomial
1460  --    put in the correct place
1461
1462  (not containsVariables(t2)) and canCoerceByFunction(t1,t2) =>
1463    -- try coerceByFunction
1464    (not canCoerceByMap(t1,t2)) and
1465      (code := coerceByFunction(triple,t2)) => code
1466    intCodeGenCoerce1(val,t1,t2)
1467
1468  -- 2. Set up a failure point otherwise
1469
1470  intCodeGenCoerce1(val,t1,t2)
1471
1472intCodeGenCoerce1(val,t1,t2) ==
1473  -- Internal function to previous one
1474  -- designed to ensure that we don't use coerceOrCroak on mappings
1475--(t2 is ['Mapping,:.]) => THROW('coerceOrCroaker, 'croaked)
1476  objNew(['coerceOrCroak,mkObjCode(['wrap,val],t1),
1477        MKQ t2, MKQ $mapName],t2)
1478
1479