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 35New Selection of Modemaps 36 37selection of applicable modemaps is done in two steps: 38 first it tries to find a modemap inside an argument domain, and if 39 this fails, by evaluation of pattern modemaps 40the result is a list of functions with signatures, which have the 41 following form: 42 [sig,elt,cond] where 43 sig is the signature gained by evaluating the modemap condition 44 elt is the slot number to get the implementation 45 cond are runtime checks which are the results of evaluating the 46 modemap condition 47 48the following flags are used: 49 $Coerce is NIL, if function selection is done which requires exact 50 matches (e.g. for coercion functions) 51 if $SubDom is true, then runtime checks have to be compiled 52)endif 53 54sayFunctionSelection(op,args,target,dc,func) == 55 $abbreviateTypes : local := true 56 startTimingProcess 'debug 57 fsig := formatSignatureArgs args 58 if not LISTP fsig then fsig := LIST fsig 59 if func then func := bright ['"by ",func] 60 sayMSG concat ['%l,:bright '"Function Selection for",op,:func,'%l, 61 '" Arguments:",:bright fsig] 62 if target then sayMSG concat ['" Target type:", 63 :bright prefix2String target] 64 if dc then sayMSG concat ['" From: ", 65 :bright prefix2String dc] 66 stopTimingProcess 'debug 67 68sayFunctionSelectionResult(op,args,mmS) == 69 $abbreviateTypes : local := true 70 startTimingProcess 'debug 71 if mmS then printMms mmS 72 else sayMSG concat ['" -> no function",:bright op, 73 '"found for arguments",:bright formatSignatureArgs args] 74 stopTimingProcess 'debug 75 76selectMms(op,args,$declaredMode) == 77 -- selects applicable modemaps for node op and arguments args 78 -- if there is no local modemap, and it is not a package call, then 79 -- the cached function selectMms1 is called 80 startTimingProcess 'modemaps 81 n:= getUnname op 82 val := getValue op 83 opMode := objMode val 84 85 -- see if we have a functional parameter 86 ((isSharpVarWithNum(n) and opMode) or (val and opMode)) and 87 opMode is ['Mapping,:ta] => 88 imp := 89 val => wrapped2Quote objVal val 90 n 91 [[['local,:ta], imp , NIL]] 92 93 ((isSharpVarWithNum(n) and opMode) or (val and opMode)) and 94 opMode is ['Variable,f] => 95 emptyAtree op 96 op.0 := f 97 selectMms(op,args,$declaredMode) 98 99 isSharpVarWithNum(n) and opMode is ['FunctionCalled,f] => 100 op.0 := f 101 selectMms(op,args,$declaredMode) 102 103 types1 := getOpArgTypes(n,args) 104 numArgs := #args 105 member($EmptyMode,types1) => NIL 106 107 tar := getTarget op 108 dc := getAtree(op,'dollar) 109 110 null dc and val and objMode(val) = $AnonymousFunction => 111 tree := mkAtree objValUnwrap getValue op 112 putTarget(tree,['Mapping,tar,:types1]) 113 bottomUp tree 114 val := getValue tree 115 [[['local,:rest objMode val], wrapped2Quote objVal val, NIL]] 116 117 if (n = 'map) and (first types1 = $AnonymousFunction) 118 then 119 tree := mkAtree objValUnwrap getValue first args 120 ut := 121 tar => underDomainOf tar 122 NIL 123 ua := [underDomainOf x for x in rest types1] 124 member(NIL,ua) => NIL 125 putTarget(tree,['Mapping,ut,:ua]) 126 bottomUp tree 127 val := getValue tree 128 types1 := [objMode val,:rest types1] 129 RPLACA(args,tree) 130 131 if numArgs = 1 and (n = "numer" or n = "denom") and 132 isEqualOrSubDomain(first types1,$Integer) and null dc then 133 dc := ['Fraction, $Integer] 134 putAtree(op, 'dollar, dc) 135 136 137 if $reportBottomUpFlag then sayFunctionSelection(n,types1,tar,dc,NIL) 138 139 identType := 'Variable 140 for x in types1 while not $declaredMode repeat 141 not EQCAR(x,identType) => $declaredMode:= x 142 types2 := [altTypeOf(x,y,$declaredMode) for x in types1 for y in args] 143 144 mmS:= 145 dc => selectDollarMms(dc,n,types1,types2) 146 147 if n = "/" and tar = $Integer then 148 tar := $RationalNumber 149 putTarget(op,tar) 150 151 -- now to speed up some standard selections 152 if not tar then 153 tar := defaultTarget(op,n,#types1,types1) 154 if tar and $reportBottomUpFlag then 155 sayMSG concat ['" Default target type:", 156 :bright prefix2String tar] 157 158 selectLocalMms(op,n,types1,tar) or 159 (VECTORP op and selectMms1(n,tar,types1,types2,'T)) 160 if $reportBottomUpFlag then sayFunctionSelectionResult(n,types1,mmS) 161 stopTimingProcess 'modemaps 162 mmS 163 164-- selectMms1 is in clammed.boot 165 166selectMms2(op,tar,args1,args2,$Coerce) == 167 -- decides whether to find functions from a domain or package 168 -- or by general modemap evaluation 169 if tar = $EmptyMode then tar := NIL 170 nargs := #args1 171 mmS := NIL 172 mmS := 173 -- special case map for the time being 174 $Coerce and (op = 'map) and (2 = nargs) and 175 (first(args1) is ['Variable,fun]) => 176 null (ud := underDomainOf CADR args1) => NIL 177 if tar then ut := underDomainOf(tar) 178 else ut := nil 179 null (mapMms := selectMms1(fun,ut,[ud],[NIL],true)) => NIL 180 mapMm := CDAAR mapMms 181 selectMms1(op,tar,[['Mapping,:mapMm],CADR args1], 182 [NIL,CADR args2],$Coerce) 183 184 $Coerce and (op = 'map) and (2 = nargs) and 185 (first(args1) is ['FunctionCalled,fun]) => 186 null (ud := underDomainOf CADR args1) => NIL 187 if tar then ut := underDomainOf(tar) 188 else ut := nil 189 funNode := mkAtreeNode fun 190 transferPropsToNode(fun,funNode) 191 null (mapMms := selectLocalMms(funNode,fun,[ud],NIL)) => NIL 192 mapMm := CDAAR mapMms 193 selectMms1(op,tar,[['Mapping,:mapMm],CADR args1], 194 [NIL,CADR args2],$Coerce) 195 196 -- get the argument domains and the target 197 a := nil 198 for x in args1 repeat if x then a := cons(x,a) 199 for x in args2 repeat if x then a := cons(x,a) 200 if tar and not isPartialMode tar then a := cons(tar,a) 201 202 -- for typically homogeneous functions, throw in resolve too 203 if op in '(_= _+ _* _- ) then 204 r := resolveTypeList a 205 if r ~= nil then a := cons(r,a) 206 207 if tar and not isPartialMode tar then 208 if xx := underDomainOf(tar) then a := cons(xx,a) 209 for x in args1 repeat 210 PAIRP(x) and first(x) in '(List Vector Stream FiniteSet Array) => 211 xx := underDomainOf(x) => a := cons(xx,a) 212 213 -- now extend this list with those from the arguments to 214 -- any Unions, Mapping or Records 215 216 a' := nil 217 a := nreverse REMDUP a 218 for x in a repeat 219 null x => 'iterate 220 x is ['Union,:l] => 221 -- check if we have a tagged union 222 l and first l is [":",:.] => 223 for [.,.,t] in l repeat 224 a' := cons(t,a') 225 a' := append(reverse l,a') 226 x is ['Mapping,:l] => a' := append(reverse l,a') 227 x is ['Record,:l] => 228 a' := append(reverse [CADDR s for s in l],a') 229 x is ['FunctionCalled,name] => 230 (xm := get(name,'mode,$e)) and not isPartialMode xm => 231 a' := cons(xm,a') 232 a := append(a,REMDUP a') 233 a := [x for x in a | PAIRP(x)] 234 235 -- step 1. see if we have one without coercing 236 a' := a 237 while a repeat 238 x := first a 239 a := rest a 240 ATOM x => 'iterate 241 mmS := append(mmS, findFunctionInDomain(op,x,tar,args1,args2,NIL,NIL)) 242 243 -- step 2. if we didn't get one, trying coercing (if we are 244 -- suppose to) 245 246 if null(mmS) and $Coerce then 247 a := a' 248 while a repeat 249 x := first a 250 a := rest a 251 ATOM x => 'iterate 252 mmS := append(mmS, 253 findFunctionInDomain(op,x,tar,args1,args2,$Coerce,NIL)) 254 255 mmS or selectMmsGen(op,tar,args1,args2) 256 mmS and orderMms(op, mmS,args1,args2,tar) 257 258isAVariableType t == 259 t is ['Variable,.] or t = $Symbol or t is ['OrderedVariableList,.] 260 261defaultTarget(opNode,op,nargs,args) == 262 -- this is for efficiency. Chooses standard targets for operations 263 -- when no target exists. 264 265 target := nil 266 267 nargs = 0 => 268 op = 'nil => 269 putTarget(opNode, target := '(List (None))) 270 target 271 op = 'true or op = 'false => 272 putTarget(opNode, target := $Boolean) 273 target 274 op = 'pi => 275 putTarget(opNode, target := ['Pi]) 276 target 277 op = 'infinity => 278 putTarget(opNode, target := ['OnePointCompletion, $Integer]) 279 target 280 member(op, '(plusInfinity minusInfinity)) => 281 putTarget(opNode, target := ['OrderedCompletion, $Integer]) 282 target 283 target 284 285 a1 := first args 286 ATOM a1 => target 287 a1f := QCAR a1 288 289 nargs = 1 => 290 op = 'kernel => 291 putTarget(opNode, target := ['Kernel, ['Expression, $Integer]]) 292 target 293 op = 'list => 294 putTarget(opNode, target := ['List, a1]) 295 target 296 target 297 298 a2 := CADR args 299 300 nargs >= 2 and op = "draw" and a1 is ['FunctionCalled,sym] and a2 is ['Segment,.] => 301 302 -- this clears up some confusion over 2D and 3D graphics 303 304 symNode := mkAtreeNode sym 305 transferPropsToNode(sym,symNode) 306 307 nargs >= 3 and CADDR args is ['Segment,.] => 308 selectLocalMms(symNode,sym,[$DoubleFloat, $DoubleFloat],NIL) 309 putTarget(opNode, target := '(ThreeDimensionalViewport)) 310 target 311 312 (mms := selectLocalMms(symNode,sym,[$DoubleFloat],NIL)) => 313 [.,targ,:.] := CAAR mms 314 targ = $DoubleFloat => 315 putTarget(opNode, target := '(TwoDimensionalViewport)) 316 target 317 targ = ['Point, $DoubleFloat] => 318 putTarget(opNode, target := '(ThreeDimensionalViewport)) 319 target 320 target 321 322 target 323 324 nargs >= 2 and op = "makeObject" and a1 is ['FunctionCalled,sym] and a2 is ['Segment,.] => 325 -- we won't actually bother to put a target on makeObject 326 -- this is just to figure out what the first arg is 327 symNode := mkAtreeNode sym 328 transferPropsToNode(sym,symNode) 329 330 nargs >= 3 and CADDR args is ['Segment,.] => 331 selectLocalMms(symNode,sym,[$DoubleFloat, $DoubleFloat],NIL) 332 target 333 334 selectLocalMms(symNode,sym,[$DoubleFloat],NIL) 335 target 336 337 nargs = 2 => 338 op = "elt" => 339 a1 = '(BasicOperator) and a2 is ['List, ['OrderedVariableList, .]] => 340 ['Expression, $Integer] 341 target 342 343 op = "eval" => 344 a1 is ['Expression,b1] and a2 is ['Equation, ['Polynomial,b2]] => 345 target := 346 canCoerce(b2, a1) => a1 347 t := resolveTT(b1, b2) 348 (not t) or (t = $Any) => nil 349 resolveTT(a1, t) 350 if target then putTarget(opNode, target) 351 target 352 a1 is ['Equation, .] and a2 is ['Equation, .] => 353 target := resolveTT(a1, a2) 354 if target and not (target = $Any) then putTarget(opNode,target) 355 else target := nil 356 target 357 a1 is ['Equation, .] and a2 is ['List, a2e] and a2e is ['Equation, .] => 358 target := resolveTT(a1, a2e) 359 if target and not (target = $Any) then putTarget(opNode,target) 360 else target := nil 361 target 362 a2 is ['Equation, a2e] or a2 is ['List, ['Equation, a2e]] => 363 target := resolveTT(a1, a2e) 364 if target and not (target = $Any) then putTarget(opNode,target) 365 else target := nil 366 target 367 368 op = "**" or op = "^" => 369 a2 = $Integer => 370 if (target := resolveTCat(a1,'(Field))) then 371 putTarget(opNode,target) 372 target 373 a1 = '(AlgebraicNumber) and (a2 = $Float or a2 = $DoubleFloat) => 374 target := ['Expression, a2] 375 putTarget(opNode,target) 376 target 377 a1 = '(AlgebraicNumber) and a2 is ['Complex, a3] and (a3 = $Float or a3 = $DoubleFloat) => 378 target := ['Expression, a3] 379 putTarget(opNode,target) 380 target 381 ((a2 = $RationalNumber) and 382 (typeIsASmallInteger(a1) or isEqualOrSubDomain(a1,$Integer))) => 383 putTarget(opNode, target := '(AlgebraicNumber)) 384 target 385 ((a2 = $RationalNumber) and (isAVariableType(a1) 386 or a1 is ['Polynomial, .])) => 387 putTarget(opNode, target := defaultTargetFE a1) 388 target 389 isAVariableType(a1) and (a2 = $PositiveInteger or a2 = $NonNegativeInteger) => 390 putTarget(opNode, target := '(Polynomial (Integer))) 391 target 392 isAVariableType(a2) => 393 putTarget(opNode, target := defaultTargetFE a1) 394 target 395 a2 is ['Polynomial, D] => 396 (a1 = a2) or isAVariableType(a1) 397 or (a1 = D) 398 or ((a1 is [=$QuotientField, D1]) and (D1 = a1)) => 399 putTarget(opNode, target := defaultTargetFE a2) 400 target 401 target 402 target 403 404 op = '_/ => 405 isEqualOrSubDomain(a1, $Integer) and isEqualOrSubDomain(a2, $Integer) => 406 putTarget(opNode, target := $RationalNumber) 407 target 408 a1 = a2 => 409 if (target := resolveTCat(first args, '(Field))) then 410 putTarget(opNode,target) 411 target 412 a1 is ['Variable,.] and a2 is ['Variable,.] => 413 putTarget(opNode,target := mkRationalFunction '(Integer)) 414 target 415 isEqualOrSubDomain(a1,$Integer) and a2 is ['Variable,.] => 416 putTarget(opNode,target := mkRationalFunction '(Integer)) 417 target 418 a1 is ['Variable,.] and 419 a2 is ['Polynomial,D] => 420 putTarget(opNode,target := mkRationalFunction D) 421 target 422 target 423 a2 is ['Variable,.] and 424 a1 is ['Polynomial,D] => 425 putTarget(opNode,target := mkRationalFunction D) 426 target 427 target 428 a2 is ['Polynomial,D] and (a1 = D) => 429 putTarget(opNode,target := mkRationalFunction D) 430 target 431 target 432 433 a3 := CADDR args 434 nargs = 3 => 435 op = "eval" => 436 a3 is ['List, a3e] => 437 target := resolveTT(a1, a3e) 438 if not (target = $Any) then putTarget(opNode,target) 439 else target := nil 440 target 441 442 target := resolveTT(a1, a3) 443 if not (target = $Any) then putTarget(opNode,target) 444 else target := nil 445 target 446 target 447 448mkRationalFunction D == ['Fraction, ['Polynomial, D]] 449 450defaultTargetFE(a,:options) == 451 a is ['Variable,.] or a = $RationalNumber or MEMQ(QCAR a, 452 [QCAR $Symbol, 453 'Pi]) or typeIsASmallInteger(a) or isEqualOrSubDomain(a, $Integer) or 454 a = '(AlgebraicNumber) => 455 IFCAR options => [$FunctionalExpression, ['Complex, $Integer]] 456 [$FunctionalExpression, $Integer] 457 a is ['Complex,uD] => defaultTargetFE(uD, true) 458 a is [D, uD] and MEMQ(D, '(Polynomial Fraction)) => 459 defaultTargetFE(uD, IFCAR options) 460 a is [=$FunctionalExpression,.] => a 461 IFCAR options => [$FunctionalExpression, ['Complex, a]] 462 [$FunctionalExpression, a] 463 464altTypeOf(type,val,$declaredMode) == 465 (EQCAR(type,'Symbol) or EQCAR(type,'Variable)) and 466 (a := getMinimalVarMode(objValUnwrap getValue(val),$declaredMode)) => 467 a 468 type is ['OrderedVariableList,vl] and 469 INTEGERP(val1 := objValUnwrap getValue(val)) and 470 (a := getMinimalVarMode(vl.(val1 - 1),$declaredMode)) => 471 a 472 type = $PositiveInteger => $Integer 473 type = $NonNegativeInteger => $Integer 474 type = '(List (PositiveInteger)) => '(List (Integer)) 475 NIL 476 477getOpArgTypes(opname, args) == 478 l := getOpArgTypes1(opname, args) 479 [f(a,opname) for a in l] where 480 f(x,op) == 481 x is ['FunctionCalled,g] and op ~= 'name => 482 m := get(g,'mode,$e) => 483 m is ['Mapping,:.] => m 484 x 485 x 486 x 487 488getOpArgTypes1(opname, args) == 489 null args => NIL 490 -- special cases first 491 opname = 'coef and args is [b,n] => 492 [first getModeSet b, first getModeSetUseSubdomain n] 493 opname = 'monom and args is [d,c] => 494 [first getModeSetUseSubdomain d, first getModeSet c] 495 opname = 'monom and args is [v,d,c] => 496 [first getModeSet v, first getModeSetUseSubdomain d, first getModeSet c] 497 (opname = 'cons) and (2 = #args) and (CADR(args) = 'nil) => 498 ms := [first getModeSet x for x in args] 499 if CADR(ms) = '(List (None)) then 500 ms := [first ms,['List,first ms]] 501 ms 502 nargs := #args 503 v := argCouldBelongToSubdomain(opname,nargs) 504 mss := NIL 505 for i in 0..(nargs-1) for x in args repeat 506 ms := 507 v.i = 0 => first getModeSet x 508 first getModeSetUseSubdomain x 509 mss := [ms,:mss] 510 nreverse mss 511 512argCouldBelongToSubdomain(op, nargs) == 513 -- this returns a vector containing 0 or ^0 for each argument. 514 -- if ^0, this indicates that there exists a modemap for the 515 -- op that needs a subdomain in that position 516 nargs = 0 => NIL 517 v := GETZEROVEC nargs 518 isMap(op) => v 519 mms := getModemapsFromDatabase(op,nargs) 520 null mms => v 521 nargs:=nargs-1 522 -- each signature has form 523 -- [domain of implementation, target, arg1, arg2, ...] 524 for [sig,cond,:.] in mms repeat 525 for t in CDDR sig for i in 0..(nargs) repeat 526 CONTAINEDisDomain(t,cond) => 527 v.i := 1 + v.i 528 v 529 530CONTAINEDisDomain(symbol,cond) == 531-- looks for [isSubDomain,symbol,[domain]] in cond: returning T or NIL 532-- with domain being one of PositiveInteger and NonNegativeInteger 533 ATOM cond => false 534 MEMQ(QCAR cond,'(AND OR and or)) => 535 or/[CONTAINEDisDomain(symbol, u) for u in QCDR cond] 536 EQ(QCAR cond,'isDomain) => 537 EQ(symbol,CADR cond) and PAIRP(dom:=CADDR cond) and 538 MEMQ(dom,'(PositiveInteger NonNegativeInteger)) 539 false 540 541selectDollarMms(dc,name,types1,types2) == 542 -- finds functions for name in domain dc 543 isPartialMode dc => throwKeyedMsg("S2IF0001",NIL) 544 mmS := findFunctionInDomain(name,dc,NIL,types1,types2,'T,'T) => 545 orderMms(name, mmS,types1,types2,NIL) 546 if $reportBottomUpFlag then sayMSG 547 ["%b",'" function not found in ",prefix2String dc,"%d","%l"] 548 NIL 549 550selectLocalMms(op,name,types,tar) == 551 -- partial rewrite, looks now for exact local modemap 552 mmS:= getLocalMms(name,types,tar) => mmS 553 obj := getValue op 554 obj and (objVal obj is ['SPADMAP, :mapDef]) and 555 analyzeMap(op,types,mapDef,tar) and getLocalMms(name,types,tar) 556 557-- next defn may be better, test when more time. RSS 3/11/94 558-- selectLocalMms(op,name,types,tar) == 559-- mmS := getLocalMms(name,types,tar) 560-- -- if no target, just return what we got 561-- mmS and null tar => mmS 562-- matchingMms := nil 563-- for mm in mmS repeat 564-- [., targ, :.] := mm 565-- if tar = targ then matchingMms := cons(mm, matchingMms) 566-- -- if we got some exact matches on the target, return them 567-- matchingMms => nreverse matchingMms 568-- 569-- obj := getValue op 570-- obj and (objVal obj is ['SPADMAP, :mapDef]) and 571-- analyzeMap(op,types,mapDef,tar) and getLocalMms(name,types,tar) 572 573getLocalMms(name,types,tar) == 574 -- looks for exact or subsumed local modemap in $e 575 mmS := NIL 576 for (mm:=[dcSig,:.]) in get(name,'localModemap,$e) repeat 577 -- check format and destructure 578 dcSig isnt [dc,result,:args] => NIL 579 -- make number of args is correct 580 #types ~= #args => NIL 581 -- check for equal or subsumed arguments 582 subsume := (not $useIntegerSubdomain) or (tar = result) or 583 get(name,'recursive,$e) 584 acceptableArgs := 585 and/[f(b,a,subsume) for a in args for b in types] where 586 f(x,y,subsume) == 587 if subsume 588 then isEqualOrSubDomain(x,y) 589 else x = y 590 not acceptableArgs => 591 -- interpreted maps are ok 592 dc = 'interpOnly and not($Coerce)=> mmS := [mm,:mmS] 593 NIL 594 mmS := [mm,:mmS] 595 nreverse mmS 596 597-- Helper to avoid bad coercions (SF 2974970). See 598-- 599-- http://groups.google.com/group/fricas-devel/browse_thread/thread/a93abc242431a6bc?hl=en# 600-- 601-- for more info. 602isApproximate(t) == 603 op := first(t) 604 member(op, ["Float", "DoubleFloat"]) => true 605 member(op, ["Complex", "Expression", "List", "Polynomial", 606 "Matrix", "Vector"]) => isApproximate(first(rest(t))) 607 false 608 609mmCost(name, sig,cond,tar,args1,args2) == 610 cost := mmCost0(name, sig,cond,tar,args1,args2) 611 res := CADR sig 612 res = $PositiveInteger => cost - 2 613 res = $NonNegativeInteger => cost - 1 614 res = $DoubleFloat => cost + 1 615 cost 616 617mmCost0(name, sig,cond,tar,args1,args2) == 618 sigArgs := CDDR sig 619 n:= 620 null cond => 1 621 not (or/cond) => 1 622 0 623 624 -- try to favor homogeneous multiplication 625 626--if name = "*" and 2 = #sigArgs and first sigArgs ~= first rest sigArgs then n := n + 1 627 628 -- because of obscure problem in evalMm, sometimes we will have extra 629 -- modemaps with the wrong number of arguments if we want to the one 630 -- with no arguments and the name is overloaded. Thus check for this. 631 632 nargs := #args1 633 634 if args1 then 635 for x1 in args1 for x2 in args2 for x3 in sigArgs repeat 636 n := n + 637 isEqualOrSubDomain(x1,x3) => 0 638 topcon := first deconstructT x1 639 topcon2 := first deconstructT x3 640 topcon = topcon2 => 3 641 first topcon2 = 'Mapping => 2 642 4 643 if isApproximate(x1) ~= isApproximate(x3) then 644 n := n + 10*nargs 645 else if sigArgs then n := n + 100000000000 646 647 res := CADR sig 648 res=tar => 10000*n 649 10000*n + 1000*domainDepth(res) + hitListOfTarget(res) 650 651orderMms(name, mmS,args1,args2,tar) == 652 -- it counts the number of necessary coercions of the argument types 653 -- if this isn't enough, it compares the target types 654 mmS and null rest mmS => mmS 655 mS:= NIL 656 N:= NIL 657 for mm in MSORT mmS repeat 658 [sig,.,cond]:= mm 659 b:= 'T 660 p:= CONS(m := mmCost(name, sig,cond,tar,args1,args2),mm) 661 mS:= 662 null mS => list p 663 m < CAAR mS => CONS(p,mS) 664 S:= mS 665 until b repeat 666 b := null rest S or m < CAADR S => 667 RPLACD(S, CONS(p, rest S)) 668 S := rest S 669 mS 670 mmS and [rest p for p in mS] 671 672domainDepth(d) == 673 -- computes the depth of lisp structure d 674 atom d => 0 675 MAX(domainDepth(first d) + 1, domainDepth(rest d)) 676 677hitListOfTarget(t) == 678 -- assigns a number between 1 and 998 to a type t 679 680 -- want to make it hard to go to Polynomial Pi 681 682 t = '(Polynomial (Pi)) => 90000 683 684 EQ(first t, 'Polynomial) => 300 685 EQ(first t, 'List) => 400 686 EQ(first t, 'Matrix) => 910 687 EQ(first t, 'UniversalSegment) => 501 688 EQ(first t, 'Union) => 999 689 EQ(first t, 'Expression) => 1600 690 500 691 692isOpInDomain(opName,dom,nargs) == 693 -- returns true only if there is an op in the given domain with 694 -- the given number of arguments 695 mmList := ASSQ(opName, getOperationAlistFromLisplib first dom) 696 mmList := subCopy(mmList,constructSubst dom) 697 null mmList => NIL 698 gotOne := NIL 699 nargs := nargs + 1 700 for mm in rest mmList while not gotOne repeat 701 nargs = #first mm => gotOne := [mm, :gotOne] 702 gotOne 703 704findCommonSigInDomain(opName,dom,nargs) == 705 -- this looks at all signatures in dom with given opName and nargs 706 -- number of arguments. If no matches, returns NIL. Otherwise returns 707 -- a "signature" where a type position is non-NIL only if all 708 -- signatures shares that type . 709 first(dom) in '(Union Record Mapping) => NIL 710 mmList := ASSQ(opName, getOperationAlistFromLisplib first dom) 711 mmList := subCopy(mmList,constructSubst dom) 712 null mmList => NIL 713 gotOne := NIL 714 nargs := nargs + 1 715 vec := NIL 716 for mm in rest mmList repeat 717 nargs = #first mm => 718 null vec => vec := LIST2VEC first mm 719 for i in 0.. for x in first mm repeat 720 if vec.i and vec.i ~= x then vec.i := NIL 721 VEC2LIST vec 722 723findUniqueOpInDomain(op,opName,dom) == 724 -- return function named op in domain dom if unique, choose one if not 725 mmList := ASSQ(opName, getOperationAlistFromLisplib first dom) 726 mmList := subCopy(mmList,constructSubst dom) 727 null mmList => 728 throwKeyedMsg("S2IS0021",[opName,dom]) 729 mmList := rest mmList -- ignore the operator name 730 -- use evaluation type context to narrow down the candidate set 731 if target := getTarget op then 732 mmList := [mm for mm in mmList | mm is [=rest target,:.]] 733 null mmList => throwKeyedMsg("S2IS0061",[opName,target,dom]) 734 if #mmList > 1 then 735 mm := selectMostGeneralMm mmList 736 sayKeyedMsg("S2IS0022", [opName, dom, ['Mapping, :first mm]]) 737 else mm := first mmList 738 [sig,slot,:.] := mm 739 fun := 740--+ 741 $genValue => 742 compiledLookupCheck(opName,sig,evalDomain dom) 743 NRTcompileEvalForm(opName, sig, evalDomain dom) 744 NULL(fun) or NULL(PAIRP(fun)) => NIL 745 first fun = function(Undef) => throwKeyedMsg("S2IS0023", [opName, dom]) 746 binVal := 747 $genValue => wrap fun 748 fun 749 putValue(op,objNew(binVal,m:=['Mapping,:sig])) 750 putModeSet(op,[m]) 751 752selectMostGeneralMm mmList == 753 -- selects the modemap in mmList with arguments all the other 754 -- argument types can be coerced to 755 -- also selects function with #args closest to 2 756 min := 100 757 mml := mmList 758 while mml repeat 759 [mm,:mml] := mml 760 sz := #first mm 761 if (met := ABS(sz - 3)) < min then 762 min := met 763 fsz := sz 764 mmList := [mm for mm in mmList | (#first mm) = fsz] 765 mml := rest mmList 766 genMm := first mmList 767 while mml repeat 768 [mm,:mml] := mml 769 and/[canCoerceFrom(genMmArg,mmArg) for mmArg in CDAR mm 770 for genMmArg in CDAR genMm] => genMm := mm 771 genMm 772 773findFunctionInDomain(op,dc,tar,args1,args2,$Coerce,$SubDom) == 774 -- looks for a modemap for op with signature args1 -> tar 775 -- in the domain of computation dc 776 -- tar may be NIL (= unknown) 777 null isLegitimateMode(tar, nil, nil) => nil 778 dcName := first dc 779 member(dcName,'(Union Record Mapping Enumeration)) => 780 -- First cut code that ignores args2, $Coerce and $SubDom 781 -- When domains no longer have to have Set, the hard coded 6 and 7 782 -- should go. 783 op = '_= => 784 #args1 ~= 2 or args1.0 ~= dc or args1.1 ~= dc => NIL 785 tar and tar ~= '(Boolean) => NIL 786 [[[dc, '(Boolean), dc, dc], ['(Boolean),'$,'$], [NIL, NIL]]] 787 op = 'coerce => 788 dcName='Enumeration and (args1.0=$Symbol or tar=dc)=> 789 [[[dc, dc, $Symbol], ['$,$Symbol], [NIL, NIL]]] 790 args1.0 ~= dc => NIL 791 tar and tar ~= $OutputForm => NIL 792 [[[dc, $OutputForm, dc], [$OutputForm, '$], [NIL, NIL]]] 793 member(dcName,'(Record Union)) => 794 findFunctionInCategory(op,dc,tar,args1,args2,$Coerce,$SubDom) 795 NIL 796 fun:= NIL 797 ( p := ASSQ(op,getOperationAlistFromLisplib dcName) ) and 798 SL := constructSubst dc 799 -- if the arglist is homogeneous, first look for homogeneous 800 -- functions. If we don't find any, look at remaining ones 801 if isHomogeneousList args1 then 802 q := NIL 803 r := NIL 804 for mm in rest p repeat 805 -- CDAR of mm is the signature argument list 806 if isHomogeneousList CDAR mm then q := [mm,:q] 807 else r := [mm,:r] 808 q := allOrMatchingMms(q,args1,tar,dc) 809 for mm in q repeat 810 fun:= nconc(fun,findFunctionInDomain1(mm,op,tar,args1,args2,SL)) 811 r := reverse r 812 else r := rest p 813 r := allOrMatchingMms(r,args1,tar,dc) 814 if not fun then -- consider remaining modemaps 815 for mm in r repeat 816 fun:= nconc(fun,findFunctionInDomain1(mm,op,tar,args1,args2,SL)) 817 if not fun and $reportBottomUpFlag then 818 sayMSG concat 819 ['" -> no appropriate",:bright op,'"found in", 820 :bright prefix2String dc] 821 fun 822 823allOrMatchingMms(mms,args1,tar,dc) == 824 -- if there are exact matches on the arg types, return them 825 -- otherwise return the original list 826 null mms or null rest mms => mms 827 x := NIL 828 for mm in mms repeat 829 [sig,:.] := mm 830 [res,:args] := MSUBSTQ(dc,"$",sig) 831 args ~= args1 => nil 832 x := CONS(mm,x) 833 if x then x 834 else mms 835 836isHomogeneousList y == 837 y is [x] => true 838 y and rest y => 839 z := first y 840 "and"/[x = z for x in rest y] 841 NIL 842 843findFunctionInDomain1(omm,op,tar,args1,args2,SL) == 844 dc := rest (dollarPair := ASSQ('$, SL)) 845 -- need to drop '$ from SL 846 mm:= subCopy(omm, SL) 847 -- tests whether modemap mm is appropriate for the function 848 -- defined by op, target type tar and argument types args 849 850 [sig,slot,cond,y] := mm 851 [osig,:.] := omm 852 osig := subCopy(osig, SUBSTQ(CONS('$,'$), dollarPair, SL)) 853 if CONTAINED('_#, sig) or CONTAINED('construct, sig) then 854 sig := [replaceSharpCalls t for t in sig] 855 rtcp := [[]] 856 matchMmCond cond and matchMmSig(mm,tar,args1,args2, rtcp) and 857 -- RTC is a list of run-time checks to be performed 858 RTC := nreverse CAR(rtcp) 859 EQ(y, 'ELT) => [[CONS(dc, sig), osig, RTC]] 860 EQ(y, 'CONST) => [[CONS(dc,sig),osig, RTC]] 861 EQ(y, 'ASCONST) => [[CONS(dc, sig), osig, RTC]] 862 y is ['XLAM, :.] => [[CONS(dc,sig), y, RTC]] 863 sayKeyedMsg("S2IF0006",[y]) 864 NIL 865 866--------------------> NEW DEFINITION (override in xrun.boot) 867findFunctionInCategory(op,dc,tar,args1,args2,$Coerce,$SubDom) == 868 -- looks for a modemap for op with signature args1 -> tar 869 -- in the domain of computation dc 870 -- tar may be NIL (= unknown) 871 dcName := first dc 872 not MEMQ(dcName,'(Record Union Enumeration)) => NIL 873 fun:= NIL 874 -- cat := constructorCategory dc 875 makeFunc := get_oplist_maker(dcName) or 876 systemErrorHere '"findFunctionInCategory" 877 [funlist,.] := FUNCALL(makeFunc,"$",dc,$CategoryFrame) 878 -- get list of implementations and remove sharps 879 maxargs := -1 880 impls := nil 881 for [a,b,d] in funlist repeat 882 not EQ(a,op) => nil 883 d is ['XLAM,xargs,:.] => 884 if PAIRP(xargs) then maxargs := MAX(maxargs,#xargs) 885 else maxargs := MAX(maxargs,1) 886 impls := cons([b,nil,true,d],impls) 887 impls := cons([b,d,true,d],impls) 888 impls := NREVERSE impls 889 if maxargs ~= -1 then 890 SL:= NIL 891 for i in 1..maxargs repeat 892 impls := SUBSTQ(GENSYM(), INTERNL1('"#", STRINGIMAGE i), impls) 893 impls and 894 SL:= constructSubst dc 895 for mm in impls repeat 896 fun:= nconc(fun,findFunctionInDomain1(mm,op,tar,args1,args2,SL)) 897 if not fun and $reportBottomUpFlag then 898 sayMSG concat 899 ['" -> no appropriate",:bright op,'"found in", 900 :bright prefix2String dc] 901 fun 902 903matchMmCond(cond) == 904 -- tests the condition, which comes with a modemap 905 -- cond is 'T or a list, but I hate to test for 'T (ALBI) 906 $domPvar: local := nil 907 atom cond or 908 cond is ['AND,:conds] or cond is ['and,:conds] => 909 and/[matchMmCond c for c in conds] 910 cond is ['OR,:conds] or cond is ['or,:conds] => 911 or/[matchMmCond c for c in conds] 912 cond is ['has,dom,x] => 913 hasCaty(dom,x,NIL) ~= 'failed 914 cond is ['not,cond1] => not matchMmCond cond1 915 keyedSystemError("S2GE0016", 916 ['"matchMmCond",'"unknown form of condition"]) 917 918matchMmSig(mm, tar, args1, args2, rtcp) == 919 -- matches the modemap signature against args1 -> tar 920 -- if necessary, runtime checks are created for subdomains 921 -- then the modemap condition is evaluated 922 [sig,:.]:= mm 923 if CONTAINED('_#, sig) then 924 sig := [replaceSharpCalls COPY t for t in sig] 925 null args1 => matchMmSigTar(tar, first sig) 926 a := rest sig 927 arg:= NIL 928 for i in 1.. while args1 and args2 and a until not b repeat 929 x1 := first args1 930 args1 := rest args1 931 x2 := first args2 932 args2 := rest args2 933 x := first a 934 a := rest a 935 rtc:= NIL 936 if x is ['SubDomain,y,:.] then x:= y 937 b := isEqualOrSubDomain(x1,x) or 938 (STRINGP(x) and (x1 is ['Variable,v]) and (x = PNAME v)) or 939 $SubDom and isSubDomain(x,x1) => rtc:= 'T 940 $Coerce => x2=x or canCoerceFrom(x1,x) 941 x1 is ['Variable,:.] and x = '(Symbol) 942 RPLACA(rtcp, CONS(rtc, CAR(rtcp))) 943 null args1 and null a and b and matchMmSigTar(tar, first sig) 944 945matchMmSigTar(t1,t2) == 946 -- t1 is a target type specified by :: or by a declared variable 947 -- t2 is the target of a modemap signature 948 null t1 or 949 isEqualOrSubDomain(t2,t1) => true 950 if t2 is ['Union,a,b] then 951 if a='"failed" then return matchMmSigTar(t1, b) 952 if b='"failed" then return matchMmSigTar(t1, a) 953 $Coerce and 954 isPartialMode t1 => resolveTM(t2,t1) 955-- I think this should be true -SCM 956-- true 957 canCoerceFrom(t2,t1) 958 959constructSubst(d) == 960 -- constructs a substitution which substitutes d for $ 961 -- and the arguments of d for #1, #2 .. 962 SL:= list CONS('$,d) 963 for x in rest d for v in $FormalMapVariableList repeat 964 SL:= CONS(CONS(v,x),SL) 965 SL 966 967filterModemapsFromPackages(mms, names, op) == 968 -- mms is a list of modemaps 969 -- names is a list of domain constructors 970 -- this returns a 2-list containing those modemaps that have one 971 -- of the names in the package source of the modemap and all the 972 -- rest of the modemaps in the second element. 973 good := NIL 974 bad := NIL 975 for mm in mms repeat 976 isFreeFunctionFromMm(mm) => bad := cons(mm, bad) 977 type := getDomainFromMm mm 978 null type => bad := cons(mm,bad) 979 if PAIRP type then type := first type 980 GETDATABASE(type,'CONSTRUCTORKIND) = 'category => bad := cons(mm,bad) 981 name := object2String type 982 found := nil 983 for n in names while not found repeat 984 STRPOS(n,name,0,NIL) => found := true 985 if found 986 then good := cons(mm, good) 987 else bad := cons(mm,bad) 988 [good,bad] 989 990 991isTowerWithSubdomain(towerType,elem) == 992 not PAIRP towerType => NIL 993 dt := deconstructT towerType 994 2 ~= #dt => NIL 995 s := underDomainOf(towerType) 996 s = elem => towerType 997 isEqualOrSubDomain(s,elem) and constructM(first dt,[elem]) 998 999exact?(mmS, tar, args) == 1000 ex := inex := NIL 1001 for (mm := [sig, [mmC, :.], :.]) in mmS repeat 1002 [c, t, :a] := sig 1003 ok := true 1004 for pat in a for arg in args while ok repeat 1005 not CONTAINED(['isDomain, pat, arg], mmC) => ok := NIL 1006 ok => ex := CONS(mm, ex) 1007 inex := CONS(mm, inex) 1008 [ex, inex] 1009 1010matchMms(mmaps, op, tar, args1, args2) == 1011 mmS := NIL 1012 for [sig, mmC] in mmaps repeat 1013 -- sig is [dc, result, :args] 1014 [c, t, :a] := sig 1015 $Subst := 1016 tar and not isPartialMode tar => 1017 -- throw in the target if it is not the same as one 1018 -- of the arguments 1019 member(t, a) => NIL 1020 [[t, :tar]] 1021 NIL 1022 if a then matchTypes(a, args1, args2) 1023 not EQ($Subst, 'failed) => 1024 mmS := nconc(evalMm(op, tar, sig, mmC), mmS) 1025 mmS 1026 1027selectMmsGen(op,tar,args1,args2) == 1028 -- general modemap evaluation of op with argument types args1 1029 -- evaluates the condition and looks for the slot number 1030 -- returns all functions which are applicable 1031 -- args2 is a list of polynomial types for symbols 1032 $Subst: local := NIL 1033 $SymbolType: local := NIL 1034 1035 null (S := getModemapsFromDatabase(op, LENGTH args1)) => NIL 1036 1037 if (op = 'map) and (2 = #args1) and 1038 (first(args1) is ['Mapping, ., elem]) and 1039 (a := isTowerWithSubdomain(CADR args1,elem)) 1040 then args1 := [first args1, a] 1041 1042 -- we first split the modemaps into two groups: 1043 -- haves: these are from packages that have one of the top level 1044 -- constructor names in the package name 1045 -- havenots: everything else 1046 1047 -- get top level constructor names for constructors with parameters 1048 conNames := nil 1049 if op = 'reshape then args := APPEND(rest args1, rest args2) 1050 else args := APPEND(args1,args2) 1051 if tar then args := [tar,:args] 1052 -- for common aggregates, use under domain also 1053 for a in REMDUP args repeat 1054 a => 1055 atom a => nil 1056 fa := QCAR a 1057 fa in '(Record Union) => NIL 1058 conNames := insert(STRINGIMAGE fa, conNames) 1059 1060 if conNames 1061 then [haves,havenots] := filterModemapsFromPackages(S,conNames,op) 1062 else 1063 haves := NIL 1064 havenots := S 1065 1066 mmS := NIL 1067 1068 if $reportBottomUpFlag then 1069 sayMSG ['%l,:bright '"Modemaps from Associated Packages"] 1070 1071 if haves then 1072 [havesExact, havesInexact] := exact?(haves, tar, args1) 1073 if $reportBottomUpFlag then 1074 for mm in APPEND(havesExact,havesInexact) for i in 1.. repeat 1075 sayModemapWithNumber(mm,i) 1076 if havesExact then 1077 mmS := matchMms(havesExact, op, tar, args1, args2) 1078 if mmS then 1079 if $reportBottomUpFlag then 1080 sayMSG '" found an exact match!" 1081 return mmS 1082 mmS := matchMms(havesInexact,op,tar,args1,args2) 1083 else if $reportBottomUpFlag then sayMSG '" no modemaps" 1084 mmS => mmS 1085 1086 if $reportBottomUpFlag then 1087 sayMSG ['%l,:bright '"Remaining General Modemaps"] 1088 -- for mm in havenots for i in 1.. repeat sayModemapWithNumber(mm,i) 1089 1090 if havenots then 1091 [havesNExact,havesNInexact] := exact?(havenots,tar,args1) 1092 if $reportBottomUpFlag then 1093 for mm in APPEND(havesNExact,havesNInexact) for i in 1.. repeat 1094 sayModemapWithNumber(mm,i) 1095 if havesNExact then 1096 mmS := matchMms(havesNExact,op,tar,args1,args2) 1097 if mmS then 1098 if $reportBottomUpFlag then 1099 sayMSG '" found an exact match!" 1100 return mmS 1101 mmS := matchMms(havesNInexact,op,tar,args1,args2) 1102 else if $reportBottomUpFlag then sayMSG '" no modemaps" 1103 mmS 1104 1105matchTypes(pm,args1,args2) == 1106 -- pm is a list of pattern variables, args1 a list of argument types, 1107 -- args2 a list of polynomial types for symbols 1108 -- the result is a match from pm to args, if one exists 1109 for v in pm for t1 in args1 for t2 in args2 until $Subst='failed repeat 1110 p:= ASSQ(v,$Subst) => 1111 t := rest p 1112 t=t1 => $Coerce and EQCAR(t1,'Symbol) and 1113 (q := ASSQ(v,$SymbolType)) and t2 and 1114 (t3 := resolveTT(rest q, t2)) and 1115 RPLACD(q, t3) 1116 $Coerce => 1117 if EQCAR(t,'Symbol) and (q := ASSQ(v,$SymbolType)) then 1118 t := rest q 1119 if EQCAR(t1,'Symbol) and t2 then t1:= t2 1120 t0 := resolveTT(t,t1) => RPLACD(p,t0) 1121 $Subst:= 'failed 1122 $Subst:= 'failed 1123 $Subst:= CONS(CONS(v,t1),$Subst) 1124 if EQCAR(t1,'Symbol) and t2 then $SymbolType:= CONS(CONS(v,t2),$SymbolType) 1125 1126evalMm(op,tar,sig,mmC) == 1127 -- evaluates a modemap with signature sig and condition mmC 1128 -- the result is a list of lists [sig,slot,cond] or NIL 1129 --if $Coerce is NIL, tar has to be the same as the computed target type 1130 mS:= NIL 1131 for st in evalMmStack mmC repeat 1132 SL:= evalMmCond(op,sig,st) 1133 not EQ(SL,'failed) => 1134 SL := fixUpTypeArgs SL 1135 sig:= [subCopy(deepSubCopy(x,SL),$Subst) for x in sig] 1136 not containsVars sig => 1137 isFreeFunctionFromMmCond mmC and (m := evalMmFreeFunction(op,tar,sig,mmC)) => 1138 mS:= nconc(m,mS) 1139 "or"/[not isValidType(arg) for arg in sig] => nil 1140 [dc,t,:args]:= sig 1141 $Coerce or null tar or tar=t => 1142 mS:= nconc(findFunctionInDomain(op,dc,t,args,args,NIL,'T),mS) 1143 mS 1144 1145evalMmFreeFunction(op,tar,sig,mmC) == 1146 [dc,t,:args]:= sig 1147 $Coerce or null tar or tar=t => 1148 nilArgs := nil 1149 for a in args repeat nilArgs := [NIL,:nilArgs] 1150 [[[["__FreeFunction__",:dc],t,:args], [t, :args], nilArgs]] 1151 nil 1152 1153evalMmStack(mmC) == 1154 -- translates the modemap condition mmC into a list of stacks 1155 mmC is ['AND,:a] => 1156 ["NCONC"/[evalMmStackInner cond for cond in a]] 1157 mmC is ['OR,:args] => [:evalMmStack a for a in args] 1158 mmC is ['partial,:mmD] => evalMmStack mmD 1159 mmC is ['ofCategory,pvar,cat] and cat is ['Join,:args] => 1160 evalMmStack CONS('AND,[['ofCategory,pvar,c] for c in args]) 1161 mmC is ['ofType,:.] => [NIL] 1162 mmC is ['has,pat,x] => 1163 x = 'ATTRIBUTE => BREAK() 1164 x = 'SIGNATURE => 1165 [[['ofCategory,pat,['CATEGORY,'unknown,x]]]] 1166 [['ofCategory,pat,x]] 1167 [[mmC]] 1168 1169evalMmStackInner(mmC) == 1170 mmC is ['OR,:args] => 1171 keyedSystemError("S2GE0016", 1172 ['"evalMmStackInner",'"OR condition nested inside an AND"]) 1173 mmC is ['partial,:mmD] => evalMmStackInner mmD 1174 mmC is ['ofCategory,pvar,cat] and cat is ['Join,:args] => 1175 [['ofCategory, pvar, c] for c in args] 1176 mmC is ['ofType,:.] => NIL 1177 mmC is ['isAsConstant] => NIL 1178 mmC is ['has,pat,x] => 1179 x = 'ATTRIBUTE => BREAK() 1180 x = 'SIGNATURE => 1181 [['ofCategory,pat,['CATEGORY,'unknown,x]]] 1182 [['ofCategory,pat,x]] 1183 [mmC] 1184 1185evalMmCond(op,sig,st) == 1186 $insideEvalMmCondIfTrue : local := true 1187 evalMmCond0(op,sig,st) 1188 1189evalMmCond0(op,sig,st) == 1190 -- evaluates the nonempty list of modemap conditions st 1191 -- the result is either 'failed or a substitution list 1192 SL:= evalMmDom st 1193 SL='failed => 'failed 1194 for p in SL until p1 and not b repeat b:= 1195 p1 := ASSQ(first p, $Subst) 1196 p1 and 1197 t1 := rest p1 1198 t := rest p 1199 t=t1 or 1200 containsVars t => 1201 if $Coerce and EQCAR(t1, 'Symbol) then t1 := getSymbolType first p 1202 resolveTM1(t1,t) 1203 $Coerce and 1204 -- if we are looking at the result of a function, the coerce 1205 -- goes the opposite direction 1206 (t1 = $AnonymousFunction and t is ['Mapping, :.]) => t 1207 first p = CADR sig and not member(first p, CDDR sig) => 1208 canCoerceFrom(t,t1) => 'T 1209 NIL 1210 canCoerceFrom(t1,t) => 'T 1211 isSubDomain(t,t1) => RPLACD(p,t1) 1212 EQCAR(t1, 'Symbol) and canCoerceFrom(getSymbolType first p, t) 1213 ( SL and p1 and not b and 'failed ) or evalMmCat(op,sig,st,SL) 1214 1215fixUpTypeArgs SL == 1216 for (p := [v, :t2]) in SL repeat 1217 t1 := LASSOC(v, $Subst) 1218 null t1 => RPLACD(p,replaceSharpCalls t2) 1219 RPLACD(p, coerceTypeArgs(t1, t2, SL)) 1220 SL 1221 1222replaceSharpCalls t == 1223 noSharpCallsHere t => t 1224 doReplaceSharpCalls t 1225 1226doReplaceSharpCalls t == 1227 ATOM t => t 1228 t is ['_#, l] => #l 1229 t is ['construct,: l] => EVAL ['LIST,:l] 1230 [first t, :[doReplaceSharpCalls u for u in rest t]] 1231 1232noSharpCallsHere t == 1233 t isnt [con, :args] => true 1234 MEMQ(con,'(construct _#)) => NIL 1235 and/[noSharpCallsHere u for u in args] 1236 1237coerceTypeArgs(t1, t2, SL) == 1238 -- if the type t has type-valued arguments, coerce them to the new types, 1239 -- if needed. 1240 t1 isnt [con1, :args1] or t2 isnt [con2, :args2] => t2 1241 con1 ~= con2 => t2 1242 coSig := rest GETDATABASE(first t1, 'COSIG) 1243 and/coSig => t2 1244 csub1 := constructSubst t1 1245 csub2 := constructSubst t2 1246 cs1 := rest getConstructorSignature con1 1247 cs2 := rest getConstructorSignature con2 1248 [con1, : 1249 [makeConstrArg(arg1, arg2, constrArg(c1,csub1,SL), 1250 constrArg(c2,csub2,SL), cs) 1251 for arg1 in args1 for arg2 in args2 for c1 in cs1 for c2 in cs2 1252 for cs in coSig]] 1253 1254constrArg(v,sl,SL) == 1255 x := LASSOC(v,sl) => 1256 y := LASSOC(x,SL) => y 1257 y := LASSOC(x, $Subst) => y 1258 x 1259 y := LASSOC(x, $Subst) => y 1260 v 1261 1262makeConstrArg(arg1, arg2, t1, t2, cs) == 1263 if arg1 is ['_#, l] then arg1 := # l 1264 if arg2 is ['_#, l] then arg2 := # l 1265 cs => arg2 1266 t1 = t2 => arg2 1267 obj1 := objNewWrap(arg1, t1) 1268 obj2 := coerceInt(obj1, t2) 1269 null obj2 => throwKeyedMsgCannotCoerceWithValue(wrap arg1,t1,t2) 1270 objValUnwrap obj2 1271 1272evalMmDom(st) == 1273 -- evals all isDomain(v,d) of st 1274 SL:= NIL 1275 for mmC in st until SL='failed repeat 1276 mmC is ['isDomain,v,d] => 1277 STRINGP d => SL:= 'failed 1278 p := ASSQ(v, SL) and not (d = rest p) => SL := 'failed 1279 d1:= subCopy(d,SL) 1280 CONSP(d1) and MEMQ(v,d1) => SL:= 'failed 1281 SL:= augmentSub(v,d1,SL) 1282 mmC is ['isFreeFunction,v,fun] => 1283 SL:= augmentSub(v,subCopy(fun,SL),SL) 1284 SL 1285 1286orderMmCatStack st == 1287 -- tries to reorder stack so that free pattern variables appear 1288 -- as parameters first 1289 null(st) or null rest(st) => st 1290 vars := DELETE_-DUPLICATES [CADR(s) for s in st | isPatternVar(CADR(s))] 1291 null vars => st 1292 havevars := nil 1293 haventvars := nil 1294 for s in st repeat 1295 cat := CADDR s 1296 mem := nil 1297 for v in vars while not mem repeat 1298 if MEMQ(v,cat) then 1299 mem := true 1300 havevars := cons(s,havevars) 1301 if not mem then haventvars := cons(s,haventvars) 1302 null havevars => st 1303 st := nreverse nconc(haventvars,havevars) 1304 SORT(st, function mmCatComp) 1305 1306mmCatComp(c1, c2) == 1307 b1 := ASSQ(CADR c1, $Subst) 1308 b2 := ASSQ(CADR c2, $Subst) 1309 b1 and null(b2) => true 1310 false 1311 1312evalMmCat(op,sig,stack,SL) == 1313 -- evaluates all ofCategory's of stack as soon as possible 1314 $hope:local:= NIL 1315 numConds:= #stack 1316 stack:= orderMmCatStack [mmC for mmC in stack | EQCAR(mmC,'ofCategory)] 1317 while stack until not makingProgress repeat 1318 st := stack 1319 stack := NIL 1320 makingProgress := NIL 1321 for mmC in st repeat 1322 S:= evalMmCat1(mmC,op, SL) 1323 S='failed and $hope => 1324 stack:= CONS(mmC,stack) 1325 S = 'failed => return S 1326 not atom S => 1327 makingProgress:= 'T 1328 SL:= mergeSubs(S,SL) 1329 if stack or S='failed then 'failed else SL 1330 1331evalMmCat1(mmC is ['ofCategory,d,c],op, SL) == 1332 -- evaluates mmC using information from the lisplib 1333 -- d may contain variables, and the substitution list $Subst is used 1334 -- the result is a substitution or failed 1335 $domPvar: local := NIL 1336 $hope:= NIL 1337 NSL:= hasCate(d,c,SL) 1338 NSL='failed and isPatternVar d and $Coerce and ( p:= ASSQ(d,$Subst) ) 1339 and (EQCAR(rest p, 'Variable) or EQCAR(rest p, 'Symbol)) => 1340 RPLACD(p,getSymbolType d) 1341 hasCate(d,c,SL) 1342 NSL='failed and isPatternVar d => 1343 -- following is hack to take care of the case where we have a 1344 -- free substitution variable with a category condition on it. 1345 -- This would arise, for example, where a package has an argument 1346 -- that is not in a needed modemap. After making the following 1347 -- dummy substitutions, the package can be instantiated and the 1348 -- modemap used. RSS 12-22-85 1349 -- If c is not Set, Ring or Field then the more general mechanism 1350 dom := defaultTypeForCategory(c, SL) 1351 null dom => 1352 op ~= 'coerce => 'failed -- evalMmCatLastChance(d,c,SL) 1353 null (p := ASSQ(d,$Subst)) => 1354 dom => 1355 NSL := [CONS(d,dom)] 1356 op ~= 'coerce => 'failed -- evalMmCatLastChance(d,c,SL) 1357 if containsVars dom then dom := resolveTM(rest p, dom) 1358 $Coerce and canCoerce(rest p, dom) => 1359 NSL := [CONS(d,dom)] 1360 op ~= 'coerce => 'failed -- evalMmCatLastChance(d,c,SL) 1361 NSL 1362 1363hasCate(dom,cat,SL) == 1364 -- asks whether dom has cat under SL 1365 -- augments substitution SL or returns 'failed 1366 dom = $EmptyMode => NIL 1367 isPatternVar dom => 1368 (p := ASSQ(dom, SL)) and ((NSL := hasCate(rest p, cat, SL)) ~= 'failed) => 1369 NSL 1370 (p:= ASSQ(dom,$Subst)) or (p := ASSQ(dom, SL)) => 1371-- S := hasCate(rest p, cat, augmentSub(first p, rest p, copy SL)) 1372 S := hasCate1(rest p, cat, SL, dom) 1373 not (S='failed) => S 1374 hasCateSpecial(dom, rest p, cat, SL) 1375 if SL ~= 'failed then $hope:= 'T 1376 'failed 1377 SL1 := [[v,:d] for [v,:d] in SL | not containsVariables d] 1378 if SL1 then cat := subCopy(cat, SL1) 1379 hasCaty(dom,cat,SL) 1380 1381hasCate1(dom, cat, SL, domPvar) == 1382 $domPvar:local := domPvar 1383 hasCate(dom, cat, SL) 1384 1385hasCateSpecial(v,dom,cat,SL) == 1386 -- v is a pattern variable, dom it's binding under $Subst 1387 -- tries to change dom, so that it has category cat under SL 1388 -- the result is a substitution list or 'failed 1389 EQCAR(cat,'Field) or EQCAR(cat, 'DivisionRing) => 1390 if isSubDomain(dom,$Integer) then dom := $Integer 1391 d:= [$QuotientField, dom] 1392 hasCaty(dom,'(IntegralDomain),augmentSub(v,d,SL)) 1393 cat is ['PolynomialCategory, d, :.] => 1394 dom' := ['Polynomial, d] 1395 (containsVars d or canCoerceFrom(dom, dom')) 1396 and hasCaty(dom', cat, augmentSub(v,dom',SL)) 1397 isSubDomain(dom,$Integer) => 1398 NSL:= hasCate($Integer,cat,augmentSub(v,$Integer,SL)) 1399 NSL = 'failed => 1400 hasCateSpecialNew(v, dom, cat, SL) 1401 hasCaty($Integer,cat,NSL) 1402 hasCateSpecialNew(v, dom, cat, SL) 1403 1404-- to be used in $newSystem only 1405hasCateSpecialNew(v,dom,cat,SL) == 1406 fe := member(QCAR cat, '(ElementaryFunctionCategory 1407 TrigonometricFunctionCategory ArcTrigonometricFunctionCategory 1408 HyperbolicFunctionCategory ArcHyperbolicFunctionCategory 1409 PrimitiveFunctionCategory SpecialFunctionCategory Evalable 1410 CombinatorialOpsCategory TranscendentalFunctionCategory 1411 AlgebraicallyClosedFunctionSpace ExpressionSpace 1412 LiouvillianFunctionCategory FunctionSpace)) 1413 alg := member(QCAR cat, '(RadicalCategory AlgebraicallyClosedField)) 1414 fefull := fe or alg or EQCAR(cat, 'CombinatorialFunctionCategory) 1415 partialResult := 1416 EQCAR(dom, 'Variable) or EQCAR(dom, 'Symbol) => 1417 first(cat) in '(Magma AbelianSemiGroup AbelianGroup) => 1418 d := ['Polynomial, $Integer] 1419 augmentSub(v, d, SL) 1420 EQCAR(cat, 'Group) => 1421 d := ['Fraction, ['Polynomial, $Integer]] 1422 augmentSub(v, d, SL) 1423 fefull => 1424 d := defaultTargetFE dom 1425 augmentSub(v, d, SL) 1426 'failed 1427 isEqualOrSubDomain(dom, $Integer) => 1428 fe => 1429 d := defaultTargetFE $Integer 1430 augmentSub(v, d, SL) 1431 alg => 1432 d := '(AlgebraicNumber) 1433 --d := defaultTargetFE $Integer 1434 augmentSub(v, d, SL) 1435 'failed 1436 underDomainOf dom = $ComplexInteger => 1437 d := defaultTargetFE $ComplexInteger 1438 hasCaty(d,cat,augmentSub(v, d, SL)) 1439 (dom = $RationalNumber) and alg => 1440 d := '(AlgebraicNumber) 1441 --d := defaultTargetFE $Integer 1442 augmentSub(v, d, SL) 1443 fefull => 1444 d := defaultTargetFE dom 1445 augmentSub(v, d, SL) 1446 'failed 1447 partialResult = 'failed => 'failed 1448 hasCaty(d, cat, partialResult) 1449 1450hasCaty(d,cat,SL) == 1451 -- calls hasCat, which looks up a hashtable and returns: 1452 -- 1. T, NIL or a (has x1 x2) condition, if cat is not parameterized 1453 -- 2. a list of pairs (argument to cat,condition) otherwise 1454 -- then the substitution SL is augmented, or the result is 'failed 1455 cat is ['CATEGORY,.,:y] => hasAttSig(d,subCopy(y,constructSubst d),SL) 1456 cat is ['SIGNATURE,foo,sig] => 1457 hasSig(d,foo,subCopy(sig,constructSubst d),SL) 1458 cat is ['ATTRIBUTE,a] => BREAK() 1459 x:= hasCat(opOf d,opOf cat) => 1460 y:= IFCDR cat => 1461 S := constructSubst d 1462 for [z,:cond] in x until not (S1='failed) repeat 1463 S' := [[p, :mkDomPvar(p, d, z, y)] for [p,:d] in S] 1464 if $domPvar then 1465 dom := [first d, :[domArg(arg, i, z, y) for i in 0.. 1466 for arg in rest d]] 1467 SL := augmentSub($domPvar, dom, copy SL) 1468 z' := [domArg2(a, S, S') for a in z] 1469 S1:= unifyStruct(y,z',copy SL) 1470 if not (S1='failed) then S1:= 1471 atom cond => S1 1472 ncond := subCopy(cond, S) 1473 ncond is ['has, =d, =cat] => 'failed 1474 hasCaty1(ncond,S1) 1475 S1 1476 atom x => SL 1477 ncond := subCopy(x, constructSubst d) 1478 ncond is ['has, =d, =cat] => 'failed 1479 hasCaty1(substitute('failed, ['has, d, cat], ncond), SL) 1480 'failed 1481 1482mkDomPvar(p, d, subs, y) == 1483 l := MEMQ(p, $FormalMapVariableList) => 1484 domArg(d, #$FormalMapVariableList - #l, subs, y) 1485 d 1486 1487domArg(type, i, subs, y) == 1488 p := MEMQ($FormalMapVariableList.i, subs) => 1489 y.(#subs - #p) 1490 type 1491 1492domArg2(arg, SL1, SL2) == 1493 isSharpVar arg => subCopy(arg, SL1) 1494 arg = '_$ and $domPvar => $domPvar 1495 subCopy(arg, SL2) 1496 1497hasCaty1(cond,SL) == 1498 -- cond is either a (has a b) or an OR/AND clause of such conditions, 1499 -- or a special flag 'failed to indicate failure 1500 -- SL is augmented, if cond is true, otherwise the result is 'failed 1501 $domPvar: local := NIL 1502 cond is 'failed => 'failed 1503 cond is ['has,a,b] => hasCate(a,b,SL) 1504 cond is ['AND,:args] => 1505 for x in args while not (S='failed) repeat S:= 1506 x is ['has,a,b] => hasCate(a,b, SL) 1507 -- next line is for an obscure bug in the table 1508 x is [['has,a,b]] => hasCate(a,b, SL) 1509 --'failed 1510 hasCaty1(x, SL) 1511 S 1512 cond is ['OR,:args] => 1513 for x in args until not (S='failed) repeat S:= 1514 x is ['has,a,b] => hasCate(a,b,copy SL) 1515 -- next line is for an obscure bug in the table 1516 x is [['has,a,b]] => hasCate(a,b,copy SL) 1517 --'failed 1518 hasCaty1(x, copy SL) 1519 S 1520 keyedSystemError("S2GE0016", 1521 ['"hasCaty1",'"unexpected condition from category table"]) 1522 1523hasAttSig(d,x,SL) == 1524 -- d is domain, x a list of attributes and signatures 1525 -- the result is an augmented SL, if d has x, 'failed otherwise 1526 for y in x until SL='failed repeat SL:= 1527 y is ['ATTRIBUTE,a] => BREAK() 1528 y is ['SIGNATURE,foo,s] => hasSig(d,foo,s,SL) 1529 keyedSystemError("S2GE0016", 1530 ['"hasAttSig",'"unexpected form of unnamed category"]) 1531 SL 1532 1533hasSigAnd(andCls, S0, SL) == 1534 dead := NIL 1535 SA := 'failed 1536 for cls in andCls while not dead repeat 1537 SA := 1538 atom cls => copy SL 1539 cls is ['has,a,b] => 1540 hasCate(subCopy(a,S0),subCopy(b,S0),copy SL) 1541 keyedSystemError("S2GE0016", 1542 ['"hasSigAnd",'"unexpected condition for signature"]) 1543 if SA = 'failed then dead := true 1544 SA 1545 1546hasSigOr(orCls, S0, SL) == 1547 found := NIL 1548 SA := 'failed 1549 for cls in orCls until found repeat 1550 SA := 1551 atom cls => copy SL 1552 cls is ['has,a,b] => 1553 hasCate(subCopy(a,S0),subCopy(b,S0),copy SL) 1554 cls is ['AND,:andCls] or cls is ['and,:andCls] => 1555 hasSigAnd(andCls, S0, SL) 1556 keyedSystemError("S2GE0016", 1557 ['"hasSigOr",'"unexpected condition for signature"]) 1558 if SA ~= 'failed then found := true 1559 SA 1560 1561hasSig(dom,foo,sig,SL) == 1562 -- tests whether domain dom has function foo with signature sig 1563 -- under substitution SL 1564 $domPvar: local := nil 1565 fun := constructor? first dom => 1566 S0:= constructSubst dom 1567 p := ASSQ(foo, getOperationAlistFromLisplib first dom) => 1568 for [x, ., cond, .] in rest p until not (S = 'failed) repeat 1569 S:= 1570 atom cond => copy SL 1571 cond is ['has,a,b] => 1572 hasCate(subCopy(a,S0),subCopy(b,S0),copy SL) 1573 cond is ['AND,:andCls] or cond is ['and,:andCls] => 1574 hasSigAnd(andCls, S0, SL) 1575 cond is ['OR,:orCls] or cond is ['or,:orCls] => 1576 hasSigOr(orCls, S0, SL) 1577 keyedSystemError("S2GE0016", 1578 ['"hasSig",'"unexpected condition for signature"]) 1579 not (S='failed) => S:= unifyStruct(subCopy(x,S0),sig,S) 1580 S 1581 'failed 1582 'failed 1583 1584hasCatExpression(cond,SL) == 1585 cond is ['OR,:l] => 1586 or/[(y:=hasCatExpression(x,SL)) ~= 'failed for x in l] => y 1587 cond is ['AND,:l] => 1588 and/[(SL:= hasCatExpression(x,SL)) ~= 'failed for x in l] => SL 1589 cond is ['has,a,b] => hasCate(a,b,SL) 1590 keyedSystemError("S2GE0016", 1591 ['"hasSig",'"unexpected condition for attribute"]) 1592 1593unifyStruct(s1,s2,SL) == 1594 -- tests for equality of s1 and s2 under substitutions SL and $Subst 1595 -- the result is a substitution list or 'failed 1596 s1=s2 => SL 1597 if s1 is ['_:,x,.] then s1:= x 1598 if s2 is ['_:,x,.] then s2:= x 1599 if not atom s1 and first s1 = '_# then s1 := LENGTH CADR s1 1600 if not atom s2 and first s2 = '_# then s2 := LENGTH CADR s2 1601 s1=s2 => SL 1602 isPatternVar s1 => unifyStructVar(s1,s2,SL) 1603 isPatternVar s2 => unifyStructVar(s2,s1,SL) 1604 atom s1 or atom s2 => 'failed 1605 until null s1 or null s2 or SL='failed repeat 1606 SL := unifyStruct(first s1, first s2, SL) 1607 s1 := rest s1 1608 s2 := rest s2 1609 atom s1 => 1610 if s1 = s2 then s2 := nil 1611 s1 := nil 1612 atom s2 => s2 := nil 1613 s1 or s2 => 'failed 1614 SL 1615 1616unifyStructVar(v,s,SL) == 1617 -- the first argument is a pattern variable, which is not substituted 1618 -- by SL 1619 CONTAINED(v,s) => 'failed 1620 ps := LASSOC(s, SL) 1621 s1 := (ps => ps; s) 1622 (s0 := LASSOC(v, SL)) or (s0 := LASSOC(v,$Subst)) => 1623 S:= unifyStruct(s0,s1,copy SL) 1624 S='failed => 1625 $Coerce and not atom s0 and constructor? first s0 => 1626 containsVars s0 or containsVars s1 => 1627 ns0 := subCopy(s0, SL) 1628 ns1 := subCopy(s1, SL) 1629 containsVars ns0 or containsVars ns1 => 1630 $hope:= 'T 1631 'failed 1632 if canCoerce(ns0, ns1) then s3 := s1 1633 else if canCoerce(ns1, ns0) then s3 := s0 1634 else s3 := nil 1635 s3 => 1636 if (s3 ~= s0) then SL := augmentSub(v,s3,SL) 1637 if (s3 ~= s1) and isPatternVar(s) then SL := augmentSub(s,s3,SL) 1638 SL 1639 'failed 1640 $domPvar => 1641 s3 := resolveTT(s0,s1) 1642 s3 => 1643 if (s3 ~= s0) then SL := augmentSub(v,s3,SL) 1644 if (s3 ~= s1) and isPatternVar(s) then SL := augmentSub(s,s3,SL) 1645 SL 1646 'failed 1647-- isSubDomain(s,s0) => augmentSub(v,s0,SL) 1648 'failed 1649 'failed 1650 augmentSub(v,s,S) 1651 augmentSub(v,s,SL) 1652 1653ofCategory(dom,cat) == 1654 -- entry point to category evaluation from other points than type 1655 -- analysis 1656 -- the result is true or NIL 1657 $Subst:local:= NIL 1658 $hope:local := NIL 1659 IDENTP dom => NIL 1660 cat is ['Join,:cats] => and/[ofCategory(dom,c) for c in cats] 1661 (hasCaty(dom,cat,NIL) ~= 'failed) 1662 1663printMms(mmS) == 1664 -- mmS a list of modemap signatures 1665 sayMSG '" " 1666 for [sig,imp,.] in mmS for i in 1.. repeat 1667 istr := STRCONC('"[",STRINGIMAGE i,'"]") 1668 if QCSIZE(istr) = 3 then istr := STRCONC(istr,'" ") 1669 sayMSG [:bright istr, '"signature: ", :formatSignature rest sig] 1670 first sig = 'local => 1671 sayMSG ['" implemented: local function ",imp] 1672 imp is ['XLAM,:.] => 1673 sayMSG concat('" implemented: XLAM from ", 1674 prefix2String first sig) 1675 sayMSG concat('" implemented: slot ",imp, 1676 '" from ", prefix2String first sig) 1677 sayMSG '" " 1678 1679containsVars(t) == 1680 -- tests whether term t contains a * variable 1681 atom t => isPatternVar t 1682 containsVars1(t) 1683 1684containsVars1(t) == 1685 -- recursive version, which works on a list 1686 [t1,:t2]:= t 1687 atom t1 => 1688 isPatternVar t1 or 1689 atom t2 => isPatternVar t2 1690 containsVars1(t2) 1691 containsVars1(t1) or 1692 atom t2 => isPatternVar t2 1693 containsVars1(t2) 1694 1695-- [[isPartialMode]] tests whether m contains [[$EmptyMode]]. The 1696-- constant [[$EmptyMode]] (defined in bootfuns.lisp) evaluates to 1697-- [[|$EmptyMode|]]. This constants is inserted in a modemap during 1698-- compile time if the modemap is not yet complete. 1699isPartialMode m == 1700 CONTAINED($EmptyMode,m) 1701 1702 1703getSymbolType var == 1704-- var is a pattern variable 1705 p := ASSQ(var, $SymbolType) => rest p 1706 t:= '(Polynomial (Integer)) 1707 $SymbolType:= CONS(CONS(var,t),$SymbolType) 1708 t 1709 1710isEqualOrSubDomain(d1,d2) == 1711 -- last 2 parts are for tagged unions (hack for now, RSS) 1712 (d1=d2) or isSubDomain(d1,d2) or 1713 (atom(d1) and ((d2 is ['Variable,=d1]) or (d2 is [=d1]))) 1714 or (atom(d2) and ((d1 is ['Variable,=d2]) or (d1 is [=d2]))) 1715 1716defaultTypeForCategory(cat, SL) == 1717 -- this function returns a domain belonging to cat 1718 -- note that it is important to note that in some contexts one 1719 -- might not want to use this result. For example, evalMmCat1 1720 -- calls this and should possibly fail in some cases. 1721 cat := subCopy(cat, SL) 1722 c := first cat 1723 d := GETDATABASE(c, 'DEFAULTDOMAIN) 1724 d => [d, :rest cat] 1725 cat is [c] => 1726 c = 'Field => $RationalNumber 1727 c in '(Ring IntegralDomain EuclideanDomain GcdDomain 1728 OrderedRing DifferentialRing) => '(Integer) 1729 c = 'OrderedSet => $Symbol 1730 c = 'FloatingPointSystem => '(Float) 1731 NIL 1732 cat is [c,p1] => 1733 c = 'FiniteLinearAggregate => ['Vector, p1] 1734 c = 'VectorCategory => ['Vector, p1] 1735 c = 'SetAggregate => ['Set, p1] 1736 c = 'SegmentCategory => ['Segment, p1] 1737 NIL 1738 cat is [c,p1,p2] => 1739 NIL 1740 cat is [c,p1,p2,p3] => 1741 cat is ['MatrixCategory, d, ['Vector, =d], ['Vector, =d]] => 1742 ['Matrix, d] 1743 NIL 1744 NIL 1745