path: root/src/interp/c-util.boot

-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
-- All rights reserved.
-- Copyright (C) 2007-2015, 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 g_-util
import g_-opt
namespace BOOT

module c_-util where
  makeWorkerName: %Symbol -> %Symbol
  clearReplacement: %Symbol -> %Thing
  replaceSimpleFunctions: %Form -> %Form
  foldExportedFunctionReferences: (%Database,%List %Code) -> %List %Code
  diagnoseUnknownType: (%Mode,%Env) -> %Form
  declareUnusedParameters: %Code -> %Code
  registerFunctionReplacement: (%Database,%Symbol,%Form) -> %Thing
  getSuccessEnvironment: (%Form,%Env) -> %Env
  getInverseEnvironment: (%Form,%Env) -> %Env
  giveVariableSomeValue: (%Symbol,%Mode,%Env) -> %Env
  registerConstructor: (%Symbol,%Env) -> %Env
  currentDB: %Env -> %Maybe %Database
  -- functor data manipulation
  dbInfovec: %Symbol -> %Maybe %FunctorData

--% Accessors of domain and category objects

++ Return thr i-th part of a category object
macro categoryRef(c,i) ==
  vectorRef(c,i)

++ Return the i-th part of a domain object.
macro domainRef(d,i) ==
  vectorRef(d,i)

++ Return the canonical form for a domain or category object
macro canonicalForm d ==
  vectorRef(d,0)

++ Return the constructor that instantiates to the domain
++ or category object
macro instantiationCtor d ==
  canonicalForm(d).op

++ Return the canonical forms of the arguments used to instantiate
++ a domain or a category object.
macro instantiationArgs d ==
  canonicalForm(d).args

++ Return the number of arguments used to instantiate a domain object.  
macro instantiationArity d ==
  # instantiationArgs d

++ Return the list of operations exported by a category object
macro categoryExports d ==
  categoryRef(d,1)

++ Return the attribute alist of a category object.
macro categoryAttributes d ==
  categoryRef(d,2)

++ Return a 3-list of data describing the hierarchy of category `c'.
macro categoryAssociatedTypes c ==
  categoryRef(c,4)

++ Return the list of principal ancestors of category `c'.  
macro categoryPrincipals c ==
  first categoryAssociatedTypes c

++ Return the list of [ancestor,predicate,index] data of catagory `c',
++ where `ancestor' is a fundamental ancestor, `index' its sequence number.
macro categoryAncestors c ==
  second categoryAssociatedTypes c

macro categoryLocals c ==
  third categoryAssociatedTypes c

macro categoryParameters c ==
  categoryRef(c,5)

++ Reference a 3-list
++   [lookupFunction,thisDomain,optable]
++ necessary for function lookup in a domain:
macro domainDirectory d ==
  domainRef(d,1)

++ Reference the lookup function of a domain object
macro domainLookupFunction d ==
  first domainDirectory d
  
++ Reference the operator-code table of a domain object.  
macro domainOperatorTable d ==
  third domainDirectory d

++ Reference the list of (attribute, predIndex) pairs for this domain.
macro domainAttributes d ==
  domainRef(d,2)
  
++ Return the predicate values associated with the domain object.
++ This is an integer interpreted as bit vector
macro domainPredicates d ==
  domainRef(d,3)

++ Return a 3-element dotted list of address data for a domain.
macro domainData d ==
  domainRef(d,4)

--%  
structure %CompilationData ==
  Record(subst: %Substitution,idata: %Substitution,bytes: List %Fixnum,
    shell: %Vector %Thing, items: %Buffer %Pair(%SourceEntity,%Code),
      lib: %Libstream,outpath: %Pathname) with
        cdSubstitution == (.subst)
        cdImplicits == (.idata)
        cdBytes == (.bytes)
        cdShell == (.shell)
        cdItems == (.items)
        cdLib == (.lib)
        cdOutput == (.outpath)

++ Make a fresh compilation data structure.
makeCompilationData() ==
  mk%CompilationData(nil,nil,nil,nil,[nil,:0],nil,nil)

++ Subsitution that replaces parameters with formals.
macro dbFormalSubst db ==
  cdSubstitution dbCompilerData db

++ Return source-level parameters of this constructor.
dbParameters db ==
  dbConstructorForm(db).args

++ Return implicit parameter data associated to `db'.  This
++ information is active only during the elaboration of the
++ constructor associated with `db'.
macro dbImplicitData db ==
  cdImplicits dbCompilerData db

++ Return the list of encoding bytes for a function during elaboration.
++ Transcient data.
macro dbByteList db ==
  cdBytes dbCompilerData db

++ Return the domain shell of the category object (or the category object
++ of the domain) being elaborated.
macro dbDomainShell db ==
  cdShell dbCompilerData db

++ Return a buffer of entities referenced during elaboration
++ of current functor.
macro dbEntityBuffer db ==
  cdItems dbCompilerData db

++ List (in reverse order) of used entities during elaboration of
++ current functor.
macro dbUsedEntities db ==
  first dbEntityBuffer db

++ Number of used entities during elaboration of current functor.
macro dbEntityCount db ==
  rest dbEntityBuffer db

macro dbLibstream db ==
  cdLib dbCompilerData db

macro dbCodeStream db ==
  libCodeStream dbLibstream db

macro dbInsnStream db ==
  libInsnStream dbLibstream db

macro dbOutputPath db ==
  cdOutput dbCompilerData db

++ Return the existential substitution of `db'.
dbQuerySubst db ==
  x := dbImplicitData db => first x
  nil

++ List of implicit parameters to the constructor.
dbImplicitParameters db ==
  ASSOCLEFT dbQuerySubst db

dbImplicitConstraints db ==
  x := dbImplicitData db => second x

++ Apply the formal substitution or `db'to the form `x'.
macro dbSubstituteFormals(db,x) ==
  applySubst(dbFormalSubst db,x)

++ Apply the query substitution of `db' to the form `x'.  
macro dbSubstituteQueries(db,x) ==
  applySubst(dbQuerySubst db,x)

++ Apply both query and formal variable substitutions of `db' to `x'.
dbSubstituteAllQuantified(db,x) ==
  applySubst([:dbQuerySubst db,:dbFormalSubst db],x)

--%
$SetCategory ==
  '(SetCategory)
  
--%

