path: root/src/interp/wi2.boot

-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
-- All rights reserved.
-- Copyright (C) 2007-2010, 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 macros
import define
namespace BOOT

-- ??? turns off buggy code
$NRTopt := false

compDefineFunctor1(df, m,$e,$prefix,$formalArgList) ==
    ['DEF,form,signature,$functorSpecialCases,body] := df
    signature := markKillAll signature
--  1. bind global variables
    $addForm: local := nil
    $functionStats: local:= [0,0]
    $functorStats: local:= [0,0]
    $DEFdepth :    local  := 0            --for conversion to new compiler 3/93
    $capsuleStack : local := nil          --for conversion to new compiler 3/93
    $predicateStack:local := nil          --for conversion to new compiler 3/93
    $signatureStack:local := nil          --for conversion to new compiler 3/93
    $importStack  : local := nil          --for conversion to new compiler 3/93
    $globalImportStack  : local := nil    --for conversion to new compiler 3/93
    $globalDeclareStack : local := nil
    $globalImportDefAlist: local:= nil
    $localMacroStack  : local := nil      --for conversion to new compiler 3/93
    $freeStack   : local := nil           --for conversion to new compiler 3/93
    $domainLevelVariableList: local := nil--for conversion to new compiler 3/93
    $localLoopVariables: local := nil
    $pathStack : local := nil
    $form: local := nil
    $op: local := nil
    $signature: local := nil
    $functorTarget: local := nil
    $Representation: local := nil
         --Set in doIt, accessed in the compiler - compNoStacking
    $LocalDomainAlist: local  --set in doIt, accessed in genDeltaEntry
    $LocalDomainAlist:= nil
    $functorForm: local := nil
    $functorLocalParameters: local := nil
    $CheckVectorList: local := nil
                  --prevents CheckVector from printing out same message twice
    $getDomainCode: local -- code for getting views
    $insideFunctorIfTrue: local:= true
    $setelt: local := "setShellEntry"
    $genSDVar: local:= 0
    originale:= $e
    [$op,:argl]:= form
    $formalArgList:= [:argl,:$formalArgList]
    $pairlis := pairList(argl,$FormalMapVariableList)
    $mutableDomain: local :=
      -- all defaulting packages should have caching turned off
       isCategoryPackageName $op or   
         (if $mutableDomains then MEMQ($op,$mutableDomains)
            else false )   --true if domain has mutable state
    signature':=
      [first signature,:[getArgumentModeOrMoan(a,form,$e) for a in argl]]
    $functorForm:= $form:= [$op,:argl]
    $globalImportStack := 
       [markKillAll x for x in rest $functorForm for typ in rest signature' 
           | getConstructorKindFromDB opOf typ = "category"]
    if null first signature' then signature':=
      modemap2Signature getModemap($form,$e)
    target:= first signature'
    $functorTarget:= target
    $e:= giveFormalParametersValues(argl,$e)
    [ds,.,$e]:= compMakeCategoryObject(target,$e) or
--+ copy needed since slot1 is reset; compMake.. can return a cached vector
      sayBrightly '"   cannot produce category object:"
      pp target
      return nil
    $domainShell:= COPY_-SEQ ds
    attributeList := ds.2 --see below under "loadTimeAlist"
--+ 7 lines for $NRT follow
-->--these globals used by NRTmakeCategoryAlist, set by NRTsetVector4Part1
    $condAlist: local := nil
    $uncondAlist: local := nil
-->>-- next global initialized here, reset by buildFunctor
    $NRTslot1PredicateList: local :=
      removeDuplicates [second x for x in attributeList]
-->>-- next global initialized here, used by NRTgenAttributeAlist (NRUNOPT)
    $NRTattributeAlist: local := NRTgenInitialAttributeAlist attributeList
    $NRTslot1Info: local := nil --set in NRTmakeSlot1Info
       --this is used below to set $lisplibSlot1 global
    $NRTaddForm: local := nil   -- see compAdd
    $NRTdeltaList: local := nil --list of misc. elts used in compiled fncts
    $NRTdeltaListComp: local := nil --list of compiled forms for $NRTdeltaList
    $NRTdeltaLength: local := 0 -- =length of block of extra entries in vector
    $template: local:= nil --stored in the lisplib
    $functionLocations: local := nil --locations of defined functions in source
    -- generate slots for arguments first, then for $NRTaddForm in compAdd
    for x in argl repeat NRTgetLocalIndex x
    [.,.,$e]:= compMakeDeclaration("$",target,$e)
    --The following loop sees if we can economise on ADDed operations
    --by using those of Rep, if that is the same. Example: DIRPROD
    if not $insideCategoryPackageIfTrue  then
      if body is ['add,ab:=[fn,:.],['CAPSULE,:cb]] and fn in '(List Vector)
         and FindRep(cb) = ab
               where FindRep cb ==
                 u:=
                   while cb repeat
                     atom cb => return nil
                     cb is [["%LET",'Rep,v,:.],:.] => return (u:=v)
                     cb:=rest cb
                 u
      then $e:= augModemapsFromCategoryRep('_$,ab,cb,target,$e)
      else $e:= augModemapsFromCategory('_$,'_$,'_$,target,$e)
    $signature:= signature'
    operationAlist:= SUBLIS($pairlis,$domainShell.(1))
    parSignature:= SUBLIS($pairlis,signature')
    parForm:= SUBLIS($pairlis,form)
 
--  (3.1) now make a list of the functor's local parameters; for
--  domain D in argl,check its signature: if domain, its type is Join(A1,..,An);
--  in this case, D is replaced by D1,..,Dn (gensyms) which are set
--  to the A1,..,An view of D
--+
    $functorLocalParameters:=
      argPars :=
        makeFunctorArgumentParameters(argl,rest signature',first signature')
 -- must do above to bring categories into scope --see line 5 of genDomainView
      argl
--  4. compile body in environment of %type declarations for arguments
    op':= $op
    rettype:= signature'.target
    T:= compFunctorBody(body,rettype,$e,parForm)
---------------> new <---------------------
    $convert2NewCompiler => 
       return markFinish($originalBody,[$form,['Mapping,:signature'],T.env])
---------------> new <---------------------
    -- If only compiling certain items, then ignore the body shell.
    $compileOnlyCertainItems =>
       reportOnFunctorCompilation()
       [nil, ['Mapping, :signature'], originale]
 
    body':= T.expr
    lamOrSlam:= if $mutableDomain then 'LAM else 'SPADSLAM
    fun:= compile SUBLIS($pairlis, [op',[lamOrSlam,argl,body']])
    --The above statement stops substitutions gettting in one another's way
--+
    operationAlist := SUBLIS($pairlis,$lisplibOperationAlist)
    if $LISPLIB then
      augmentLisplibModemapsFromFunctor(parForm,operationAlist,parSignature)
    reportOnFunctorCompilation()
 
--  5. give operator a 'modemap property
    $insideFunctorIfTrue:= false
    if $LISPLIB then
      $lisplibKind:=
        $functorTarget is ["CATEGORY",key,:.] and key~="domain" => 'package
        'domain
      $lisplibForm:= form
      modemap:= [[parForm,:parSignature],[true,op']]
      $lisplibModemap:= modemap
      if null $bootStrapMode then
        $NRTslot1Info := NRTmakeSlot1Info()
        $isOpPackageName: local := isCategoryPackageName $op
        if $isOpPackageName then lisplibWrite('"slot1DataBase",
          ['updateSlot1DataBase,MKQ $NRTslot1Info],$libFile)
        $lisplibFunctionLocations := SUBLIS($pairlis,$functionLocations)
        libFn := getConstructorAbbreviation op'
        $lookupFunction: local :=
            NRTgetLookupFunction($functorForm,$lisplibModemap.mmTarget,$NRTaddForm)
            --either lookupComplete (for forgetful guys) or lookupIncomplete
        $byteAddress :local := 0
        $byteVec :local := nil
        $NRTslot1PredicateList :=
          [simpBool x for x in $NRTslot1PredicateList]
        rwriteLispForm('loadTimeStuff,
          ['MAKEPROP,MKQ $op,''infovec,getInfovecCode()])
      $lisplibSlot1 := $NRTslot1Info --NIL or set by $NRTmakeSlot1
      $lisplibOperationAlist:= operationAlist
    lisplibWrite('"compilerInfo",
       ['SETQ,'$CategoryFrame,
        ['put,['QUOTE,op'],'
         (QUOTE isFunctor),
          ['QUOTE,operationAlist],['addModemap,['QUOTE,op'],['
           QUOTE,parForm],['QUOTE,parSignature],true,['QUOTE,op'],
            ['put,['QUOTE,op' ],'(QUOTE mode),
             ['QUOTE,['Mapping,:parSignature]],'$CategoryFrame]]]],$libFile)
    if null argl then
      evalAndRwriteLispForm('NILADIC,
            ['MAKEPROP, ['QUOTE,op'], ['QUOTE,'NILADIC], true])
    [fun,['Mapping,:signature'],originale]

makeFunctorArgumentParameters(argl,sigl,target) ==
  $forceAdd: local:= true
  $ConditionalOperators: local
  target := markKillAll target
  ("append"/[fn(a,augmentSig(s,findExtras(a,target)))
              for a in argl for s in sigl]) where
    findExtras(a,target) ==
      --  see if conditional information implies anything else
      --  in the signature of a
      target is ['Join,:l] => "union"/[findExtras(a,x) for x in l]
      target is ['CATEGORY,.,:l] => "union"/[findExtras1(a,x) for x in l] where
        findExtras1(a,x) ==
          x is ['AND,:l] => "union"/[findExtras1(a,y) for y in l]
          x is ['OR,:l] => "union"/[findExtras1(a,y) for y in l]
          x is ['IF,c,p,q] =>
            union(findExtrasP(a,c),
                  union(findExtras1(a,p),findExtras1(a,q))) where
              findExtrasP(a,x) ==
                x is ['AND,:l] => "union"/[findExtrasP(a,y) for y in l]
                x is ['OR,:l] => "union"/[findExtrasP(a,y) for y in l]
                x is ["has",=a,y] and y is ['SIGNATURE,:.] => [y]
                nil
        nil
    augmentSig(s,ss) ==
       -- if we find something extra, add it to the signature
      null ss => s
      for u in ss repeat
        $ConditionalOperators:=[rest u,:$ConditionalOperators]
      s is ['Join,:sl] =>
        u:=ASSQ('CATEGORY,ss) =>
          SUBST([:u,:ss],u,s)
        ['Join,:sl,['CATEGORY,'package,:ss]]
      ['Join,s,['CATEGORY,'package,:ss]]
    fn(a,s) ==
      isCategoryForm(s,$CategoryFrame) =>
        s is ["Join",:catlist] => genDomainViewList(a,rest s)
        [genDomainView(a,a,s,"getDomainView")]
      [a]

compDefineCapsuleFunction(df,m,oldE,$prefix,$formalArgList) ==
    ['DEF,form,originalSignature,specialCases,body] := df
    signature := markKillAll originalSignature
    $markFreeStack: local := nil       --holds "free variables"
    $localImportStack : local := nil   --local import stack for function
    $localDeclareStack: local := nil   
    $localLoopVariables: local := nil
    originalDef := COPY df
    [lineNumber,:specialCases] := specialCases
    e := oldE
    --1. bind global variables
    $form: local := nil
    $op: local := nil
    $functionStats: local:= [0,0]
    $argumentConditionList: local
    $finalEnv: local := nil
             --used by ReplaceExitEtc to get a common environment
    $initCapsuleErrorCount: local:= #$semanticErrorStack
    $insideCapsuleFunctionIfTrue: local:= true
    $CapsuleModemapFrame: local:= e
    $CapsuleDomainsInScope: local:= get("$DomainsInScope","special",e)
    $insideExpressionIfTrue: local:= true
    $returnMode:= m
    [$op,:argl]:= form
    $form:= [$op,:argl]
    argl:= stripOffArgumentConditions argl
    $formalArgList:= [:argl,:$formalArgList]
 
    --let target and local signatures help determine modes of arguments
    argModeList:=
      identSig:= hasSigInTargetCategory(argl,form,first signature,e) =>
        (e:= checkAndDeclare(argl,form,identSig,e); rest identSig)
      [getArgumentModeOrMoan(a,form,e) for a in argl]
    argModeList:= stripOffSubdomainConditions(argModeList,argl)
    signature':= [first signature,:argModeList]
    if null identSig then  --make $op a local function
      oldE := put($op,'mode,['Mapping,:signature'],oldE)
 
    --obtain target type if not given
    if null first signature' then signature':=
      identSig => identSig
      getSignature($op,rest signature',e) or return nil
    e:= giveFormalParametersValues(argl,e)
 
    $signatureOfForm:= signature' --this global is bound in compCapsuleItems
    $functionLocations := [[[$op,$signatureOfForm],:lineNumber],
      :$functionLocations]
    e:= addDomain(first signature',e)
    e:= compArgumentConditions e
 
    if $profileCompiler then
      for x in argl for t in rest signature' repeat profileRecord('arguments,x,t)
 
 
    --4. introduce needed domains into extendedEnv
    for domain in signature' repeat e:= addDomain(domain,e)
 
    --6. compile body in environment with extended environment
    rettype:= resolve(signature'.target,$returnMode)
 
    localOrExported :=
      not MEMQ($op,$formalArgList) and
        getmode($op,e) is ['Mapping,:.] => 'local
      'exported
 
    --6a skip if compiling only certain items but not this one
    -- could be moved closer to the top
    formattedSig := formatUnabbreviated ['Mapping,:signature']
    $compileOnlyCertainItems and _
      not member($op, $compileOnlyCertainItems) =>
        sayBrightly ['"   skipping ", localOrExported,:bright $op]
        [nil,['Mapping,:signature'],oldE]
    sayBrightly ['"   compiling ",localOrExported,
      :bright $op,'": ",:formattedSig]
---------------------> new <---------------------------------
    returnType := signature'.target
--  trialT := returnType = "$" and get("Rep",'value,e) and comp(body,'Rep,e)
    trialT := returnType = "$" and comp(body,$EmptyMode,e)
    ------------------------------------------------------  11/1/94    
    -- try comp-ing in $EmptyMode; if succeed 
    --   if we succeed then trialT.mode = "$" or "Rep"
    --   do a coerce to get the correct result
    T := (trialT and coerce(trialT,returnType)) 
         -------------------------------------- 11/1/94
          or CATCH('compCapsuleBody, compOrCroak(body,returnType,e))
    markChanges(originalDef,T,$signatureOfForm)
    [nil,['Mapping,:signature'],oldE]
    ---------------------------------
 
compCapsuleInner(itemList,m,e) ==
  e:= addInformation(m,e)
           --puts a new 'special' property of $Information
  data:= ["PROGN",:itemList]
      --RPLACd by compCapsuleItems and Friends
  e:= compCapsuleItems(itemList,nil,e)
  $convert2NewCompiler => 
     [nil,m,e] --nonsense but that's fine
  localParList:= $functorLocalParameters
  if $addForm then data:= ['add,$addForm,data]
  code:=
    $insideCategoryIfTrue and not $insideCategoryPackageIfTrue => data
    processFunctor($form,$signature,data,localParList,e)
  [MKPF([:$getDomainCode,code],"PROGN"),m,e]

compSingleCapsuleItem(item,$predl,$e) ==
  $localImportStack : local := nil
  $localDeclareStack: local := nil
  $markFreeStack: local := nil
  newItem := macroExpandInPlace(item,qe(25,$e))
  qe(26,$e)
  doIt(newItem, $predl)
  qe(27,$e)
  $e
 
compImport(["import",:doms],m,e) ==
  for dom in doms repeat 
    dom := markKillAll dom
    markImport dom
    e:=addDomain(dom,e)
  ["/throwAway",$NoValueMode,e]
 
mkUnion(a,b) ==
  b="$" and $Rep is ["Union",:l] => b
  a is ["Union",:l] =>
    b is ["Union",:l'] => ["Union",:setUnion(l,l')]
    member(b, l) => a
    ["Union",:setUnion([b],l)]
  b is ["Union",:l] => 
    member(a, l) => b
    ["Union",:setUnion([a],l)]
  string? a => ["Union",b,a]
  ["Union",a,b]

compForMode(x,m,e) ==
  $compForModeIfTrue: local:= true
  $convert2NewCompiler: local := nil
  comp(x,m,e)
 
compMakeCategoryObject(c,$e) ==
  not isCategoryForm(c,$e) => nil
  c := markKillAll c
  u:= mkEvalableCategoryForm c => [eval markKillAll u,$Category,$e]
  nil
 
macroExpand(x,e) ==   --not worked out yet
  atom x => (u:= get(x,'macro,e) => macroExpand(u,e); x)
  x is ['DEF,lhs,sig,spCases,rhs] =>
    ['DEF,macroExpand(lhs,e), macroExpandList(sig,e),macroExpandList(spCases,e),
      macroExpand(rhs,e)]
  x is ['MI,a,b] => 
      ['MI,a,macroExpand(b,e)]
  macroExpandList(x,e)
 
--======================================================================
--                    From apply.boot
--======================================================================
applyMapping([op,:argl],m,e,ml) ==
  #argl~=#ml-1 => nil
  isCategoryForm(first ml,e) =>
                                --is op a functor?
    pairlis:= pairList(argl,$FormalMapVariableList)
    ml' := SUBLIS(pairlis, ml)
    argl':=
      [T.expr for x in argl for m' in rest ml'] where
        T() == [.,.,e]:= comp(x,m',e) or return "failed"
    if argl'="failed" then return nil
    form:= [op,:argl']
---------------------> new <----------------------------
    if constructor? op then form := markKillAll form
---------------------> new <----------------------------
    convert([form,first ml',e],m)
  argl':=
    [T.expr for x in argl for m' in rest ml] where
      T() == [.,.,e]:= comp(x,m',e) or return "failed"
  if argl'="failed" then return nil
  form:=
    not MEMQ(op,$formalArgList) and atom op and not get(op,'value,e) =>
      nprefix := $prefix or
   -- following needed for referencing local funs at capsule level
        getAbbreviation($op,#rest $form)
      [op',:argl',"$"] where
        op':= INTERN strconc(encodeItem nprefix,";",encodeItem op)
    ['%call,['applyFun,op],:argl']
  pairlis := pairList(argl',$FormalMapVariableList)
  convert([form,SUBLIS(pairlis,first ml),e],m)
 
compFormWithModemap(form,m,e,modemap) ==
  compFormWithModemap1(form,m,e,modemap,true) or compFormWithModemap1(form,m,e,modemap,false)

compFormWithModemap1(form,m,e,modemap,Rep2Dollar?) ==
  [op,:argl] := form := markKillExpr form
  [[dc,:.],:.] := modemap
----------> new: <-----------
  if Rep2Dollar? then 
    if dc = 'Rep then
      modemap := SUBST('Rep,'_$,modemap)
      m       := SUBST('Rep,'_$,m)
    else return nil
----------> new: <-----------
  [map:= [.,target,:.],[pred,impl]]:= modemap
  -- this fails if the subsuming modemap is conditional
  --impl is ['Subsumed,:.] => nil
  if isCategoryForm(target,e) and isFunctor op then
    [modemap,e]:= substituteIntoFunctorModemap(argl,modemap,e) or return nil
    [map:= [.,target,:.],:cexpr]:= modemap
  sv:=listOfSharpVars map
  if sv then
     -- SAY [ "compiling ", op, " in compFormWithModemap,
     -- mode= ",map," sharp vars=",sv]
    for x in argl for ss in $FormalMapVariableList repeat
      if ss in sv then
        [map:= [.,target,:.],:cexpr]:= modemap :=SUBST(x,ss,modemap)
        -- SAY ["new map is",map]
  not (target':= coerceable(target,m,e)) => nil
  markMap := map
  map:= [target',:rest map]
  [f,Tl,sl]:= compApplyModemap(form,modemap,e) or return nil
 
  --generate code; return
  T:=
    e':=
      Tl => (LAST Tl).env
      e
    [x',m',e'] where
      m':= SUBLIS(sl,map.(1))
      x':=
        form':= [f,:[t.expr for t in Tl]]
        m'=$Category or isCategoryForm(m',e) => form'
        -- try to deal with new-style Unions where we know the conditions
        op = "elt" and f is ['XLAM,:.] and IDENTP(z:=first argl) and
          (c:=get(z,'condition,e)) and
            c is [["case",=z,c1]] and
              (c1 is ['_:,=(second argl),=m] or EQ(c1,second argl) ) =>
-- first is a full tag, as placed by getInverseEnvironment
-- second is what getSuccessEnvironment will place there
                ['%tail,z]
        markTran(form,form',markMap,e')
  qt(18,T)
  convert(T,m)

convert(T,m) ==
  tcheck T
  qe(23,T.env)
  coerce(T,resolve(T.mode,m) or return nil)

compElt(origForm,m,E) ==
  form := markKillAll origForm
  form isnt ["elt",aDomain,anOp] => compForm(origForm,m,E)
  aDomain="Lisp" =>
    markLisp([anOp',m,E],E)where anOp'() == (anOp=$Zero => 0; anOp=$One => 1; anOp)
  isDomainForm(aDomain,E) =>
    markImport opOf aDomain
    E:= addDomain(aDomain,E)
    mmList:= getModemapListFromDomain(anOp,0,aDomain,E)
    modemap:=
      n:=#mmList
      1=n => mmList.(0)
      0=n =>
        return
          stackMessage ['"Operation ","%b",anOp,"%d",
                         '"missing from domain: ", aDomain]
      stackWarning ['"more than 1 modemap for: ",anOp,
                  '" with dc=",aDomain,'" ===>"
        ,mmList]
      mmList.(0)
----------> new: <-----------
    if aDomain = 'Rep then
      modemap := SUBST('Rep,'_$,modemap)
      m       := SUBST('Rep,'_$,m)
----------> new: <-----------
    [sig,[pred,val]]:= modemap
    #sig~=2 and val isnt ["CONST",:.] => nil
--+
    val := genDeltaEntry([opOf anOp,:modemap],E)
    x := markTran(origForm,[val],sig,[E])
    [x,second sig,E] --implies fn calls used to access constants
  compForm(origForm,m,E)
 
pause op == op
compApplyModemap(form,modemap,$e) ==
  sl := nil
  [op,:argl] := form                   --form to be compiled
  [[mc,mr,:margl],:fnsel] := modemap   --modemap we are testing
 
  -- $e     is the current environment
  -- sl     substitution list, nil means bottom-up, otherwise top-down
 
  -- 0.  fail immediately if #argl=#margl
 
  if #argl~=#margl then return nil
 
  -- 1.  use modemap to evaluate arguments, returning failed if
  --     not possible
 
  lt:=
    [[.,m',$e]:=
      comp(y,g,$e) or return "failed" where
        g:= SUBLIS(sl,m) where
            sl:= pmatchWithSl(m',m,sl) for y in argl for m in margl]
  lt="failed" => return nil
 
  -- 2.  coerce each argument to final domain, returning failed
  --     if not possible
 
  lt':= [coerce(y,d) or return "failed"
         for y in lt for d in SUBLIS(sl,margl)]
  lt'="failed" => return nil
 
  -- 3.  obtain domain-specific function, if possible, and return
 
  --$bindings is bound by compMapCond
  [f,$bindings]:= compMapCond(op,mc,sl,fnsel) or return nil
 
--+ can no longer trust what the modemap says for a reference into
--+ an exterior domain (it is calculating the displacement based on view
--+ information which is no longer valid; thus ignore this index and
--+ store the signature instead.
 
--$NRTflag=true and f is [op1,d,.] and NE(d,'$) and member(op1,'(ELT CONST)) =>
  f is [op1,d,.] and op1 in '(ELT CONST Subsumed) =>
    [genDeltaEntry([op,:modemap],$e),lt',$bindings]
  markImport mc
  [f,lt',$bindings]
 
compMapCond''(cexpr,dc) ==
  cexpr=true => true
  --cexpr = "true" => true
---------------> new <----------------------
  cexpr is [op,:l] and op in '(and AND) => and/[compMapCond''(u,dc) for u in l]
  cexpr is [op,:l] and op in '(or OR)   => or/[compMapCond''(u,dc) for u in l]
---------------> new <----------------------
  cexpr is ["not",u] => not compMapCond''(u,dc)
  cexpr is ["has",name,cat] => (knownInfo cexpr => true; false)
        --for the time being we'll stop here - shouldn't happen so far
        --$disregardConditionIfTrue => true
        --stackSemanticError(("not known that",'%b,name,
        -- '%d,"has",'%b,cat,'%d),nil)
  --now it must be an attribute
  member(["ATTRIBUTE",dc,cexpr],get("$Information","special",$e)) => true
  --for the time being we'll stop here - shouldn't happen so far
  stackMessage ["not known that",'%b,dc,'%d,"has",'%b,cexpr,'%d]
  false
 
--======================================================================
--                    From nruncomp.boot
--======================================================================
optDeltaEntry(op,sig,dc,eltOrConst) ==
  return nil    --------> kill it
  $killOptimizeIfTrue = true => nil
  ndc :=
    dc = '$ => $functorForm
    atom dc and (dcval := get(dc,'value,$e)) => dcval.expr
    dc
--if (atom dc) and (dcval := get(dc,'value,$e))
--   then ndc := dcval.expr
--   else ndc := dc
  sig := SUBST(ndc,dc,sig)
  not optimizableDomain? ndc => nil
  dcval := optCallEval ndc
  -- MSUBST guarantees to use EQUAL testing
  sig := MSUBST(devaluate dcval, ndc, sig)
  if rest ndc then
     for new in rest devaluate dcval for old in rest ndc repeat
       sig := MSUBST(new,old,sig)
     -- optCallEval sends (List X) to (LIst (Integer)) etc,
     -- so we should make the same transformation
  fn := compiledLookup(op,sig,dcval)
  if null fn then
    -- following code is to handle selectors like first, rest
     nsig := [quoteSelector tt for tt in sig] where
       quoteSelector(x) ==
         not(IDENTP x) => x
         get(x,'value,$e) => x
         x='$ => x
         MKQ x
     fn := compiledLookup(op,nsig,dcval)
     if null fn then return nil
  eltOrConst="CONST" => 
     hehe fn
     [op]                    -----------> return just the op here
--   ['XLAM,'ignore,MKQ SPADCALL fn]
  getFunctionReplacement compileTimeBindingOf first fn
 
genDeltaEntry(opMmPair,e) ==
--called from compApplyModemap
--$NRTdeltaLength=0.. always equals length of $NRTdeltaList
  [.,[odc,:.],.] := opMmPair
  --opModemapPair := SUBLIS($LocalDomainAlist,opMmPair)
  [op,[dc,:sig],[.,cform:=[eltOrConst,:.]]] := opMmPair
  if $profileCompiler = true then 
    profileRecord(dc,op,sig)
--  markImport dc
  eltOrConst = 'XLAM => cform
  if eltOrConst = 'Subsumed then eltOrConst := 'ELT
    -- following hack needed to invert Rep to $ substitution
  if odc = 'Rep and cform is [.,.,osig] then sig:=osig
  newimp := optDeltaEntry(op,sig,dc,eltOrConst) => newimp
  setDifference(listOfBoundVars dc,$functorLocalParameters) ~= [] =>
    ['applyFun,['compiledLookupCheck,MKQ op,
         mkList consSig(sig,dc),consDomainForm(dc,nil)]]
 --if cons? dc then
 --   sig := substitute('$,dc,sig)
 --   cform := substitute('$,dc,cform)
  opModemapPair :=
    [op,[dc,:[genDeltaSig x for x in sig]],['T,cform]] -- force pred to T
  if null NRTassocIndex dc and
    (member(dc,$functorLocalParameters) or cons? dc) then
    --create "%domain" entry to $NRTdeltaList
      $NRTdeltaList:= [["%domain",NRTaddInner dc,:dc],:$NRTdeltaList]
      saveNRTdeltaListComp:= $NRTdeltaListComp:=[nil,:$NRTdeltaListComp]
      $NRTdeltaLength := $NRTdeltaLength+1
      compEntry:=
        dc
      saveNRTdeltaListComp.first := compEntry
      chk(saveNRTdeltaListComp,102)
  u :=
    [eltOrConst,'$,$NRTbase+$NRTdeltaLength-index] where index() ==
      (n:= POSN1(opModemapPair,$NRTdeltaList)) => n + 1
        --n + 1 since $NRTdeltaLength is 1 too large
      $NRTdeltaList:= [opModemapPair,:$NRTdeltaList]
      $NRTdeltaListComp:=[nil,:$NRTdeltaListComp]
      $NRTdeltaLength := $NRTdeltaLength+1
      0
  u

--======================================================================
--                    From nruncomp.boot
--======================================================================
parseIf t ==
  t isnt [p,a,b] => t
  ifTran(parseTran p,parseTran a,parseTran b) where
    ifTran(p,a,b) ==
      null($InteractiveMode) and p='true  => a
      null($InteractiveMode) and p='false  => b
      p is ['not,p'] => ifTran(p',b,a)
      p is ['IF,p',a',b'] => ifTran(p',ifTran(a',COPY a,COPY b),ifTran(b',a,b))
      p is ['SEQ,:l,['exit,1,p']] =>
        ['SEQ,:l,['exit,1,ifTran(p',incExitLevel a,incExitLevel b)]]
         --this assumes that l has no exits
      a is ['IF, =p,a',.] => ['IF,p,a',b]
      b is ['IF, =p,.,b'] => ['IF,p,a,b']
--      makeSimplePredicateOrNil p is ['SEQ,:s,['exit,1,val]] =>
--        parseTran ['SEQ,:s,['exit,1,incExitLevel ['IF,val,a,b]]]
      ['IF,p,a,b]

--======================================================================
--                         From parse.boot
--======================================================================
parseNot u ==  ['not,parseTran first u]

makeSimplePredicateOrNil p == nil
 
--======================================================================
--                         From g-cndata.boot
--======================================================================
mkUserConstructorAbbreviation(c,a,type) ==
  if $AnalyzeOnly or $convert2NewCompiler then
    $abbreviationStack := [[type,a,:c],:$abbreviationStack]
  if cons? c then c:= first c  --  Existing constructors will be wrapped
  constructorAbbreviationErrorCheck(c,a,type,'abbreviationError)
  clearClams()
  clearConstructorCache(c)
  installConstructor(c,type)
  setAutoLoadProperty(c)
 
--======================================================================
--                         From iterator.boot
--======================================================================

compreduce(form is [.,op,x],m,e) ==
  T := compForm(form,m,e) or return nil
  y := T.expr
  y.first := "REDUCE"
  ------------------<== distinquish this as the special reduce form
  (y is ["REDUCE",:.]) and (id:= getIdentity(op,e)) and (u := comp0(id,m,e)) and
    # getNumberTypesInScope() > 1 => markSimpleReduce([:y, ["@",u.expr,m]], T)
  T

compReduce1(form is ["REDUCE",op,.,collectForm],m,e,$formalArgList) ==
-------------------------------> 11/28 all new to preserve collect forms
  markImport m
  [collectOp,:itl,body]:= collectForm
  $e:= e
  itl:= [([.,$e]:= compIterator(x,$e) or return "failed").(0) for x in itl]
  itl="failed" => return nil
  e:= $e
  T0 := comp0(body,m,e) or return nil
  md := T0.mode
  T1 := compOrCroak(collectForm,["List",md],e) 
  T  := [["REDUCE",op,nil,T1.expr],md,T1.env]
  markReduce(form,T)
 
compIterator(it,e) ==
  it is ["IN",x,y] =>
    --these two lines must be in this order, to get "for f in list f"
    --to give  an error message if f is undefined
  ---------------> new <---------------------
    [y',m,e] := markInValue(y, e)
    x := markKillAll x
    ------------------
    $formalArgList:= [x,:$formalArgList]
    [.,mUnder]:=
      modeIsAggregateOf("List",m,e) or modeIsAggregateOf("Vector",m,e) or return
         stackMessage ["mode: ",m," must be a list or vector of some mode"]
    if null get(x,"mode",e) then [.,.,e]:=
      compMakeDeclaration(x,mUnder,e) or return nil
    e:= giveVariableSomeValue(x,mUnder,e)
    markReduceIn(it, [["IN",x,y'],e])
  it is ["ON",x,y] =>
---------------> new <---------------------
    x := markKillAll x
    ------------------
    $formalArgList:= [x,:$formalArgList]
    y := markKillAll y
    markImport m
---------------> new <---------------------
    [y',m,e]:= comp(y,$EmptyMode,e) or return nil
    [.,mUnder]:=
      modeIsAggregateOf("List",m,e) or return
        stackMessage ["mode: ",m," must be a list of other modes"]
    if null get(x,"mode",e) then [.,.,e]:=
      compMakeDeclaration(x,m,e) or return nil
    e:= giveVariableSomeValue(x,m,e)
    [["ON",x,y'],e]
  it is ["STEP",oindex,start,inc,:optFinal] =>
    index := markKillAll oindex
    $formalArgList:= [index,:$formalArgList]
    --if all start/inc/end compile as small integers, then loop
    --is compiled as a small integer loop
    final':= nil
---------------> new <---------------------
    u := smallIntegerStep(it,index,start,inc,optFinal,e) => u
---------------> new <---------------------
    [start,.,e]:=
      comp(markKillAll start,$Integer,e) or return
        stackMessage ["start value of index: ",start," must be an integer"]
    [inc,.,e]:=
      comp(markKillAll inc,$Integer,e) or return
        stackMessage ["index increment:",inc," must be an integer"]
    if optFinal is [final] then
      [final,.,e]:=
        comp(markKillAll final,$Integer,e) or return
          stackMessage ["final value of index: ",final," must be an integer"]
      optFinal:= [final]
    indexmode:=
      comp(third it,$NonNegativeInteger,e) => $NonNegativeInteger
      $Integer
--  markImport ['Segment,indexmode]
    if null get(index,"mode",e) then [.,.,e]:=
      compMakeDeclaration(index,indexmode,e) or return nil
    e:= giveVariableSomeValue(index,indexmode,e)
    markReduceStep(it, [["STEP",markStep(index),start,inc,:optFinal],e])
  it is ["WHILE",p] =>
    [p',m,e]:=
      comp(p,$Boolean,e) or return
        stackMessage ["WHILE operand: ",p," is not Boolean valued"]
    markReduceWhile(it, [["WHILE",p'],e])
  it is ["UNTIL",p] => markReduceUntil(it, ($until:= p; ['$until,e]))
  it is ["|",x] =>
    u:=
      comp(x,$Boolean,e) or return
        stackMessage ["SUCHTHAT operand: ",x," is not Boolean value"]
    markReduceSuchthat(it, [["|",u.expr],u.env])
  nil

smallIntegerStep(it,index,start,inc,optFinal,e) ==
  start    := markKillAll start
  inc      := markKillAll inc
  optFinal := markKillAll optFinal
  startNum := source2Number start
  incNum   := source2Number inc
  mode := get(index,"mode",e) 
--fail if
----> a) index has a mode that is not $SmallInteger
----> b) one of start,inc, final won't comp as a $SmallInteger
  mode and mode ~= $SmallInteger => nil
  null (start':= comp(start,$SmallInteger,e)) => nil
  null (inc':= comp(inc,$SmallInteger,start'.env)) => nil
  if optFinal is [final] and not (final':= comp(final,$SmallInteger,inc'.env)) then
--    not (FIXP startNum and FIXP incNum) => return nil
--    null FIXP startNum or ABSVAL startNum > 100 => return nil
    -----> assume that optFinal is $SmallInteger
    T := comp(final,$EmptyMode,inc'.env) or return nil
    final' := T
    maximalSuperType T.mode ~= $Integer => return nil
    givenRange := T.mode
  indexmode:= $SmallInteger
  [.,.,e]:= compMakeDeclaration(index,indexmode,
     (final' => final'.env; inc'.env)) or return nil
  range :=
    FIXP startNum and FIXP incNum =>
      startNum >  0 and incNum > 0 => $PositiveInteger
      startNum <  0 and incNum < 0 => $NegativeInteger
      incNum >  0 => $NonNegativeInteger   --startNum = 0
      $NonPositiveInteger
    givenRange => givenRange
    nil
  e:= put(index,"range",range,e)
  e:= giveVariableSomeValue(index,indexmode,e)
  noptFinal := 
    final' => 
      [final'.expr]
    nil
  [markStepSI(it,["ISTEP",index,start'.expr,inc'.expr,:noptFinal]),e]

source2Number n ==
  n := markKillAll n
  n = $Zero => 0
  n = $One  => 1
  n

compRepeatOrCollect(form,m,e) ==
  fn(form,[m,:$exitModeStack],[#$exitModeStack,:$leaveLevelStack],$formalArgList
    ,e) where
      fn(form,$exitModeStack,$leaveLevelStack,$formalArgList,e) ==
        $until: local
        [repeatOrCollect,:itl,body]:= form
        itl':=
          [([x',e]:= compIterator(x,e) or return "failed"; x') for x in itl]
        itl'="failed" => nil
        targetMode:= first $exitModeStack
--        pp '"---------"
--        pp targetMode
        bodyMode:=
          repeatOrCollect="COLLECT" =>
            targetMode = '$EmptyMode => '$EmptyMode
            (u:=modeIsAggregateOf('List,targetMode,e)) =>
              second u
            (u:=modeIsAggregateOf('Vector,targetMode,e)) =>
              repeatOrCollect:='COLLECTV
              second u
            stackMessage('"Invalid collect bodytype")
            return nil
            -- If we're doing a collect, and the type isn't conformable
            -- then we've boobed. JHD 26.July.1990
          $NoValueMode
        [body',m',e']:= T :=
          -- (m1:= listOrVectorElementMode targetMode) and comp(body,m1,e) or
            compOrCroak(body,bodyMode,e) or return nil
        markRepeatBody(body, T)
        if $until then
          [untilCode,.,e']:= comp($until,$Boolean,e')
          itl':= substitute(["UNTIL",untilCode],'$until,itl')
        form':= [repeatOrCollect,:itl',body']
        m'':=
          repeatOrCollect="COLLECT" =>
            (u:=modeIsAggregateOf('List,targetMode,e)) => first u
            ["List",m']
          repeatOrCollect="COLLECTV" =>
            (u:=modeIsAggregateOf('Vector,targetMode,e)) => first u
            ["Vector",m']
          m'
--------> new <--------------
        markImport m''
--------> new <--------------
        markRepeat(form,coerceExit([form',m'',e'],targetMode))
 
chaseInferences(origPred,$e) ==
  pred := markKillAll origPred
  ----------------------------12/4/94 do this immediately
  foo hasToInfo pred where
    foo pred ==
      knownInfo pred => nil
      $e:= actOnInfo(pred,$e)
      pred:= infoToHas pred
      for u in get("$Information","special",$e) repeat
        u is ["COND",:l] =>
          for [ante,:conseq] in l repeat
            ante=pred => [foo w for w in conseq]
            ante is ["and",:ante'] and member(pred,ante') =>
              ante':= delete(pred,ante')
              v':=
                # ante'=1 => first ante'
                ["and",:ante']
              v':= ["COND",[v',:conseq]]
              member(v',get("$Information","special",$e)) => nil
              $e:=
                put("$Information","special",[v',:
                  get("$Information","special",$e)],$e)
            nil
  $e
 
--======================================================================
--                   doit Code
--======================================================================
doIt(item,$predl) ==
  $GENNO: local:= 0
  $coerceList: local := nil
  --->                 
  if item is ['PART,.,a] then item := a
  -------------------------------------
  item is ['SEQ,:.] => doItSeq item
  isDomainForm(item,$e) => doItDomain item
  item is ["%LET",:.] => doItLet item
  item is [":",a,t] => [.,.,$e]:= 
    markDeclaredImport markKillAll t
    compOrCroak(item,$EmptyMode,$e)
  item is ["import",:doms] =>
     item := ["import",:(doms := markKillAll doms)]
     for dom in doms repeat
       sayBrightly ['"   importing ",:formatUnabbreviated dom]
     [.,.,$e] := compOrCroak(item,$EmptyMode,$e)
     wiReplaceNode(item,'(PROGN),10)
  item is ["IF",:.] => doItIf(item,$predl,$e)
  item is ["where",b,:l] => compOrCroak(item,$EmptyMode,$e)
  item is ["MDEF",:.] => [.,.,$e]:= compOrCroak(item,$EmptyMode,$e)
  item is ['DEF,:.] => doItDef item
  T:= compOrCroak(item,$EmptyMode,$e) => doItExpression(item,T)
  true => cannotDo()

holdIt item == item
 
doItIf(item is [.,p,x,y],$predl,$e) ==
  olde:= $e
  [p',.,$e]:= qt(19,comp(p,$Boolean,$e)) or userError ['"not a Boolean:",p]
  oldFLP:=$functorLocalParameters
  if x~="%noBranch" then
--> new <-----------------------
    qe(20,compSingleCapsuleItem(x,[p,:$predl],getSuccessEnvironment(markKillAll p,$e)))
---> new                                                 -----------
    x':=localExtras(oldFLP)
          where localExtras(oldFLP) ==
            EQ(oldFLP,$functorLocalParameters) => NIL
            flp1:=$functorLocalParameters
            oldFLP':=oldFLP
            n:=0
            while oldFLP' repeat
              oldFLP':=rest oldFLP'
              flp1:=rest flp1
              n:=n+1
            -- Now we have to add code to compile all the elements
            -- of functorLocalParameters that were added during the
            -- conditional compilation
            nils:=ans:=[]
            for u in flp1 repeat -- is =u form always an atom?
              if atom u or (or/[v is [.,=u,:.] for v in $getDomainCode])
                then
                  nils:=[u,:nils]
                else
                  gv := gensym()
                  ans:=[["%LET",gv,u],:ans]
                  nils:=[gv,:nils]
              n:=n+1

            $functorLocalParameters:=[:oldFLP,:reverse nils]
            reverse ans
  oldFLP:=$functorLocalParameters
  if y~="%noBranch" then
--> new <-----------------------
    qe(21,compSingleCapsuleItem(y,[['not, p],:$predl],getInverseEnvironment(markKillAll p,olde)))
-->                                                      ----------- 
    y':=localExtras(oldFLP)
  wiReplaceNode(item,["COND",[p',x,:x'],['%true,y,:y']],12)

doItSeq item == 
  ['SEQ,:l,['exit,1,x]] := item
  item.first := "PROGN"
  lastNode(item).first := x
  for it1 in rest item repeat $e:= compSingleCapsuleItem(it1,$predl,$e)

doItDomain item ==
  -- convert naked top level domains to import
  u:= ["import", [first item,:rest item]]
  markImport second u
  stackWarning ["Use: import ", [first item,:rest item]]
--wiReplaceNode(item, u, 14)
  item.first := first u
  item.rest := rest u
  doIt(item,$predl)

doItLet item ==
  qe(3,$e)
  res := doItLet1 item
  qe(4,$e)
  res
 
doItLet1 item ==
  ["%LET",lhs,rhs,:.] := item
  not (compOrCroak(item,$EmptyMode,$e) is [code,.,$e]) =>
      stackSemanticError(["cannot compile assigned value to",:bright lhs],nil)
  qe(5,$e)
  code := markKillAll code
  not (code is ["%LET",lhs',rhs',:.] and atom lhs') =>
      code is ["PROGN",:.] =>
         stackSemanticError(["multiple assignment ",item," not allowed"],nil)
      wiReplaceNode(item, code, 24)
  lhs:= lhs'
  if not member(KAR rhs,$NonMentionableDomainNames) and
      not MEMQ(lhs, $functorLocalParameters) then
         $functorLocalParameters:= [:$functorLocalParameters,lhs]
  if (rhs' := rhsOfLetIsDomainForm code) then
      if isFunctor rhs' then
        $globalImportDefAlist := pp [[lhs, :rhs'],:$globalImportDefAlist]
      if lhs="Rep" then
        $Representation:= (get("Rep",'value,$e)).expr
           --$Representation bound by compDefineFunctor, used in compNoStacking
--+
        if $NRTopt = true
          then NRTgetLocalIndex $Representation
--+
      $LocalDomainAlist:= --see genDeltaEntry
        [[lhs,:SUBLIS($LocalDomainAlist,(get(lhs,'value,$e)).0)],:$LocalDomainAlist]
--+
  qe(6,$e)
  code is ["%LET",:.] =>
      rhsCode:= rhs'
      op := "setShellEntry"
      wiReplaceNode(item,[op,'$,NRTgetLocalIndex lhs,rhsCode], 16)
  wiReplaceNode(item, code, 18)

rhsOfLetIsDomainForm code ==
  code is ["%LET",.,rhs',:.] =>
    isDomainForm(rhs',$e) => rhs'
    isDomainForm(rhs' := markKillAll rhs',$e) => rhs'
    false
  false

doItDef item == 
  ['DEF,[op,:.],:.] := item
  body:= isMacro(item,$e) => $e := putMacro(op,body,$e)
  [.,.,$e]:= t:= compOrCroak(item,$EmptyMode,$e)
  chk(item,3)
  item.first := "CodeDefine"
        --Note that DescendCode, in CodeDefine, is looking for this
  second(item).rest := [$signatureOfForm]
  chk(item,4)
      --This is how the signature is updated for buildFunctor to recognise
--+
  functionPart:= ['dispatchFunction,t.expr]
  wiReplaceNode(CDDR item,[functionPart], 20)
  chk(item, 30)

doItExpression(item,T) ==
  SETQ($ITEM,COPY item)
  SETQ($T1,COPY T.expr)
  chk(T.expr, 304)
  u := markCapsuleExpression(item, T)
  [code,.,$e]:= u
  wiReplaceNode(item,code, 22)

wiReplaceNode(node,ocode,key) ==
  ncode := [first ocode,:rest ocode]
  code := replaceNodeInStructureBy(node,ncode)
  SETQ($NODE,COPY node)
  SETQ($NODE1, COPY first code)
  SETQ($NODE2, COPY rest  code)
  node.first := first code
  node.rest := rest  code
  chk(code, key)
  chk(node, key + 1)

replaceNodeInStructureBy(node, x) == 
  $nodeCopy: local := [first node,:rest node]
  replaceNodeBy(node, x)
  node

replaceNodeBy(node, x) ==
  atom x => nil
  for y in tails x | x is [=node,:.] repeat x.first := $nodeCopy
  nil  

chk(x,key) == fn(x,0,key) where fn(x,cnt,key) ==
  cnt > 10000 => 
    sayBrightly ["--> ", key, " <---"]
    hahaha(key)
  atom x => cnt
  vector? x => systemError nil
  for y in x repeat cnt := fn(y, cnt + 1, key)
  cnt