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

-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
-- All rights reserved.
-- Copyright (C) 2007-2009, 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_-analy
namespace BOOT


-- Functions which require special handlers (also see end of file)

$specialOps := '(
  ADEF AlgExtension _and _case COERCE COLLECT construct Declare DEF Dollar
   equation error free has IF _is _isnt iterate _break %LET _local MDEF _or
    pretend QUOTE REDUCE REPEAT _return SEQ TARGET tuple typeOf _where 
     _[_|_|_] %Macro %MLambda %Import %Export %Inline %With %Add %Match)

$repeatLabel := NIL
$anonymousMapCounter := 0

++ List of free variables in the current function
$freeVariables := []

++ List of bound variables in the current function
$boundVariables := []

--% Void stuff

voidValue() == '"()"

--% Handlers for Anonymous Function Definitions

upADEF t ==
  t isnt [.,[vars,types,.,body],pred,.] => NIL
  -- do some checking on what we got
  for var in vars repeat
    if not IDENTP(var) then throwKeyedMsg("S2IS0057",[var])
  -- unabbreviate types
  types := [(if t then evaluateType unabbrev t else NIL) for t in types]
  -- we do not allow partial types
  if isPartialMode(m := first types) then throwKeyedMsg("S2IS0058",[m])

  -- we want everything to be declared or nothing. The exception is that
  -- we do not require a target type since we will compute one anyway.
  if null(m) and rest types then
    m := second types
    types' := rest rest types
  else
    types' := rest types
  for type in types' repeat
    if (type and null m) or (m and null type) then
      throwKeyedMsg("S2IS0059",NIL)
    if isPartialMode type  then throwKeyedMsg("S2IS0058",[type])