dbInfovec name ==
  getConstructorKindFromDB name is "category" => nil
  loadLibIfNotLoaded(name)
  u := property(name,'infovec) => u
  nil

++ Access to the shell template  associated with an infovec.
macro ivDomainShell iv ==
  first iv

++ Access to the operation table associated with an infovec.
macro ivOptable iv ==
  second iv

++ Access the alist mapping an attribute to the predicate index
++ associated with an infovec.
macro ivAttributePredicateIndexDirectory iv ==
  third iv

++ Access to additional data in the infovec
macro ivAdditionalData iv ==
  fourth iv

++ Access to predicate bitvector as associated with an infovec.
macro ivPredicateBitvector iv ==
  first ivAdditionalData iv

++ Access to the vector of category default package functors
++ associated with an infovec.
macro ivCategoryDefaults iv ==
  second ivAdditionalData iv

++ Access to the principal ancestors of a domain shell associated
++ with an infovec.
macro ivPrincipalAncestors iv ==
  third ivAdditionalData iv

++ Return the exported operation descriptors bytecode vector
++ associated with an infovec.
ivExportBytecodes iv ==
  [.,.,.,:vec] := ivAdditionalData iv
  vec

--% 

++ Token to indicate that a function body should be ignored.
$ClearBodyToken ==
  KEYWORD::OpenAxiomClearBodyToken

++
$ConstructorCache := hashTable 'EQ

++
$instantRecord := hashTable 'EQ


++ if true continue compiling after errors
$scanIfTrue := false


++ If within a loop, which kind? (list comprehension or plain old loop)
$loopKind := nil

++ If within a loop, the program point for the start of the body.
$repeatBodyLabel := nil

++ The number of occurrance of `iterate' in a (plain old) loop.
$iterateCount := nil

++ The number of occurrance of `break' in a (plain old) loop.
$breakCount := 0


+++ If non nil, holds compiled value of 'Rep' of the current domain.
$Representation := nil


$formalArgList := []

++ The formal body of the category being currently compiled.
$currentCategoryBody := nil

$compErrorMessageStack := nil

--% Optimization control

++ true if we have to proclaim function signatures in the generated Lisp.
$optProclaim := false

++ true if we have to inline simple functions before codegen.
$optReplaceSimpleFunctions := false

++ true if we have to resolve references to exported operations.
$optExportedFunctionReference := false

--%

++ Quote form, if not a basic value.
quoteMinimally form ==
  integer? form or string? form or form = nil or form = true => form
  quote form

++ If using old `Rep' definition semantics, return `$' when m is `Rep'.
++ Otherwise, return `m'.
dollarIfRepHack m ==
  m = "Rep" and $useRepresentationHack => "$"
  m

++ The inverse of the above.
RepIfRepHack m ==
  m = "$" and $useRepresentationHack => "Rep"
  m

++ If using old `Rep' definition semantics, return `$' is m is `Rep'.
-- ??? Eventually this and the above should be merged and/or removed.
substituteDollarIfRepHack m ==
  $useRepresentationHack => substitute("$","Rep",m)
  m

++ Return the triple for the representation domain for the
++ current functor, if any.
getRepresentation: %Env -> %Maybe %Mode
getRepresentation e ==
  u := get('Rep,'value,e) => u.expr
  get('Rep,"macro",e)


++ Returns true if the form `t' is an instance of the Tuple constructor.
isTupleInstance: %Form -> %Boolean
isTupleInstance t ==
  t is ["Tuple",.]

++ Returns true if the signature `sig' describes a function that can
++ accept a homogeneous variable length argument list.
isHomoegenousVarargSignature: %Sig -> %Boolean
isHomoegenousVarargSignature sig ==
  #sig = 1 and isTupleInstance first sig

++ Returns true if the arguments list `args' match in shape the
++ parameter type list `sig'.  This means that either the number
++ of arguments is exactly the number of parameters, or that the
++ signature describes a homogeneous vararg operation.
enoughArguments: (%List %Form,%Sig) -> %Boolean
enoughArguments(args,sig) ==
  #args = #sig or isHomoegenousVarargSignature sig

++ Returns true if the operation described by the signature `sig'
++ wants its arguments as a Tuple object.
wantArgumentsAsTuple: (%List %Form,%Sig) -> %Boolean
wantArgumentsAsTuple(args,sig) ==
  isHomoegenousVarargSignature sig and #args ~= #sig

abstractionOperator? x ==
  symbol? x and symbolMember?(x,$AbstractionOperator)

++ We are about to seal the (Lisp) definition of a function.
++ Augment the body of any function definition in the form `x'
++ with declarations for unused parameters.
++ that are unused.
declareUnusedParameters x == (augment x; x) where
  augment x == 
    atomic? x => nil
    x is [op,parms,body] and abstractionOperator? op =>
      augment body
      unused := [p for p in parms | not usesVariable?(body,p)]
      null unused => [body]
      x.rest.rest := [["DECLARE",["IGNORE",:unused]],body]
    for x' in x repeat
      augment x'

devaluate d ==
  not vector? d => d
  categoryObject? d => canonicalForm d
  #d > 0 =>
    d' := canonicalForm d
    isFunctor d' => d'
    d
  d
 
devaluateList l == [devaluate d for d in l]
 
devaluateDeeply x ==
  vector? x => devaluate x
  x isnt [.,:.] => x
  [devaluateDeeply y for y in x]

--% Debugging Functions
 
--CONTINUE() == continue()
continue() == FIN comp($x,$m,$f)
 
LEVEL(:l) == apply('level,l)
level(:l) ==
  null l => same()
  l is [n] and integer? n => displayComp ($level:= n)
  SAY '"Correct format: (level n) where n is the level you want to go to"
 
UP() == up()
up() == displayComp ($level:= $level-1)
 
SAME() == same()
same() == displayComp $level
 
DOWN() == down()
down() == displayComp ($level:= $level+1)
 
displaySemanticErrors() ==
  n:= #($semanticErrorStack:= removeDuplicates $semanticErrorStack)
  n=0 => nil
  l:= reverse! $semanticErrorStack
  $semanticErrorStack:= nil
  sayBrightly bright '"  Semantic Errors:"
  displaySemanticError(l,$OutputStream)
  sayBrightly '" "
  displayWarnings()
 
displaySemanticError(l,stream) ==
  for x in l for i in 1.. repeat
    sayBrightly(['"      [",i,'"] ",:first x],stream)
 
displayWarnings() ==
  n:= #($warningStack:= removeDuplicates $warningStack)
  n=0 => nil
  sayBrightly bright '"  Warnings:"
  l := reverse! $warningStack
  displayWarning(l,$OutputStream)
  $warningStack:= nil
  sayBrightly '" "
 
displayWarning(l,stream) ==
  for x in l for i in 1.. repeat
    sayBrightly(['"      [",i,'"] ",:x],stream)
 
displayComp level ==
  $bright:= " << "
  $dim:= " >> "
  if $insideCapsuleFunctionIfTrue then
    sayBrightly ['"error in function",:bright $op,'"%l"]
  --mathprint removeZeroOne mkErrorExpr level
  pp removeZeroOne mkErrorExpr level
  sayBrightly ['"****** level",:bright level,'" ******"]
  [$x,$m,$f,$exitModeStack]:= ELEM($s,level)
  SAY("$x:= ",$x)
  sayBrightly ['"$m := ",:listify form2String $m]
  --SAY "$f:="
  --F_,PRINT_-ONE $f
  nil
 
mkErrorExpr level ==
  bracket ASSOCLEFT drop(level-#$s,$s) where
    bracket l ==
      #l<2 => l
      l is [a,b] =>
        highlight(b,a) where
          highlight(b,a) ==
            b isnt [.,:.] =>
              substitute(var,b,a) where
                var:= makeSymbol strconc(STRINGIMAGE $bright,STRINGIMAGE b,STRINGIMAGE $dim)
            highlight1(b,a) where
              highlight1(b,a) ==
                a isnt [.,:.] => a
                a is [ =b,:c] => [$bright,b,$dim,:c]
                [highlight1(b,first a),:highlight1(b,rest a)]
      substitute(bracket rest l,second l,first l)
 
compAndTrace [x,m,e] ==
  SAY("tracing comp, compFormWithModemap of: ",x)
  TRACE_,1(["comp","compFormWithModemap"],nil)
  T:= comp(x,m,e)
  UNTRACE_,1 "comp"
  UNTRACE_,1 "compFormWithModemap"
  T
 
errorRef s == 
  stackWarning('"%1b has no value", [s])
 
unErrorRef s == 
  unStackWarning('"'%1b has no value",[s])
 
--% ENVIRONMENT FUNCTIONS
 
consProplistOf(var,proplist,prop,val) ==
  semchkProplist(var,proplist,prop,val)
  $InteractiveMode and (u:= assoc(prop,proplist)) =>
    u.rest := val
    proplist
  [[prop,:val],:proplist]
 
warnLiteral x ==
  stackWarning('"%1b is BOTH a variable a literal",[x])
 
intersectionEnvironment(e,e') ==
  ce:= makeCommonEnvironment(e,e')
  ic := intersectionContour(deltaContour(e,ce),deltaContour(e',ce)) =>
    addContour(ic,ce)
  ce
 
deltaContour([[c,:cl],:el],[[c',:cl'],:el']) ==
  not sameObject?(el,el') => systemError '"deltaContour" --a cop out for now
  eliminateDuplicatePropertyLists contourDifference(c,c') where
    contourDifference(c,c') ==
      [first x for x in tails c while not sameObject?(x,c')]
    eliminateDuplicatePropertyLists contour ==
      contour is [[x,:.],:contour'] =>
        LASSOC(x,contour') =>
                               --save some CONSing if possible
          [first contour,:DELLASOS(x,eliminateDuplicatePropertyLists contour')]
        [first contour,:eliminateDuplicatePropertyLists contour']
      nil
 
intersectionContour(c,c') ==
  $var: local := nil
  computeIntersection(c,c') where
    computeIntersection(c,c') ==
      varlist:= removeDuplicates ASSOCLEFT c
      varlist':= removeDuplicates ASSOCLEFT c'
      interVars := setIntersection(varlist,varlist')
      unionVars := setUnion(varlist,varlist')
      diffVars := setDifference(unionVars,interVars)
      modeAssoc:= buildModeAssoc(diffVars,c,c')
      [:modeAssoc,:
        [[x,:proplist]
          for [x,:y] in c | member(x,interVars) and
            (proplist:= interProplist(y,LASSOC($var:= x,c')))]]
    interProplist(p,p') ==
                            --p is new proplist; p' is old one
      [:modeCompare(p,p'),:[pair' for pair in p | (pair':= compare(pair,p'))]]
    buildModeAssoc(varlist,c,c') ==
      [[x,:mp] for x in varlist | (mp:= modeCompare(LASSOC(x,c),LASSOC(x,c')))]
    compare(pair is [prop,:val],p') ==
      --1. if the property-value pair are identical, accept it immediately
      pair=(pair':= assoc(prop,p')) => pair
      --2. if property="value" and modes are unifiable, give intersection
      --       property="value" but value=genSomeVariable)()
      (val':= KDR pair') and prop="value" and
        (m:= unifiable(val.mode,val'.mode)) => ["value",genSomeVariable(),m,nil]
            --this tells us that an undeclared variable received
            --two different values but with identical modes
      --3. property="mode" is covered by modeCompare
      prop="mode" => nil
    modeCompare(p,p') ==
      pair := symbolAssoc("mode",p) =>
        pair' := symbolAssoc("mode",p') =>
          m'':= unifiable(rest pair,rest pair') => [["mode",:m'']]
          stackSemanticError(['"%b",$var,'"%d","has two modes: "],nil)
       --stackWarning ("mode for",'"%b",$var,'"%d","introduced conditionally")
        [["conditionalmode",:rest pair]]
        --LIST pair
       --stackWarning ("mode for",'"%b",$var,'"%d","introduced conditionally")
      pair' := symbolAssoc("mode",p') => [["conditionalmode",:rest pair']]
        --LIST pair'
    unifiable(m1,m2) ==
      m1=m2 => m1
        --we may need to add code to coerce up to tagged unions
        --but this can not be done here, but should be done by compIf
      m:=
        m1 is ["Union",:.] =>
          m2 is ["Union",:.] => ["Union",:S_+(rest m1,rest m2)]
          ["Union",:S_+(rest m1,[m2])]
        m2 is ["Union",:.] => ["Union",:S_+(rest m2,[m1])]
        ["Union",m1,m2]
      for u in getDomainsInScope $e repeat
        if u is ["Union",:u'] and (and/[listMember?(v,u') for v in rest m]) then
          return m
        --this loop will return nil if not satisfied
 
addContour(c,E is [cur,:tail]) ==
  [append!(fn(c,E),cur),:tail] where
    fn(c,e) ==
        for [x,:proplist] in c repeat
           fn1(x,proplist,getProplist(x,e)) where
              fn1(x,p,ee) ==
                for pv in p repeat fn3(x,pv,ee) where
                 fn3(x,pv,e) ==
                   [p,:v]:=pv
                   if p="conditionalmode" then
                     pv.first := "mode"
                     --check for conflicts with earlier mode
                     if vv := symbolTarget("mode",e) then
                        if v ~=vv then
                          stackWarning('"The conditional modes %1p and %2p conflict",
                            [v,vv])
        [c]

++ Return the common root of the environments e and e'.
++ Note: we use cell pointer comparison instead of general object
++ equality comparison because both are expected to build from
++ a commont cell node.
makeCommonEnvironment(e,e') ==
  interE makeSameLength(e,e') where
    interE [e,e'] ==
      sameObject?(rest e,rest e') =>
        [interLocalE makeSameLength(first e,first e'),:rest e]
      interE [rest e,rest e']
    interLocalE [le,le'] ==
      sameObject?(rest le,rest le') =>
        [interC makeSameLength(first le,first le'),:rest le]
      interLocalE [rest le,rest le']
    interC [c,c'] ==
      sameObject?(c,c') => c
      interC [rest c,rest c']
    makeSameLength(x,y) ==
      fn(x,y,#x,#y) where
        fn(x,y,nx,ny) ==
          nx>ny => fn(rest x,y,nx-1,ny)
          nx<ny => fn(x,rest y,nx,ny-1)
          [x,y]

++ Return the lexically leftmost location in an assignment for.
lhsOfAssignment x ==
  x is [":=",lhs,:.] => lhsOfAssignment lhs
  x

getSuccessEnvironment(a,e) ==
  a is ["is",id,m] =>
    id := lhsOfAssignment id
    ident? id and isDomainForm(m,$EmptyEnvironment) =>
      e:=put(id,"specialCase",m,e)
      currentProplist:= getProplist(id,e)
      [.,.,e] := T := comp(m,$EmptyMode,e) or return nil -- duplicates compIs
      newProplist:= consProplistOf(id,currentProplist,"value",[m,:rest removeEnv T])
      addBinding(id,newProplist,e)
    e
  a is ["case",x,m] and (x := lhsOfAssignment x) and ident? x =>
    put(x,"condition",[a,:get(x,"condition",e)],e)
  a is ["and",:args] =>
    for form in args repeat
      e := getSuccessEnvironment(form,e)
    e
  a is ["not",a'] => getInverseEnvironment(a',e)
  -- Follow temporaries in complex conditionals
  symbol? a and (T := get(a,"value",e)) => getSuccessEnvironment(T.expr,e)
  e

isUnionMode(m,e) ==
  m is ["Union",:.] => m
  v := get(RepIfRepHack m,"value",e) =>
    (v.expr is ["Union",:.] => v.expr; nil)
  nil

++ Return the UnionCategory of `m' in the environment `e', if known.
unionLike?(m,e) ==
  isUnionMode(m,e) is ['Union,:branches] => ['UnionCategory,:branches]
  -- Take a cheap approximation at domains with Union-like flavour.
  T := compForMode(m,$EmptyMode,e) or return nil
  T.expr is ['Union,:branches] => ['UnionCategory,:T.expr.args]
  T.mode is ['UnionCategory,:.] => T.mode
  T.mode is ['UnionType] => ['UnionCategory]
  T.mode isnt ['Join,:cats,['CATEGORY,.,:sigs]] => nil
  listMember?(['UnionType],cats) =>
    ['UnionCategory,
      :[b for ['SIGNATURE,"case",[=$Boolean,'$,["[||]",b]]] in sigs]]
  nil

++ If `x' designates a store with multiple views, e.g. Union, return
++ the collection of those modes.
unionProperty(x,e) ==
  x isnt [.,:.] => unionLike?(getmode(x,e),e)
  nil

getInverseEnvironment(a,e) ==
  a is ["case",x,m] and (x := lhsOfAssignment x) and ident? x =>
    --the next two lines are necessary to get 3-branched Unions to work
    -- old-style unions, that is
    (get(x,"condition",e) is [["OR",:oldpred]]) and listMember?(a,oldpred) =>
      put(x,"condition",[MKPF(remove(oldpred,a),"OR")],e)
    unionProperty(x,e) is ['UnionCategory,:l] =>
      l' := remove(l,m)
      for u in l' repeat
	 if u is ['_:,=m,:.] then l' := remove(l',u)
      newpred:= MKPF([["case",x,m'] for m' in l'],"OR")
      put(x,"condition",[newpred,:get(x,"condition",e)],e)
    e
  a is ["not",a'] => getSuccessEnvironment(a',e)
  -- Follow temporaries in complex conditionals
  symbol? a and (T := get(a,"value",e)) => getInverseEnvironment(T.expr,e)
  e

++ Give some abstract value to the variable `v' of mode `m' in `e'.
++ Return the resulting environment.
giveVariableSomeValue(x,m,e) ==
  put(x,'value,[genSomeVariable(),m,nil],e)


printEnv E ==
  for x in E for i in 1.. repeat
    for y in x for j in 1.. repeat
      SAY('"******CONTOUR ",j,'", LEVEL ",i,'":******")
      for z in y repeat
        finishLine $OutputStream
        SAY("Properties Of: ",first z)
        for u in rest z repeat
          PRIN1 first u
          printString ": "
          PRETTYPRINT tran(rest u,first u) where
            tran(val,prop) ==
              prop="value" => drop(-1,val)
              val
 
prEnv E ==
  for x in E for i in 1.. repeat
    for y in x for j in 1.. repeat
      SAY('"******CONTOUR ",j,'", LEVEL ",i,'":******")
      for z in y | null symbolTarget("modemap",rest z) repeat
        finishLine $OutputStream
        SAY("Properties Of: ",first z)
        for u in rest z repeat
          PRIN1 first u
          printString ": "
          PRETTYPRINT tran(rest u,first u) where
            tran(val,prop) ==
              prop="value" => drop(-1,val)
              val
 
prModemaps E ==
  listOfOperatorsSeenSoFar:= nil
  for x in E for i in 1.. repeat
    for y in x for j in 1.. repeat
      for z in y | not member(first z,listOfOperatorsSeenSoFar) and
        (modemap := symbolTarget("modemap",rest z)) repeat
          listOfOperatorsSeenSoFar:= [first z,:listOfOperatorsSeenSoFar]
          finishLine $OutputStream
          PRIN1 first z
          printString ": "
          PRETTYPRINT modemap
 
prTriple T ==
   SAY '"Code:"
   pp T.0
   SAY '"Mode:"
   pp T.1
 
TrimCF() ==
  new:= nil
  old:= CAAR $CategoryFrame
  for u in old repeat
    if objectAssoc(first u,new) = nil then
      uold:= rest u
      unew:= nil
      for v in uold repeat
        if objectAssoc(first v,unew) = nil then
          unew:= [v,:unew]
      new:= [[first u,:reverse! unew],:new]
  $CategoryFrame:= [[reverse! new]]
  nil

--%

++ Returns non-nil if `t' is a known type in the environement `e'.
diagnoseUnknownType(t,e) ==
  t isnt [.,:.] =>
    t in '($ constant) => t
    t' := assoc(t,getDomainsInScope e) => t'
    (m := getmode(t,e)) and isCategoryForm(m,$CategoryFrame) => t
    string? t => t
    -- ??? We should not to check for $$ at this stage.  
    -- ??? This is a bug in the compiler that needs to be fixed.
    t = "$$" => t
    stackSemanticError(['"The identifier", :bright t, 
                         '"is not known to name a type"],nil)
  [ctor,:args] := t
  ctor is "Mapping" => 
    for t' in args repeat diagnoseUnknownType(t',e)
    t
  ctor is "Record" =>
    for [[.,n,t'],:fields] in tails args repeat 
      diagnoseUnknownType(t',e)
      for [.,=n,.] in fields repeat
        stackSemanticError(['"Field", :bright n, 
          '"declared more than once."], nil)
    t
  ctor is "Union" =>
    if args is [[":",:.],:.] then
      for [[.,n,t'],:fields] in tails args repeat 
        diagnoseUnknownType(t',e)
        for [.,=n,.] in fields repeat
          stackSemanticError(['"Field", :bright n, 
            '"declared more than once."], nil)
    else
      for t' in args repeat diagnoseUnknownType(t',e)
    t
  ctor is "Enumeration" =>
    for t' in args repeat
      ident? t' => nil
      stackSemanticError(['"Enumerators must be symbols."], nil)
    -- Make sure we don't have repeated symbolic values
    for [sym,:syms] in tails args repeat
      symbolMember?(sym,syms) => 
        stackSemanticError(['"Symbolic value ", :bright sym, 
          '"is listed twice"], nil)
    t
  ctor is "[||]" => t
  builtinConstructor? ctor => t
  -- ??? Ideally `e' should be a local extension of $CategoryFrame
  -- ??? so that we don't have to access it here as a global state.
  get(ctor,"isFunctor",$CategoryFrame) 
    or get(ctor,"isCategory",$CategoryFrame) => t
  -- ctor maybe a constructor, but user forgot to import.  Warn.
  getConstructorAbbreviationFromDB ctor =>
    stackWarning('"Type %1pb is not in scope.  Import it",[t])
    t
  stackSemanticError(['"Identifier", :bright ctor, 
                       '"is not known to name a constructor"],nil)

--% PREDICATES
 
 
isConstantId(name,e) ==
  ident? name =>
    pl:= getProplist(name,e) =>
      (symbolTarget("value",pl) or symbolTarget("mode",pl) => false; true)
    true
  false
 
isFalse() == nil
 
isFluid s ==
  s isnt [.,:.] and char "$" = stringChar(PNAME s,0)
 
isFunction(x,e) ==
  get(x,"modemap",e) or GETL(x,"SPECIAL") or x="case" or getmode(x,e) is [
    "Mapping",:.]
 
isLiteral: (%Symbol,%Env) -> %Boolean
isLiteral(x,e) == 
  get(x,"isLiteral",e) => true
  false

++ Remember the name of the constructor definition being processed.
registerConstructor(x,e) ==
  put('%compilerData,'%ctor,x,e)

++ Retrieve the DB of the constructor definition being processed.
currentDB e ==
  ctor := get('%compilerData,'%ctor,e) => constructorDB ctor
  nil

makeLiteral: (%Symbol,%Env) -> %Thing
makeLiteral(x,e) == 
  put(x,"isLiteral","true",e)
 
isSomeDomainVariable s ==
  ident? s and #(x:= symbolName s) > 2 and
    stringChar(x,0) = char "#" and stringChar(x,1) = char "#"

++ Return non-nil is the domain form `x' is a `subset' of domain
++ form `y' in the environment `e'.  The relation of subdomain
++ is understood as equivalent to the fact that all values of
++ the domain designated by `x' are also values of the domain
++ designated by `y'.  Examples include declaration of domain `x'
++ as satisfying  SubsetCategory(SomeCategory, y).  Or, when
++ x is defined as SubDomain(y,pred).  In that case, the predicate
++ is returned and its parameter is `#1'.
isSubset(x,y,e) ==
  x = y => true
  -- Every domain or catgory is a subset of Type.
  y = $Type => true
  -- When using the old style definition, the current domain
  -- is considered a subset of its representation domain
  x is '$ and y is 'Rep => $useRepresentationHack
  -- Expand domain representation form
  x is 'Rep and not $useRepresentationHack =>
    isSubset(getRepresentation e,y,e)
  y is '$ and get(y,'%dc,e) = x => true
  -- Or, if x has the Subsets property set by SubsetCategory.
  pred := LASSOC(opOf x,get(opOf y,"Subsets",e)) => pred
  -- Or, they are related by subdomain chain.
  isDomainForm(x,e) and isSubDomain(x,y)
 
isDomainInScope(domain,e) ==
  domainList:= getDomainsInScope e
  domain isnt [.,:.] =>
    symbolMember?(domain,domainList) => true
    not ident? domain or isSomeDomainVariable domain => true
    false
  (name:= first domain)="Category" => true
  objectAssoc(name,domainList) => true
--   null rest domain or domainMember(domain,domainList) => true
--   false
  isFunctor name => false
  true --is not a functor
 
isSimple x ==
  atomic? x => true
  isSideEffectFree x.op and (and/[isSimple y for y in x.args])
 
isSideEffectFree op ==
  op is ["elt",.,op'] => isSideEffectFree op'
  not ident? op => false
  listMember?(op,$SideEffectFreeFunctionList) or constructor? op
 
isAlmostSimple x ==
  --returns (<new predicate> . <list of assignments>) or nil
  $assignmentList: local := nil --$assigmentList is only used in this function
  transform:=
    fn x where
      fn x ==
        x isnt [.,:.] or null rest x => x
        [op,y,:l]:= x
        op="has" => x
        op="is" => x
        op=":=" =>
          ident? y => (setAssignment [x]; y)
          (setAssignment [[":=",g:= genVariable(),:l],[":=",y,g]]; g)
        op = "case" and ident? y => x
        isSideEffectFree op => [op,:mapInto(rest x, function fn)]
        $assignmentList:= "failed"
      setAssignment x ==
        $assignmentList="failed" => nil
        $assignmentList:= [:$assignmentList,:x]
  $assignmentList="failed" => nil
  wrapSEQExit [:$assignmentList,transform]
 
incExitLevel u ==
  adjExitLevel(u,1,1)
  u
 
decExitLevel u ==
  (adjExitLevel(u,1,-1); removeExit0 u) where
    removeExit0 x ==
      x isnt [.,:.] => x
      x is ["exit",0,u] => removeExit0 u
      [removeExit0 first x,:removeExit0 rest x]
 
adjExitLevel(x,seqnum,inc) ==
  x isnt [.,:.] => x
  x is [op,:l] and op in '(SEQ REPEAT COLLECT) =>
    for u in l repeat adjExitLevel(u,seqnum+1,inc)
  x is ["exit",n,u] =>
    (adjExitLevel(u,seqnum,inc); seqnum>n => x; x.rest.first := n+inc)
  x is [op,:l] => for u in l repeat adjExitLevel(u,seqnum,inc)
 
wrapSEQExit l ==
  null rest l => first l
  [:c,x]:= [incExitLevel u for u in l]
  ["SEQ",:c,["exit",1,x]]
 
 
--% UTILITY FUNCTIONS
 
makeWorkerName op ==
  makeSymbol strconc(symbolName op,'";")
 
removeEnv t == [t.expr,t.mode,$EmptyEnvironment]  -- t is a triple
 
-- This function seems no longer used
--ordinsert(x,l) ==
--  null l => [x]
--  x=first l => l
--  _?ORDER(x,first l) => [x,:l]
--  [first l,:ordinsert(x,rest l)]
 
makeNonAtomic x ==
  x isnt [.,:.] => [x]
  x
 
flatten(l,key) ==
  null l => nil
  first l is [k,:r] and k=key => [:r,:flatten(rest l,key)]
  [first l,:flatten(rest l,key)]
 
genDomainVar() ==
  $Index:= $Index+1
  makeSymbol strconc('"#D",toString $Index)
 
genVariable() ==
  makeSymbol strconc('"#G",toString ($genSDVar:= $genSDVar+1))
 
genSomeVariable() ==
  makeSymbol strconc('"##",toString ($genSDVar:= $genSDVar+1))
 
listOfIdentifiersIn x ==
  ident? x => [x]
  x is [op,:l] => removeDuplicates ("append"/[listOfIdentifiersIn y for y in l])
  nil
 
mapInto(x,fn) == [apply(fn,[y]) for y in x]
 
numOfOccurencesOf(x,y) ==
  fn(x,y,0) where
    fn(x,y,n) ==
      null y => 0
      x=y => n+1
      atomic? y => n
      symbol? x and abstraction? y =>
        symbolMember?(x,y.absParms) => n
        fn(x,y.absBody,n)
      fn(x,first y,n)+fn(x,rest y,n)
 
compilerMessage(msg,args) ==
  $PrintCompilerMessageIfTrue => sayPatternMsg(msg,args)
 
printDashedLine() ==
  SAY
   '"--------------------------------------------------------------------------"
 
stackSemanticError(msg,expr) ==
  BUMPERRORCOUNT "semantic"
  if $insideCapsuleFunctionIfTrue then msg:= [$op,": ",:msg]
  if msg isnt [.,:.] then msg:= [msg]
  entry:= [msg,expr]
  if not listMember?(entry,$semanticErrorStack) then $semanticErrorStack:=
    [entry,:$semanticErrorStack]
  $scanIfTrue and $insideCapsuleFunctionIfTrue=true and #$semanticErrorStack-
    $initCapsuleErrorCount>3 => THROW("compCapsuleBody",nil)
  nil
 
stackWarning(msg,args == nil) ==
  msg := buildMessage(msg, args)
  if $insideCapsuleFunctionIfTrue then msg:= [$op,": ",:msg]
  if not listMember?(msg,$warningStack) then
    $warningStack:= [msg,:$warningStack]
  nil
 
unStackWarning(msg,args) ==
  msg := buildMessage(msg,args)
  if $insideCapsuleFunctionIfTrue then msg:= [$op,": ",:msg]
  $warningStack := remove!($warningStack,msg)
  nil
 
stackMessage(msg,args == nil) ==
  if args ~= nil then
    msg := buildMessage(msg,args)
  $compErrorMessageStack:= [msg,:$compErrorMessageStack]
  nil
 
stackMessageIfNone msg ==
  --used in situations such as compForm where the earliest message is wanted
  if null $compErrorMessageStack then $compErrorMessageStack:=
    [msg,:$compErrorMessageStack]
  nil
 
stackAndThrow(msg, args == nil) ==
  if args ~= nil then
    msg := buildMessage(msg,args)
  $compErrorMessageStack:= [msg,:$compErrorMessageStack]
  THROW("compOrCroak",nil)
 
printString x == PRINC (string? x => x; PNAME x)
 
printAny x ==
  if x isnt [.,:.] then printString x else PRIN1 x
 
printSignature(before,op,[target,:argSigList]) ==
  printString before
  printString op
  printString ": _("
  if argSigList then
    printAny first argSigList
    for m in rest argSigList repeat (printString ","; printAny m)
  printString "_) -> "
  printAny target
  finishLine $OutputStream
 
elapsedTime() ==
  currentTime:= TEMPUS_-FUGIT()
  elapsedSeconds:= (currentTime-$previousTime)*QUOTIENT(1.0,$timerTicksPerSecond)
  $previousTime:= currentTime
  elapsedSeconds
 
addStats([a,b],[c,d]) == [a+c,b+d]
 
printStats [byteCount,elapsedSeconds] ==
  timeString := normalizeStatAndStringify elapsedSeconds
  if byteCount = 0 then SAY('"Time: ",timeString,'" SEC.") else
    SAY('"Size: ",byteCount,'" BYTES     Time: ",timeString,'" SEC.")
  finishLine $OutputStream
  nil
 
++is domain of category form also of category form'?
++domain is only used for SubsetCategory resolution.
++ `db', if non-nil, is the DB for the constructor being compiled.
++Ensuring that X being a Ring means that it satisfies (Algebra X)
extendsCategoryForm(db,domain,form,form') ==
  form=form' => true
  form=$Category => nil
  form' is ["Join",:l] =>
    and/[extendsCategoryForm(db,domain,form,x) for x in l]
  form' is ["CATEGORY",.,:l] =>
    and/[extendsCategoryForm(db,domain,form,x) for x in l]
  form' is ["SubsetCategory",cat,dom] =>
    extendsCategoryForm(db,domain,form,cat) and isSubset(domain,dom,$e)
  form is ["Join",:l] =>
    or/[extendsCategoryForm(db,domain,x,form') for x in l]
  form is ["CATEGORY",.,:l] =>
    listMember?(form',l) or
      stackWarning('"not known that %1 is of mode %2p",[form',form]) or true
  -- if we are compiling the category `form', then we should look at
  -- the body as provided in the current definition, not a version
  -- possibly compiled previously that may have changed.
  -- FIXME: should not we go all the way down and implement
  --        polynormic recursion?
  domain = "$" and form = dbConstructorForm db => 
    extendsCategoryForm(db,domain, $currentCategoryBody, form')
  isCategoryForm(form,$EmptyEnvironment) =>
    -- -- If we have an existing definition for this category, use it.
    -- (db := constructorDB form.op) and loadDB db =>
    --   form' is ['SIGNATURE,op,types,:.] => assoc([op,args],dbOperations db)
    --   form' is ['ATTRIBUTE,a] => assoc(a,dbAttributes db)
    --   subst := pairList(dbConstructorForm(db).args,form.args)
    --   or/[extendsCategoryForm(db,domain,applySubst(subst,cat),form')
    --        for [cat,:.] in dbAncestors db]
    -- Otherwise constructs the associated domain shell
    formVec:=(compMakeCategoryObject(form,$e)).expr
            --Must be $e to pick up locally bound domains
    form' is ["SIGNATURE",op,args,:.] =>
        assoc([op,args],categoryExports formVec) or
            assoc(substitute(domain,"$",[op,args]),
                  substitute(domain,"$",categoryExports formVec))
    form' is ["ATTRIBUTE",at] =>
         assoc(at,categoryAttributes formVec) or
            assoc(substitute(domain,"$",at),substitute(domain,"$",categoryAttributes formVec))
    form' is ["IF",:.] => true --temporary hack so comp won't fail
    listMember?(form',categoryPrincipals formVec) or
     listMember?(form',substitute(domain,"$",categoryPrincipals formVec)) or
      (or/
        [extendsCategoryForm(db,domain,substitute(domain,"$",cat),form')
          for [cat,:.] in categoryAncestors formVec])
  nil
 
getmode(x,e) ==
  prop:=getProplist(x,e)
  u := symbolTarget("value",prop) => u.mode
  symbolTarget("mode",prop)
 
getmodeOrMapping(x,e) ==
  u:= getmode(x,e) => u
  (u:= get(x,"modemap",e)) is [[[.,:map],.],:.] => ["Mapping",:map]
  nil
 
outerProduct l ==
                --of a list of lists
  null l => [nil]
  "append"/[[[x,:y] for y in outerProduct rest l] for x in first l]
 
sublisR(al,u) ==
  u isnt [.,:.] => u
  y:= rassoc(t:= [sublisR(al,x) for x in u],al) => y
  true => t
 
substituteOp(op',op,x) ==
  x isnt [.,:.] => x
  [(op=(f:= first x) => op'; f),:[substituteOp(op',op,y) for y in rest x]]
 
--substituteForFormalArguments(argl,expr) ==
--  applySubst([[v,:a] for a in argl for v in $FormalMapVariableList],expr)
 
 -- following is only intended for substituting in domains slots 1 and 4
 -- signatures and categories
sublisV(p,e) ==
  (p isnt [.,:.] => e; suba(p,e)) where
    suba(p,e) ==
      string? e => e
      -- no need to descend vectors unless they are categories
      categoryObject? e => vector [suba(p,e.i) for i in 0..maxIndex e]
      e isnt [.,:.] => (y := objectAssoc(e,p) => rest y; e)
      u:= suba(p,first e)
      v:= suba(p,rest e)
      sameObject?(first e,u) and sameObject?(rest e,v) => e
      [u,:v]

--% DEBUGGING PRINT ROUTINES used in breaks
 
old2NewModemaps x ==
--  [[dcSig,pred] for [dcSig,[pred,:.],:.] in x]
  x is [dcSig,[pred,:.],:.]  =>  [dcSig,pred]
  x

traceUp() ==
  $x isnt [.,:.] => sayBrightly "$x is an atom"
  for y in rest $x repeat
    u:= comp(y,$EmptyMode,$f) =>
      sayBrightly [y,'" ==> mode",'"%b",u.mode,'"%d"]
    sayBrightly [y,'" does not compile"]
 
traceDown() ==
  mmList:= getFormModemaps($x,$f) =>
    for mm in mmList repeat if u:= qModemap mm then return u
  sayBrightly "no modemaps for $x"
 
qModemap mm ==
  sayBrightly ['"%b","modemap",'"%d",:formatModemap mm]
  [[dc,target,:sl],[pred,:.]]:= mm
  and/[qArg(a,m) for a in rest $x for m in sl] => target
  sayBrightly ['"%b","fails",'"%d",'"%l"]
 
qArg(a,m) ==
  yesOrNo:=
    u:= comp(a,m,$f) => "yes"
    "no"
  sayBrightly [a," --> ",m,'"%b",yesOrNo,'"%d"]
  yesOrNo="yes"
 
displayProplist(x,alist) ==
  sayBrightly ["properties of",'"%b",x,'"%d",":"]
  fn alist where
    fn alist ==
      alist is [[prop,:val],:l] =>
        if prop="value" then val:= [val.expr,val.mode,'"..."]
        sayBrightly ["   ",'"%b",prop,'"%d",": ",val]
        fn deleteAssoc(prop,l)
 
displayModemaps E ==
  listOfOperatorsSeenSoFar:= nil
  for x in E for i in 1.. repeat
    for y in x for j in 1.. repeat
      for z in y | not member(first z,listOfOperatorsSeenSoFar) and
        (modemaps := symbolTarget("modemap",rest z)) repeat
          listOfOperatorsSeenSoFar:= [first z,:listOfOperatorsSeenSoFar]
          displayOpModemaps(first z,modemaps)
 
--% General object traversal functions
 
GCOPY ob == copyTree ob  -- for now
 
--%
++ format the set of candidate operations.
displayAmbiguousSignatures(op,sigs) ==
  [:showCandidate(op, sig) for sig in sigs] where
     showCandidate(op,sig) ==
       ["%l", "        ", op, '": ", 
         :bright formatUnabbreviated ["Mapping",:sig]]

++ Display diagnostic message about ambiguous operation `op', with
++ possible resolutions given by the list `sigs'.
ambiguousSignatureError(op, sigs) ==
  stackSemanticError(['"signature of lhs not unique.  Candidates are:",
    :displayAmbiguousSignatures($op,sigs)],nil)


--% Capsule Directory Management

++ Holds the list of slot number-export function pairs of 
++ the current functor.
$capsuleDirectory := nil

clearCapsuleDirectory() ==
  $capsuleDirectory := nil
  $capsuleFunctionStack := nil

++ Return the linkage name of the exported operation associated with
++ slot number `slot'.  A nil entry means that either the operation
++ is not defined, or it is conditional.
getCapsuleDirectoryEntry slot ==
  scalarTarget(slot,$capsuleDirectory)

++ Update the current capsule directory with entry controlled by 
++ predicate `pred'.
updateCapsuleDirectory(entry,pred) ==
  pred isnt true => nil
  $capsuleDirectory := [entry,:$capsuleDirectory]




--% Tree walkers

++ Walk VM conditional forms mutating sub-forms with the unary
++ function `fun'
mutateConditionalFormWithUnaryFunction(form,fun) ==
  form isnt ['%when,:body] => form
  for clauses in tails body repeat
    -- a clause is a list of forms
    for subForms in tails first clauses repeat
      subForms.first := apply(fun,[first subForms])
  form

++ Walk VM a binding-form mutating enclosed expression forms with
++ the unary function `fun'.  Every sub-form is visited except
++ local variable declarations, though their initializers
++ are visited.
mutateBindingFormWithUnaryFunction(form,fun) ==
  form isnt [op,inits,:body] and op in '(LET %bind) => form
  for defs in tails inits repeat
    def := first defs
    def isnt [.,:.] => nil -- no initializer
    def.rest.first := apply(fun,[second def])
  for stmts in tails body repeat
    stmts.first := apply(fun,[first stmts])
  form

--% 

--middleEndExpand: %Form -> %Code
middleEndExpand x ==
  x is '%void => '""  -- NIL would have caused havoc elsewhere
  x is '%false or x is '%nil => 'NIL
  ident? x and (x' := x has %Rename) => x'
  atomic? x => x
  [op,:args] := x
  ident? op and (fun := getOpcodeExpander op) =>
    middleEndExpand apply(fun,[x])
  a := middleEndExpand op
  b := middleEndExpand args
  sameObject?(a,op) and sameObject?(b,args) => x
  [a,:b]


--% A function is simple if it looks like a super combinator, and it
--% does not use its environment argument.  They can be safely replaced
--% by more efficient (hopefully) functions.

compileTimeBindingOf u ==
  symbol? u => u
  null(name:= BPINAME u)  => keyedSystemError("S2OO0001",[u])
  name="Undef" => MOAN "optimiser found unknown function"
  name
 
getFunctionReplacement name ==
  property(compileTimeBindingOf name,'SPADreplace)

++ remove any replacement info possibly associated with `name'.
clearReplacement name ==
  property(name,"SPADreplace") := nil
  property(name,'%redex) := nil

evalAndPrintBackendStmt(lib,stmt) ==
  eval stmt
  printBackendStmt(lib,stmt)

++ Register the inlinable form of a function.
registerFunctionReplacement(db,name,body) ==
  evalAndPrintBackendStmt(dbLibstream db,
    ["PUT",MKQ name,MKQ "SPADreplace",quoteMinimally body])

++ Remember the redex form of this function
registerRedexForm(db,name,parms,body) ==
  evalAndPrintBackendStmt(dbLibstream db,
    ["PUT",quote name,quote '%redex,quote ['ILAM,parms,body]])

++ Retrieve the redex form of the function `name'.
redexForm name ==
  property(name,'%redex) 

++ Attempt to resolve the indirect reference to a constant form
++ `[spadConstant,$,n]' to a simpler expression
resolveConstantForm form ==
  fun := getCapsuleDirectoryEntry third form or return form
  -- Conservatively preserve object identity and storage 
  -- consumption by not folding non-atomic constant forms.
  getFunctionReplacement fun isnt ['XLAM,=nil,body] => form
  atomic? body or isVMConstantForm body => body
  form

mutateArgumentList(args,fun) ==
  for x in tails args repeat
    arg := first x
    atomic? arg => nil
    x.first := apply(fun,[arg])
  args

inlineDirectCall call ==
  x := redexForm call.op => doInlineCall(call.args,x.absParms,x.absBody)
  fun := getFunctionReplacement call.op or return call
  -- the renaming case
  symbol? fun =>
    call.op := fun
    NBUTLAST call
  -- the substitution case.
  fun is ["XLAM",parms,body] =>
    -- almost constant function
    parms = nil => body
    -- identity function too
    parms is [=body] => first call.args
    -- conservatively approximate eager semantics
    every?(function sideEffectFree?,call.args) =>
      -- alpha rename before substitution.
      newparms := [gensym() for p in parms]
      body := applySubst(pairList(parms,newparms),body)
      applySubst!(pairList(newparms,call.args),body)
    -- a non-side effect free argument used exactly once is OK.
    parms is [p] and numOfOccurencesOf(p,body) = 1 =>
      substitute(first call.args,p,body)
    -- get cute later.
    call
  call

resolveIndirectCall form ==
  fun := lastNode form
  fun isnt [['%tref,'$,n]] => form
  op := getCapsuleDirectoryEntry n or return form
  form.op := op
  fun.first := '$
  inlineDirectCall form
    
++ Walk `form' and replace simple functions as appropriate.
replaceSimpleFunctions form ==
  atomic? form => form
  form.op is 'DECLARE => form 
  form.op is '%when =>
    mutateConditionalFormWithUnaryFunction(form,function replaceSimpleFunctions)
  form.op in '(LET %bind) =>
    mutateBindingFormWithUnaryFunction(form,function replaceSimpleFunctions)
  form is ['spadConstant,'$,.] => resolveConstantForm form
  -- process argument first.
  mutateArgumentList(form.args,function replaceSimpleFunctions)
  form.op is 'SPADCALL => resolveIndirectCall form
  -- see if we know something about this function.
  [fun,:args] := form
  symbol? fun => inlineDirectCall form
  not cons? fun => form
  form.first := replaceSimpleFunctions fun
  form


++ We are processing a function definition with parameter list `vars'
++ and body given by `body'.  If `body' is a forwarding function call, 
++ return the target function.  Otherwise, return nil.
forwardingCall?(vars,body) ==
  vars is [:vars',.] and body is [fun,: =vars'] and ident? fun => fun
  nil


++ Return true if `form' has a linear usage of all variables in `vars'.
usesVariablesLinearly?(form,vars) ==
  atomic? form => true
  form.op is '%when =>
    and/[sideEffectFree? p and usesVariablesLinearly?(c,vars)
           for [p,c] in form.args]
  and/[numOfOccurencesOf(var,form) < 2 for var in vars] 

++ List of builtin operators we should not attempt to promote
++ to inlinable status.
$NonExpandableOperators ==
  '(%store %LET SPADCALL %bind LET)

++ We are processing a function definition with parameter list `vars'
++ and body given by `body'.  If `body' is a form that can be inlined,
++ then return the inline form.  Otherwise, return nil.
expandableDefinition?(vars,body) ==
  expand? :=
    -- We definitely don't want to expand a form that uses
    -- the domain of computation environment.
    vars isnt [:vars',env] or usesVariable?(body,env) => false

    -- Constants are currently implemented as niladic functions, and
    -- we want to avoid disturbing object identity, so we rule
    -- out use of side-effect full operators.  
    -- FIXME: This should be done only for constant creators.
    null vars' => sideEffectFree? body

    atomic? body => true
    [op,:args] := body
    not ident? op or symbolMember?(op,$NonExpandableOperators) => false
    every?(function atomic?,args)
      or semiSimpleRelativeTo?(body,$simpleVMoperators) =>
                usesVariablesLinearly?(body,vars')
    false
  expand? =>
    body is [fun,: =vars'] and symbol? fun => fun
    ['XLAM,vars',body]
  nil

++ A list of routines for diagnostic reports.  These functions, in an
++ abstract sense, have type: forall T: Type . String -> T, so they
++ can be used in T-returning functions, for any T.  
$coreDiagnosticFunctions == 
  '(error userError systemError)

almostPure? x ==
  ops := [:$coreDiagnosticFunctions,:$VMsideEffectFreeOperators]
  semiSimpleRelativeTo?(x,ops)

++ `defs' is a list of function definitions from the current domain.
++ Walk that list and replace references to unconditional operations
++ with their corresponding linkage names.  
foldExportedFunctionReferences(db,defs) ==
  for fun in defs repeat
    fun isnt [name,lamex] => nil
    getFunctionReplacement name => nil
    lamex isnt ['%lambda,vars,body] => nil
    body := replaceSimpleFunctions body
    form := expandableDefinition?(vars,body) =>
      registerFunctionReplacement(db,name,form)
      second(fun) := ["LAMBDA",vars,["DECLARE",["IGNORE",last vars]],body]
    if almostPure? body then
      registerRedexForm(db,name,vars,body)
    lamex.absBody := body
  defs

++ record optimizations permitted at level `level'.
setCompilerOptimizations level ==
  level = nil => nil
  integer? level =>
    if level = 0 then
      -- explicit request for no optimization.
      $optProclaim := false
      $optReplaceSimpleFunctions := false
    if level > 0 then 
      $optProclaim := true
      $optReplaceSimpleFunctions := true
    if level > 1 then
      $optExportedFunctionReference := true
    if level > 2 then
      $optimizeRep := true
  coreError '"unknown optimization level request"


--% Lisp backend support.

++ Proclaim the type of the capsule function `op' with signature `sig'.
++ Note that all capsule functions take an additional argument 
++ standing for the domain of computation object.
proclaimCapsuleFunction(db,op,sig) ==
  printBackendStmt(dbLibstream db,
    ["DECLAIM",["FTYPE",
       ["FUNCTION",[:[vmType first d for d in tails rest sig],"%Shell"], 
          vmType first sig],op]]) where
      vmType d ==
        $subdomain and d = "$" =>
          -- We want accurate approximation for subdomains/superdomains
          -- that are specialized and known to the VM.
          (m := getVMType normalize $functorForm) = "%Thing" =>
             getVMType normalize "$"
          m
        getVMType normalize d
      normalize(d,top? == true) ==
        d = "$" => 
          not top? => "*"
          -- If the representation is explicitly stated, use it.  That way
          -- we optimize abstractions just as well as builtins.
          r := getRepresentation $e => normalize(r,top?)
          -- Cope with old-style constructor definition
          $functorForm isnt [.,:.] => [$functorForm] 
          normalize($functorForm,top?)
        d isnt [.,:.] => 
          top? => "%Thing"
          getmode(d,$e) => "*"
          d
        [first d, :[normalize(first args,false) for args in tails rest d]]

++ Lisp back end compiler for %slam forms [namd,args,:body].
++ A %slam form is one that is `functional' in the sense that
++ its values are cached, so that equal lists of argument values
++ yield equal values.  The arguments-value pairs are stored
++ in a hash table.  This backend compiler is used to compile constructors.
backendCompileSPADSLAM: (%Database,%Symbol,%List %Symbol,%Code) -> %Symbol
backendCompileSPADSLAM(db,name,args,body) ==
  al := mkCacheName name       -- global name for the cache hash table.
  auxfn := makeWorkerName name -- name of the worker function.
  g2 := gensym()               -- local name for the cache value.
  u := 
    args = nil => [nil,[auxfn]]
    args is [g] => [g,[auxfn,g]]
    [gensym(),[auxfn,:args]]
  key := first u              -- key into the instantiation table cache
  app := second u             -- code to compute value
  code := 
    args = nil => ["COND",[al],[true,["SETQ",al,app]]]
    [binder,:inits] :=
      args is [.] => ["LET",[g2,["assoc",key,al]]]
      ["LET*",[key,["LIST",:args]],[g2,["assoc",key,al]]]
    [binder,inits,
      ["COND",
        [g2,["CDR",g2]],
          [true, 
            ["PROGN",["SETQ",g2,app],
               ["SETQ",al,["cons5",["CONS",key,g2],al]],g2]]]]
  -- define the global cache.
  evalAndPrintBackendStmt(dbLibstream db,['DEFPARAMETER,al,nil])
  assembleCode [auxfn,["LAMBDA",args,:body]]
  assembleCode [name,["LAMBDA",args,code]]

backendCompile2: (%Maybe %Database,%Code) -> %Symbol
backendCompile2 (db,code) ==
  code isnt [name,[type,args,:body]] =>
    systemError ['"parenthesis error in: ", code]
  type = '%slam => backendCompileSPADSLAM(db,name,args,body)
  assembleCode [name,[type,args,:body]]

++ returns all fuild variables contained in `x'.  Fuild variables are
++ identifiers starting with '$', except domain variable names.
backendFluidize x ==
  ident? x and x ~= "$" and x ~= "$$" and
    stringChar(symbolName x,0) = char "$" and
      not digit? stringChar(symbolName x,1) => x
  atomic? x => nil
  first x is "FLUID" => second x
  a := backendFluidize first x
  b := backendFluidize rest x
  a = nil => b
  [a,:b]


$FluidVars := []
$LocalVars := []
$SpecialVars := []


++ push `x' into the list of local variables.
pushLocalVariable: %Symbol -> %List %Symbol
pushLocalVariable x ==
  p := symbolName x
  x ~= "$" and stringChar(p,0) = char "$" and
    stringChar(p,1) ~= char "," and not digit? stringChar(p,1) => nil
  PUSH(x,$LocalVars)

isLispSpecialVariable x ==
  s := symbolName x
  stringChar(s,0) = char "$" and #s > 1 and
    alphabetic? stringChar(s,1) and not readOnly? x
  
noteSpecialVariable x ==
  $SpecialVars := insert(x,$SpecialVars)

--%
--% Compile Time operation lookup for the benefit of domain inlining.
--%

++ If `x' is a formal map variable, returns its position.
++ Otherwise return nil.
formal?: %Symbol -> %Maybe %Short
formal? x ==
  or/[i for i in 0.. for y in $FormalMapVariableList | symbolEq?(x,y)]

++ Expand the form at position `slot' in the domain template `shell'
++ with argument list `args'.
expandFormTemplate(shell,args,slot) ==
  integer? slot =>
    slot = 0 => "$"
    slot = 2 => "$$"
    expandFormTemplate(shell,args,vectorRef(shell,slot))
  slot isnt [.,:.] => slot
  slot is ["local",parm] and (n := formal? parm) => 
    args.n   -- FIXME: we should probably expand with dual signature
  slot is ['%eval,val] => val
  slot is ['QUOTE,val] => 
    string? val => val
    slot
  [expandFormTemplate(shell,args,i) for i in slot]

++ Compare the form at `slot' in the domain templare `shell'
++ for equality with `form'.
equalFormTemplate(shell,args,slot,form) ==
  integer? slot =>
    slot = 0 => form = "$"
    slot = 2 => form = "$$"
    equalFormTemplate(shell,args,vectorRef(shell,slot),form)
  slot is ["local",parm] and (n := formal? parm) => 
    equalFormTemplate(shell,args,args.n,form)
  slot is ['%eval,val] => form = val
  slot is ['QUOTE,val] => 
     string? val or symbol? val or integer? val => val = form
     slot = form
  slot isnt [.,:.] or form isnt [.,:.] => form = slot
  #slot ~= #form => false
  and/[equalFormTemplate(shell,args,i,x) for i in slot for x in form]

++ Subroutine of lookupDefiningFunction.
++ Return the location of function templates with signature `sig',
++ descriptor address in the range [start,end), in the domain 
++ template `shell' whose local reference vector is `funDesc'.
++ Return value:
++    nil         => function not defined by `shell'.
++    "ambiguous" => too many candidates
++    <number>    => slot number of unique matching function.
getFunctionTemplate(sig,start,end,shell,args,funDesc) ==
  nargs := #rest sig
  loc := nil                           -- candidate locations
  while loc ~= "ambiguous" and start < end repeat
    n := arrayRef(funDesc,start)       -- arity of current operator
    PROGN
      -- Skip if arity mismatch
      i := start
      n ~= nargs => nil
      -- We are not interested in predicates, at this point.
      -- Skip if this operator's signature does not match 
      i := i + 2
      or/[not equalFormTemplate(shell,args,funDesc.k,t) 
           for k in i.. for t in sig] => nil
      -- Grab the location of this match
      loc := 
        integer? loc => "ambiguous"
        arrayRef(funDesc,i + n + 1)
    start := start + n + 4
  loc

++ Subroutine of lookupDefiningFunction.
lookupInheritedDefiningFunction(op,sig,shell,args,slot) ==
  dom := expandFormTemplate(shell,args,slot)
  dom isnt [.,:.] or dom is ["local",:.] => nil
  lookupDefiningFunction(op,sig,dom)

++ Return the name of the function definition that explicitly implements
++ the operation `op' with signature `sig' in the domain of 
++ computation `dc'.  Otherwise, return nil.
++ Note: Only a function defined by the domain template, or its add-chains,
++       and that is unambiguous is returned.  In particular, this
++       function defaulting packages.
lookupDefiningFunction(op,sig,dc) ==
  -- 1. Read domain information, if available.  Silently give up if
  -- the constructor is just not there
  [ctor,:args] := dc
  db := constructorDB ctor or return nil -- we only deal with instantiations
  loadDBIfCan db
  dbTemplate db = nil => nil  -- incomplete functor
  -- 1.1. Niladic constructors don't need approximation.
  --      FIXME: However, there may be cylic dependencies
  --      such as AN ~> IAN ~> EXPR INT ~> AN that prevents
  --      us from full evaluation.  
  args = nil and symbolMember?(ctor,$SystemInlinableConstructorNames) =>
    compiledLookup(op,sig,dc)
  -- 1.2. Don't look into defaulting package
  isDefaultPackageName ctor => nil
  infovec := property(ctor,'infovec) or return nil
  -- 1.3. We need information about the original domain template
  shell := dbTemplate db               -- domain template
  opTable := second infovec            -- operator-code table
  opTableLength := #opTable
  forgetful := dbLookupFunction db is 'lookupIncomplete

  -- 2. Get the address range of op's descriptor set
  [.,.,.,:funDesc] := fourth infovec
  index := getOpCode(op, opTable, opTableLength - 1)
  -- 2.1. For a forgetful functor, try the add chain
  index = nil =>
    forgetful and lookupInheritedDefiningFunction(op,sig,shell,args,5)
  -- 2.2. The operation is either defined here, or is available
  --      from category package defaults.
  limit := 
    index + 2 < opTableLength => vectorRef(opTable,index + 2)
    #funDesc 

  -- 3. Locate the descriptor with matching signature
  loc := getFunctionTemplate(sig,opTable.index,limit,shell,args,funDesc)

  -- 4. Look into the add-chain if necessary
  loc = nil =>
    lookupInheritedDefiningFunction(op,sig,shell,args,domainRef(shell,5))

  -- 5. Give up if the operation is overloaded on semantics predicates.
  loc is 'ambiguous => nil

  -- 6. We have a location to a function descriptor.
  fun := domainRef(shell,loc)
  -- 6.1. A constant producing function?
  fun is ['%constant,[fun',.]] => fun'
  -- 6.2. An inherited function?
  fun is [idx,:.] => 
    not integer? idx => nil          -- a UFO?
    loc := arrayRef(funDesc,idx + 1)
    if loc = 0 then loc := 5
    domainRef(shell,loc) = nil => nil
    lookupInheritedDefiningFunction(op,sig,shell,args,shell.loc)
  -- 6.3. Whatever.
  fun

++ flag parameters needs to be made atomic, otherwise Lisp is confused.
++ We try our best to preserve
++ Note that we don't need substitution in the body because flag
++ parameters are never used in the body.
cleanParameterList! parms ==
  count := 0
  for vars in tails parms repeat
    v := first vars
    ident? v => nil
    t := nil
    until not symbolMember?(t,parms) repeat
      count := count + 1
      t := makeSymbol strconc('"T",toString count)
    vars.first := t
  parms

--%
--% Other compiler artifact support
--%

moveLibdirByCopy lib ==
  checkMkdir libDirname lib
  for src in directoryEntries libStationaryDirname lib repeat
    dst := makeFilePath(directory <- relativeDirname libDirname lib,
             name <- filePathName src, type <- filePathType src)
    copyFile(filePathString src,filePathString dst)
  removeFile libStationaryDirname lib = 0 => libDirname lib
  systemError ['"Could not remove stationary directory",
                :bright libStationaryDirname lib]