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