--  $localVars: local := nil
--  $freeVars:  local := nil
--  $env:       local := [[nil]]
  $compilingMap : local := true

  -- if there is a predicate, merge it in with the body
  if pred ~= true then body := ['IF,pred,body,'%noMapVal]

  tar := getTarget t
  null m and tar is ['Mapping,.,:argTypes] and (#vars = #argTypes) =>
    if isPartialMode tar then throwKeyedMsg("S2IS0058",[tar])
    evalTargetedADEF(t,vars,rest tar,body)
  null m => evalUntargetedADEF(t,vars,types,body)
  evalTargetedADEF(t,vars,types,body)

evalUntargetedADEF(t,vars,types,body) ==
  -- recreate a parse form
  if vars is [var]
    then vars := var
    else vars := ["tuple",:vars]
  val := objNewWrap(["+->",vars,body],$AnonymousFunction)
  putValue(t,val)
  putModeSet(t,[objMode val])

evalTargetedADEF(t,vars,types,body) ==
  $mapName : local := makeInternalMapName('"anonymousFunction",
    #vars,$anonymousMapCounter,'"internal")
  $anonymousMapCounter := 1 + $anonymousMapCounter
  $compilingMap   : local := true  -- state that we are trying to compile
  $mapThrowCount  : local := 0     -- number of "return"s encountered
  $mapReturnTypes : local := nil   -- list of types from returns
  $repeatLabel    : local := nil   -- for loops; see upREPEAT
  $breakCount     : local := 0     -- breaks from loops; ditto

  -- now substitute formal names for the parm variables
  -- this is used in the interpret-code case, but isn't so bad any way
  -- since it makes the bodies look more like regular map bodies

  sublist := [[var,:GENSYM()] for var in vars]
  body := sublisNQ(sublist,body)
  vars := [rest v for v in sublist]

  for m in rest types for var in vars repeat
    $env:= put(var,'mode,m,$env)
    mkLocalVar($mapName,var)
  for lvar in getLocalVars($mapName,body) repeat
    mkLocalVar($mapName,lvar)
  -- set up catch point for interpret-code mode
  x := CATCH('mapCompiler,compileTargetedADEF(t,vars,types,body))
  x = 'tryInterpOnly => mkInterpTargetedADEF(t,vars,types,body)
  x

mkInterpTargetedADEF(t,vars,types,oldBody) ==
  null first types =>
    throwKeyedMsg("S2IS0056",NIL)
    throwMessage '"   map result type needed but not present."
  arglCode := ["LIST",:[argCode for type in rest types for var in vars]]
    where argCode() == ['putValueValue,['mkAtreeNode,MKQ var],
      objNewCode(["wrap",var],type)]
  put($mapName,'mapBody,oldBody,$e)
  body := ['rewriteMap1,MKQ $mapName,arglCode,MKQ types]
  compileADEFBody(t,vars,types,body,first types)

compileTargetedADEF(t,vars,types,body) ==
  val := compileBody(body,first types)
  computedResultType := objMode val
  body := wrapMapBodyWithCatch flattenCOND objVal val
  compileADEFBody(t,vars,types,body,computedResultType)

compileADEFBody(t,vars,types,body,computedResultType) ==
--+
  $compiledOpNameList := [$mapName]
  minivectorName := makeInternalMapMinivectorName(PNAME $mapName)
  body := substitute(minivectorName,"$$$",body)
  setDynamicBinding(minivectorName,LIST2VEC $minivector)

  -- The use of the three variables $definingMap, $genValue and $compilingMap
  -- is to cover the following cases:
  --
  -- $definingMap: This is set in analyzeMap and covers examples like:
  --  addx x == ((y: Integer): Integer +-> x + y)
  --  g := addx 10
  --  g 3
  -- i.e. we are storing the mapping as an object.
  --
  -- $compilingMap: This covers mappings which are created and applied "on the
  -- "fly", for example:
  --  [map(h +-> D(h, t), v) for v in [t]]
  --
  -- $genValue: This seems to be needed when we create a map as an argument 
  -- for a constructor, e.g.:
  --  Dx: LODO(EXPR INT, f +-> D(f, x)) := D()
  --
  -- MCD 13/3/96
  parms := [:vars,"envArg"]
  if not $definingMap and ($genValue or $compilingMap) then
    fun := [$mapName,["LAMBDA",parms, 
                        declareGlobalVariables [minivectorName],
                          :declareUnusedParameters(parms,body)]]
    code :=  wrap compileInteractive fun
  else
    $freeVariables := []
    $boundVariables := [minivectorName,:vars]
    -- CCL does not support upwards funargs, so we check for any free variables
    -- and pass them into the lambda as part of envArg.
    body := checkForFreeVariables(body,"ALL")
    fun := ["function",["LAMBDA",parms,
                         :declareUnusedParameters(parms,body)]]
    code := ["CONS", fun, ["VECTOR", :reverse $freeVariables]]

  val := objNew(code,rt := ['Mapping,computedResultType,:rest types])
  putValue(t,val)
  putModeSet(t,[rt])

--% Handler for Algebraic Extensions

upAlgExtension t ==
  -- handler for algebraic extension declaration.  These are of
  --  the form "a | a**2+1", and have the effect that "a" is declared
  --  to be a simple algebraic extension, with respect to the given
  --  polynomial, and given the value "a" in this type.
  t isnt [op,var,eq] => nil
  null $genValue => throwKeyedMsg("S2IS0001",NIL)
  a := getUnname var
  clearCmdParts ['propert,a]  --clear properties of a
  algExtension:= eq2AlgExtension eq
  upmode := ['UnivariatePolynomial,a,$EmptyMode]
  $declaredMode : local := upmode
  putTarget(algExtension,upmode)
  ms:= bottomUp algExtension
  triple:= getValue algExtension
  upmode:= resolveTMOrCroak(objMode(triple),upmode)
  null (T:= coerceInteractive(triple,upmode)) =>
    throwKeyedMsgCannotCoerceWithValue(objVal(triple),
      objMode(triple),upmode)
  newmode := objMode T
  (field := resolveTCat(third newmode,'(Field))) or
    throwKeyedMsg("S2IS0002",[eq])
  pd:= ['UnivariatePolynomial,a,field]
  null (canonicalAE:= coerceInteractive(T,pd)) =>
    throwKeyedMsgCannotCoerceWithValue(objVal T,objMode T,pd)
  sae:= ['SimpleAlgebraicExtension,field,pd,objValUnwrap canonicalAE]
  saeTypeSynonym := INTERN STRCONC('"SAE",STRINGIMAGE a)
  saeTypeSynonymValue := objNew(sae,'(Domain))
  fun := getFunctionFromDomain('generator,sae,NIL)
  expr:= wrap SPADCALL(fun)
  putHist(saeTypeSynonym,'value,saeTypeSynonymValue,$e)
  putHist(a,'mode,sae,$e)
  putHist(a,'value,T2:= objNew(expr,sae),$e)
  clearDependencies(a,true)
  if $printTypeIfTrue then
    sayKeyedMsg("S2IS0003",NIL)
    sayMSG concat ['%l,'"   ",saeTypeSynonym,'" := ",
      :prefix2String objVal saeTypeSynonymValue]
    sayMSG concat ['"   ",a,'" : ",saeTypeSynonym,'" := ",a]
  putValue(op,T2)
  putModeSet(op,[sae])

eq2AlgExtension eq ==
  -- transforms "a=b" to a-b for processing
  eq is [op,:l] and VECP op and (getUnname op='equation) =>
    [mkAtreeNode "-",:l]
  eq

--% Handlers for booleans

upand x ==
  -- generates code for  and  forms. The second argument is only
  -- evaluated if the first argument is true.
  x isnt [op,term1,term2] => NIL
  putTarget(term1,$Boolean)
  putCallInfo(term1,"and",1,2)
  putTarget(term2,$Boolean)
  putCallInfo(term2,"and",2,2)
  ms := bottomUp term1
  ms isnt [=$Boolean] => nil   -- use general modemap
  $genValue =>
    -- ??? we should find a way to check whether the
    -- ??? the type of the second operand matters or not.
    not objValUnwrap(getValue term1) =>     -- first operand is `false'
        putValue(x,getValue term1)
        putModeSet(x,ms)
    -- first term is true, so look at the second one
    ms := bottomUp term2
    ms isnt [=$Boolean] => nil
    putValue(x,getValue term2)
    putModeSet(x,ms)

  ms := bottomUp term2
  ms isnt [=$Boolean] => nil  -- use general modemap
  -- generate an IF expression and let the rest of the code handle it
  -- ??? In full generality, this is still incorrect.  We should be
  -- ??? looking up modemaps to see whether the interpretation is
  -- ??? unique and the target type is Boolean before going on
  -- ??? generating LISP IF-expression. -- gdr 2008/01/14
  cond := [mkAtreeNode "=",mkAtree "false",term1]
  putTarget(cond,$Boolean)
  code := [mkAtreeNode "IF",cond,mkAtree "false",term2]
  putTarget(code,$Boolean)
  bottomUp code
  putValue(x,getValue code)
  putModeSet(x,ms)

upor x ==
  -- generates code for  or  forms. The second argument is only
  -- evaluated if the first argument is false.
  x isnt [op,term1,term2] => NIL
  putTarget(term1,$Boolean)
  putCallInfo(term1,"or",1,2)
  putTarget(term2,$Boolean)
  putCallInfo(term2,"or",2,2)
  ms := bottomUp term1
  ms isnt [=$Boolean] => nil
  $genValue =>
    objValUnwrap(getValue term1) =>  -- first operand is true, we are done.
        putValue(x,getValue term1)
        putModeSet(x,ms)
    -- first term is false, so look at the second one
    ms := bottomUp term2
    ms isnt [=$Boolean] => nil
    putValue(x,getValue term2)
    putModeSet(x,ms)

  ms := bottomUp term2
  ms isnt [=$Boolean] => nil
  -- generate an IF expression and let the rest of the code handle it
  cond := [mkAtreeNode "=",mkAtree "true",term1]
  putTarget(cond,$Boolean)
  -- ??? the following code generation is incorrect.  -- gdr
  code := [mkAtreeNode "IF",cond,mkAtree "true",term2]
  putTarget(code,$Boolean)
  bottomUp code
  putValue(x,getValue code)
  putModeSet(x,ms)

--% Handlers for case

++ subroutine of upcase. Handles the situation where `case' may
++ have been defined as a library function.  
++ `op', `lhs' are VATs; `rhs' is unevaluated.
userDefinedCase(t is [op, lhs, rhs]) ==
  -- We want to resolve the situation by general modemap selection.
  -- So, we want to let bottomUp (which called us through upcase)
  -- to continue the work.  The way we do that is to return `nil'.
  -- Therefore we need a VAT for `rhs' with sufficient information
  -- to prevent bottomUp from trying to evaluate `rhs'.
  putAtree(op, 'flagArgsPos, flagArguments("case",2))
  r := mkAtreeNode $immediateDataSymbol
  m := quasiquote rhs
  putMode(r, m)
  putValue(r, objNewWrap(MKQ rhs,m))
  putModeSet(r, [m])
  RPLACD(cdr t, [r])                   -- fix up contained for rhs.
  nil                                  -- tell bottomUp to continue.

upcase t ==
  t isnt [op,lhs,rhs] => nil
  putCallInfo(lhs,"case",1,2)
  bottomUp lhs
  triple := getValue lhs
  objMode(triple) isnt ['Union,:unionDoms] => userDefinedCase t
  if (rhs' := isDomainValuedVariable(rhs)) then rhs := rhs'
  if first unionDoms is [":",.,.] then
     for i in 0.. for d in unionDoms repeat
        if d is [":",=rhs,.] then rhstag := i
     if NULL rhstag then error '"upcase: bad Union form"
     $genValue =>
        rhstag = first unwrap objVal triple => code := wrap true
        code := wrap false
     code :=
        ["COND",
          [["EQL",rhstag,["CAR",["unwrap",objVal triple]]],
            true],
              [''T,false]]
  else
    $genValue =>
        t' := coerceUnion2Branch triple
        rhs = objMode t' => code := wrap true
        code := wrap false
    triple' := objNewCode(["wrap",objVal triple],objMode triple)
    code :=
        ["COND",
          [["EQUAL",MKQ rhs,["objMode",['coerceUnion2Branch,triple']]],
            true],
              [''T,false]]
  putValue(op,objNew(code,$Boolean))
  putModeSet(op,[$Boolean])

--% Handlers for TARGET

upTARGET t ==
  -- Evaluates the rhs to a mode,which is used as the target type for
  -- the lhs.
  t isnt [op,lhs,rhs] => nil
  -- do not (yet) support local variables on the rhs
  (not $genValue) and or/[CONTAINED(var,rhs) for var in $localVars] =>
    keyedMsgCompFailure("S2IC0010",[rhs])
  $declaredMode: local := NIL
  m:= evaluateType unabbrev rhs
  not isLegitimateMode(m,NIL,NIL) => throwKeyedMsg("S2IE0004",[m])
  categoryForm?(m) => throwKeyedMsg("S2IE0014",[m])
  $declaredMode:= m
  not atom(lhs) and putTarget(lhs,m)
  ms := bottomUp lhs
  first ms ~= m =>
    throwKeyedMsg("S2IC0011",[first ms,m])
  putValue(op,getValue lhs)
  putModeSet(op,ms)

--% Handlers for COERCE

upCOERCE t ==
  -- evaluate the lhs and then tries to coerce the result to the
  -- mode which is the rhs.
  -- previous to 5/16/89, this had the same semantics as
  --    (lhs@rhs) :: rhs
  -- this must be made explicit now.
  t isnt [op,lhs,rhs] => nil
  $useConvertForCoercions : local := true
  -- do not (yet) support local variables on the rhs
  (not $genValue) and or/[CONTAINED(var,rhs) for var in $localVars] =>
    keyedMsgCompFailure("S2IC0006",[rhs])
  $declaredMode: local := NIL
  m := evaluateType unabbrev rhs
  not isLegitimateMode(m,NIL,NIL) => throwKeyedMsg("S2IE0004",[m])
  categoryForm?(m) => throwKeyedMsg("S2IE0014",[m])
  $declaredMode:= m
  -- 05/16/89 (RSS) following line commented out to give correct
  -- semantic difference between :: and @
  bottomUp lhs
  type:=evalCOERCE(op,lhs,m)
  putModeSet(op,[type])

evalCOERCE(op,tree,m) ==
  -- the value of tree is coerced to mode m
  -- this is not necessary, if the target property of tree was used
  v  := getValue tree
  t1 := objMode(v)
  if $genValue and t1 is ['Union,:.] then
    v := coerceUnion2Branch v
    t1 := objMode(v)
  e  := objVal(v)
  value:=
    t1=m => v
    t2 :=
      if isPartialMode m
        then
          $genValue and (t1 = $Symbol) and containsPolynomial m =>
            resolveTM(['UnivariatePolynomial,objValUnwrap(v),$Integer],m)
          resolveTM(t1,m)
        else m
    null t2 => throwKeyedMsgCannotCoerceWithValue(e,t1,m)
    $genValue => coerceOrRetract(v,t2)
    objNew(getArgValue(tree,t2),t2)
  val:= value or throwKeyedMsgCannotCoerceWithValue(e,t1,m)
  putValue(op,val)
  objMode(val)

--% Handlers for COLLECT

upCOLLECT t ==
  -- $compilingLoop variable insures that throw to interp-only mode
  --   goes to the outermost loop.
  $compilingLoop => upCOLLECT1 t
  upCOLLECT0 t

upCOLLECT0 t ==
  -- sets up catch point for interpret-code mode
  $compilingLoop: local := true
  ms:=CATCH('loopCompiler,upCOLLECT1 t)
  ms = 'tryInterpOnly => interpOnlyCOLLECT t
  ms

upCOLLECT1 t ==
  t isnt [op,:itrl,body] => nil
  -- upCOLLECT with compiled body
  if (target := getTarget t) and not getTarget(body) then
    if target is [agg,S] and agg in '(List Vector Stream InfiniteTuple) then
      putTarget(body,S)
  $interpOnly => interpCOLLECT(op,itrl,body)
  isStreamCollect itrl => collectStream(t,op,itrl,body)
  upLoopIters itrl
  ms:= bottomUpCompile body
  [m]:= ms
  for itr in itrl repeat
    itr is ["UNTIL", pred] => bottomUpCompilePredicate(pred,'"until")
  mode:= ['Tuple,m]
  evalCOLLECT(op,rest t,mode)
  putModeSet(op,[mode])

upLoopIters itrl ==
  -- type analyze iterator loop iterators
  for iter in itrl repeat
    iter is ["WHILE",pred] =>
      bottomUpCompilePredicate(pred,'"while")
    iter is ["SUCHTHAT",pred] =>
      bottomUpCompilePredicate(pred,'"|")
    iter is ["UNTIL",:.] =>
      NIL      -- handle after body is analyzed
    iter is ["IN",index,s] =>
      upLoopIterIN(iter,index,s)
    iter is ["STEP",index,lower,step,:upperList] =>
      upLoopIterSTEP(index,lower,step,upperList)
      -- following is an optimization
      typeIsASmallInteger(get(index,'mode,$env)) =>
        RPLACA(iter,'ISTEP)
    -- at this point, the AST may already be badly corrupted,
    -- but better late than never.
    throwKeyedMsg("S2IS0061",nil)

upLoopIterIN(iter,index,s) ==
  iterMs := bottomUp s

  null IDENTP index =>  throwKeyedMsg("S2IS0005",[index])

  if $genValue and first iterMs is ['Union,:.] then
    v := coerceUnion2Branch getValue s
    m := objMode v
    putValue(s,v)
    putMode(s,m)
    iterMs := [m]
    putModeSet(s,iterMs)

  -- transform segment variable into STEP
  iterMs is [['Segment,.]] or iterMs is [['UniversalSegment,.]] =>
    lower := [mkAtreeNode 'lo,s]
    step := [mkAtreeNode 'incr, s]
    upperList :=
      CAAR(iterMs) = 'Segment => [[mkAtreeNode 'hi,s]]
      NIL
    upLoopIterSTEP(index,lower,step,upperList)
    newIter := ['STEP,index,lower,step,:upperList]
    RPLACA(iter,first newIter)
    RPLACD(iter,rest newIter)

  iterMs isnt [['List,ud]] => throwKeyedMsg("S2IS0006",[index])
  put(index,'mode,ud,$env)
  mkLocalVar('"the iterator expression",index)

upLoopIterSTEP(index,lower,step,upperList) ==
  null IDENTP index => throwKeyedMsg("S2IS0005",[index])
  ltype := IFCAR bottomUpUseSubdomain(lower)
  not (typeIsASmallInteger(ltype) or isEqualOrSubDomain(ltype,$Integer))=>
    throwKeyedMsg("S2IS0007",['"lower"])
  stype := IFCAR bottomUpUseSubdomain(step)
  not (typeIsASmallInteger(stype) or isEqualOrSubDomain(stype,$Integer))=>
    throwKeyedMsg("S2IS0008",NIL)
  types := [ltype]
  utype := nil
  for upper in upperList repeat
    utype := IFCAR bottomUpUseSubdomain(upper)
    not (typeIsASmallInteger(utype) or isEqualOrSubDomain(utype,$Integer))=>
      throwKeyedMsg("S2IS0007",['"upper"])
  if utype then types := [utype, :types]
  else types := [stype, :types]
  type := resolveTypeListAny REMDUP types
  put(index,'mode,type,$env)
  mkLocalVar('"the iterator expression",index)

evalCOLLECT(op,[:itrl,body],m) ==
  iters := [evalLoopIter itr for itr in itrl]
  bod := getArgValue(body,computedMode body)
  if bod isnt ['SPADCALL,:.] then bod := ['unwrap,bod]
  code := timedOptimization asTupleNewCode0(second m, ['COLLECT,:iters,bod])
  if $genValue then code := wrap timedEVALFUN code
  putValue(op,objNew(code,m))

falseFun(x) == nil

evalLoopIter itr ==
  -- generate code for loop iterator
  itr is ['STEP,index,lower,step,:upperList] =>
    ['STEP,getUnname index,getArgValue(lower,$Integer),
      getArgValue(step,$Integer),
        :[getArgValue(upper,$Integer) for upper in upperList]]
  itr is ['ISTEP,index,lower,step,:upperList] =>
    ['ISTEP,getUnname index,getArgValue(lower,$SmallInteger),
      getArgValue(step,$SmallInteger),
        :[getArgValue(upper,$SmallInteger) for upper in upperList]]
  itr is ['IN,index,s] =>
    ['IN,getUnname index,getArgValue(s,['List,get(index,'mode,$env)])]
  (itr is [x,pred]) and (x in '(WHILE UNTIL SUCHTHAT)) =>
    [x,getArgValue(pred,$Boolean)]

interpCOLLECT(op,itrl,body) ==
  -- interpret-code mode COLLECT handler
  $collectTypeList: local := NIL
  $indexVars: local := NIL
  $indexTypes: local := NIL
  emptyAtree op
  emptyAtree itrl
  emptyAtree body
  code := ['COLLECT,:[interpIter itr for itr in itrl],
    interpCOLLECTbody(body,$indexVars,$indexTypes)]
  value := timedEVALFUN code
  t :=
    null value => '(None)
    last $collectTypeList
  rm := ['Tuple,t]
  value := [objValUnwrap coerceInteractive(objNewWrap(v,m),t)
    for v in value for m in $collectTypeList]
  putValue(op,objNewWrap(asTupleNew(getVMType t, #value, value),rm))
  putModeSet(op,[rm])

interpIter itr ==
  -- interpret loop iterator
  itr is ['STEP,index,lower,step,:upperList] =>
    $indexVars:= [getUnname index,:$indexVars]
    [m]:= bottomUp lower
    $indexTypes:= [m,:$indexTypes]
    for up in upperList repeat bottomUp up
    ['STEP,getUnname index,getArgValue(lower,$Integer),
      getArgValue(step,$Integer),
        :[getArgValue(upper,$Integer) for upper in upperList]]
  itr is ['ISTEP,index,lower,step,:upperList] =>
    $indexVars:= [getUnname index,:$indexVars]
    [m]:= bottomUp lower
    $indexTypes:= [m,:$indexTypes]
    for up in upperList repeat bottomUp up
    ['ISTEP,getUnname index,getArgValue(lower,$SmallInteger),
      getArgValue(step,$SmallInteger),
        :[getArgValue(upper,$SmallInteger) for upper in upperList]]
  itr is ['IN,index,s] =>
    $indexVars:=[getUnname index,:$indexVars]
    [m]:= bottomUp s
    m isnt ['List,um] => throwKeyedMsg("S2IS0009",[m])
    $indexTypes:=[um,:$indexTypes]
    ['IN,getUnname index,getArgValue(s,m)]
  (itr is [x,pred]) and (x in '(WHILE UNTIL SUCHTHAT)) =>
    [x,interpLoop(pred,$indexVars,$indexTypes,$Boolean)]

interpOnlyCOLLECT t ==
  -- called when compilation failed in COLLECT body, not in compiling map
  $genValue: local := true
  $interpOnly: local := true
  upCOLLECT t

interpCOLLECTbody(expr,indexList,indexTypes) ==
  -- generate code for interpret-code collect
  ['interpCOLLECTbodyIter,MKQ expr,MKQ indexList,['LIST,:indexList],
    MKQ indexTypes]

interpCOLLECTbodyIter(exp,indexList,indexVals,indexTypes) ==
  -- execute interpret-code collect body.  keeps list of type of
  --  elements in list in $collectTypeList.
  emptyAtree exp
  for i in indexList for val in indexVals for type in indexTypes repeat
    put(i,'value,objNewWrap(val,type),$env)
  [m]:=bottomUp exp
  $collectTypeList:=
    null $collectTypeList => [rm:=m]
    [:$collectTypeList,rm:=resolveTT(m,last $collectTypeList)]
  null rm => throwKeyedMsg("S2IS0010",NIL)
  value:=
    rm ~= m => coerceInteractive(getValue exp,rm)
    getValue exp
  objValUnwrap(value)

--% Stream Collect functions

isStreamCollect itrl ==
  -- calls bottomUp on iterators and if any of them are streams
  -- then whole shebang is a stream
  isStream := false
  for itr in itrl until isStream repeat
    itr is ['IN,.,s] =>
      iterMs := bottomUp s
      iterMs is [['Stream,:.]] => isStream := true
      iterMs is [['InfiniteTuple,:.]] => isStream := true
      iterMs is [['UniversalSegment,:.]] => isStream := true
    itr is ['STEP,.,.,.] => isStream := true
  isStream

collectStream(t,op,itrl,body) ==
  v := CATCH('loopCompiler,collectStream1(t,op,itrl,body))
  v = 'tryInterpOnly => throwKeyedMsg("S2IS0011",NIL)
  v

collectStream1(t,op,itrl,body) ==
  $indexVars:local := NIL
  upStreamIters itrl
  if #$indexVars = 1 then mode:=collectOneStream(t,op,itrl,body)
  else mode:=collectSeveralStreams(t,op,itrl,body)
  putModeSet(op,[mode])

upStreamIters itrl ==
  -- type analyze stream collect loop iterators
  for iter in itrl repeat
    iter is ['IN,index,s] =>
      upStreamIterIN(iter,index,s)
    iter is ['STEP,index,lower,step,:upperList] =>
      upStreamIterSTEP(index,lower,step,upperList)

upStreamIterIN(iter,index,s) ==
  iterMs := bottomUp s

  -- transform segment variable into STEP
  iterMs is [['Segment,.]] or iterMs is [['UniversalSegment,.]] =>
    lower := [mkAtreeNode 'lo, s]
    step := [mkAtreeNode 'incr, s]
    upperList :=
      CAAR(iterMs) = 'Segment => [[mkAtreeNode 'hi,s]]
      NIL
    upStreamIterSTEP(index,lower,step,upperList)
    newIter := ['STEP,index,lower,step,:upperList]
    RPLACA(iter,first newIter)
    RPLACD(iter,rest newIter)

  (iterMs isnt [['List,ud]]) and (iterMs isnt [['Stream,ud]])
    and (iterMs isnt [['InfinitTuple, ud]]) =>
      throwKeyedMsg("S2IS0006",[index])
  put(index,'mode,ud,$env)
  mkLocalVar('"the iterator expression",index)
  s :=
    iterMs is [['List,ud],:.] =>
      form:=[mkAtreeNode 'pretend, [mkAtreeNode 'COERCE,s,['Stream,ud]],
             ['InfiniteTuple, ud]]
      bottomUp form
      form
    s
  $indexVars:= [[index,:s],:$indexVars]

upStreamIterSTEP(index,lower,step,upperList) ==
  null isEqualOrSubDomain(ltype := IFCAR bottomUpUseSubdomain(lower),
    $Integer) => throwKeyedMsg("S2IS0007",['"lower"])
  null isEqualOrSubDomain(stype := IFCAR bottomUpUseSubdomain(step),
    $Integer) => throwKeyedMsg("S2IS0008",NIL)
  for upper in upperList repeat
    null isEqualOrSubDomain(IFCAR bottomUpUseSubdomain(upper),
      $Integer) => throwKeyedMsg("S2IS0007",['"upper"])

  put(index,'mode,type := resolveTT(ltype,stype),$env)
  null type => throwKeyedMsg("S2IS0010", nil)
  mkLocalVar('"the iterator expression",index)

  s :=
    null upperList =>
      -- create the function that does the appropriate incrementing
      genFun := 'generate
      form := [mkAtreeNode genFun,
        [[mkAtreeNode 'Dollar, ['IncrementingMaps,type],
          mkAtreeNode 'incrementBy],step],lower]
      bottomUp form
      form
    form := [mkAtreeNode 'SEGMENT,lower,first upperList]
    putTarget(form,['Segment,type])
    form := [mkAtreeNode 'construct,form]
    putTarget(form,['List,['Segment,type]])
    form := [mkAtreeNode 'expand,form]
    putTarget(form,'(List (Integer)))
    form:=[mkAtreeNode 'pretend, [mkAtreeNode 'COERCE,form,['Stream,$Integer]],
           ['InfiniteTuple, $Integer]]
    bottomUp form
    form
  $indexVars:= [[index,:s],:$indexVars]

collectOneStream(t,op,itrl,body) ==
  -- build stream collect for case of iterating over a single stream
  --  In this case we don't need to build records
  form := mkAndApplyPredicates itrl
  bodyVec := mkIterFun(first $indexVars,body,$localVars)
  form := [mkAtreeNode 'map,bodyVec,form]
  bottomUp form
  val := getValue form
  m := objMode val
  m isnt ['Stream, ud] and m isnt ['InfiniteTuple, ud] =>
    systemError '"Not a Stream"
  newVal := objNew(objVal val, ['InfiniteTuple, ud])
  putValue(op,newVal)
  objMode newVal

mkAndApplyPredicates itrl ==
  -- for one index variable case for now.  may generalize later
  [indSet] := $indexVars
  [.,:s] := indSet
  for iter in itrl repeat
    iter is ['WHILE,pred] =>
      fun := 'filterWhile
      predVec := mkIterFun(indSet,pred,$localVars)
      s := [mkAtreeNode fun,predVec,s]
    iter is ['UNTIL,pred] =>
      fun := 'filterUntil
      predVec := mkIterFun(indSet,pred,$localVars)
      s := [mkAtreeNode fun,predVec,s]
    iter is ['SUCHTHAT,pred] =>
      fun := 'select
      putTarget(pred,$Boolean)
      predVec := mkIterFun(indSet,pred,$localVars)
      s := [mkAtreeNode fun,predVec,s]
  s

mkIterFun([index,:s],funBody,$localVars) ==
  -- transform funBody into a lambda with index as the parameter
  mode := objMode getValue s
  mode isnt ['Stream, indMode] and mode isnt ['InfiniteTuple, indMode] =>
    keyedSystemError('"S2GE0016", '("mkIterFun" "bad stream index type"))
  put(index,'mode,indMode,$env)
  mkLocalVar($mapName,index)
  [m]:=bottomUpCompile funBody
  mapMode := ['Mapping,m,indMode]
  $freeVariables := []
  $boundVariables := [index]
  -- CCL does not support upwards funargs, so we check for any free variables
  -- and pass them into the lambda as part of envArg.
  body := checkForFreeVariables(getValue funBody,$localVars)
  parms := [index,"envArg"]
  val:=['function,['LAMBDA,parms,:declareUnusedParameters(parms,objVal body)]]
  vec := mkAtreeNode GENSYM()
  putValue(vec,objNew(['CONS,val,["VECTOR",:reverse $freeVariables]],mapMode))
  vec

checkForFreeVariables(v,locals) ==
  -- v is the body of a lambda expression.  The list $boundVariables is all the
  -- bound variables, the parameter locals contains local variables which might
  -- be free, or the token ALL, which means that any parameter is a candidate
  -- to be free.
  NULL v => v
  SYMBOLP v =>
    v="$$$" => v -- Placeholder for mini-vector
    MEMQ(v,$boundVariables) => v
    p := POSITION(v,$freeVariables) =>
      ["getSimpleArrayEntry","envArg",positionInVec(p,#($freeVariables))]
    (locals = "ALL") or MEMQ(v,locals) =>
      $freeVariables := [v,:$freeVariables]
      ["getSimpleArrayEntry","envArg",positionInVec(0,#($freeVariables))]
    v
  LISTP v =>
    rest(LASTTAIL v) => -- Must be a better way to check for a genuine list?
      v
    [op,:args] := v
    LISTP op => 
      -- Might have a mode at the front of a list, or be calling a function
      -- which returns a function.
      [checkForFreeVariables(op,locals),:[checkForFreeVariables(a,locals) for a in args]]
    op = "LETT" => -- Expands to a SETQ.
      ["SETF",:[checkForFreeVariables(a,locals) for a in args]]
    op = "COLLECT" => -- Introduces a new bound variable?
      first(args) is ["STEP",var,:.] =>
       $boundVariables := [var,:$boundVariables]
       r := ["COLLECT",:[checkForFreeVariables(a,locals) for a in args]]
       $boundVariables := delete(var,$boundVariables)
       r
      ["COLLECT",:[checkForFreeVariables(a,locals) for a in args]]
    op = "REPEAT" => -- Introduces a new bound variable?
      first(args) is ["STEP",var,:.] =>
       $boundVariables := [var,:$boundVariables]
       r := ["REPEAT",:[checkForFreeVariables(a,locals) for a in args]]
       $boundVariables := delete(var,$boundVariables)
       r
      ["REPEAT",:[checkForFreeVariables(a,locals) for a in args]]
    op = "%LET" =>
      args is [var,form,name] =>
        -- This is some bizarre %LET, not what one would expect in Common Lisp!
        -- Treat var as a free variable, since it may be bound out of scope
        -- if we are in a lambda within another lambda.
        newvar := 
          p := POSITION(var,$freeVariables) =>
            ["getSimpleArrayEntry","envArg",positionInVec(p,#($freeVariables))]
          $freeVariables := [var,:$freeVariables]
          ["getSimpleArrayEntry","envArg",positionInVec(0,#($freeVariables))]
        ["SETF",newvar,checkForFreeVariables(form,locals)]
      error "Non-simple variable bindings are not currently supported"
    op = "PROG" =>
      error "Non-simple variable bindings are not currently supported"
    op = "LAMBDA" => v
    op = "QUOTE" => v
    op = "getValueFromEnvironment" => v
    [op,:[checkForFreeVariables(a,locals) for a in args]]
  v

positionInVec(p,l) ==
  -- We cons up the free list, but need to keep positions consistent so
  -- count from the end of the list.
  l-p-1

collectSeveralStreams(t,op,itrl,body) ==
  -- performs collects over several streams in parallel
  $index: local := nil
  [form,:zipType] := mkZipCode $indexVars
  form := mkAndApplyZippedPredicates(form,zipType,itrl)
  vec := mkIterZippedFun($indexVars,body,zipType,$localVars)
  form := [mkAtreeNode 'map, vec, form]
  bottomUp form
  val := getValue form
  m := objMode val
  m isnt ['Stream, ud] and m isnt ['InfiniteTuple, ud] =>
    systemError '"Not a Stream"
  newVal := objNew(objVal val, ['InfiniteTuple, ud])
  putValue(op,newVal)
  objMode newVal

mkZipCode indexList ==
  -- create interpreter form for turning a list of parallel streams
  -- into a stream of nested record types.  returns [form,:recordType]
  #indexList = 2 =>
    [[.,:s2],[.,:s1]] := indexList
    t1 := second objMode getValue s1
    t2 := second objMode getValue s2
    zipType := ['Record,['_:,'part1,t1], ['_:,'part2,t2] ]
    zipFun := [mkAtreeNode 'Dollar, ['MakeRecord,mkEvalable t1,
                                     mkEvalable t2],
               mkAtreeNode 'makeRecord]
    form := [mkAtreeNode 'map,zipFun,s1,s2]
    [form,:zipType]
  [form,:zipType] := mkZipCode rest indexList
  [[.,:s],:.] := indexList
  t := second objMode getValue s
  zipFun := [mkAtreeNode 'Dollar, ['MakeRecord,mkEvalable t,
                                   mkEvalable zipType],
             mkAtreeNode 'makeRecord]
  form := [mkAtreeNode 'map,zipFun,s,form]
  zipType := ['Record,['_:,'part1,t],['_:,'part2,zipType]]
  [form,:zipType]

mkAndApplyZippedPredicates (s,zipType,itrl) ==
  -- for one index variable case for now.  may generalize later
  for iter in itrl repeat
    iter is ['WHILE,pred] =>
      predVec := mkIterZippedFun($indexVars,pred,zipType,$localVars)
      s := [mkAtreeNode 'swhile,predVec,s]
    iter is ['UNTIL,pred] =>
      predVec := mkIterZippedFun($indexVars,pred,zipType,$localVars)
      s := [mkAtreeNode 'suntil,predVec,s]
    iter is ['SUCHTHAT,pred] =>
      putTarget(pred,$Boolean)
      predVec := mkIterZippedFun($indexVars,pred,zipType,$localVars)
      s := [mkAtreeNode 'select,predVec,s]
  s

mkIterZippedFun(indexList,funBody,zipType,$localVars) ==
  -- transform funBody into a lamda with $index as the parameter
  numVars:= #indexList
  for [var,:.] in indexList repeat
    funBody := subVecNodes(mkIterVarSub(var,numVars),var,funBody)
  put($index,'mode,zipType,$env)
  mkLocalVar($mapName,$index)
  [m]:=bottomUpCompile funBody
  mapMode := ['Mapping,m,zipType]
  $freeVariables := []
  $boundVariables := [$index]
  -- CCL does not support upwards funargs, so we check for any free variables
  -- and pass them into the lambda as part of envArg.
  body :=
   [checkForFreeVariables(form,$localVars) for form in getValue funBody]
  parms := [$index,'envArg]
  val:=['function,['LAMBDA,parms,:declareUnusedParameters(parms,objVal body)]]
  vec := mkAtreeNode GENSYM()
  putValue(vec,objNew(['CONS,val,["VECTOR",:reverse $freeVariables]],mapMode))
  vec

subVecNodes(new,old,form) ==
  ATOM form =>
    (VECP form) and (form.0 = old) => new
    form
  [subVecNodes(new,old,first form), :subVecNodes(new,old,rest form)]

mkIterVarSub(var,numVars) ==
  n := iterVarPos var
  n=2 =>
    [mkAtreeNode "elt",mkNestedElts(numVars-2),mkAtreeNode 'part2]
  n=1 =>
    [mkAtreeNode "elt",mkNestedElts(numVars-2),mkAtreeNode 'part1]
  [mkAtreeNode "elt",mkNestedElts(numVars-n),mkAtreeNode 'part1]

iterVarPos var ==
  for [index,:.] in reverse $indexVars for i in 1.. repeat
    index=var => return(i)

mkNestedElts n ==
  n=0 => mkAtreeNode($index or ($index:= GENSYM()))
  [mkAtreeNode "elt", mkNestedElts(n-1), mkAtreeNode 'part2]

--% Handlers for construct

upconstruct t ==
  --Computes the common mode set of the construct by resolving across
  --the argument list, and evaluating
  t isnt [op,:l] => nil
  dol := getAtree(op,'dollar)
  tar := getTarget(op) or dol
  null l => upNullList(op,l,tar)
  tar is ['Record,:types] => upRecordConstruct(op,l,tar)
  isTaggedUnion tar => upTaggedUnionConstruct(op,l,tar)
  aggs := '(List)
  if tar and CONSP(tar) and not isPartialMode(tar) then
    first(tar) in aggs =>
      ud :=
        (l is [[realOp, :.]]) and (getUnname(realOp) = 'COLLECT) => tar
        second tar
      for x in l repeat if not getTarget(x) then putTarget(x,ud)
    first(tar) in '(Matrix SquareMatrix RectangularMatrix) =>
      vec := ['List,underDomainOf tar]
      for x in l repeat if not getTarget(x) then putTarget(x,vec)
  nargs := #l
  argModeSetList:= [bottomUp putCallInfo(x,"construct",i,nargs)
                      for x in l for i in 1..]
  dol and dol is [topType,:.] and not (topType in aggs) =>
    (mmS:= selectMms(op,l,tar)) and (mS:= evalForm(op,getUnname op,l,mmS)) =>
      putModeSet(op,mS)
    NIL
  (tar and tar is [topType,:.] and not (topType in aggs)) and
    (mmS:= modemapsHavingTarget(selectMms(op,l,tar),tar)) and
        (mS:= evalForm(op,getUnname op,l,mmS)) =>
          putModeSet(op,mS)
  eltTypes := replaceSymbols([first x for x in argModeSetList],l)
  eltTypes is [['Tuple, td]] =>
    mode := ['List, td]
    evalTupleConstruct(op, l, mode, tar)
  eltTypes is [['InfiniteTuple, td]] =>
    mode := ['Stream, td]
    evalInfiniteTupleConstruct(op, l, mode, tar)
  if not isPartialMode(tar) and tar is ['List,ud] then
    mode := ['List, resolveTypeListAny cons(ud,eltTypes)]
  else mode := ['List, resolveTypeListAny eltTypes]
  if isPartialMode tar then tar:=resolveTM(mode,tar)
  evalconstruct(op,l,mode,tar)

modemapsHavingTarget(mmS,target) ==
  -- returns those modemaps have the signature result matching the
  -- given target
  [mm for mm in mmS | ([[.,res,:.],:.] := mm) and res = target]

evalTupleConstruct(op,l,m,tar) ==
  ['List, ud] := m
  code := ['APPEND,
    :([["asTupleAsList", getArgValueOrThrow(x,['Tuple, ud])] for x in l])]
  val :=
    $genValue => objNewWrap(timedEVALFUN code,m)
    objNew(code,m)

  (val1 := coerceInteractive(val,tar or m)) =>
    putValue(op,val1)
    putModeSet(op,[tar or m])
  putValue(op,val)
  putModeSet(op,[m])

evalInfiniteTupleConstruct(op,l,m,tar) ==
  ['Stream, ud] := m
  code := first [(getArgValue(x,['InfiniteTuple, ud]) or
    throwKeyedMsg("S2IC0007",[['InifinteTuple, ud]])) for x in l]
  val :=
    $genValue => objNewWrap(timedEVALFUN code,m)
    objNew(code,m)
  if tar then val1 := coerceInteractive(val,tar) else val1 := val

  val1 =>
    putValue(op,val1)
    putModeSet(op,[tar or m])
  putValue(op,val)
  putModeSet(op,[m])

evalconstruct(op,l,m,tar) ==
  [agg,:.,underMode]:= m
  code := ['LIST, :(argCode:=[(getArgValue(x,underMode) or
    throwKeyedMsg("S2IC0007",[underMode])) for x in l])]
  val :=
    $genValue => objNewWrap(timedEVALFUN code,m)
    objNew(code,m)
  if tar then val1 := coerceInteractive(val,tar) else val1 := val

  val1 =>
    putValue(op,val1)
    putModeSet(op,[tar or m])
  putValue(op,val)
  putModeSet(op,[m])

replaceSymbols(modeList,l) ==
  -- replaces symbol types with their corresponding polynomial types
  --  if not all type are symbols
  not member($Symbol,modeList) => modeList
  modeList is [a,:b] and and/[a=x for x in b] => modeList
  [if m=$Symbol then getMinimalVarMode(objValUnwrap(getValue arg),
    $declaredMode) else m for m in modeList for arg in l]

upNullList(op,l,tar) ==
  -- handler for [] (empty list)
  defMode :=
    tar and tar is [a,b] and (a in '(Stream Vector List)) and
      not isPartialMode(b) => ['List,b]
    '(List (None))
  val := objNewWrap(NIL,defMode)
  tar and not isPartialMode(tar) =>
    null (val' := coerceInteractive(val,tar)) =>
      throwKeyedMsg("S2IS0013",[tar])
    putValue(op,val')
    putModeSet(op,[tar])
  putValue(op,val)
  putModeSet(op,[defMode])

upTaggedUnionConstruct(op,l,tar) ==
  -- special handler for tagged union constructors
  tar isnt [.,:types] => nil
  #l ~= 1 => throwKeyedMsg("S2IS0051",[#l,tar])
  bottomUp first l
  obj := getValue first l
  (code := coerceInteractive(getValue first l,tar)) or
    throwKeyedMsgCannotCoerceWithValue(objVal obj, objMode obj,tar)
  putValue(op,code)
  putModeSet(op,[tar])

upRecordConstruct(op,l,tar) ==
  -- special handler for record constructors
  tar isnt [.,:types] => nil
  argModes := nil
  for arg in l repeat bottomUp arg
  argCode :=
    [(getArgValue(arg,type) or throwKeyedMsgCannotCoerceWithValue(
      objVal getValue arg,objMode getValue arg,type))
        for arg in l for ['_:,.,type] in types]
  len := #l
  code :=
    (len = 1) => ["CONS", :argCode, '()]
    (len = 2) => ["CONS",:argCode]
    ['VECTOR,:argCode]
  if $genValue then code :=  wrap timedEVALFUN code
  putValue(op,objNew(code,tar))
  putModeSet(op,[tar])

--% Handlers for declarations

upDeclare t ==
  t isnt  [op,lhs,rhs] => nil
  (not $genValue) and or/[CONTAINED(var,rhs) for var in $localVars] =>
    keyedMsgCompFailure("S2IS0014",[lhs])
  mode := evaluateType unabbrev rhs
  mode = $Void => throwKeyedMsgSP("S2IS0015",NIL,op)
  not isLegitimateMode(mode,nil,nil) => throwKeyedMsgSP("S2IE0004",[mode],op)
  categoryForm?(mode) => throwKeyedMsgSP("S2IE0011",[mode, 'category],op)
  packageForm?(mode) => throwKeyedMsgSP("S2IE0011",[mode, 'package],op)
  getAtree(op,"callingFunction") =>
    -- This isn't a real declaration, rather a field specification.
    not IDENTP lhs => throwKeyedMsg("S2IE0020",nil)
    -- ??? When we come to support field spec as type, change this.
    putValue(op,objNewWrap([":",lhs,mode],mode))
    putModeSet(op,[mode])
  junk :=
    lhs is ["free",["tuple",:vars]] or lhs is ['free,['LISTOF,:vars]] or
      lhs is ["free",:vars] =>
        for var in vars repeat declare(["free",var],mode)
    lhs is ["local",["tuple",:vars]] or lhs is ["local",['LISTOF,:vars]] or
      lhs is ["local",:vars] =>
        for var in vars repeat declare(["local",var],mode)
    lhs is ["tuple",:vars] or lhs is ["LISTOF",:vars] =>
      for var in vars repeat declare(var,mode)
    declare(lhs,mode)
  putValue(op,objNewWrap(voidValue(), $Void))
  putModeSet(op,[$Void])

declare(var,mode) ==
  -- performs declaration.
  -- 10/31/89: no longer coerces value to new declared type
  if var is ['local,v] then
    uplocalWithType(v,mode)
    var := v
  if var is ['free,v] then
    upfreeWithType(v,mode)
    var := v
  validateVariableNameOrElse var
  if get(var,'isInterpreterFunction,$e) then
    mode isnt ['Mapping,.,:args] =>
      throwKeyedMsg("S2IS0017",[var,mode])
    -- validate that the new declaration has the defined # of args
    mapval := objVal get(var,'value,$e)
    -- mapval looks like '(%Map (args . defn))
    margs := CAADR mapval
    -- if one args, margs is not a pair, just #1 or NIL
    -- otherwise it looks like (tuple #1 #2 ...)
    nargs :=
      null margs => 0
      CONSP margs => -1 + #margs
      1
    nargs ~= #args => throwKeyedMsg("S2IM0008",[var])
  if $compilingMap then mkLocalVar($mapName,var)
  else clearDependencies(var,true)
  isLocalVar(var) => put(var,'mode,mode,$env)
  mode is ['Mapping,:.] => declareMap(var,mode)
  v := get(var,'value,$e) =>
    -- only allow this if either
    --   - value already has given type
    --   - new mode is same as old declared mode
    objMode(v) = mode => putHist(var,'mode,mode,$e)
    mode = get(var,'mode,$e) => NIL   -- nothing to do
    throwKeyedMsg("S2IS0052",[var,mode])
  putHist(var,'mode,mode,$e)

declareMap(var,mode) ==
  -- declare a Mapping property
  (v:=get(var,'value,$e)) and objVal(v) isnt ["%Map",:.] =>
    throwKeyedMsg("S2IS0019",[var])
  isPartialMode mode => throwKeyedMsg("S2IM0004",NIL)
  putHist(var,'mode,mode,$e)

getAndEvalConstructorArgument tree ==
  triple := getValue tree
  objMode triple = '(Domain) => triple
  isWrapped objVal(triple) => triple
  isLocalVar objVal triple => compFailure('"   Local variable or parameter used in type")
  objNewWrap(timedEVALFUN objVal(triple), objMode(triple))

replaceSharps(x,d) ==
  -- replaces all sharps in x by the arguments of domain d
  -- all replaces the triangle variables
  SL:= NIL
  for e in rest d for var in $FormalMapVariableList repeat
    SL:= CONS(CONS(var,e),SL)
  x := subCopy(x,SL)
  SL:= NIL
  for e in rest d for var in $TriangleVariableList repeat
    SL:= CONS(CONS(var,e),SL)
  subCopy(x,SL)

isDomainValuedVariable form ==
  -- returns the value of form if form is a variable with a type value
  IDENTP form and (val := (
    get(form,'value,$InteractiveFrame) or _
    (CONSP($env) and get(form,'value,$env)) or _
    (CONSP($e) and get(form,'value,$e)))) and
      (member(m := objMode(val),'((Domain) (Category)))
          or conceptualType m = $Category) =>
        objValUnwrap(val)
  nil


++ returns true if category form `c1' implies category form `c2'.
++ Both are assumed to be definite categories, i.e. they contain
++ no variables.
categoryImplies(c1,c2) ==
  c2 = $Type => true
  c1 is ["Join",:cats] =>  
    or/[categoryImplies(c,c2) for c in cats] => true
  c1 = c2
  -- ??? Should also check conditional definition and
  -- ??? possibly attributes

++ returns true if domain `d' satisfies category `c'.
evalCategory(d,c) ==
  -- tests whether domain d has category c
  isPartialMode d => true            -- maybe too generous
  -- If this is a local variable then, its declared type 
  -- must imply category `c' satisfaction.
  IDENTP d and (m := getmode(d,$env)) => categoryImplies(m,c)
  ofCategory(d,c)

isOkInterpMode m ==
  isPartialMode(m) => isLegitimateMode(m,nil,nil)
  isValidType(m) and isLegitimateMode(m,nil,nil)

isLegitimateRecordOrTaggedUnion u ==
  and/[x is [":",.,d] and isLegitimateMode(d,nil,nil) for x in u]

isPolynomialMode m ==
  -- If m is a polynomial type this function returns a list of its
  --  variables, and nil otherwise
  m is [op,a,:rargs] =>
    a := removeQuote a
    op in '(Polynomial RationalFunction AlgebraicFunction Expression
      ElementaryFunction LiouvillianFunction FunctionalExpression
        CombinatorialFunction) => 'all
    op = 'UnivariatePolynomial => LIST a
    op = 'Variable       => LIST a
    op in '(MultivariatePolynomial DistributedMultivariatePolynomial
      HomogeneousDistributedMultivariatePolynomial) => a
    NIL
  NIL

containsPolynomial m ==
  atom m => NIL
  [d,:.] := m
  d in $univariateDomains or d in $multivariateDomains or
    d in '(Polynomial RationalFunction) => true
  (m' := underDomainOf m) and containsPolynomial m'

containsVariables m ==
  atom m => NIL
  [d,:.] := m
  d in $univariateDomains or d in $multivariateDomains => true
  (m' := underDomainOf m) and containsVariables m'

listOfDuplicates l ==
  l is [x,:l'] =>
    x in l' => [x,:listOfDuplicates deleteAll(x,l')]
    listOfDuplicates l'

-- The following function removes all occurrences of x from the list l

deleteAll(x,l) ==
  null l => nil
  x = first(l) => deleteAll(x,rest l)
  [first l,:deleteAll(x,rest l)]