Initial population.

1 files changed, 1833 insertions, 0 deletions

diff --git a/src/interp/i-funsel.boot.pamphlet b/src/interp/i-funsel.boot.pamphlet
new file mode 100644
index 00000000..6e34e518
--- /dev/null
+++ b/src/interp/i-funsel.boot.pamphlet
@@ -0,0 +1,1833 @@
+\documentclass{article}
+\usepackage{axiom}
+
+\title{\File{src/interp/i-funsel.boot} Pamphlet}
+\author{The Axiom Team}
+
+\begin{document}
+\maketitle
+\begin{abstract}
+\end{abstract}
+\eject
+\tableofcontents
+\eject
+
+\begin{verbatim}
+New Selection of Modemaps
+
+selection of applicable modemaps is done in two steps:
+  first it tries to find a modemap inside an argument domain, and if
+  this fails, by evaluation of pattern modemaps
+the result is a list of functions with signatures, which have the
+  following form:
+  [sig,elt,cond] where
+    sig is the signature gained by evaluating the modemap condition
+    elt is the slot number to get the implementation
+    cond are runtime checks which are the results of evaluating the
+    modemap condition
+
+the following flags are used:
+ $Coerce is NIL, if function selection is done which requires exact
+   matches (e.g. for coercion functions)
+ if $SubDom is true, then runtime checks have to be compiled
+\end{verbatim}
+\section{Functions}
+\subsection{isPartialMode}
+[[isPartialMode]] tests whether m contains [[$EmptyMode]]. The
+constant [[$EmptyMode]] (defined in bootfuns.lisp) evaluates to
+[[|$EmptyMode|]]. This constants is inserted in a modemap during
+compile time if the modemap is not yet complete.
+<<isPartialMode>>=
+isPartialMode m ==
+  CONTAINED($EmptyMode,m)
+
+@
+\section{License}
+<<license>>=
+-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
+-- All rights reserved.
+--
+-- Redistribution and use in source and binary forms, with or without
+-- modification, are permitted provided that the following conditions are
+-- met:
+--
+--     - Redistributions of source code must retain the above copyright
+--       notice, this list of conditions and the following disclaimer.
+--
+--     - Redistributions in binary form must reproduce the above copyright
+--       notice, this list of conditions and the following disclaimer in
+--       the documentation and/or other materials provided with the
+--       distribution.
+--
+--     - Neither the name of The Numerical ALgorithms Group Ltd. nor the
+--       names of its contributors may be used to endorse or promote products
+--       derived from this software without specific prior written permission.
+--
+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
+-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
+-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
+-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+@
+<<*>>=
+<<license>>
+
+SETANDFILEQ($constructorExposureList, '(Boolean Integer String))
+
+sayFunctionSelection(op,args,target,dc,func) ==
+  $abbreviateTypes : local := true
+  startTimingProcess 'debug
+  fsig := formatSignatureArgs args
+  if not LISTP fsig then fsig := LIST fsig
+  if func then func := bright ['"by ",func]
+  sayMSG concat ['%l,:bright '"Function Selection for",op,:func,'%l,
+    '"      Arguments:",:bright fsig]
+  if target then sayMSG concat ['"      Target type:",
+    :bright prefix2String target]
+  if dc	 then sayMSG concat ['"      From:     ",
+    :bright prefix2String dc]
+  stopTimingProcess 'debug
+
+sayFunctionSelectionResult(op,args,mmS) ==
+  $abbreviateTypes : local := true
+  startTimingProcess 'debug
+  if mmS then printMms mmS
+  else sayMSG concat ['"   -> no function",:bright op,
+    '"found for arguments",:bright formatSignatureArgs args]
+  stopTimingProcess 'debug
+
+selectMms(op,args,$declaredMode) ==
+  -- selects applicable modemaps for node op and arguments args
+  -- if there is no local modemap, and it is not a package call, then
+  --   the cached function selectMms1 is called
+  startTimingProcess 'modemaps
+  n:= getUnname op
+  val := getValue op
+  opMode := objMode val
+
+  -- see if we have a functional parameter
+  ((isSharpVarWithNum(n) and opMode) or (val and opMode)) and
+      opMode is ['Mapping,:ta] =>
+	imp :=
+	  val => wrapped2Quote objVal val
+	  n
+	[[['local,:ta], imp , NIL]]
+
+  ((isSharpVarWithNum(n) and opMode) or (val and opMode)) and
+      opMode is ['Variable,f] =>
+	 emptyAtree op
+	 op.0 := f
+	 selectMms(op,args,$declaredMode)
+
+  isSharpVarWithNum(n) and opMode is ['FunctionCalled,f] =>
+	 op.0 := f
+	 selectMms(op,args,$declaredMode)
+
+  types1 := getOpArgTypes(n,args)
+  numArgs := #args
+  member('(SubDomain (Domain)),types1) => NIL
+  member('(Domain),types1) => NIL
+  member($EmptyMode,types1) => NIL
+
+  tar := getTarget op
+  dc  := getAtree(op,'dollar)
+
+  null dc and val and objMode(val) = $AnonymousFunction =>
+      tree := mkAtree objValUnwrap getValue op
+      putTarget(tree,['Mapping,tar,:types1])
+      bottomUp tree
+      val := getValue tree
+      [[['local,:rest objMode val], wrapped2Quote objVal val, NIL]]
+
+  if (n = 'map) and (first types1 = $AnonymousFunction)
+    then
+      tree := mkAtree objValUnwrap getValue first args
+      ut :=
+	tar => underDomainOf tar
+	NIL
+      ua := [underDomainOf x for x in rest types1]
+      member(NIL,ua) => NIL
+      putTarget(tree,['Mapping,ut,:ua])
+      bottomUp tree
+      val := getValue tree
+      types1 := [objMode val,:rest types1]
+      RPLACA(args,tree)
+
+  if numArgs = 1 and (n = "numer" or n = "denom") and
+    isEqualOrSubDomain(first types1,$Integer) and null dc then
+      dc := ['Fraction, $Integer]
+      putAtree(op, 'dollar, dc)
+
+
+  if $reportBottomUpFlag then sayFunctionSelection(n,types1,tar,dc,NIL)
+
+  identType := 'Variable
+  for x in types1 while not $declaredMode repeat
+      not EQCAR(x,identType) => $declaredMode:= x
+  types2 := [altTypeOf(x,y,$declaredMode) for x in types1 for y in args]
+
+  mmS:=
+    dc => selectDollarMms(dc,n,types1,types2)
+
+    if n = "/" and tar = $Integer then
+      tar := $RationalNumber
+      putTarget(op,tar)
+
+    -- now to speed up some standard selections
+    if not tar then
+      tar := defaultTarget(op,n,#types1,types1)
+      if tar and $reportBottomUpFlag then
+	sayMSG concat ['"      Default target type:",
+	  :bright prefix2String tar]
+
+    selectLocalMms(op,n,types1,tar) or
+      (VECTORP op and selectMms1(n,tar,types1,types2,'T))
+  if $reportBottomUpFlag then sayFunctionSelectionResult(n,types1,mmS)
+  stopTimingProcess 'modemaps
+  mmS
+
+-- selectMms1 is in clammed.boot
+
+selectMms2(op,tar,args1,args2,$Coerce) ==
+  -- decides whether to find functions from a domain or package
+  --   or by general modemap evaluation
+  or/[STRINGP arg for arg in args1] => NIL
+  if tar = $EmptyMode then tar := NIL
+  nargs := #args1
+  mmS := NIL
+  mmS :=
+    -- special case map for the time being
+    $Coerce and (op = 'map) and (2 = nargs) and
+      (first(args1) is ['Variable,fun]) =>
+	null (ud := underDomainOf CADR args1) => NIL
+	if tar then ut := underDomainOf(tar)
+	else ut := nil
+	null (mapMms := selectMms1(fun,ut,[ud],[NIL],true)) => NIL
+	mapMm := CDAAR mapMms
+	selectMms1(op,tar,[['Mapping,:mapMm],CADR args1],
+	  [NIL,CADR args2],$Coerce)
+
+    $Coerce and (op = 'map) and (2 = nargs) and
+      (first(args1) is ['FunctionCalled,fun]) =>
+	null (ud := underDomainOf CADR args1) => NIL
+	if tar then ut := underDomainOf(tar)
+	else ut := nil
+	funNode := mkAtreeNode fun
+	transferPropsToNode(fun,funNode)
+	null (mapMms := selectLocalMms(funNode,fun,[ud],NIL)) => NIL
+	mapMm := CDAAR mapMms
+	selectMms1(op,tar,[['Mapping,:mapMm],CADR args1],
+	  [NIL,CADR args2],$Coerce)
+
+    -- get the argument domains and the target
+    a := nil
+    for x in args1 repeat if x then a := cons(x,a)
+    for x in args2 repeat if x then a := cons(x,a)
+    if tar and not isPartialMode tar then a := cons(tar,a)
+
+    -- for typically homogeneous functions, throw in resolve too
+    if op in '(_= _+ _* _- ) then
+      r := resolveTypeList a
+      if r ^= nil then a := cons(r,a)
+
+    if tar and not isPartialMode tar then
+      if xx := underDomainOf(tar) then a := cons(xx,a)
+    for x in args1 repeat
+      PAIRP(x) and CAR(x) in '(List Vector Stream FiniteSet Array) =>
+	xx := underDomainOf(x) => a := cons(xx,a)
+
+    -- now extend this list with those from the arguments to
+    -- any Unions, Mapping or Records
+
+    a' := nil
+    a := nreverse REMDUP a
+    for x in a repeat
+      null x => 'iterate
+      x = '(RationalRadicals) => a' := cons($RationalNumber,a')
+      x is ['Union,:l] =>
+	-- check if we have a tagged union
+	l and first l is [":",:.] =>
+	  for [.,.,t] in l repeat
+	    a' := cons(t,a')
+	a' := append(reverse l,a')
+      x is ['Mapping,:l] => a' := append(reverse l,a')
+      x is ['Record,:l] =>
+	a' := append(reverse [CADDR s for s in l],a')
+      x is ['FunctionCalled,name] =>
+	(xm := get(name,'mode,$e)) and not isPartialMode xm =>
+	  a' := cons(xm,a')
+    a := append(a,REMDUP a')
+    a := [x for x in a | PAIRP(x)]
+
+    -- step 1. see if we have one without coercing
+    a' := a
+    while a repeat
+      x:= CAR a
+      a:= CDR a
+      ATOM x => 'iterate
+      mmS := append(mmS, findFunctionInDomain(op,x,tar,args1,args2,NIL,NIL))
+
+    -- step 2. if we didn't get one, trying coercing (if we are
+    --	       suppose to)
+
+    if null(mmS) and $Coerce then
+      a := a'
+      while a repeat
+	x:= CAR a
+	a:= CDR a
+	ATOM x => 'iterate
+	mmS := append(mmS,
+	  findFunctionInDomain(op,x,tar,args1,args2,$Coerce,NIL))
+
+    mmS or selectMmsGen(op,tar,args1,args2)
+  mmS and orderMms(op, mmS,args1,args2,tar)
+
+isAVariableType t ==
+    t is ['Variable,.] or t = $Symbol or t is ['OrderedVariableList,.]
+
+defaultTarget(opNode,op,nargs,args) ==
+  -- this is for efficiency. Chooses standard targets for operations
+  -- when no target exists.
+
+  target := nil
+
+  nargs = 0 =>
+    op = 'nil =>
+      putTarget(opNode, target := '(List (None)))
+      target
+    op = 'true	or op = 'false =>
+      putTarget(opNode, target := $Boolean)
+      target
+    op = 'pi =>
+      putTarget(opNode, target := ['Pi])
+      target
+    op = 'infinity =>
+      putTarget(opNode, target := ['OnePointCompletion, $Integer])
+      target
+    member(op, '(plusInfinity minusInfinity)) =>
+      putTarget(opNode, target := ['OrderedCompletion, $Integer])
+      target
+    target
+
+  a1 := CAR args
+  ATOM a1 => target
+  a1f := QCAR a1
+
+  nargs = 1 =>
+    op = 'kernel =>
+      putTarget(opNode, target := ['Kernel, ['Expression, $Integer]])
+      target
+    op = 'list =>
+      putTarget(opNode, target := ['List, a1])
+      target
+    target
+
+  a2 := CADR args
+
+  nargs >= 2 and op = "draw" and a1 is ['FunctionCalled,sym] and a2 is ['Segment,.] =>
+
+    -- this clears up some confusion over 2D and 3D graphics
+
+    symNode := mkAtreeNode sym
+    transferPropsToNode(sym,symNode)
+
+    nargs >= 3 and CADDR args is ['Segment,.] =>
+      selectLocalMms(symNode,sym,[$DoubleFloat, $DoubleFloat],NIL)
+      putTarget(opNode, target := '(ThreeDimensionalViewport))
+      target
+
+    (mms := selectLocalMms(symNode,sym,[$DoubleFloat],NIL)) =>
+      [.,targ,:.] := CAAR mms
+      targ = $DoubleFloat =>
+	  putTarget(opNode, target := '(TwoDimensionalViewport))
+	  target
+      targ = ['Point, $DoubleFloat] =>
+	  putTarget(opNode, target := '(ThreeDimensionalViewport))
+	  target
+      target
+
+    target
+
+  nargs >= 2 and op = "makeObject" and a1 is ['FunctionCalled,sym] and a2 is ['Segment,.] =>
+    -- we won't actually bother to put a target on makeObject
+    -- this is just to figure out what the first arg is
+    symNode := mkAtreeNode sym
+    transferPropsToNode(sym,symNode)
+
+    nargs >= 3 and CADDR args is ['Segment,.] =>
+      selectLocalMms(symNode,sym,[$DoubleFloat, $DoubleFloat],NIL)
+      target
+
+    selectLocalMms(symNode,sym,[$DoubleFloat],NIL)
+    target
+
+  nargs = 2 =>
+    op = "elt" =>
+	a1 = '(BasicOperator) and a2 is ['List, ['OrderedVariableList, .]] =>
+	   ['Expression, $Integer]
+	target
+
+    op = "eval" =>
+	a1 is ['Expression,b1] and a2 is ['Equation, ['Polynomial,b2]] =>
+	    target :=
+	      canCoerce(b2, a1) => a1
+	      t := resolveTT(b1, b2)
+	      (not t) or (t = $Any) => nil
+	      resolveTT(a1, t)
+	    if target then putTarget(opNode, target)
+	    target
+	a1 is ['Equation, .] and a2 is ['Equation, .] =>
+	    target := resolveTT(a1, a2)
+	    if target and not (target = $Any) then putTarget(opNode,target)
+	    else target := nil
+	    target
+	a1 is ['Equation, .] and a2 is ['List, a2e] and a2e is ['Equation, .] =>
+	    target := resolveTT(a1, a2e)
+	    if target and not (target = $Any) then putTarget(opNode,target)
+	    else target := nil
+	    target
+	a2 is ['Equation, a2e] or a2 is ['List, ['Equation, a2e]] =>
+	    target := resolveTT(a1, a2e)
+	    if target and not (target = $Any) then putTarget(opNode,target)
+	    else target := nil
+	    target
+
+    op = "**" or op = "^" =>
+      a2 = $Integer =>
+	if (target := resolveTCat(a1,'(Field))) then
+	  putTarget(opNode,target)
+	target
+      a1 = '(AlgebraicNumber) and (a2 = $Float or a2 = $DoubleFloat) =>
+	  target := ['Expression, a2]
+	  putTarget(opNode,target)
+	  target
+      a1 = '(AlgebraicNumber) and a2 is ['Complex, a3] and (a3 = $Float or a3 = $DoubleFloat) =>
+	  target := ['Expression, a3]
+	  putTarget(opNode,target)
+	  target
+      ((a2 = $RationalNumber) and
+	(typeIsASmallInteger(a1) or isEqualOrSubDomain(a1,$Integer))) =>
+	    putTarget(opNode, target := '(AlgebraicNumber))
+	    target
+      ((a2 = $RationalNumber) and (isAVariableType(a1)
+	  or a1 is ['Polynomial,.] or a1 is ['RationalFunction,.])) =>
+	    putTarget(opNode, target := defaultTargetFE a1)
+	    target
+      isAVariableType(a1) and (a2 = $PositiveInteger or a2 = $NonNegativeInteger) =>
+	  putTarget(opNode, target := '(Polynomial (Integer)))
+	  target
+      isAVariableType(a2) =>
+	putTarget(opNode, target := defaultTargetFE a1)
+	target
+      a2 is ['Polynomial, D] =>
+	(a1 = a2) or isAVariableType(a1)
+	 or ((a1 is ['RationalFunction, D1]) and (D1 = D)) or (a1 = D)
+	  or ((a1 is [=$QuotientField, D1]) and (D1 = a1)) =>
+	    putTarget(opNode, target := defaultTargetFE a2)
+	    target
+	target
+      a2 is ['RationalFunction, D] =>
+	(a1 = a2) or isAVariableType(a1)
+	 or ((a1 is ['RationalFunction, D1]) and (D1 = D)) or (a1 = D)
+	  or ((a1 is [=$QuotientField, D1]) and (D1 = a1)) =>
+	    putTarget(opNode, target := defaultTargetFE a2)
+	    target
+	target
+      target
+
+    op = '_/ =>
+      isEqualOrSubDomain(a1, $Integer) and isEqualOrSubDomain(a2, $Integer) =>
+	putTarget(opNode, target := $RationalNumber)
+	target
+      a1 = a2 =>
+	if (target := resolveTCat(CAR args,'(Field))) then
+	  putTarget(opNode,target)
+	target
+      a1 is ['Variable,.] and a2 is ['Variable,.] =>
+	putTarget(opNode,target := mkRationalFunction  '(Integer))
+	target
+      isEqualOrSubDomain(a1,$Integer) and a2 is ['Variable,.] =>
+	putTarget(opNode,target := mkRationalFunction '(Integer))
+	target
+      a1 is ['Variable,.] and
+	a2 is ['Polynomial,D] =>
+	  putTarget(opNode,target := mkRationalFunction D)
+	  target
+	target
+      a2 is ['Variable,.] and
+	a1 is ['Polynomial,D] =>
+	  putTarget(opNode,target := mkRationalFunction D)
+	  target
+	target
+      a2 is ['Polynomial,D] and (a1 = D) =>
+	putTarget(opNode,target := mkRationalFunction D)
+	target
+      target
+
+  a3 := CADDR args
+  nargs = 3 =>
+    op = "eval" =>
+	a3 is ['List, a3e] =>
+	    target := resolveTT(a1, a3e)
+	    if not (target = $Any) then putTarget(opNode,target)
+	    else target := nil
+	    target
+
+	target := resolveTT(a1, a3)
+	if not (target = $Any) then putTarget(opNode,target)
+	else target := nil
+	target
+  target
+
+mkRationalFunction D ==	 ['Fraction, ['Polynomial, D]]
+
+defaultTargetFE(a,:options) ==
+  a is ['Variable,.] or a = $RationalNumber or MEMQ(QCAR a,
+    [QCAR $Symbol, 'RationalRadicals,
+     'Pi]) or typeIsASmallInteger(a) or isEqualOrSubDomain(a, $Integer) or
+       a = '(AlgebraicNumber) =>
+          IFCAR options => [$FunctionalExpression, ['Complex, $Integer]]
+          [$FunctionalExpression, $Integer]
+  a is ['Complex,uD] => defaultTargetFE(uD, true)
+  a is [D,uD] and MEMQ(D, '(Polynomial RationalFunction Fraction)) =>
+     defaultTargetFE(uD, IFCAR options)
+  a is [=$FunctionalExpression,.] => a
+  IFCAR options => [$FunctionalExpression, ['Complex, a]]
+  [$FunctionalExpression, a]
+
+altTypeOf(type,val,$declaredMode) ==
+  (EQCAR(type,'Symbol) or EQCAR(type,'Variable)) and
+    (a := getMinimalVarMode(objValUnwrap getValue(val),$declaredMode)) =>
+      a
+  type is ['OrderedVariableList,vl] and
+    INTEGERP(val1 := objValUnwrap getValue(val)) and
+      (a := getMinimalVarMode(vl.(val1 - 1),$declaredMode)) =>
+	a
+  type = $PositiveInteger    => $Integer
+  type = $NonNegativeInteger => $Integer
+  type = '(List (PositiveInteger)) => '(List (Integer))
+  NIL
+
+getOpArgTypes(opname, args) ==
+  l := getOpArgTypes1(opname, args)
+  [f(a,opname) for a in l] where
+    f(x,op) ==
+      x is ['FunctionCalled,g] and op ^= 'name =>
+	m := get(g,'mode,$e) =>
+	  m is ['Mapping,:.] => m
+	  x
+	x
+      x
+
+getOpArgTypes1(opname, args) ==
+  null args => NIL
+  -- special cases first
+  opname = 'coef and args is [b,n] =>
+    [CAR getModeSet b, CAR getModeSetUseSubdomain n]
+  opname = 'monom and args is [d,c] =>
+    [CAR getModeSetUseSubdomain d,CAR getModeSet c]
+  opname = 'monom and args is [v,d,c] =>
+    [CAR getModeSet v,CAR getModeSetUseSubdomain d,CAR getModeSet c]
+  (opname = 'cons) and (2 = #args) and (CADR(args) = 'nil) =>
+    ms := [CAR getModeSet x for x in args]
+    if CADR(ms) = '(List (None)) then
+      ms := [first ms,['List,first ms]]
+    ms
+  nargs := #args
+  v := argCouldBelongToSubdomain(opname,nargs)
+  mss := NIL
+  for i in 0..(nargs-1) for x in args repeat
+    ms :=
+      v.i = 0 => CAR getModeSet x
+      CAR getModeSetUseSubdomain x
+    mss := [ms,:mss]
+  nreverse mss
+
+argCouldBelongToSubdomain(op, nargs) ==
+  -- this returns a vector containing 0 or ^0 for each argument.
+  -- if ^0, this indicates that there exists a modemap for the
+  -- op that needs a subdomain in that position
+  nargs = 0 => NIL
+  v := GETZEROVEC nargs
+  isMap(op) => v
+  mms := getModemapsFromDatabase(op,nargs)
+  null mms => v
+  nargs:=nargs-1
+  -- each signature has form
+  -- [domain of implementation, target, arg1, arg2, ...]
+  for [sig,cond,:.] in mms repeat
+    for t in CDDR sig for i in 0..(nargs) repeat
+      CONTAINEDisDomain(t,cond) =>
+	  v.i := 1 + v.i
+  v
+
+CONTAINEDisDomain(symbol,cond) ==
+-- looks for [isSubDomain,symbol,[domain]] in cond: returning T or NIL
+-- with domain being one of PositiveInteger and NonNegativeInteger
+   ATOM cond => false
+   MEMQ(QCAR cond,'(AND OR and or)) =>
+       or/[CONTAINEDisDomain(symbol, u) for u in QCDR cond]
+   EQ(QCAR cond,'isDomain) =>
+       EQ(symbol,CADR cond) and PAIRP(dom:=CADDR cond) and
+	 MEMQ(dom,'(PositiveInteger NonNegativeInteger))
+   false
+
+selectDollarMms(dc,name,types1,types2) ==
+  -- finds functions for name in domain dc
+  isPartialMode dc => throwKeyedMsg("S2IF0001",NIL)
+  mmS := findFunctionInDomain(name,dc,NIL,types1,types2,'T,'T) =>
+    orderMms(name, mmS,types1,types2,NIL)
+  if $reportBottomUpFlag then sayMSG
+    ["%b",'"          function not found in ",prefix2String dc,"%d","%l"]
+  NIL
+
+selectLocalMms(op,name,types,tar) ==
+  -- partial rewrite, looks now for exact local modemap
+  mmS:= getLocalMms(name,types,tar) => mmS
+  obj := getValue op
+  obj and (objVal obj is ['MAP,:mapDef]) and
+    analyzeMap(op,types,mapDef,tar) and getLocalMms(name,types,tar)
+
+-- next defn may be better, test when more time. RSS 3/11/94
+-- selectLocalMms(op,name,types,tar) ==
+--  mmS := getLocalMms(name,types,tar)
+--  -- if no target, just return what we got
+--  mmS and null tar => mmS
+--  matchingMms := nil
+--  for mm in mmS repeat
+--    [., targ, :.] := mm
+--    if tar = targ then matchingMms := cons(mm, matchingMms)
+--  -- if we got some exact matchs on the target, return them
+--  matchingMms => nreverse matchingMms
+--
+--  obj := getValue op
+--  obj and (objVal obj is ['MAP,:mapDef]) and
+--    analyzeMap(op,types,mapDef,tar) and getLocalMms(name,types,tar)
+
+getLocalMms(name,types,tar) ==
+  -- looks for exact or subsumed local modemap in $e
+  mmS := NIL
+  for  (mm:=[dcSig,:.]) in get(name,'localModemap,$e) repeat
+    -- check format and destructure
+    dcSig isnt [dc,result,:args] => NIL
+    -- make number of args is correct
+    #types ^= #args => NIL
+    -- check for equal or subsumed arguments
+    subsume := (not $useIntegerSubdomain) or (tar = result) or
+      get(name,'recursive,$e)
+    acceptableArgs :=
+      and/[f(b,a,subsume) for a in args for b in types] where
+	f(x,y,subsume) ==
+	  if subsume
+	    then isEqualOrSubDomain(x,y)
+	    else x = y
+    not acceptableArgs =>
+      -- interpreted maps are ok
+      dc = 'interpOnly and not($Coerce)=> mmS := [mm,:mmS]
+      NIL
+    mmS := [mm,:mmS]
+  nreverse mmS
+
+mmCost(name, sig,cond,tar,args1,args2) ==
+  cost := mmCost0(name, sig,cond,tar,args1,args2)
+  res := CADR sig
+  res = $PositiveInteger => cost - 2
+  res = $NonNegativeInteger => cost - 1
+  res = $DoubleFloat => cost + 1
+  cost
+
+mmCost0(name, sig,cond,tar,args1,args2) ==
+  sigArgs := CDDR sig
+  n:=
+    null cond => 1
+    not (or/cond) => 1
+    0
+
+  -- try to favor homogeneous multiplication
+
+--if name = "*" and 2 = #sigArgs and first sigArgs ^= first rest sigArgs then n := n + 1
+
+  -- because of obscure problem in evalMm, sometimes we will have extra
+  -- modemaps with the wrong number of arguments if we want to the one
+  -- with no arguments and the name is overloaded. Thus check for this.
+
+  if args1 then
+    for x1 in args1 for x2 in args2 for x3 in sigArgs repeat
+      n := n +
+	isEqualOrSubDomain(x1,x3) => 0
+	topcon := first deconstructT x1
+	topcon2 := first deconstructT x3
+	topcon = topcon2 => 3
+	CAR topcon2 = 'Mapping => 2
+	4
+  else if sigArgs then n := n + 100000000000
+
+  res := CADR sig
+  res=tar => 10000*n
+  10000*n + 1000*domainDepth(res) + hitListOfTarget(res)
+
+orderMms(name, mmS,args1,args2,tar) ==
+  -- it counts the number of necessary coercions of the argument types
+  -- if this isn't enough, it compares the target types
+  mmS and null rest mmS => mmS
+  mS:= NIL
+  N:= NIL
+  for mm in MSORT mmS repeat
+    [sig,.,cond]:= mm
+    b:= 'T
+    p:= CONS(m := mmCost(name, sig,cond,tar,args1,args2),mm)
+    mS:=
+      null mS => list p
+      m < CAAR mS => CONS(p,mS)
+      S:= mS
+      until b repeat
+	b:= null CDR S or m < CAADR S =>
+	  RPLACD(S,CONS(p,CDR S))
+	S:= CDR S
+      mS
+  mmS and [CDR p for p in mS]
+
+domainDepth(d) ==
+  -- computes the depth of lisp structure d
+  atom d => 0
+  MAX(domainDepth(CAR d)+1,domainDepth(CDR d))
+
+hitListOfTarget(t) ==
+  -- assigns a number between 1 and 998 to a type t
+
+  -- want to make it hard to go to Polynomial Pi
+
+  t = '(Polynomial (Pi)) => 90000
+
+  EQ(CAR t, 'Polynomial) => 300
+  EQ(CAR t, 'List) => 400
+  EQ(CAR t,'Matrix) => 910
+  EQ(CAR t,'UniversalSegment) => 501
+  EQ(CAR t,'RationalFunction) => 900
+  EQ(CAR t,'Union) => 999
+  EQ(CAR t,'Expression) => 1600
+  500
+
+--------------------> NEW DEFINITION (override in interop.boot.pamphlet)
+getFunctionFromDomain(op,dc,args) ==
+  -- finds the function op with argument types args in dc
+  -- complains, if no function or ambiguous
+
+  $reportBottomUpFlag:local:= NIL
+  member(CAR dc,$nonLisplibDomains) =>
+    throwKeyedMsg("S2IF0002",[CAR dc])
+  not constructor? CAR dc =>
+    throwKeyedMsg("S2IF0003",[CAR dc])
+
+  p := findFunctionInDomain(op,dc,NIL,args,args,NIL,NIL)
+
+  -- NEW COMPILER COMPATIBILITY ON
+
+  if not p then
+    p :=
+      op = "^" =>
+	  findFunctionInDomain("**",dc,NIL,args,args,NIL,NIL)
+      op = "**" =>
+	  findFunctionInDomain("^",dc,NIL,args,args,NIL,NIL)
+      nil
+
+  -- NEW COMPILER COMPATIBILITY OFF
+
+  p =>
+    domain := evalDomain dc
+    for mm in nreverse p until b repeat
+      [[.,:sig],:.] := mm
+      b := compiledLookup(op,sig,domain)
+    b or  throwKeyedMsg("S2IS0023",[op,dc])
+
+
+  throwKeyedMsg("S2IF0004",[op,dc])
+
+isOpInDomain(opName,dom,nargs) ==
+  -- returns true only if there is an op in the given domain with
+  -- the given number of arguments
+  mmList := ASSQ(opName,getOperationAlistFromLisplib CAR dom)
+  mmList := subCopy(mmList,constructSubst dom)
+  null mmList => NIL
+  gotOne := NIL
+  nargs := nargs + 1
+  for mm in CDR mmList while not gotOne repeat
+    nargs = #CAR mm => gotOne := [mm, :gotOne]
+  gotOne
+
+findCommonSigInDomain(opName,dom,nargs) ==
+  -- this looks at all signatures in dom with given opName and nargs
+  -- number of arguments. If no matches, returns NIL. Otherwise returns
+  -- a "signature" where a type position is non-NIL only if all
+  -- signatures shares that type .
+  CAR(dom) in '(Union Record Mapping) => NIL
+  mmList := ASSQ(opName,getOperationAlistFromLisplib CAR dom)
+  mmList := subCopy(mmList,constructSubst dom)
+  null mmList => NIL
+  gotOne := NIL
+  nargs := nargs + 1
+  vec := NIL
+  for mm in CDR mmList repeat
+    nargs = #CAR mm =>
+      null vec	=> vec := LIST2VEC CAR mm
+      for i in 0.. for x in CAR mm repeat
+	if vec.i and vec.i ^= x then vec.i := NIL
+  VEC2LIST vec
+
+findUniqueOpInDomain(op,opName,dom) ==
+  -- return function named op in domain dom if unique, choose one if not
+  mmList := ASSQ(opName,getOperationAlistFromLisplib CAR dom)
+  mmList := subCopy(mmList,constructSubst dom)
+  null mmList =>
+    throwKeyedMsg("S2IS0021",[opName,dom])
+  if #CDR mmList > 1 then
+    mm := selectMostGeneralMm CDR mmList
+    sayKeyedMsg("S2IS0022",[opName,dom,['Mapping,:CAR mm]])
+  else mm := CADR mmList
+  [sig,slot,:.] := mm
+  fun :=
+--+
+      $genValue =>
+	 compiledLookupCheck(opName,sig,evalDomain dom)
+      NRTcompileEvalForm(opName, sig, evalDomain dom)
+  NULL(fun) or NULL(PAIRP(fun)) => NIL
+  CAR fun = function(Undef) => throwKeyedMsg("S2IS0023",[opName,dom])
+  binVal :=
+    $genValue => wrap fun
+    fun
+  putValue(op,objNew(binVal,m:=['Mapping,:sig]))
+  putModeSet(op,[m])
+
+selectMostGeneralMm mmList ==
+  -- selects the modemap in mmList with arguments all the other
+  -- argument types can be coerced to
+  -- also selects function with #args closest to 2
+  min := 100
+  mml := mmList
+  while mml repeat
+    [mm,:mml] := mml
+    sz := #CAR mm
+    if (met := ABS(sz - 3)) < min then
+      min := met
+      fsz := sz
+  mmList := [mm for mm in mmList | (#CAR mm) = fsz]
+  mml := CDR mmList
+  genMm := CAR mmList
+  while mml repeat
+    [mm,:mml] := mml
+    and/[canCoerceFrom(genMmArg,mmArg) for mmArg in CDAR mm
+      for genMmArg in CDAR genMm] => genMm := mm
+  genMm
+
+--------------------> NEW DEFINITION (override in xrun.boot.pamphlet)
+findFunctionInDomain(op,dc,tar,args1,args2,$Coerce,$SubDom) ==
+  -- looks for a modemap for op with signature	args1 -> tar
+  --   in the domain of computation dc
+  -- tar may be NIL (= unknown)
+  null isLegitimateMode(tar, nil, nil) => nil
+  dcName:= CAR dc
+  member(dcName,'(Union Record Mapping)) =>
+    -- First cut code that ignores args2, $Coerce and $SubDom
+    -- When domains no longer have to have Set, the hard coded 6 and 7
+    -- should go.
+    op = '_= =>
+	#args1 ^= 2 or args1.0 ^= dc or args1.1 ^= dc => NIL
+	tar and tar ^= '(Boolean) => NIL
+	[[[dc, '(Boolean), dc, dc], 6, [NIL, NIL]]]
+    op = 'coerce =>
+	#args1 ^= 1 or args1.0 ^= dc => NIL
+	tar and tar ^= $OutputForm => NIL
+	[[[dc, $OutputForm, dc], 7, [NIL, NIL]]]
+    member(dcName,'(Record Union)) =>
+      findFunctionInCategory(op,dc,tar,args1,args2,$Coerce,$SubDom)
+    NIL
+  fun:= NIL
+  ( p := ASSQ(op,getOperationAlistFromLisplib dcName) ) and
+    SL := constructSubst dc
+    -- if the arglist is homogeneous, first look for homogeneous
+    -- functions. If we don't find any, look at remaining ones
+    if isHomogeneousList args1 then
+      q := NIL
+      r := NIL
+      for mm in CDR p repeat
+	-- CDAR of mm is the signature argument list
+	if isHomogeneousList CDAR mm then q := [mm,:q]
+	else r := [mm,:r]
+      q := allOrMatchingMms(q,args1,tar,dc)
+      for mm in q repeat
+	mm:= subCopy(mm,SL)
+	fun:= nconc(fun,findFunctionInDomain1(mm,op,tar,args1,args2,SL))
+      r := reverse r
+    else r := CDR p
+    r := allOrMatchingMms(r,args1,tar,dc)
+    if not fun then    -- consider remaining modemaps
+      for mm in r repeat
+	mm:= subCopy(mm,SL)
+	fun:= nconc(fun,findFunctionInDomain1(mm,op,tar,args1,args2,SL))
+  if not fun and $reportBottomUpFlag then
+    sayMSG concat
+      ['"   -> no appropriate",:bright op,'"found in",
+	:bright prefix2String dc]
+  fun
+
+allOrMatchingMms(mms,args1,tar,dc) ==
+  -- if there are exact matches on the arg types, return them
+  -- otherwise return the original list
+  null mms or null rest mms => mms
+  x := NIL
+  for mm in mms repeat
+    [sig,:.] := mm
+    [res,:args] := MSUBSTQ(dc,"$",sig)
+    args ^= args1 => nil
+    x := CONS(mm,x)
+  if x then x
+  else mms
+
+isHomogeneousList y ==
+  y is [x] => true
+  y and rest y =>
+    z := CAR y
+    "and"/[x = z for x in CDR y]
+  NIL
+
+--------------------> NEW DEFINITION (override in xrun.boot.pamphlet)
+findFunctionInDomain1(mm,op,tar,args1,args2,SL) ==
+  -- tests whether modemap mm is appropriate for the function
+  -- defined by op, target type tar and argument types args
+  $RTC:local:= NIL
+  -- $RTC is a list of run-time checks to be performed
+  dc:= CDR ASSQ('$,SL)
+  [sig,slot,cond,y] := mm
+  if CONTAINED('_#, sig) or CONTAINED('construct, sig) then
+    sig := [replaceSharpCalls t for t in sig]
+  matchMmCond cond and matchMmSig(mm,tar,args1,args2) and
+    EQ(y,'Subsumed) and
+      -- hmmmm: do Union check in following because (as in DP)
+      -- Unions are subsumed by total modemaps which are in the
+      -- mm list in findFunctionInDomain.
+      y := 'ELT	     -- if subsumed fails try it again
+      not $SubDom and CAR sig isnt ['Union,:.] and slot is [tar,:args] and
+	(f := findFunctionInDomain(op,dc,tar,args,args,NIL,NIL)) => f
+    EQ(y,'ELT) => [[CONS(dc,sig),slot,nreverse $RTC]]
+    EQ(y,'CONST) => [[CONS(dc,sig),slot,nreverse $RTC]]
+--  EQ(y,'ASCONST) => [[CONS(dc,sig),slot,nreverse $RTC]]
+    y is ['XLAM,:.] => [[CONS(dc,sig),y,nreverse $RTC]]
+    sayKeyedMsg("S2IF0006",[y])
+    NIL
+
+--------------------> NEW DEFINITION (override in xrun.boot.pamphlet)
+findFunctionInCategory(op,dc,tar,args1,args2,$Coerce,$SubDom) ==
+  -- looks for a modemap for op with signature	args1 -> tar
+  --   in the domain of computation dc
+  -- tar may be NIL (= unknown)
+  dcName:= CAR dc
+  not MEMQ(dcName,'(Record Union)) => NIL
+  fun:= NIL
+ --  cat := constructorCategory dc
+  makeFunc := GETL(dcName,"makeFunctionList") or
+      systemErrorHere '"findFunctionInCategory"
+  [funlist,.] := FUNCALL(makeFunc,"$",dc,$CategoryFrame)
+  -- get list of implementations and remove sharps
+  maxargs := -1
+  impls := nil
+  for [a,b,d] in funlist repeat
+    not EQ(a,op) => nil
+    d is ['XLAM,xargs,:.] =>
+      if PAIRP(xargs) then maxargs := MAX(maxargs,#xargs)
+      else maxargs := MAX(maxargs,1)
+      impls := cons([b,nil,true,d],impls)
+    impls := cons([b,d,true,d],impls)
+  impls := NREVERSE impls
+  if maxargs ^= -1 then
+    SL:= NIL
+    for i in 1..maxargs repeat
+      impls := SUBSTQ(GENSYM(),INTERNL('"#",STRINGIMAGE i),impls)
+  impls and
+    SL:= constructSubst dc
+    for mm in impls repeat
+      mm:= subCopy(mm,SL)
+      fun:= nconc(fun,findFunctionInDomain1(mm,op,tar,args1,args2,SL))
+  if not fun and $reportBottomUpFlag then
+    sayMSG concat
+      ['"   -> no appropriate",:bright op,'"found in",
+	:bright prefix2String dc]
+  fun
+
+matchMmCond(cond) ==
+  -- tests the condition, which comes with a modemap
+  -- cond is 'T or a list, but I hate to test for 'T (ALBI)
+  $domPvar: local := nil
+  atom cond or
+    cond is ['AND,:conds] or cond is ['and,:conds] =>
+      and/[matchMmCond c for c in conds]
+    cond is ['OR,:conds] or cond is ['or,:conds] =>
+      or/[matchMmCond c for c in conds]
+    cond is ['has,dom,x] =>
+      hasCaty(dom,x,NIL) ^= 'failed
+    cond is ['not,cond1] => not matchMmCond cond1
+    keyedSystemError("S2GE0016",
+      ['"matchMmCond",'"unknown form of condition"])
+
+matchMmSig(mm,tar,args1,args2) ==
+  -- matches the modemap signature against  args1 -> tar
+  -- if necessary, runtime checks are created for subdomains
+  -- then the modemap condition is evaluated
+  [sig,:.]:= mm
+  if CONTAINED('_#, sig) then
+    sig := [replaceSharpCalls COPY t for t in sig]
+  null args1 => matchMmSigTar(tar,CAR sig)
+  a:= CDR sig
+  arg:= NIL
+  for i in 1.. while args1 and args2 and a until not b repeat
+    x1:= CAR args1
+    args1:= CDR args1
+    x2:= CAR args2
+    args2:= CDR args2
+    x:= CAR a
+    a:= CDR a
+    rtc:= NIL
+    if x is ['SubDomain,y,:.] then x:= y
+    b := isEqualOrSubDomain(x1,x) or
+      (STRINGP(x) and (x1 is ['Variable,v]) and (x = PNAME v)) or
+	$SubDom and isSubDomain(x,x1) => rtc:= 'T
+	$Coerce => x2=x or canCoerceFrom(x1,x)
+	x1 is ['Variable,:.] and x = '(Symbol)
+    $RTC:= CONS(rtc,$RTC)
+  null args1 and null a and b and matchMmSigTar(tar,CAR sig)
+
+matchMmSigTar(t1,t2) ==
+  -- t1 is a target type specified by :: or by a declared variable
+  -- t2 is the target of a modemap signature
+  null t1 or
+    isEqualOrSubDomain(t2,t1) => true
+    if t2 is ['Union,a,b] then
+      if a='"failed" then return matchMmSigTar(t1, b)
+      if b='"failed" then return matchMmSigTar(t1, a)
+    $Coerce and
+      isPartialMode t1 => resolveTM(t2,t1)
+-- I think this should be true	-SCM
+--    true
+      canCoerceFrom(t2,t1)
+
+constructSubst(d) ==
+  -- constructs a substitution which substitutes d for $
+  -- and the arguments of d for #1, #2 ..
+  SL:= list CONS('$,d)
+  for x in CDR d for i in 1.. repeat
+    SL:= CONS(CONS(INTERNL('"#",STRINGIMAGE i),x),SL)
+  SL
+
+filterModemapsFromPackages(mms, names, op) ==
+  -- mms is a list of modemaps
+  -- names is a list of domain constructors
+  -- this returns a 2-list containing those modemaps that have one
+  -- of the names in the package source of the modemap and all the
+  -- rest of the modemaps in the second element.
+  good := NIL
+  bad  := NIL
+  -- hack to speed up factorization choices for mpolys and to overcome
+  -- some poor naming of packages
+  mpolys := '("Polynomial" "MultivariatePolynomial"
+   "DistributedMultivariatePolynomial"
+      "HomogeneousDistributedMultivariatePolynomial")
+  mpacks := '("MFactorize" "MRationalFactorize")
+  for mm in mms repeat
+    isFreeFunctionFromMm(mm) => bad := cons(mm, bad)
+    type := getDomainFromMm mm
+    null type => bad := cons(mm,bad)
+    if PAIRP type then type := first type
+    GETDATABASE(type,'CONSTRUCTORKIND) = 'category => bad := cons(mm,bad)
+    name := object2String type
+    found := nil
+    for n in names while not found repeat
+      STRPOS(n,name,0,NIL) => found := true
+      -- hack, hack
+      (op = 'factor) and member(n,mpolys) and member(name,mpacks) =>
+	found := true
+    if found
+      then good := cons(mm, good)
+      else bad := cons(mm,bad)
+  [good,bad]
+
+
+isTowerWithSubdomain(towerType,elem) ==
+  not PAIRP towerType => NIL
+  dt := deconstructT towerType
+  2 ^= #dt => NIL
+  s := underDomainOf(towerType)
+  isEqualOrSubDomain(s,elem) and constructM(first dt,[elem])
+
+selectMmsGen(op,tar,args1,args2) ==
+  -- general modemap evaluation of op with argument types args1
+  -- evaluates the condition and looks for the slot number
+  -- returns all functions which are applicable
+  -- args2 is a list of polynomial types for symbols
+  $Subst: local := NIL
+  $SymbolType: local := NIL
+
+  null (S := getModemapsFromDatabase(op,QLENGTH args1)) => NIL
+
+  if (op = 'map) and (2 = #args1) and
+    (CAR(args1) is ['Mapping,., elem]) and
+      (a := isTowerWithSubdomain(CADR args1,elem))
+	then args1 := [CAR args1,a]
+
+  -- we first split the modemaps into two groups:
+  --   haves:	 these are from packages that have one of the top level
+  --		 constructor names in the package name
+  --   havenots: everything else
+
+  -- get top level constructor names for constructors with parameters
+  conNames := nil
+  if op = 'reshape then args := APPEND(rest args1, rest args2)
+  else args := APPEND(args1,args2)
+  if tar then args := [tar,:args]
+  -- for common aggregates, use under domain also
+  for a in REMDUP args repeat
+    a =>
+      atom a => nil
+      fa := QCAR a
+      fa in '(Record Union) => NIL
+      conNames := insert(STRINGIMAGE fa, conNames)
+
+  if conNames
+    then [haves,havenots] := filterModemapsFromPackages(S,conNames,op)
+    else
+      haves := NIL
+      havenots := S
+
+  mmS := NIL
+
+  if $reportBottomUpFlag then
+    sayMSG ['%l,:bright '"Modemaps from Associated Packages"]
+
+  if haves then
+    [havesExact,havesInexact] := exact?(haves,tar,args1) where
+      exact?(mmS,tar,args) ==
+	ex := inex := NIL
+	for (mm := [sig,[mmC,:.],:.]) in mmS repeat
+	  [c,t,:a] := sig
+	  ok := true
+	  for pat in a for arg in args while ok repeat
+	    not CONTAINED(['isDomain,pat,arg],mmC) => ok := NIL
+	  ok => ex := CONS(mm,ex)
+	  inex := CONS(mm,inex)
+	[ex,inex]
+    if $reportBottomUpFlag then
+      for mm in APPEND(havesExact,havesInexact) for i in 1.. repeat
+	sayModemapWithNumber(mm,i)
+    if havesExact then
+      mmS := matchMms(havesExact,op,tar,args1,args2) where
+	matchMms(mmaps,op,tar,args1,args2) ==
+	  mmS := NIL
+	  for [sig,mmC] in mmaps repeat
+	    -- sig is [dc,result,:args]
+	    $Subst :=
+	      tar and not isPartialMode tar =>
+		-- throw in the target if it is not the same as one
+		-- of the arguments
+		res := CADR sig
+		member(res,CDDR sig) => NIL
+		[[res,:tar]]
+	      NIL
+	    [c,t,:a] := sig
+	    if a then matchTypes(a,args1,args2)
+	    not EQ($Subst,'failed) =>
+	      mmS := nconc(evalMm(op,tar,sig,mmC),mmS)
+	  mmS
+      if mmS then
+	if $reportBottomUpFlag then
+	  sayMSG '"   found an exact match!"
+	return mmS
+    mmS := matchMms(havesInexact,op,tar,args1,args2)
+  else if $reportBottomUpFlag then sayMSG '"   no modemaps"
+  mmS => mmS
+
+  if $reportBottomUpFlag then
+    sayMSG ['%l,:bright '"Remaining General Modemaps"]
+  --  for mm in havenots for i in 1.. repeat sayModemapWithNumber(mm,i)
+
+  if havenots then
+    [havesNExact,havesNInexact] := exact?(havenots,tar,args1)
+    if $reportBottomUpFlag then
+      for mm in APPEND(havesNExact,havesNInexact) for i in 1.. repeat
+	sayModemapWithNumber(mm,i)
+    if havesNExact then
+      mmS := matchMms(havesNExact,op,tar,args1,args2)
+      if mmS then
+	if $reportBottomUpFlag then
+	  sayMSG '"   found an exact match!"
+	return mmS
+    mmS := matchMms(havesNInexact,op,tar,args1,args2)
+  else if $reportBottomUpFlag then sayMSG '"   no modemaps"
+  mmS
+
+matchTypes(pm,args1,args2) ==
+  -- pm is a list of pattern variables, args1 a list of argument types,
+  --   args2 a list of polynomial types for symbols
+  -- the result is a match from pm to args, if one exists
+  for v in pm for t1 in args1 for t2 in args2 until $Subst='failed repeat
+    p:= ASSQ(v,$Subst) =>
+      t:= CDR p
+      t=t1 => $Coerce and EQCAR(t1,'Symbol) and
+	(q := ASSQ(v,$SymbolType)) and t2 and
+	  (t3 := resolveTT(CDR q, t2)) and
+	    RPLACD(q, t3)
+      $Coerce =>
+	if EQCAR(t,'Symbol) and (q := ASSQ(v,$SymbolType)) then
+	  t := CDR q
+	if EQCAR(t1,'Symbol) and t2 then t1:= t2
+	t0 := resolveTT(t,t1) => RPLACD(p,t0)
+	$Subst:= 'failed
+      $Subst:= 'failed
+    $Subst:= CONS(CONS(v,t1),$Subst)
+    if EQCAR(t1,'Symbol) and t2 then $SymbolType:= CONS(CONS(v,t2),$SymbolType)
+
+evalMm(op,tar,sig,mmC) ==
+  -- evaluates a modemap with signature sig and condition mmC
+  -- the result is a list of lists [sig,slot,cond] or NIL
+  --if $Coerce is NIL, tar has to be the same as the computed target type
+--if CONTAINED('LinearlyExplicitRingOver,mmC) then hohoho()
+  mS:= NIL
+  for st in evalMmStack mmC repeat
+    SL:= evalMmCond(op,sig,st)
+    not EQ(SL,'failed) =>
+      SL := fixUpTypeArgs SL
+      sig:= [subCopy(deepSubCopy(x,SL),$Subst) for x in sig]
+      not containsVars sig =>
+	isFreeFunctionFromMmCond mmC and (m := evalMmFreeFunction(op,tar,sig,mmC)) =>
+	   mS:= nconc(m,mS)
+	"or"/[^isValidType(arg) for arg in sig] => nil
+	[dc,t,:args]:= sig
+	$Coerce or null tar or tar=t =>
+	  mS:= nconc(findFunctionInDomain(op,dc,t,args,args,NIL,'T),mS)
+  mS
+
+evalMmFreeFunction(op,tar,sig,mmC) ==
+  [dc,t,:args]:= sig
+  $Coerce or null tar or tar=t =>
+     nilArgs := nil
+     for a in args repeat nilArgs := [NIL,:nilArgs]
+     [[[["__FreeFunction__",:dc],t,:args], [t, :args], nilArgs]]
+  nil
+
+evalMmStack(mmC) ==
+  -- translates the modemap condition mmC into a list of stacks
+  mmC is ['AND,:a] =>
+    ["NCONC"/[evalMmStackInner cond for cond in a]]
+  mmC is ['OR,:args] => [:evalMmStack a for a in args]
+  mmC is ['partial,:mmD] => evalMmStack mmD
+  mmC is ['ofCategory,pvar,cat] and cat is ['Join,:args] =>
+    evalMmStack CONS('AND,[['ofCategory,pvar,c] for c in args])
+  mmC is ['ofType,:.] => [NIL]
+  mmC is ['has,pat,x] =>
+    MEMQ(x,'(ATTRIBUTE SIGNATURE)) =>
+      [[['ofCategory,pat,['CATEGORY,'unknown,x]]]]
+    [['ofCategory,pat,x]]
+  [[mmC]]
+
+evalMmStackInner(mmC) ==
+  mmC is ['OR,:args] =>
+    keyedSystemError("S2GE0016",
+      ['"evalMmStackInner",'"OR condition nested inside an AND"])
+  mmC is ['partial,:mmD] => evalMmStackInner mmD
+  mmC is ['ofCategory,pvar,cat] and cat is ['Join,:args] =>
+    [['ofCategory, pvar, c] for c in args]
+  mmC is ['ofType,:.] => NIL
+  mmC is ['isAsConstant] => NIL
+  mmC is ['has,pat,x] =>
+    MEMQ(x,'(ATTRIBUTE SIGNATURE)) =>
+      [['ofCategory,pat,['CATEGORY,'unknown,x]]]
+    [['ofCategory,pat,x]]
+  [mmC]
+
+evalMmCond(op,sig,st) ==
+  $insideEvalMmCondIfTrue : local := true
+  evalMmCond0(op,sig,st)
+
+evalMmCond0(op,sig,st) ==
+  -- evaluates the nonempty list of modemap conditions st
+  -- the result is either 'failed or a substitution list
+  SL:= evalMmDom st
+  SL='failed => 'failed
+  for p in SL until p1 and not b repeat b:=
+    p1:= ASSQ(CAR p,$Subst)
+    p1 and
+      t1:= CDR p1
+      t:= CDR p
+      t=t1 or
+	containsVars t =>
+	  if $Coerce and EQCAR(t1,'Symbol) then t1:= getSymbolType CAR p
+	  resolveTM1(t1,t)
+	$Coerce and
+	  -- if we are looking at the result of a function, the coerce
+	  -- goes the opposite direction
+	  (t1 = $AnonymousFunction and t is ['Mapping, :.]) => t
+	  CAR p = CADR sig and not member(CAR p, CDDR sig) =>
+	    canCoerceFrom(t,t1) => 'T
+	    NIL
+	  canCoerceFrom(t1,t) => 'T
+	  isSubDomain(t,t1) => RPLACD(p,t1)
+	  EQCAR(t1,'Symbol) and canCoerceFrom(getSymbolType CAR p,t)
+  ( SL and p1 and not b and 'failed ) or evalMmCat(op,sig,st,SL)
+
+fixUpTypeArgs SL ==
+  for (p := [v, :t2]) in SL repeat
+    t1 := LASSOC(v, $Subst)
+    null t1 => RPLACD(p,replaceSharpCalls t2)
+    RPLACD(p, coerceTypeArgs(t1, t2, SL))
+  SL
+
+replaceSharpCalls t ==
+  noSharpCallsHere t => t
+  doReplaceSharpCalls t
+
+doReplaceSharpCalls t ==
+  ATOM t => t
+  t is ['_#, l] => #l
+  t is ['construct,: l] => EVAL ['LIST,:l]
+  [CAR t,:[ doReplaceSharpCalls u for u in CDR t]]
+
+noSharpCallsHere t ==
+  t isnt [con, :args] => true
+  MEMQ(con,'(construct _#)) => NIL
+  and/[noSharpCallsHere u for u in args]
+
+coerceTypeArgs(t1, t2, SL) ==
+  -- if the type t has type-valued arguments, coerce them to the new types,
+  -- if needed.
+  t1 isnt [con1, :args1] or t2 isnt [con2, :args2] => t2
+  con1 ^= con2 => t2
+  coSig := CDR GETDATABASE(CAR t1, 'COSIG)
+  and/coSig => t2
+  csub1 := constructSubst t1
+  csub2 := constructSubst t2
+  cs1 := CDR getConstructorSignature con1
+  cs2 := CDR getConstructorSignature con2
+  [con1, :
+    [makeConstrArg(arg1, arg2, constrArg(c1,csub1,SL),
+      constrArg(c2,csub2,SL), cs)
+       for arg1 in args1 for arg2 in args2 for c1 in cs1 for c2 in cs2
+	 for cs in coSig]]
+
+constrArg(v,sl,SL) ==
+  x := LASSOC(v,sl) =>
+    y := LASSOC(x,SL) => y
+    y := LASSOC(x, $Subst) => y
+    x
+  y := LASSOC(x, $Subst) => y
+  v
+
+makeConstrArg(arg1, arg2, t1, t2, cs) ==
+  if arg1 is ['_#, l] then arg1 := # l
+  if arg2 is ['_#, l] then arg2 := # l
+  cs => arg2
+  t1 = t2 => arg2
+  obj1 := objNewWrap(arg1, t1)
+  obj2 := coerceInt(obj1, t2)
+  null obj2 => throwKeyedMsgCannotCoerceWithValue(wrap arg1,t1,t2)
+  objValUnwrap obj2
+
+evalMmDom(st) ==
+  -- evals all isDomain(v,d) of st
+  SL:= NIL
+  for mmC in st until SL='failed repeat
+    mmC is ['isDomain,v,d] =>
+      STRINGP d => SL:= 'failed
+      p:= ASSQ(v,SL) and not (d=CDR p) => SL:= 'failed
+      d1:= subCopy(d,SL)
+      CONSP(d1) and MEMQ(v,d1) => SL:= 'failed
+      SL:= augmentSub(v,d1,SL)
+    mmC is ['isFreeFunction,v,fun] =>
+      SL:= augmentSub(v,subCopy(fun,SL),SL)
+  SL
+
+orderMmCatStack st ==
+  -- tries to reorder stack so that free pattern variables appear
+  -- as parameters first
+  null(st) or null rest(st) => st
+  vars := DELETE_-DUPLICATES [CADR(s) for s in st | isPatternVar(CADR(s))]
+  null vars => st
+  havevars := nil
+  haventvars := nil
+  for s in st repeat
+    cat := CADDR s
+    mem := nil
+    for v in vars while not mem repeat
+      if MEMQ(v,cat) then
+	mem := true
+	havevars := cons(s,havevars)
+    if not mem then haventvars := cons(s,haventvars)
+  null havevars => st
+  st := nreverse nconc(haventvars,havevars)
+  SORT(st, function mmCatComp)
+
+mmCatComp(c1, c2) ==
+  b1 := ASSQ(CADR c1, $Subst)
+  b2 := ASSQ(CADR c2, $Subst)
+  b1 and null(b2) => true
+  false
+
+evalMmCat(op,sig,stack,SL) ==
+  -- evaluates all ofCategory's of stack as soon as possible
+  $hope:local:= NIL
+  numConds:= #stack
+  stack:= orderMmCatStack [mmC for mmC in stack | EQCAR(mmC,'ofCategory)]
+  while stack until not makingProgress repeat
+    st := stack
+    stack := NIL
+    makingProgress := NIL
+    for mmC in st repeat
+      S:= evalMmCat1(mmC,op, SL)
+      S='failed and $hope =>
+	stack:= CONS(mmC,stack)
+      S = 'failed => return S
+      not atom S =>
+	makingProgress:= 'T
+	SL:= mergeSubs(S,SL)
+  if stack or S='failed then 'failed else SL
+
+evalMmCat1(mmC is ['ofCategory,d,c],op, SL) ==
+  -- evaluates mmC using information from the lisplib
+  -- d may contain variables, and the substitution list $Subst is used
+  -- the result is a substitution or failed
+  $domPvar: local := NIL
+  $hope:= NIL
+  NSL:= hasCate(d,c,SL)
+  NSL='failed and isPatternVar d and $Coerce and ( p:= ASSQ(d,$Subst) )
+    and (EQCAR(CDR p,'Variable) or EQCAR(CDR p,'Symbol)) =>
+      RPLACD(p,getSymbolType d)
+      hasCate(d,c,SL)
+  NSL='failed and isPatternVar d =>
+    -- following is hack to take care of the case where we have a
+    -- free substitution variable with a category condition on it.
+    -- This would arise, for example, where a package has an argument
+    -- that is not in a needed modemap.	 After making the following
+    -- dummy substitutions, the package can be instantiated and the
+    -- modemap used.	   RSS 12-22-85
+    -- If c is not Set, Ring or Field then the more general mechanism
+    dom := defaultTypeForCategory(c, SL)
+    null dom =>
+      op ^= 'coerce => 'failed -- evalMmCatLastChance(d,c,SL)
+    null (p := ASSQ(d,$Subst)) =>
+      dom =>
+	NSL := [CONS(d,dom)]
+      op ^= 'coerce => 'failed -- evalMmCatLastChance(d,c,SL)
+    if containsVars dom then dom := resolveTM(CDR p, dom)
+    $Coerce and canCoerce(CDR p, dom) =>
+      NSL := [CONS(d,dom)]
+    op ^= 'coerce => 'failed -- evalMmCatLastChance(d,c,SL)
+  NSL
+
+hasCate(dom,cat,SL) ==
+  -- asks whether dom has cat under SL
+  -- augments substitution SL or returns 'failed
+  dom = $EmptyMode => NIL
+  isPatternVar dom =>
+    (p:= ASSQ(dom,SL)) and ((NSL := hasCate(CDR p,cat,SL)) ^= 'failed) =>
+       NSL
+    (p:= ASSQ(dom,$Subst)) or (p := ASSQ(dom, SL)) =>
+--	S:= hasCate(CDR p,cat,augmentSub(CAR p,CDR p,copy SL))
+      S:= hasCate1(CDR p,cat,SL, dom)
+      not (S='failed) => S
+      hasCateSpecial(dom,CDR p,cat,SL)
+    if SL ^= 'failed then $hope:= 'T
+    'failed
+  SL1 := [[v,:d] for [v,:d] in SL | not containsVariables d]
+  if SL1 then cat := subCopy(cat, SL1)
+  hasCaty(dom,cat,SL)
+
+hasCate1(dom, cat, SL, domPvar) ==
+  $domPvar:local := domPvar
+  hasCate(dom, cat, SL)
+
+hasCateSpecial(v,dom,cat,SL) ==
+  -- v is a pattern variable, dom it's binding under $Subst
+  -- tries to change dom, so that it has category cat under SL
+  -- the result is a substitution list or 'failed
+  dom is ['FactoredForm,arg] =>
+    if isSubDomain(arg,$Integer) then arg := $Integer
+    d := ['FactoredRing,arg]
+    SL:= hasCate(arg,'(Ring),augmentSub(v,d,SL))
+    SL = 'failed => 'failed
+    hasCaty(d,cat,SL)
+  EQCAR(cat,'Field) or EQCAR(cat, 'DivisionRing) =>
+    if isSubDomain(dom,$Integer) then dom := $Integer
+    d:= eqType [$QuotientField, dom]
+    hasCaty(dom,'(IntegralDomain),augmentSub(v,d,SL))
+  cat is ['PolynomialCategory, d, :.] =>
+    dom' := ['Polynomial, d]
+    (containsVars d or canCoerceFrom(dom, dom'))
+       and hasCaty(dom', cat, augmentSub(v,dom',SL))
+  isSubDomain(dom,$Integer) =>
+    NSL:= hasCate($Integer,cat,augmentSub(v,$Integer,SL))
+    NSL = 'failed =>
+      hasCateSpecialNew(v, dom, cat, SL)
+    hasCaty($Integer,cat,NSL)
+  hasCateSpecialNew(v, dom, cat, SL)
+
+-- to be used in $newSystem only
+hasCateSpecialNew(v,dom,cat,SL) ==
+  fe := member(QCAR cat, '(ElementaryFunctionCategory
+       TrigonometricFunctionCategory ArcTrigonometricFunctionCategory
+	HyperbolicFunctionCategory ArcHyperbolicFunctionCategory
+	 PrimitiveFunctionCategory SpecialFunctionCategory Evalable
+	  CombinatorialOpsCategory TranscendentalFunctionCategory
+	   AlgebraicallyClosedFunctionSpace ExpressionSpace
+	     LiouvillianFunctionCategory FunctionSpace))
+  alg := member(QCAR cat, '(RadicalCategory AlgebraicallyClosedField))
+  fefull := fe or alg or EQCAR(cat, 'CombinatorialFunctionCategory)
+  partialResult :=
+    EQCAR(dom, 'Variable) or EQCAR(dom, 'Symbol) =>
+      CAR(cat) in
+       '(SemiGroup AbelianSemiGroup Monoid AbelianGroup AbelianMonoid
+         PartialDifferentialRing Ring InputForm) =>
+        	d := ['Polynomial, $Integer]
+        	augmentSub(v, d, SL)
+      EQCAR(cat, 'Group) =>
+        d := ['Fraction, ['Polynomial, $Integer]]
+        augmentSub(v, d, SL)
+      fefull =>
+        d := defaultTargetFE dom
+        augmentSub(v, d, SL)
+      'failed
+    isEqualOrSubDomain(dom, $Integer) =>
+      fe =>
+        d := defaultTargetFE $Integer
+        augmentSub(v, d, SL)
+      alg =>
+        d := '(AlgebraicNumber)
+        --d := defaultTargetFE $Integer
+        augmentSub(v, d, SL)
+      'failed
+    underDomainOf dom = $ComplexInteger =>
+      d := defaultTargetFE $ComplexInteger
+      hasCaty(d,cat,augmentSub(v, d, SL))
+    (dom = $RationalNumber) and alg =>
+      d := '(AlgebraicNumber)
+      --d := defaultTargetFE $Integer
+      augmentSub(v, d, SL)
+    fefull =>
+      d := defaultTargetFE dom
+      augmentSub(v, d, SL)
+    'failed
+  partialResult = 'failed => 'failed
+  hasCaty(d, cat, partialResult)
+
+hasCaty(d,cat,SL) ==
+  -- calls hasCat, which looks up a hashtable and returns:
+  -- 1. T, NIL or a (has x1 x2) condition, if cat is not parameterized
+  -- 2. a list of pairs (argument to cat,condition) otherwise
+  -- then the substitution SL is augmented, or the result is 'failed
+  cat is ['CATEGORY,.,:y] => hasAttSig(d,subCopy(y,constructSubst d),SL)
+  cat is ['SIGNATURE,foo,sig] =>
+    hasSig(d,foo,subCopy(sig,constructSubst d),SL)
+  cat is ['ATTRIBUTE,a] => hasAtt(d,subCopy(a,constructSubst d),SL)
+  x:= hasCat(opOf d,opOf cat) =>
+    y:= KDR cat =>
+      S	 := constructSubst d
+      for [z,:cond] in x until not (S1='failed) repeat
+	S' := [[p, :mkDomPvar(p, d, z, y)] for [p,:d] in S]
+	if $domPvar then
+	  dom := [CAR d, :[domArg(arg, i, z, y) for i in 0..
+			   for arg in CDR d]]
+	  SL := augmentSub($domPvar, dom, copy SL)
+	z' := [domArg2(a, S, S') for a in z]
+	S1:= unifyStruct(y,z',copy SL)
+	if not (S1='failed) then S1:=
+	  atom cond => S1
+	  ncond := subCopy(cond, S)
+	  ncond is ['has, =d, =cat] => 'failed
+	  hasCaty1(ncond,S1)
+      S1
+    atom x => SL
+    ncond := subCopy(x, constructSubst d)
+    ncond is ['has, =d, =cat] => 'failed
+    hasCaty1(ncond, SL)
+  'failed
+
+mkDomPvar(p, d, subs, y) ==
+  l := MEMQ(p, $FormalMapVariableList) =>
+    domArg(d, #$FormalMapVariableList - #l, subs, y)
+  d
+
+domArg(type, i, subs, y) ==
+  p := MEMQ($FormalMapVariableList.i, subs) =>
+    y.(#subs - #p)
+  type
+
+domArg2(arg, SL1, SL2) ==
+  isSharpVar arg => subCopy(arg, SL1)
+  arg = '_$ and $domPvar => $domPvar
+  subCopy(arg, SL2)
+
+hasCaty1(cond,SL) ==
+  -- cond is either a (has a b) or an OR clause of such conditions
+  -- SL is augmented, if cond is true, otherwise the result is 'failed
+  $domPvar: local := NIL
+  cond is ['has,a,b] => hasCate(a,b,SL)
+  cond is ['AND,:args] =>
+    for x in args while not (S='failed) repeat S:=
+      x is ['has,a,b] => hasCate(a,b, SL)
+      -- next line is for an obscure bug in the table
+      x is [['has,a,b]] => hasCate(a,b, SL)
+      --'failed
+      hasCaty1(x, SL)
+    S
+  cond is ['OR,:args] =>
+    for x in args until not (S='failed) repeat S:=
+      x is ['has,a,b] => hasCate(a,b,copy SL)
+      -- next line is for an obscure bug in the table
+      x is [['has,a,b]] => hasCate(a,b,copy SL)
+      --'failed
+      hasCaty1(x, copy SL)
+    S
+  keyedSystemError("S2GE0016",
+    ['"hasCaty1",'"unexpected condition from category table"])
+
+hasAttSig(d,x,SL) ==
+  -- d is domain, x a list of attributes and signatures
+  -- the result is an augmented SL, if d has x, 'failed otherwise
+  for y in x until SL='failed repeat SL:=
+    y is ['ATTRIBUTE,a] => hasAtt(d,a,SL)
+    y is ['SIGNATURE,foo,s] => hasSig(d,foo,s,SL)
+    keyedSystemError("S2GE0016",
+      ['"hasAttSig",'"unexpected form of unnamed category"])
+  SL
+
+hasSigAnd(andCls, S0, SL) ==
+  dead := NIL
+  SA := 'failed
+  for cls in andCls while not dead repeat
+    SA :=
+      atom cls => copy SL
+      cls is ['has,a,b] =>
+	hasCate(subCopy(a,S0),subCopy(b,S0),copy SL)
+      keyedSystemError("S2GE0016",
+	['"hasSigAnd",'"unexpected condition for signature"])
+    if SA = 'failed then dead := true
+  SA
+
+hasSigOr(orCls, S0, SL) ==
+  found := NIL
+  SA := 'failed
+  for cls in orCls until found repeat
+    SA :=
+      atom cls => copy SL
+      cls is ['has,a,b] =>
+	hasCate(subCopy(a,S0),subCopy(b,S0),copy SL)
+      cls is ['AND,:andCls] or cls is ['and,:andCls] =>
+	hasSigAnd(andCls, S0, SL)
+      keyedSystemError("S2GE0016",
+	['"hasSigOr",'"unexpected condition for signature"])
+    if SA ^= 'failed then found := true
+  SA
+
+hasSig(dom,foo,sig,SL) ==
+  -- tests whether domain dom has function foo with signature sig
+  -- under substitution SL
+  $domPvar: local := nil
+  fun:= constructor? CAR dom =>
+    S0:= constructSubst dom
+    p := ASSQ(foo,getOperationAlistFromLisplib CAR dom) =>
+      for [x,.,cond,.] in CDR p until not (S='failed) repeat
+	S:=
+	  atom cond => copy SL
+	  cond is ['has,a,b] =>
+	    hasCate(subCopy(a,S0),subCopy(b,S0),copy SL)
+	  cond is ['AND,:andCls] or cond is ['and,:andCls] =>
+	    hasSigAnd(andCls, S0, SL)
+	  cond is ['OR,:orCls] or cond is ['or,:orCls] =>
+	    hasSigOr(orCls, S0, SL)
+	  keyedSystemError("S2GE0016",
+	     ['"hasSig",'"unexpected condition for signature"])
+	not (S='failed) => S:= unifyStruct(subCopy(x,S0),sig,S)
+      S
+    'failed
+  'failed
+
+hasAtt(dom,att,SL) ==
+  -- tests whether dom has attribute att under SL
+  -- needs S0 similar to hasSig above ??
+  $domPvar: local := nil
+  fun:= CAR dom =>
+    atts:= subCopy(GETDATABASE(fun,'ATTRIBUTES),constructSubst dom) =>
+      PAIRP (u := getInfovec CAR dom) =>
+	--UGH! New world has attributes stored as pairs not as lists!!
+	for [x,:cond] in atts until not (S='failed) repeat
+	  S:= unifyStruct(x,att,copy SL)
+	  not atom cond and not (S='failed) => S := hasCatExpression(cond,S)
+	S
+      for [x,cond] in atts until not (S='failed) repeat
+	S:= unifyStruct(x,att,copy SL)
+	not atom cond and not (S='failed) => S := hasCatExpression(cond,S)
+      S
+    'failed
+  'failed
+
+hasCatExpression(cond,SL) ==
+  cond is ['OR,:l] =>
+    or/[(y:=hasCatExpression(x,SL)) ^= 'failed for x in l] => y
+  cond is ['AND,:l] =>
+    and/[(SL:= hasCatExpression(x,SL)) ^= 'failed for x in l] => SL
+  cond is ['has,a,b] => hasCate(a,b,SL)
+  keyedSystemError("S2GE0016",
+    ['"hasSig",'"unexpected condition for attribute"])
+
+unifyStruct(s1,s2,SL) ==
+  -- tests for equality of s1 and s2 under substitutions SL and $Subst
+  -- the result is a substitution list or 'failed
+  s1=s2 => SL
+  if s1 is ['_:,x,.] then s1:= x
+  if s2 is ['_:,x,.] then s2:= x
+  if ^atom s1 and CAR s1 = '_# then s1:= LENGTH CADR s1
+  if ^atom s2 and CAR s2 = '_# then s2:= LENGTH CADR s2
+  s1=s2 => SL
+  isPatternVar s1 => unifyStructVar(s1,s2,SL)
+  isPatternVar s2 => unifyStructVar(s2,s1,SL)
+  atom s1 or atom s2 => 'failed
+  until null s1 or null s2 or SL='failed repeat
+    SL:= unifyStruct(CAR s1,CAR s2,SL)
+    s1:= CDR s1
+    s2:= CDR s2
+  s1 or s2 => 'failed
+  SL
+
+unifyStructVar(v,s,SL) ==
+  -- the first argument is a pattern variable, which is not substituted
+  -- by SL
+  CONTAINED(v,s) => 'failed
+  ps := LASSOC(s, SL)
+  s1 := (ps => ps; s)
+  (s0 := LASSOC(v, SL)) or (s0 := LASSOC(v,$Subst)) =>
+    S:= unifyStruct(s0,s1,copy SL)
+    S='failed =>
+      $Coerce and not atom s0 and constructor? CAR s0 =>
+	containsVars s0 or containsVars s1 =>
+	  ns0 := subCopy(s0, SL)
+	  ns1 := subCopy(s1, SL)
+	  containsVars ns0 or containsVars ns1 =>
+	    $hope:= 'T
+	    'failed
+	  if canCoerce(ns0, ns1) then s3 := s1
+	  else if canCoerce(ns1, ns0) then s3 := s0
+	  else s3 := nil
+	  s3 =>
+	    if (s3 ^= s0) then SL := augmentSub(v,s3,SL)
+	    if (s3 ^= s1) and isPatternVar(s) then SL := augmentSub(s,s3,SL)
+	    SL
+	  'failed
+	$domPvar =>
+	  s3 := resolveTT(s0,s1)
+	  s3 =>
+	    if (s3 ^= s0) then SL := augmentSub(v,s3,SL)
+	    if (s3 ^= s1) and isPatternVar(s) then SL := augmentSub(s,s3,SL)
+	    SL
+	  'failed
+--	  isSubDomain(s,s0) => augmentSub(v,s0,SL)
+	'failed
+      'failed
+    augmentSub(v,s,S)
+  augmentSub(v,s,SL)
+
+ofCategory(dom,cat) ==
+  -- entry point to category evaluation from other points than type
+  --   analysis
+  -- the result is true or NIL
+  $Subst:local:= NIL
+  $hope:local := NIL
+  IDENTP dom => NIL
+  cat is ['Join,:cats] => and/[ofCategory(dom,c) for c in cats]
+  (hasCaty(dom,cat,NIL) ^= 'failed)
+
+printMms(mmS) ==
+  -- mmS a list of modemap signatures
+  sayMSG '" "
+  for [sig,imp,.] in mmS for i in 1.. repeat
+    istr := STRCONC('"[",STRINGIMAGE i,'"]")
+    if QCSIZE(istr) = 3 then istr := STRCONC(istr,'" ")
+    sayMSG [:bright istr,'"signature:   ",:formatSignature CDR sig]
+    CAR sig='local =>
+      sayMSG ['"      implemented: local function ",imp]
+    imp is ['XLAM,:.] =>
+      sayMSG concat('"      implemented: XLAM from ",
+	prefix2String CAR sig)
+    sayMSG concat('"      implemented: slot ",imp,
+      '" from ",prefix2String CAR sig)
+  sayMSG '" "
+
+containsVars(t) ==
+  -- tests whether term t contains a * variable
+  atom t => isPatternVar t
+  containsVars1(t)
+
+containsVars1(t) ==
+  -- recursive version, which works on a list
+  [t1,:t2]:= t
+  atom t1 =>
+    isPatternVar t1 or
+      atom t2 => isPatternVar t2
+      containsVars1(t2)
+  containsVars1(t1) or
+    atom t2 => isPatternVar t2
+    containsVars1(t2)
+
+<<isPartialMode>>
+
+getSymbolType var ==
+-- var is a pattern variable
+  p:= ASSQ(var,$SymbolType) => CDR p
+  t:= '(Polynomial (Integer))
+  $SymbolType:= CONS(CONS(var,t),$SymbolType)
+  t
+
+isEqualOrSubDomain(d1,d2) ==
+  -- last 2 parts are for tagged unions (hack for now, RSS)
+  (d1=d2) or isSubDomain(d1,d2) or
+    (atom(d1) and ((d2 is ['Variable,=d1]) or (d2 is [=d1])))
+     or (atom(d2) and ((d1 is ['Variable,=d2]) or (d1 is [=d2])))
+
+defaultTypeForCategory(cat, SL) ==
+  -- this function returns a domain belonging to cat
+  -- note that it is important to note that in some contexts one
+  -- might not want to use this result. For example, evalMmCat1
+  -- calls this and should possibly fail in some cases.
+  cat := subCopy(cat, SL)
+  c := CAR cat
+  d := GETDATABASE(c, 'DEFAULTDOMAIN)
+  d => [d, :CDR cat]
+  cat is [c] =>
+    c = 'Field => $RationalNumber
+    c in '(Ring IntegralDomain EuclideanDomain GcdDomain
+      OrderedRing DifferentialRing) => '(Integer)
+    c = 'OrderedSet => $Symbol
+    c = 'FloatingPointSystem => '(Float)
+    NIL
+  cat is [c,p1] =>
+    c = 'FiniteLinearAggregate => ['Vector, p1]
+    c = 'VectorCategory => ['Vector, p1]
+    c = 'SetAggregate => ['Set, p1]
+    c = 'SegmentCategory => ['Segment, p1]
+    NIL
+  cat is [c,p1,p2] =>
+    NIL
+  cat is [c,p1,p2,p3] =>
+    cat is ['MatrixCategory, d, ['Vector, =d], ['Vector, =d]] =>
+      ['Matrix, d]
+    NIL
+  NIL
+
+
+@
+\eject
+\begin{thebibliography}{99}
+\bibitem{1} nothing
+\end{thebibliography}
+\end{document}