path: root/src/interp/functor.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 lisplib
import nruncomp
import category
namespace BOOT

--% Functions for building categories
 
CategoryPrint(D,$e) ==
  SAY "--------------------------------------"
  SAY "Name (and arguments) of category:"
  PRETTYPRINT canonicalForm D
  SAY "operations:"
  PRETTYPRINT categoryExports D
  SAY "attributes:"
  PRETTYPRINT categoryAttributes D
  SAY "This is a sub-category of"
  PRETTYPRINT first categoryRef(D,4)
  for u in second categoryRef(D,4) repeat
    SAY("This has an alternate view: slot ",rest u," corresponds to ",first u)
  for u in third categoryRef(D,4) repeat
    SAY("This has a local domain: slot ",rest u," corresponds to ",first u)
  for j in $NRTbase..maxIndex D repeat
    u := categoryRef(D,j)
    null u => SAY "another domain"
    first u isnt [.,:.] => SAY("Alternate View corresponding to: ",u)
    PRETTYPRINT u

--%  Domain printing
--Global strategy here is to maintain a list of substitutions
--  ( in $Sublis), of vectors and the names that they have,
--  which may be either local names ('View1') or global names ('Where1')
--  The global names are remembered on $Sublis from one
--  invocation of DomainPrint1 to the next
 
