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