path: root/src/interp/i-analy.boot

-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
-- All rights reserved.
-- Copyright (C) 2007-2008, Gabriel Dos Reis.
-- 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.


import i_-object
namespace BOOT

$univariateDomains ==
  '(UnivariatePolynomial
    UnivariateTaylorSeries
    UnivariateLaurentSeries
    UnivariatePuiseuxSeries)

$multivariateDomains ==
  '(MultivariatePolynomial
    DistributedMultivariatePolynomial
    HomogeneousDistributedMultivariatePolynomial
    GeneralDistributedMultivariatePolynomial)

--%
$inRetract := false

--% Interpreter Analysis Functions

++ Record calling context information in the VAT `t'.
putCallInfo(t,op,arg,nargs) ==
  putAtree(t,"callingFunction",op)
  putAtree(t,"argumentNumber",arg)
  putAtree(t,"totalArgs",nargs)
  t

getMinimalVariableTower(var,t) ==
  -- gets the minimal polynomial subtower of t that contains the
  -- given variable. Returns NIL if none.
  STRINGP(t) or IDENTP(t) => NIL
  t = $Symbol => t
  t is ['Variable,u] =>
    (u = var) => t
    NIL
  t is ['Polynomial,.] => t
  t is ['RationalFunction,D] => ['Polynomial,D]
  t is [up,t',u,.] and MEMQ(up,$univariateDomains) =>
    -- power series have one more arg and different ordering
    u = var => t
    getMinimalVariableTower(var,t')
  t is [up,u,t'] and MEMQ(up,$univariateDomains) =>
    u = var => t
    getMinimalVariableTower(var,t')
  t is [mp,u,t'] and MEMQ(mp,$multivariateDomains) =>
    var in u => t
    getMinimalVariableTower(var,t')
  null (t' := underDomainOf t) => NIL
  getMinimalVariableTower(var,t')

getMinimalVarMode(id,m) ==
  --  This function finds the minimum polynomial subtower type of the
  --  polynomial domain tower m which id to which can be coerced
  --  It includes all polys above the found level if they are
  --  contiguous.
  --  E.g.:    x and G P[y] P[x] I ---> P[y] P[x] I
  --           x and P[y] G P[x] I ---> P[x] I
  m is ['Mapping, :.] => m
  defaultMode :=
    $Symbol
  null m => defaultMode
  (vl := polyVarlist m) and ((id in vl) or 'all in vl) =>
    SUBSTQ($Integer,$EmptyMode,m)
  (um := underDomainOf m) => getMinimalVarMode(id,um)
  defaultMode

polyVarlist m ==
  --  If m is a polynomial type this function returns a list of its
  --  top level variables, and nil otherwise
  -- ignore any QuotientFields that may separate poly types
  m is [=$QuotientField,op] => polyVarlist op
  m is [op,a,:.] =>
    op in '(UnivariateTaylorSeries UnivariateLaurentSeries
      UnivariatePuiseuxSeries) =>
        [., ., a, :.] := m
        a := removeQuote a
        [a]
    op in '(Polynomial RationalFunction Expression) =>
      '(all)
    a := removeQuote a
    op in '(UnivariatePolynomial) =>
      [a]
    op in $multivariateDomains =>
          a
  nil

--% Pushing Down Target Information

pushDownTargetInfo(op,target,arglist) ==
  -- put target info on args for certain operations
  target = $OutputForm => NIL
  target = $Any        => NIL
  n := LENGTH arglist
  pushDownOnArithmeticVariables(op,target,arglist)
  (pdArgs := pushDownOp?(op,n)) =>
    for i in pdArgs repeat
      x := arglist.i
      if not getTarget(x) then putTarget(x,target)
  nargs := #arglist
  1 = nargs =>
    (op = 'SEGMENT) and (target is ['UniversalSegment,S]) =>
      for x in arglist repeat
        if not getTarget(x) then putTarget(x,S)
  2 = nargs =>
    op = "*" =>            -- only push down on 1st arg if not immed
      if not getTarget CADR arglist then putTarget(CADR arglist,target)
      getTarget(x := CAR arglist) => NIL
      if getUnname(x) ^= $immediateDataSymbol then putTarget(x,target)
    op = "**" or op = "^" =>           -- push down on base
      if not getTarget CAR arglist then putTarget(CAR arglist,target)
    (op = 'equation) and (target is ['Equation,S]) =>
      for x in arglist repeat
        if not getTarget(x) then putTarget(x,S)
    (op = 'gauss) and (target is ['Gaussian,S]) =>
      for x in arglist repeat
        if not getTarget(x) then putTarget(x,S)
    (op = '_/) =>
      targ :=
        target is ['Fraction,S] => S
        target
      for x in arglist repeat
        if not getTarget(x) then putTarget(x,targ)
    (op = 'SEGMENT) and (target is ['Segment,S]) =>
      for x in arglist repeat
        if not getTarget(x) then putTarget(x,S)
    (op = 'SEGMENT) and (target is ['UniversalSegment,S]) =>
      for x in arglist repeat
        if not getTarget(x) then putTarget(x,S)
    NIL
  NIL

pushDownOnArithmeticVariables(op,target,arglist) ==
  -- tries to push appropriate target information onto variable
  -- occurring in arithmetic expressions
  PAIRP(target) and CAR(target) = 'Variable => NIL
  not MEMQ(op,'(_+ _- _* _*_* _/)) => NIL
  not containsPolynomial(target)   => NIL
  for x in arglist for i in 1.. repeat
    VECP(x) =>   -- leaf
      transferPropsToNode(xn := getUnname(x),x)
      getValue(x) or (xn = $immediateDataSymbol) => NIL
      t := getMinimalVariableTower(xn,target) or target
      if not getTarget(x) then putTarget(x,t)
    PAIRP(x) =>  -- node
      [op',:arglist'] := x
      pushDownOnArithmeticVariables(getUnname op',target,arglist')
  arglist

pushDownOp?(op,n) ==
  -- determine if for op with n arguments whether for all modemaps
  -- the target type is equal to one or more arguments. If so, a list
  -- of the appropriate arguments is returned.
  ops := [sig for [sig,:.] in getModemapsFromDatabase(op,n)]
  null ops => NIL
  op in '(_+ _* _- _exquo) => [i for i in 0..(n-1)]
  -- each signature has form
  -- [domain of implementation, target, arg1, arg2, ...]
  -- sameAsTarg is a vector that counts the number of modemaps that
  -- have the corresponding argument equal to the target type
  sameAsTarg := GETZEROVEC n
  numMms := LENGTH ops
  for [.,targ,:argl] in ops repeat
    for arg in argl for i in 0.. repeat
      targ = arg => setShellEntry(sameAsTarg,i,1 + sameAsTarg.i)
  -- now see which args have their count = numMms
  ok := NIL
  for i in 0..(n-1) repeat
    if numMms = sameAsTarg.i then ok := cons(i,ok)
  reverse ok

--% Bottom Up Processing

-- Also see I-SPEC BOOT for special handlers and I-MAP BOOT for
-- user function processing.

++ Take a parse form and return the VAT for its elaboration.
elaborateForm pf ==
  t := mkAtree1 pf
  bottomUp t
  t

bottomUp t ==
  -- bottomUp takes an attributed tree, and returns the modeSet for it.
  -- As a side-effect it also evaluates the tree.
  t is [op,:argl] =>
    tar := getTarget op
    getUnname(op) ^= $immediateDataSymbol and (v := getValue op) =>
      om := objMode(v)
      null tar => [om]
      (r := resolveTM(om,tar)) => [r]
      [om]
    if atom op then
      opName:= getUnname op
      if opName in $localVars then
        putModeSet(op,bottomUpIdentifier(op,opName))
      else
        transferPropsToNode(opName,op)
    else
      opName := NIL
      bottomUp op

    opVal := getValue op

    -- call a special handler if we are not being package called
    dol := getAtree(op,'dollar) and (opName ^= 'construct)

    (null dol) and (fn:= GETL(opName,"up")) and (u:= FUNCALL(fn, t)) => u
    nargs := #argl
    if opName then for x in argl for i in 1.. repeat
      putCallInfo(x,opName,i,nargs)

    if tar then pushDownTargetInfo(opName,tar,argl)

    -- see if we are calling a declared user map
    -- if so, push down the declared types as targets on the args
    if opVal and (objVal opVal  is ["%Map",:.]) and
      (getMode op is ['Mapping,:ms]) and (nargs + 1= #ms) then
        for m in rest ms for x in argl repeat putTarget(x,m)

    argModeSetList:= [bottomUp x for x in argl]

    if ^tar and opName = "*" and nargs = 2 then
        [[t1],[t2]] := argModeSetList
        tar := computeTypeWithVariablesTarget(t1, t2)
        tar =>
            pushDownTargetInfo(opName,tar,argl)
            argModeSetList:= [bottomUp x for x in argl]

    ms := bottomUpForm(t,op,opName,argl,argModeSetList)
    -- If this is a type producing form, then we don't want
    -- to store the representation object in the environment.
    -- Rather, we want to record the reified canonical form.
    if ms is [m] and (member(m,$LangSupportTypes) or isCategoryForm(m,$e))
    then putValue(t,objNew(devaluate objValUnwrap getValue t, m))

    -- given no target or package calling, force integer constants to
    -- belong to tightest possible subdomain

    op := CAR t                -- may have changed in bottomUpElt
    $useIntegerSubdomain and null tar and null dol and
      isEqualOrSubDomain(first ms,$Integer) =>
        val := objVal getValue op
        isWrapped val =>       -- constant if wrapped
          val := unwrap val
          bm := getBasicMode val
          putValue(op,objNewWrap(val,bm))
          putModeSet(op,[bm])
        ms
    ms
  m := getBasicMode t => [m]
  IDENTP (id := getUnname t) =>
    putModeSet(t,bottomUpIdentifier(t,id))
  keyedSystemError("S2GE0016",['"bottomUp",'"unknown object form"])

computeTypeWithVariablesTarget(p, q) ==
    polyVarlist(p) or polyVarlist(q) =>
        t := resolveTT(p, q)
        polyVarlist(t) => t
        NIL
    NIL

bottomUpCompile t ==
  $genValue:local := false
  ms := bottomUp t
  mutateToBackendCode objVal getValue t
  ms

bottomUpUseSubdomain t ==
  $useIntegerSubdomain : local := true
  ms := bottomUp t
  ($immediateDataSymbol ^= getUnname(t)) or ($Integer ^= CAR(ms)) => ms
  null INTEGERP(num := objValUnwrap getValue t) => ms
  o := getBasicObject(num)
  putValue(t,o)
  ms := [objMode o]
  putModeSet(t,ms)
  ms

bottomUpPredicate(pred, name) ==
  putTarget(pred,$Boolean)
  ms := bottomUp pred
  $Boolean ^= first ms => throwKeyedMsg('"S2IB0001",[name])
  ms

bottomUpCompilePredicate(pred, name) ==
  $genValue:local := false
  bottomUpPredicate(pred,name)


++ We are in the process of elaborating the identifier `id' into
++ the  VAT `t'.  Return the modeset of the elaboration if `id'
++ unambiguously denote a constructor.  Ambiguous constructor
++ identifiers are precisely those that denote niladic constructors.
++ By default, the ambiguity is resolved to types. 
++ See bottomUpIdentifier and isType.
isUnambiguouslyConstructor(id,t) ==
  niladicConstructorFromDB id => nil
  k := getConstructorKindFromDB id or
        id in $DomainNames => "domain"
        id in $CategoryNames => "category"
  k = nil => nil
  ms := 
    k = "category" => [$CategoryConstructor]
    [$DomainConstructor]
  if not(id in $BuiltinConstructorNames) then 
    loadIfNecessary id
  putValue(t,objNewWrap(id,first ms))
  putModeSet(t,ms)
  ms
  