DomainPrint(D,brief) ==
  -- If brief is non-nil, %then only a summary is printed
  $WhereList: local := nil
  $Sublis: local := nil
  $WhereCounter: local := 1
  env:= $e or $EmptyEnvironment --in case we are called from top level
  categoryObject? D => CategoryPrint(D,env)
  $Sublis:= [[D,:'original]]
  SAY '"-----------------------------------------------------------------------"
  DomainPrint1(D,nil,env)
  while ($WhereList) repeat
    s:= $WhereList
    $WhereList:= nil
    for u in s repeat
      finishLine $OutputStream
      SAY ['"Where ",first u,'" is:"]
      DomainPrint1(rest u,brief,env)
  SAY '"-----------------------------------------------------------------------"
 
DomainPrint1(D,brief,$e) ==
  if vector? D then
    D := D.4 --if we were passed a vector, go to the domain
  Sublis:=
    [:
      [[rest u,:makeSymbol strconc('"View",toString i)]
        for u in D for i in 1..],:$Sublis]
  for u in D for i in 1.. repeat
    brief and i>1 => nil
    uu := copyVector rest u
    uu.4 := '"This domain"
    if not brief then
      SAY ['"View number ",i,'" corresponding to categories:"]
      PRETTYPRINT first u
    if i=1 and vector? uu.5 then
      vv := copyVector uu.5
      uu.5 := vv
      for j in 0..maxIndex vv repeat
        if vector? vv.j then
          l := objectAssoc(vv.j,Sublis)
          if l
             then name:= rest l
             else
              name := DPname()
              Sublis := [[vv.j,:name],:Sublis]
              $Sublis := [first Sublis,:$Sublis]
              $WhereList := [[name,:vv.j],:$WhereList]
          vv.j := name
    if i>1 then
      uu.1 := uu.2 := uu.5 := '"As in first view"
    for i in $NRTbase..maxIndex uu repeat
      uu.i := DomainPrintSubst(uu.i,Sublis)
      if vector? uu.i then
        name := DPname()
        Sublis := [[uu.i,:name],:Sublis]
        $Sublis := [first Sublis,:$Sublis]
        $WhereList := [[name,:uu.i],:$WhereList]
        uu.i := name
      if uu.i is [.,:v] and vector? v then
        name := DPname()
        Sublis := [[v,:name],:Sublis]
        $Sublis := [first Sublis,:$Sublis]
        $WhereList := [[name,:v],:$WhereList]
        uu.i := [first uu.i,:name]
    brief => PRETTYPRINT uu.0
    PRETTYPRINT uu
 
DPname() ==
  name := makeSymbol strconc('"Where",toString $WhereCounter)
  $WhereCounter := $WhereCounter+1
  name
 
PacPrint v ==
  vv := copyVector v
  for j in 0..maxIndex vv repeat
    if vector? vv.j then
      l := objectAssoc(vv.j,Sublis)
      if l
         then name := rest l
         else
          name := DPname()
          Sublis := [[vv.j,:name],:Sublis]
          $Sublis := [first Sublis,:$Sublis]
          $WhereList := [[name,:vv.j],:$WhereList]
      vv.j := name
    if cons? vv.j and vector?(u:=rest vv.j) then
      l := objectAssoc(u,Sublis)
      if l
         then name := rest l
         else
          name := DPname()
          Sublis := [[u,:name],:Sublis]
          $Sublis := [first Sublis,:$Sublis]
          $WhereList := [[name,:u],:$WhereList]
      vv.j.rest := name
  PRETTYPRINT vv
 
DomainPrintSubst(item,Sublis) ==
  item is [a,:b] =>
    c1 := DomainPrintSubst(a,Sublis)
    c2 := DomainPrintSubst(b,Sublis)
    sameObject?(c1,a) and sameObject?(c2,b) => item
    [c1,:c2]
  l := objectAssoc(item,Sublis)
  l => rest l
  l := objectAssoc(item,Sublis)
  l => rest l
  item
 
--%  Utilities
 
mkDevaluate a ==
  a = nil => nil
  a is ['QUOTE,a'] =>
    a' = nil => nil
    a
  a is '$ => MKQ '$
  a is ['%list,:.] =>
    a.args = nil => nil
    a
  ['devaluate,a]
 
getDomainView(domain,catform) ==
  u := HasCategory(domain,catform) => u
  c := eval catform
  u := HasCategory(domain,c.0) => u
  -- note:  this is necessary because of domain == another domain, e.g.
  -- Ps are defined to be SUPs with specific arguments so that if one
  -- asks if a P is a Module over itself, here one has catform= (Module
  -- (P I)) yet domain is a SUP.  By oding this evaluation, c.0=SUP as
  -- well and test works --- RDJ 10/31/83
  throwKeyedMsg("S2IF0009",[devaluate domain, catform])
 
getPrincipalView domain ==
  pview := domain
  for [.,:view] in domain.4 repeat
    if #view > #pview then
      pview := view
  pview
 
CategoriesFromGDC x ==
  x isnt [.,:.] => nil
  x is ['%list,a,:b] and a is ['QUOTE,a'] =>
    union([[a']],"union"/[CategoriesFromGDC u for u in b])
  x is ['QUOTE,a] and a is [b] => [a]
 
compCategories(db,u,e) ==
  u isnt [.,:.] => u
  u.op is [.,:.] =>
    error ['"compCategories: need an atom in operator position", u.op]
  u.op in '(Record Union Mapping) =>
    -- There is no modemap property for these guys so do it by hand.
    [u.op, :[compCategories1(db,a,$SetCategory,e) for a in u.args]]
  u is ['SubDomain,D,.] => compCategories(db,D,e)
  v :=
    symbolEq?(u.op,dbConstructor db) => [dbConstructorModemap db]
    get(u.op,'modemap,e)
  v isnt [.,:.] =>
    error ['"compCategories: could not get proper modemap for operator",u.op]
  if rest v then
    sayBrightly ['"compCategories: ", '"%b", '"Warning", '"%d",
                 '"ignoring unexpected stuff at end of modemap"]
    pp rest v
  -- the next line "fixes" a bad modemap which sometimes appears ....
  --
  if rest v and null CAAAR v then
    v := rest v
  v := resolvePatternVars(first(v).mmSource, u.args) -- replaces #n forms
  -- select the modemap part of the first entry, and skip result etc.
  [u.op,:[compCategories1(db,a,b,e) for a in u.args for b in v]]
 
compCategories1(db,u,v,e) ==
-- v is the mode of u
  u isnt [.,:.] => u
  u is [":",x,t] => [u.op,x,compCategories1(db,t,v,e)]
  isCategoryForm(v,e) => compCategories(db,u,e)
  [c,:.] := comp(macroExpand(u,e),v,e) => c
  error 'compCategories1
 
optFunctorBody(db,x) ==
  atomic? x => x
  x is ['DomainSubstitutionMacro,parms,body] =>
    optFunctorBody(db,DomainSubstitutionFunction(parms,body))
  x is ['%list,:l] =>
    null l => nil
    l:= [optFunctorBody(db,u) for u in l]
    every?(function optFunctorBodyQuotable,l) =>
      quote [optFunctorBodyRequote u for u in l]
    ['%list,:l]
  x is ['PROGN,:l] => ['%seq,:optFunctorPROGN(db,l)]
  x is ['%when,:l] =>
    l := [v for u in l | v := relevantClause(db,u)] where
            relevantClause(db,u) ==
              u is [pred,:conseq] =>
                u := [optFunctorBody(db,pred),:optFunctorPROGN(db,conseq)]
                u is ['%otherwise] => nil
                u
              nil
    l = nil => nil
    CAAR l='%otherwise =>
      (null CDAR l => nil; null CDDAR l => CADAR l; ['%seq,:CDAR l])
    null rest l and null CDAR l =>
            --there is no meat to this conditional form
      pred:= CAAR l
      pred isnt [.,:.] => nil
      first pred="HasCategory" => nil
      ['%when,:l]
    ['%when,:l]
  [optFunctorBody(db,first x),:optFunctorBody(db,rest x)]
 
optFunctorBodyQuotable u ==
  u = nil or integer? u or string? u => true
  u isnt [.,:.] => false
  u is ['QUOTE,:.] => true
  false
 
optFunctorBodyRequote u ==
  u isnt [.,:.] => u
  u is ['QUOTE,v] => v
  systemErrorHere ["optFunctorBodyRequote",u]
 
optFunctorPROGN(db,l) ==
  l is [x,:l'] =>
    worthlessCode(db,x) => optFunctorPROGN(db,l')
    l':= optFunctorBody(db,l')
    l' is [nil] => [optFunctorBody(db,x)]
    [optFunctorBody(db,x),:l']
  l
 
worthlessCode(db,x) ==
  x is ['%when,:l] => and/[x is [.,y] and worthlessCode(db,y) for x in l]
  x is ['PROGN,:l] => optFunctorPROGN(db,l) = nil
  x is ['%list] => true
  x = nil => true
  false
 
cons5(p,l) ==
  l and (CAAR l = first p) => [p,: rest l]
  # l < 5 => [p,:l]
  l.rest.rest.rest.rest.rest := nil
  [p,:l]
 
SetDomainSlots124(dom,names,vals) ==
  l := pairList(names,vals)
  domainDirectory(dom) := sublisProp(l,domainDirectory dom)
  domainAttributes(dom) := sublisProp(l,domainAttributes dom)
  l := [[a,:devaluate b] for a in names for b in vals]
  domainData(dom) := applySubst(l,domainData dom)
  domainDirectory(dom) := sublisProp(l,domainDirectory dom)
 
sublisProp(subst,props) ==
  null props => nil
  [cp,:props']:= props
  (a' := inspect(cp,subst)) where
    inspect(cp is [a,cond,:l],subst) ==
      cond=true => cp
                        --keep original CONS
      cond is ['or,:x] =>
        (or/[inspect(u,subst) for u in x] => [a,true,:l]; nil)
      cond is ["has",nam,b] and (val := objectAssoc(nam,subst)) =>
        ev :=
          b is ['ATTRIBUTE,c] => HasAttribute(rest val,c)
          b is ['SIGNATURE,c] => HasSignature(rest val,c)
          isDomainForm(b,$CategoryFrame) => b=rest val
          HasCategory(rest val,b)
        ev => [a,true,:l]
        nil
      cp
  not a' => sublisProp(subst,props')
  props' := sublisProp(subst,props')
  sameObject?(a',cp) and sameObject?(props',rest props) => props
  [a',:props']
 
mkTypeForm x ==
  x isnt [.,:.] => mkDevaluate x
  x.op in '(CATEGORY mkCategory) => MKQ x
  x is [":",selector,dom] =>
    ['%list,MKQ ":",MKQ selector,mkTypeForm dom]
  x.op is '%call => ['MKQ, optCall x]
        --The previous line added JHD/BMT 20/3/84
        --Necessary for proper compilation of DPOLY SPAD
  x is [op] =>
    op in '(Join %list) => nil
    MKQ x
  ['%list,MKQ x.op,:[mkTypeForm a for a in x.args]]
 
DescendCodeAdd(db,base,flag) ==
  base isnt [.,:.] => DescendCodeVarAdd(db,base,flag)
  modemap := get(base.op,'modemap,$CategoryFrame)
  modemap = nil  =>
      if getmode(base.op,$e) is ["Mapping",target,:formalArgModes]
         then formalArgs := take(#formalArgModes,$FormalMapVariableList)
                --argument substitution if parameterized?
 
         else keyedSystemError("S2OR0001",[base.op])
      DescendCodeAdd1(db,base,flag,target,formalArgs,formalArgModes)
  for [[[.,:formalArgs],target,:formalArgModes],.] in modemap repeat
    (ans:= DescendCodeAdd1(db,base,flag,target,formalArgs,formalArgModes)) =>
      return ans
  ans
 
DescendCodeAdd1(db,base,flag,target,formalArgs,formalArgModes) ==
  slist := pairList(formalArgs,rest $addFormLhs)
         --base = comp $addFormLhs-- bound in compAdd
  e:= $e
  newModes := applySubst(slist,formalArgModes)
  or/[not comp(u,m,e) for u in rest $addFormLhs for m in newModes] =>
    return nil
      --I should check that the actual arguments are of the right type
  for u in formalArgs for m in newModes repeat
    [.,.,e]:= compMakeDeclaration(u,m,e)
      --we can not substitute in the formal arguments before we comp
      --for that may change the shape of the object, but we must before
      --we match signatures
  cat:= (compMakeCategoryObject(target,e)).expr
  instantiatedBase:= genvar()
  n:=maxIndex cat
  code:=
    [u
      for i in $NRTbase..n | cons? cat.i and cons? (sig:= first cat.i)
         and
          (u:=
            SetFunctionSlots(db,applySubst(slist,sig),['ELT,instantiatedBase,i],flag,
              'adding))~=nil]
     --The code from here to the end is designed to replace repeated LOAD/STORE
     --combinations (SETELT ...(ELT ..)) by MVCs where this is practicable
  copyvec := newShell (1+n)
  (for u in code repeat
      if update(u,copyvec,[]) then code := remove(code,u))
    where update(code,copyvec,sofar) ==
      code isnt [.,:.] => nil
      code.op in '(%tref ELT) =>
          copyvec.(third code):=union(copyvec.(third code), sofar)
          true
      code is ['%store,['%tref,name,number],u'] =>
        update(u',copyvec,[[name,:number],:sofar])
  for i in $NRTbase..n repeat
    for u in copyvec.i repeat
      [name,:count]:=u
      j:=i+1
      while j<= MIN(n,i+63) and LASSOC(name,copyvec.j) = count+j-i repeat j:=j+1
             --Maximum length of an MVC is 64 words
      j:=j-1
      j > i+2 =>
        for k in i..j repeat
          copyvec.k := remove(copyvec.k,[name,:count+k-i])
        code:=[["REPLACE", name, instantiatedBase,
                 KEYWORD::START1, count,
                  KEYWORD::START2, i,
                   KEYWORD::END2, j+1],:code]
    copyvec.i =>
      v:=['%tref,instantiatedBase,i]
      for u in copyvec.i repeat
        [name,:count]:=u
        v:=['%store,['%tref,name,count],v]
      code:=[v,:code]
  [["%LET",instantiatedBase,base],:code]
 
++ In a conditional branch, 'cond' is the new condition guarding
++ a branch; return an updated predicate taking into account the
++ logical combination of preceding guards and an updated
++ 'continuation predicate reflecting the new condition.
addConditionToGuard(cond,existing) ==
  TruthP cond => [existing,:existing]
  TruthP existing => [cond,:['NOT,cond]]
  [['AND,existing,cond],:['AND,existing,['NOT,cond]]]

viewsUnderCondition(views,cond) ==
  cond is ['HasCategory,dom,cat] => [[dom,:cat],:views]
  views

DescendCode(db,code,flag,viewAssoc,e) ==
  -- flag = true if we are walking down code always executed;
  -- otherwise set to conditions in which
  code = nil => nil
  code is '%noBranch => nil
  isMacro(code,e) => nil --RDJ: added 3/16/83
  code is ['add,base,:codelist] =>
    codelist:=
      [v for u in codelist | v := DescendCode(db,u,flag,viewAssoc,e)]
                  -- must do this first, to get this overriding Add code
    ['PROGN,:DescendCodeAdd(db,base,flag),:codelist]
  code is ['PROGN,:codelist] =>
    ['PROGN,:
            --Two REVERSEs leave original order, but ensure last guy wins
      reverse! [v for u in reverse codelist |
                    v := DescendCode(db,u,flag,viewAssoc,e)]]
  code is ['%when,:condlist] =>
    c:= [[u2:= ProcessCond(db,first u,e),:q] for u in condlist] where q() ==
          null u2 => nil
          [f,:flag] := addConditionToGuard(u2,flag)
          [DescendCode(db,v,f,viewsUnderCondition(viewAssoc,first u),e)
             for v in rest u]
    TruthP CAAR c => ['%seq,:CDAR c]
    while (c and (last c is [c1] or last c is [c1,[]]) and
            (c1 = '%true or c1 is ['HasAttribute,:.])) repeat
                   --strip out some worthless junk at the end
        c:=reverse! rest reverse! c
    c = nil => ['%list]
    ['%when,:c]
  code is ["%LET",name,body,:.] =>
                    --only keep the names that are useful
    u := member(name,$locals) =>
        CONTAINED('$,body) and isDomainForm(body,e) =>
          --instantiate domains which depend on $ after constants are set
          code:=['%store,['%tref,['%tref,'$,$AddChainIndex],#$locals-#u],code]
          $epilogue:=
            TruthP flag => [code,:$epilogue]
            [['%when,[ProcessCond(db,flag,e),code]],:$epilogue]
          nil
        code
    code -- doItIf deletes entries from $locals so can't optimize this
  code is ['CodeDefine,sig,implem] =>
             --Generated by doIt in COMPILER BOOT
    dom :=
      u := symbolTarget('$,viewAssoc) => ['getDomainView,'$,u]
      '$
    body:= ['%closure,implem,dom]
    SetFunctionSlots(db,sig,body,flag,'original)
  code is ['_:,:.] => (code.first := '%list; code.rest := nil)
      --Yes, I know that's a hack, but how else do you kill a line?
  code is ['%list,:.] => nil
  code is ['devaluate,:.] => nil
  code is ['MDEF,:.] => nil
  code is ['%call,:.] => code
  code is ['%store,:.] => code -- can be generated by doItIf
  stackWarning('"unknown Functor code: %1 ",[code])
  code
 
ProcessCond(db,cond,e) ==
  ncond := dbSubstituteFormals(db,cond)
  valuePosition(ncond,$NRTslot1PredicateList) => predicateBitRef(db,ncond,e)
  cond

TryGDC cond ==
            --sees if a condition can be optimised by the use of
            --information in $getDomainCode
  cond isnt [.,:.] => cond
  cond is ['HasCategory,:l] =>
    solved := nil
    for u in $getDomainCode while solved = nil repeat
      if u is ["%LET",name, =cond] then
        solved := name
    solved ~= nil => solved
    cond
  cond
 
findOperatorImplementations(db,opsig) ==
  if $insideCategoryPackageIfTrue then
    opsig := substitute('$,second dbConstructorForm db,opsig)
  removeDuplicates [u.mapImpl for u in $lisplibOperationAlist |
                      opsig = u.mapOpsig and u.mapImpl isnt [.,.,nil]]
 
SetFunctionSlots(db,sig,body,flag,mode) == --mode is either "original" or "adding"
  null body => return nil
  for catImplem in findOperatorImplementations(db,sig) repeat
    catImplem is [q,.,index] and q in '(ELT CONST) =>
      if q = 'CONST and body is ['%closure,a,b] then
         body := ['%closure,'%constant,[second a,b]]
      body:= ['%store,['%tref,'$,index],body]
      not vector? $SetFunctions => nil --packages don't set it
      TruthP vectorRef($SetFunctions,index) =>   -- the function was already assigned
        return body := nil
      vectorRef($SetFunctions,index) :=
        TruthP flag => true
        not vectorRef($SetFunctions,index) => flag
        ['_or,vectorRef($SetFunctions,index),flag]
    catImplem is ['Subsumed,:truename] =>
      mode='original =>
        truename is [fn,:.] and fn in '(Zero One) => nil --hack by RDJ 8/90
        body := SetFunctionSlots(db,truename,body,nil,mode)
    keyedSystemError("S2OR0002",[catImplem])
  body is ['%store,:.] => body
  nil
 
--%  Under what conditions may views exist?
 
InvestigateConditions(db,catvecListMaker,tbl,env) ==
  -- given a principal view and a list of secondary views,
  -- discover under what conditions the secondary view are
  -- always present.
  $Conditions: local:= nil
  $principal: local := nil
  [$principal,:secondaries]:= catvecListMaker
      --We are not interested in the principal view
      --The next block allows for the possibility that $principal may
      --have conditional secondary views
  null secondaries => '(T)
      --return for packages which generally have no secondary views
  if $principal is [op,:.] then
    principal' := getCategoryObject(tbl,$principal,$e)
    for u in categoryAncestors principal' repeat
      if not TruthP(cond:=second u) then
        new:=['CATEGORY,'domain,['IF,cond,['ATTRIBUTE,first u], '%noBranch]]
        $principal is ['Join,:l] =>
          not listMember?(new,l) =>
            $principal:=['Join,:l,new]
        $principal:=['Join,$principal,new]
  principal' :=
    pessimise $principal where
      pessimise a ==
        a isnt [.,:.] => a
        a is ['SIGNATURE,:.] => a
        a is ['IF,cond,:.] =>
          if not listMember?(cond,$Conditions) then
            $Conditions:= [cond,:$Conditions]
          nil
        [pessimise first a,:pessimise rest a]
  null $Conditions => [true,:[true for u in secondaries]]
  PrincipalSecondaries:= getViewsConditions(principal',tbl)
  MinimalPrimary:= first first PrincipalSecondaries
  MaximalPrimary := first categoryPrincipals dbDomainShell db
  necessarySecondaries:= [first u for u in PrincipalSecondaries | rest u=true]
  and/[listMember?(u,necessarySecondaries) for u in secondaries] =>
    [true,:[true for u in secondaries]]
  $HackSlot4:=
    MinimalPrimary=MaximalPrimary => nil
    MaximalPrimaries :=
      [MaximalPrimary,:categoryPrincipals CatEval(MaximalPrimary,tbl,env)]
    MinimalPrimaries :=
      [MinimalPrimary,:categoryPrincipals CatEval(MinimalPrimary,tbl,env)]
    MaximalPrimaries:=S_-(MaximalPrimaries,MinimalPrimaries)
    [[x] for x in MaximalPrimaries]
  ($Conditions:= Conds($principal,nil)) where
    Conds(code,previous) ==
           --each call takes a list of conditions, and returns a list
           --of refinements of that list
      code isnt [.,:.] => [previous]
      code is ['DomainSubstitutionMacro,.,b] => Conds(b,previous)
      code is ['IF,a,b,c] => union(Conds(b,[a,:previous]),Conds(c,previous))
      code is ['PROGN,:l] => "union"/[Conds(u,previous) for u in l]
      code is ['CATEGORY,:l] => "union"/[Conds(u,previous) for u in l]
      code is ['Join,:l] => "union"/[Conds(u,previous) for u in l]
      [previous]
  $Conditions := remove!([remove!(u,nil) for u in $Conditions],nil)
  partList:=
    [getViewsConditions(partPessimise($principal,cond),tbl) for cond in $Conditions]
  masterSecondaries:= secondaries
  for u in partList repeat
    for [v,:.] in u repeat
      if not listMember?(v,secondaries) then
        secondaries:= [v,:secondaries]
  list:= [listMember?(u,necessarySecondaries) for u in secondaries]
  for u in $Conditions for newS in partList repeat
    --newS is a list of secondaries and conditions (over and above
    --u) for which they apply
    u:=
      # u=1 => first u
      ['AND,:u]
    for [v,:.] in newS repeat
      for v' in [v,:categoryPrincipals CatEval(v,tbl,env)] repeat
        if (w:=assoc(v',$HackSlot4)) then
          w.rest := if rest w then mkOr(u,rest w,tbl,env) else u
    (list:= update(list,u,secondaries,newS,tbl,env)) where
      update(list,cond,secondaries,newS,tbl,env) ==
        (list2:=
          [flist(sec,newS,old,cond,tbl,env) for sec in secondaries for old in list]) where
            flist(sec,newS,old,cond,tbl,env) ==
              old=true => old
              for [newS2,:morecond] in newS repeat
                old:=
                  not ancestor?(sec,[newS2],tbl,env) => old
                  cond2 := mkAnd(cond,morecond,tbl,env)
                  null old => cond2
                  mkOr(cond2,old,tbl,env)
              old
        list2
  list:= [[sec,:ICformat(db,u,tbl,env)] for u in list for sec in secondaries]
  pv:= getPossibleViews($principal,tbl)
  -- $HackSlot4 is used in SetVector4 to ensure that conditional
  -- extensions of the principal view are handles correctly
  -- here we build the code necessary to remove spurious extensions
  ($HackSlot4:= [reshape(db,u,tbl,env) for u in $HackSlot4]) where
    reshape(db,u,tbl,env) ==
      ['%when,[TryGDC ICformat(db,rest u,tbl,env)],
             ['%otherwise,['RPLACA,'(CAR TrueDomain),
                             ['delete, quote first u,'(CAAR TrueDomain)]]]]
  $supplementaries:=
    [u
      for u in list | not listMember?(first u,masterSecondaries)
        and not (true=rest u) and not listMember?(first u,pv)]
  [true,:[LASSOC(ms,list) for ms in masterSecondaries]]
 
ICformat(db,u,tbl,env) ==
      u isnt [.,:.] => u
      u is ["has",:.] => compHasFormat(db,u,env)
      u is ['AND,:l] or u is ['and,:l] =>
        l:= removeDuplicates [ICformat(db,v,tbl,env) for [v,:l'] in tails l
                                | not listMember?(v,l')]
             -- we could have duplicates after, even if not before
        # l=1 => first l
        l1:= first l
        for u in rest l repeat
          l1 := mkAnd(u,l1,tbl,env)
        l1
      u is ['OR,:l] =>
        (l:= ORreduce l)
        # l=1 => ICformat(db,first l,tbl,env)
        l:= ORreduce removeDuplicates [ICformat(db,u,tbl,env) for u in l]
                 --causes multiple ANDs to be squashed, etc.
                 -- and duplicates that have been built up by tidying
        (l:= Hasreduce(l,tbl,env)) where
          Hasreduce(l,tbl,env) ==
            for u in l | u is ['HasCategory,name,cond] and cond is ['QUOTE,
              cond] repeat
                                  --check that v causes descendants to go
                for v in l | not (v=u) and v is ['HasCategory, =name,['QUOTE,
                  cond2]] repeat
                       if descendant?(cond,cond2,tbl,env) then l:= remove(l,u)
                       --v subsumes u
            for u in l | u is ['AND,:l'] or u is ['and,:l'] repeat
              for u' in l' | u' is ['HasCategory,name,cond] and cond is ['QUOTE,
                cond] repeat
                                    --check that v causes descendants to go
                  for v in l | v is ['HasCategory, =name,['QUOTE,
                    cond2]] repeat
                        if descendant?(cond,cond2,tbl,env) then l:= remove(l,u)
                         --v subsumes u
            l
        # l=1 => first l
        ['OR,:l]
      systemErrorHere ["ICformat",u]
  where
    ORreduce l ==
      for u in l | u is ['AND,:.] or u is ['and,:.] repeat
                            --check that B causes (and A B) to go
        for v in l | not (v=u) repeat
          if listMember?(v,u) or (and/[member(w,u) for w in v]) then l:=
            remove(l,u)
                 --v subsumes u
                     --Note that we are ignoring AND as a component.
                     --Convince yourself that this code still works
      l
 
partPessimise(a,trueconds) ==
  a isnt [.,:.] => a
  a is ['SIGNATURE,:.] => a
  a is ['IF,cond,:.] => (listMember?(cond,trueconds) => a; nil)
  [partPessimise(first a,trueconds),:partPessimise(rest a,trueconds)]
 
getPossibleViews(u,tbl) ==
  --returns a list of all the categories that can be views of this one
  vec := getCategoryObject(tbl,u,$e)
  views:= [first u for u in categoryAncestors vec]
  null vec.0 => [first categoryPrincipals vec,:views] --*
  [vec.0,:views] --*
      --the two lines marked  ensure that the principal view comes first
      --if you don't want it, rest it off
 
getViewsConditions(u,tbl) ==
  --returns a list of all the categories that can be views of this one
  --paired with the condition under which they are such views
  vec := getCategoryObject(tbl,u,$e)
  views:= [[first u,:second u] for u in categoryAncestors vec]
  null vec.0 =>
    null categoryPrincipals vec => views
    [[first categoryPrincipals vec,:true],:views] --*
  [[vec.0,:true],:views] --*
      --the two lines marked  ensure that the principal view comes first
      --if you don't want it, rest it off
 
DescendCodeVarAdd(db,base,flag) ==
   [SetFunctionSlots(db,sig,implem,flag,'adding) repeat
       for i in $NRTbase..maxIndex dbDomainShell db |
         categoryRef(dbDomainShell db,i) is [sig:=[op,types],:.] and
           LASSOC([base,:substitute(base,'$,types)],get(op,'modemap,$e)) is
                  [[pred,implem]]]
 
resolvePatternVars(p,args) ==
  p := applySubst(pairList($TriangleVariableList,args),p)
  applySubst(pairList($FormalMapVariableList,args),p)

--% Code Processing Packages

isCategoryPackageName nam ==
  isDefaultPackageName opOf nam

mkOperatorEntry(opSig is [op,sig,:flag],pred,count) ==
  null flag => [opSig,pred,["ELT","$",count]]
  first flag="constant" => [[op,sig],pred,["CONST","$",count]]
  systemError ["unknown variable mode: ",flag]
 
--% Code for encoding function names inside package or domain
 
++ Return the linkage name of the local operation named `op'.
encodeLocalFunctionName op ==
  prefix :=
    $prefix => $prefix
    $functorForm => symbolName dbAbbreviation constructorDB $functorForm.op
    stackAndThrow('"There is no context for local function %1b",[op]) 
  makeSymbol strconc(prefix,'";",symbolName op)
 
splitEncodedFunctionName(encodedName, sep) ==
    -- [encodedPackage, encodedItem, encodedSig, sequenceNo] or nil
    -- sep0 is the separator used in "encodeFunctionName".
    sep0 := '";"
    if not string? encodedName then
        encodedName := STRINGIMAGE encodedName
    null (p1 := STRPOS(sep0, encodedName, 0,    '"*")) => nil
    null (p2 := STRPOS(sep0, encodedName, p1+1, '"*")) => 'inner
--  This is picked up in compile for inner functions in partial compilation
    null (p3 := STRPOS(sep,  encodedName, p2+1, '"*")) => nil
    s1 := subString(encodedName, 0,    p1)
    s2 := subString(encodedName, p1+1, p2-p1-1)
    s3 := subString(encodedName, p2+1, p3-p2-1)
    s4 := subString(encodedName, p3+1)
    [s1, s2, s3, s4]