bottomUpIdentifier(t,id) ==
  ms := isUnambiguouslyConstructor(id,t) => ms
  m := isType t => bottomUpType(t, m)
  id = "%noMapVal" => throwKeyedMsg('"S2IB0002",NIL)
  id = "%noBranch" =>
    keyedSystemError("S2GE0016",
      ['"bottomUpIdentifier",'"trying to evaluate %noBranch"])
  transferPropsToNode(id,t)
  defaultType := ['Variable,id]
  -- This was meant to stop building silly symbols but had some unfortunate
  -- side effects, like not being able to say e:=foo in the interpreter.  MCD
--  defaultType :=
--    getModemapsFromDatabase(id,1) =>
--      userError ['"Cannot use operation name as a variable: ", id]
--    ['Variable, id]
  u := getValue t => --non-cached values MAY be re-evaluated
    tar := getTarget t
    expr:= objVal u
    om := objMode(u)
    (om ^= $EmptyMode) and (om isnt ['RuleCalled,.]) =>
      $genValue or GENSYMP(id) =>
        null tar => [om]
        (r := resolveTM(om,tar)) => [r]
        [om]
      bottomUpDefault(t,id,defaultType,getTarget t)
    interpRewriteRule(t,id,expr) or
      (isMapExpr expr and [objMode(u)]) or
        keyedSystemError("S2GE0016",
          ['"bottomUpIdentifier",'"cannot evaluate identifier"])
  m := namedConstant(id,t) => [m]
  bottomUpDefault(t,id,defaultType,getTarget t)

getConstantObject(id,dc,sig) ==
  mode := substitute(dc,"$",first sig)
  $genValue =>
    objNewWrap(SPADCALL compiledLookupCheck(id,sig,evalDomain dc),mode)
  objNew(["SPADCALL",["compiledLookupCheck",id,sig,["evalDomain",dc]]],mode)

namedConstant(id,t) ==
  -- for the time being, ignore the case where the target type is imposed.
  getTarget(t) ^= nil => nil
  sysmms := getModemapsFromDatabase(id,0) or return nil
  -- ignore polymorphic constants are not supported yet.
  doms := [getDCFromSystemModemap sysmm for sysmm in sysmms]
  candidates := nil
  for dc in doms | niladicConstructorFromDB first dc repeat
    LASSOC(id,getOperationAlistFromLisplib first dc) is [[sig,.,.,"CONST"]] =>
      candidates := [[dc,sig],:candidates]
  null candidates => nil
  #candidates = 1 =>
    [[dc,sig]] := candidates
    val := getConstantObject(id,dc,sig)
    putValue(t,val)
    putMode(t,objMode val)
    
  -- error for ambiguity.

bottomUpDefault(t,id,defaultMode,target) ==
  if $genValue
    then bottomUpDefaultEval(t,id,defaultMode,target,nil)
    else bottomUpDefaultCompile(t,id,defaultMode,target,nil)

bottomUpDefaultEval(t,id,defaultMode,target,isSub) ==
  -- try to get value case.

  -- 1. declared mode but no value case
  (m := getMode t) =>
    m is ['Mapping,:.] => throwKeyedMsg('"S2IB0003",[getUnname t])

    -- hmm, try to treat it like target mode or declared mode
    if isPartialMode(m) then m := resolveTM(['Variable,id],m)
    -- if there is a target, probably want it to be that way and not
    -- declared mode. Like "x" in second line:
    --   x : P[x] I
    --   y : P[x] I
    target and not isSub and
      (val := coerceInteractive(objNewWrap(id,['Variable,id]),target))=>
        putValue(t,val)
        [target]
    -- Ok, see if we can make it into declared mode from symbolic form
    -- For example, (x : P[x] I; x + 1)
    not target and not isSub and m and
      (val := coerceInteractive(objNewWrap(id,['Variable,id]),m)) =>
        putValue(t,val)
        [m]
    -- give up
    throwKeyedMsg('"S2IB0004",[id,m])

  -- 2. no value and no mode case
  val := objNewWrap(id,defaultMode)
  (null target) or (defaultMode = target) =>
    putValue(t,val)
    [defaultMode]
  if isPartialMode target then
    -- this hackery will go away when Symbol is not the default type
    if defaultMode = $Symbol and (target is [D,x,.]) then
      (D in $univariateDomains and (x = id)) or
        (D in $multivariateDomains and (id in x)) =>
           dmode := [D,x,$Integer]
           (val' := coerceInteractive(objNewWrap(id,
             ['Variable,id]),dmode)) =>
               defaultMode := dmode
               val := val'
      NIL
    target := resolveTM(defaultMode,target)
  -- The following is experimental.  SCM 10/11/90
  if target and (tm := getMinimalVarMode(id, target)) then
    target := tm
  (null target) or null (val' := coerceInteractive(val,target)) =>
    putValue(t,val)
    [defaultMode]
  putValue(t,val')
  [target]

bottomUpDefaultCompile(t,id,defaultMode,target,isSub) ==
  tmode := getMode t
  tval  := getValue t
  expr:=
    id in $localVars => id
    get(id,"mode",$env) => id       -- declared local variable
    tmode or tval =>
      envMode := tmode or objMode tval
      envMode is ['Variable, :.] => objVal tval
      id = $immediateDataSymbol => objVal tval
      ['getValueFromEnvironment,MKQ id,MKQ envMode]
    wrap id
  tmode and tval and (mdv := objMode tval) =>
    if isPartialMode tmode then
      null (tmode := resolveTM(mdv,tmode)) =>
        keyedMsgCompFailure("S2IB0010",NIL)
    putValue(t,objNew(expr,tmode))
    [tmode]
  tmode or (tval and (tmode := objMode tval)) =>
    putValue(t,objNew(expr,tmode))
    [tmode]
  obj := objNew(expr,defaultMode)
  canCoerceFrom(defaultMode, target) and
    (obj' := coerceInteractive(obj, target)) =>
        putValue(t, obj')
        [target]
  putValue(t,obj)
  [defaultMode]

interpRewriteRule(t,id,expr) ==
  null get(id,'isInterpreterRule,$e) => NIL
  (ms:= selectLocalMms(t,id,nil,nil)) and (ms:=evalForm(t,id,nil,ms)) =>
    ms
  nil

bottomUpForm(t,op,opName,argl,argModeSetList) ==
  not($inRetract) =>
    bottomUpForm3(t,op,opName,argl,argModeSetList)
  bottomUpForm2(t,op,opName,argl,argModeSetList)

bottomUpForm3(t,op,opName,argl,argModeSetList) ==
  $origArgModeSetList:local  := COPY argModeSetList
  bottomUpForm2(t,op,opName,argl,argModeSetList)

bottomUpForm2(t,op,opName,argl,argModeSetList) ==
  not atom t and EQ(opName,"%%") => bottomUpPercent t
  opVal := getValue op

  -- for things with objects in operator position, be careful before
  -- we enter general modemap selection

  lookForIt :=
    getAtree(op,'dollar) => true
    not opVal => true
    opMode := objMode opVal
    not (opModeTop := IFCAR opMode) => true
    opModeTop in '(Record Union) => false
    opModeTop in '(Variable Mapping FunctionCalled RuleCalled AnonymousFunction) => true
    false

  -- get rid of Union($, "failed") except when op is "=" and all
  -- modesets are the same

  $genValue and
    ^(opName = "=" and argModeSetList is [[m],[=m]] and m is ['Union,:.]) and
      (u := bottomUpFormUntaggedUnionRetract(t,op,opName,argl,argModeSetList)) => u

  lookForIt and (u := bottomUpFormTuple(t, op, opName, argl, argModeSetList)) => u

  -- opName can change in the call to selectMms

  (lookForIt and (mmS := selectMms(op,argl,getTarget op))) and
    (mS := evalForm(op,opName := getUnname op,argl,mmS)) =>
      putModeSet(op,mS)
  bottomUpForm0(t,op,opName,argl,argModeSetList)

bottomUpFormTuple(t, op, opName, args, argModeSetList) ==
  getAtree(op,'dollar) => NIL
  null (singles := getModemapsFromDatabase(opName, 1)) => NIL

  -- see if any of the modemaps have Tuple arguments
  haveTuple := false
  for mm in singles while not haveTuple repeat
    if getFirstArgTypeFromMm(mm) is ["Tuple",.] then haveTuple := true
  not haveTuple => nil
  nargs := #args
  nargs = 1 and getUnname first args = "Tuple" => NIL
  nargs = 1 and (ms := bottomUp first args) and
    (ms is [["Tuple",.]] or ms is [["List",.]]) => NIL

  -- now make the args into a tuple

  newArg := [mkAtreeNode "tuple",:args]
  bottomUp [op, newArg]

removeUnionsAtStart(argl,modeSets) ==
  null $genValue => modeSets
  for arg in argl for ms in modeSets repeat
    null (v := getValue arg) => nil
    m := objMode(v)
    m isnt ['Union,:.] => nil
    val := objVal(v)
    null isWrapped val => nil
    val' := retract v
    m' := objMode val'
    putValue(arg,val')
    putModeSet(arg,[m'])
    RPLACA(ms,m')
  modeSets

printableArgModeSetList() ==
  amsl := nil
  for a in reverse $origArgModeSetList repeat
    b := prefix2String first a
    if ATOM b then b := [b]
    amsl := ['%l,:b,:amsl]
  if amsl then amsl := rest amsl
  amsl

bottomUpForm0(t,op,opName,argl,argModeSetList) ==
  op0 := op
  opName0 := opName

  m := isType t =>
    bottomUpType(t, m)

  opName = 'copy and argModeSetList is [[['Record,:rargs]]] =>
    -- this is a hack until Records go through the normal
    -- modemap selection process
    rtype := ['Record,:rargs]
    code := optRECORDCOPY(['RECORDCOPY,getArgValue(CAR argl, rtype),#rargs])

    if $genValue then code := wrap timedEVALFUN code
    val := objNew(code,rtype)
    putValue(t,val)
    putModeSet(t,[rtype])

  m := getModeOrFirstModeSetIfThere op
  m is ['Record,:.] and argModeSetList is [[['Variable,x]]] and
      member(x,getUnionOrRecordTags m) and (u := bottomUpElt t) => u
  m is ['Union,:.] and argModeSetList is [[['Variable,x]]] =>
      member(x,getUnionOrRecordTags m) and (u := bottomUpElt t) => u
      not $genValue =>
        amsl := printableArgModeSetList()
        throwKeyedMsgSP("S2IB0008",['"the union object",amsl], op)
      object := retract getValue op
      object = 'failed =>
        throwKeyedMsgSP("S2IB0008",['"the union object",amsl], op)
      putModeSet(op,[objMode(object)])
      putValue(op,object)
      (u := bottomUpElt t) => u
      bottomUpForm0(t,op,opName,argl,argModeSetList)

  (opName ^= "elt") and (opName ^= "apply") and
    #argl = 1 and first first argModeSetList is ['Variable, var]
      and var in '(first last rest) and
        isEltable(op, argl, #argl) and (u := bottomUpElt t) => u

  $genValue and
    ( u:= bottomUpFormRetract(t,op,opName,argl,argModeSetList) ) => u

  (opName ^= "elt") and (opName ^= "apply") and
    isEltable(op, argl, #argl) and (u := bottomUpElt t) => u

  if FIXP $HTCompanionWindowID then
    mkCompanionPage('operationError, t)

  amsl := printableArgModeSetList()
  opName1 :=
    opName0 = $immediateDataSymbol =>
        (o := coerceInteractive(getValue op0,$OutputForm)) =>
            outputTran objValUnwrap o
        NIL
    opName0

  if null(opName1) then
    opName1 :=
        (o := getValue op0) => prefix2String objMode o
        '"<unknown type>"
    msgKey :=
        null amsl => "S2IB0013"
        "S2IB0012"
  else
    msgKey :=
        null amsl => "S2IB0011"
        (n := isSharpVarWithNum opName1) =>
            opName1 := n
            "S2IB0008g"
        "S2IB0008"

  sayIntelligentMessageAboutOpAvailability(opName1, #argl)

  not $genValue =>
    keyedMsgCompFailureSP(msgKey,[opName1, amsl], op0)
  throwKeyedMsgSP(msgKey,[opName1, amsl], op0)

sayIntelligentMessageAboutOpAvailability(opName, nArgs) ==
  -- see if we can give some decent messages about the availability if
  -- library messages

  NUMBERP opName => NIL

  oo :=  object2Identifier opOf opName
  if ( oo = "%" ) or ( oo = "Domain" ) or ( domainForm? opName ) then
    opName := "elt"

  nAllExposedMmsWithName := #getModemapsFromDatabase(opName, NIL)
  nAllMmsWithName        := #getAllModemapsFromDatabase(opName, NIL)

  -- first see if there are ANY ops with this name

  if nAllMmsWithName = 0 then
    sayKeyedMsg("S2IB0008a", [opName])
  else if nAllExposedMmsWithName = 0 then
    nAllMmsWithName = 1 => sayKeyedMsg("S2IB0008b", [opName])
    sayKeyedMsg("S2IB0008c", [opName, nAllMmsWithName])
  else
    -- now talk about specific arguments
    nAllExposedMmsWithNameAndArgs   := #getModemapsFromDatabase(opName, nArgs)
    nAllMmsWithNameAndArgs          := #getAllModemapsFromDatabase(opName, nArgs)
    nAllMmsWithNameAndArgs = 0 =>
        sayKeyedMsg("S2IB0008d", [opName, nArgs, nAllExposedMmsWithName, nAllMmsWithName - nAllExposedMmsWithName])
    nAllExposedMmsWithNameAndArgs = 0 =>
        sayKeyedMsg("S2IB0008e", [opName, nArgs, nAllMmsWithNameAndArgs - nAllExposedMmsWithNameAndArgs])
    sayKeyedMsg("S2IB0008f", [opName, nArgs, nAllExposedMmsWithNameAndArgs, nAllMmsWithNameAndArgs - nAllExposedMmsWithNameAndArgs])
  nil


++ Returns the `conceptual' type of `type', e.g., the type of type in
++ the abstract semantics, not necessarily the one from implementation
++ point of view.
conceptualType: %Thing -> %List
conceptualType type ==
  isPartialMode type => $Mode
  member(type,[$Mode,$Domain,$Category]) => $Type
  categoryForm?(type) => $Category
  $Domain

++ Returns true is `t' conceptually describes a domain or package.
isConceptualCategory: %Mode -> %Boolean
isConceptualCategory t ==
  t = $Type or t = $Category or t = $Domain or categoryForm? t

bottomUpType(t, type) ==
  mode := conceptualType type
  val:= objNew(type,mode)
  putValue(t,val)
  -- have to fix the following
  putModeSet(t,[mode])

bottomUpPercent(tree is [op,:argl]) ==
  -- handles a call %%(5), which means the output of step 5
  -- %%() is the same as %%(-1)
  null argl =>
    val:= fetchOutput(-1)
    putValue(op,val)
    putModeSet(op,[objMode(val)])
  argl is [t] =>
    i:= getArgValue(t,$Integer) =>
      val:= fetchOutput i
      putValue(op,val)
      putModeSet(op,[objMode(val)])
    throwKeyedMsgSP('"S2IB0006",NIL,t)
  throwKeyedMsgSP('"S2IB0006",NIL,op)

bottomUpFormRetract(t,op,opName,argl,amsl) ==
  -- tries to find one argument, which can be pulled back, and calls
  -- bottomUpForm again. We do not retract the first argument to a
  -- setelt, because this is presumably a destructive operation and
  -- the retract can create a new object.

  -- if no such operation exists in the database, don't bother
  $inRetract: local := true
  null getAllModemapsFromDatabase(getUnname op,#argl) => NIL

  u := bottomUpFormAnyUnionRetract(t,op,opName,argl,amsl) => u

  a  := NIL
  b  := NIL
  ms := NIL
  for x in argl for m in amsl for i in 1.. repeat
    -- do not retract first arg of a setelt
    (i = 1) and (opName = "setelt") =>
        a := [x,:a]
        ms := [m,:ms]
    (i = 1) and (opName = "set!") =>
        a := [x,:a]
        ms := [m,:ms]
    if PAIRP(m) and CAR(m) = $EmptyMode then return NIL
    object:= retract getValue x
    a:= [x,:a]
    EQ(object,'failed) =>
        putAtree(x,'retracted,nil)
        ms := [m, :ms]
    b:= true
    RPLACA(m,objMode(object))
    ms := [COPY_-TREE m, :ms]
    putAtree(x,'retracted,true)
    putValue(x,object)
    putModeSet(x,[objMode(object)])
  --insert pulled-back items
  a := nreverse a
  ms := nreverse ms

  -- check that we haven't seen these types before
  typesHad := getAtree(t, 'typesHad)
  if member(ms, typesHad) then b := nil
  else putAtree(t, 'typesHad, cons(ms, typesHad))

  b and bottomUpForm(t,op,opName,a,amsl)

retractAtree atr ==
    object:= retract getValue atr
    EQ(object,'failed) =>
        putAtree(atr,'retracted,nil)
        nil
    putAtree(atr,'retracted,true)
    putValue(atr,object)
    putModeSet(atr,[objMode(object)])
    true

bottomUpFormAnyUnionRetract(t,op,opName,argl,amsl) ==
  -- see if we have a Union

  ok := NIL
  for m in amsl while not ok repeat
    if atom first(m) then return NIL
    first m = $Any => ok := true
    (first first m = 'Union) => ok := true
  not ok => NIL

  a:= NIL
  b:= NIL

  for x in argl for m in amsl for i in 0.. repeat
    m0 := first m
    if ( (m0 = $Any) or (first m0 = 'Union) ) and
      ('failed^=(object:=retract getValue x)) then
        b := true
        RPLACA(m,objMode(object))
        putModeSet(x,[objMode(object)])
        putValue(x,object)
    a := cons(x,a)
  b and bottomUpForm(t,op,opName,nreverse a,amsl)

bottomUpFormUntaggedUnionRetract(t,op,opName,argl,amsl) ==
  -- see if we have a Union with no tags, if so retract all such guys

  ok := NIL
  for [m] in amsl while not ok repeat
    if atom m then return NIL
    if m is ['Union, :.] and null getUnionOrRecordTags m then ok := true
  not ok => NIL

  a:= NIL
  b:= NIL

  for x in argl for m in amsl for i in 0.. repeat
    m0 := first m
    if (m0 is ['Union, :.] and null getUnionOrRecordTags m0) and
      ('failed ^= (object:=retract getValue x)) then
        b := true
        RPLACA(m,objMode(object))
        putModeSet(x,[objMode(object)])
        putValue(x,object)
    a := cons(x,a)
  b and bottomUpForm(t,op,opName,nreverse a,amsl)

bottomUpElt (form:=[op,:argl]) ==
  -- this transfers expressions that look like function calls into
  -- forms with elt or apply.

    ms := bottomUp op
    ms and (ms is [['Union,:.]] or ms is [['Record,:.]]) =>
        RPLAC(CDR form, [op,:argl])
        RPLAC(CAR form, mkAtreeNode "elt")
        bottomUp form

    target  := getTarget form

    newOps := [mkAtreeNode "elt", mkAtreeNode "apply"]
    u := nil

    while ^u for newOp in newOps repeat
        newArgs := [op,:argl]
        if selectMms(newOp, newArgs, target) then
            RPLAC(CDR form, newArgs)
            RPLAC(CAR form, newOp)
            u := bottomUp form

    while ^u and ( "and"/[retractAtree(a) for a in newArgs] ) repeat
        while ^u for newOp in newOps repeat
            newArgs := [op,:argl]
            if selectMms(newOp, newArgs, target) then
                RPLAC(CDR form, newArgs)
                RPLAC(CAR form, newOp)
                u := bottomUp form
    u

isEltable(op,argl,numArgs) ==
  -- determines if the object might possible have an elt function
  -- we exclude Mapping and Variable types explicitly
  v := getValue op =>
    ZEROP numArgs => true
    not(m := objMode(v)) => nil
    m is ['Mapping, :.] => nil
    objVal(v) is ["%Map",:mapDef] and numMapArgs(mapDef) > 0 => nil
    true
  m := getMode op =>
    ZEROP numArgs => true
    m is ['Mapping, :.] => nil
    true
  numArgs ^= 1 => nil
  name := getUnname op
  name = 'SEQ => nil
--not (name in '(a e h s)) and getAllModemapsFromDatabase(name, nil) => nil
  arg := first argl
  (getUnname arg) ^= 'construct => nil
  true