path: root/src/interp/define.boot.pamphlet

\documentclass{article}
\usepackage{axiom}

\title{\File{src/interp/define.boot} Pamphlet}
\author{The Axiom Team}

\begin{document}
\maketitle
\begin{abstract}
\end{abstract}
\eject
\tableofcontents
\eject

\section{compCapsuleItems}

The variable [[data]] appears to be unbound at runtime. Optimized
code won't check for this but interpreted code fails. We should
PROVE that data is unbound at runtime but have not done so yet.
Rather than remove the code entirely (since there MIGHT be a 
path where it is used) we check for the runtime bound case and
assign [[$myFunctorBody]] if data has a value.

The [[compCapsuleInner]] function in this file LOOKS like it sets
data and expects code to manipulate the assigned data structure.
Since we can't be sure we take the least disruptive course of action.
<<compCapsuleItems>>=
compCapsuleItems(itemlist,$predl,$e) ==
  $TOP__LEVEL: local
  $myFunctorBody :local         -- := data    ---needed for translator
  if (BOUNDP 'data) then $myFunctorBody:=data -- unbound at runtime?
  $signatureOfForm: local
  $suffix: local:= 0
  for item in itemlist repeat $e:= compSingleCapsuleItem(item,$predl,$e)
  $e
 
@ 
\section{License}
<<license>>=
-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
-- 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.

@
<<*>>=
<<license>>

--% FUNCTIONS WHICH MUNCH ON == STATEMENTS
 
compDefine(form,m,e) ==
  $tripleHits: local:= 0
  $macroIfTrue: local
  $packagesUsed: local
  result:= compDefine1(form,m,e)
  result
 
compDefine1(form,m,e) ==
  $insideExpressionIfTrue: local:= false
  --1. decompose after macro-expanding form
  ['DEF,lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e)
  $insideWhereIfTrue and isMacro(form,e) and (m=$EmptyMode or m=$NoValueMode)
     => [lhs,m,put(first lhs,'macro,rhs,e)]
  null signature.target and not MEMQ(KAR rhs,$ConstructorNames) and
    (sig:= getSignatureFromMode(lhs,e)) =>
  -- here signature of lhs is determined by a previous declaration
      compDefine1(['DEF,lhs,[first sig,:rest signature],specialCases,rhs],m,e)
  if signature.target=$Category then $insideCategoryIfTrue:= true
--?? following 3 lines seem bogus, BMT 6/23/93
--?  if signature.target is ['Mapping,:map] then
--?    signature:= map
--?    form:= ['DEF,lhs,signature,specialCases,rhs]
 
-- RDJ (11/83): when argument and return types are all declared,
--  or arguments have types declared in the environment,
--  and there is no existing modemap for this signature, add
--  the modemap by a declaration, then strip off declarations and recurse
  e := compDefineAddSignature(lhs,signature,e)
-- 2. if signature list for arguments is not empty, replace ('DEF,..) by
--       ('where,('DEF,..),..) with an empty signature list;
--     otherwise, fill in all NILs in the signature
  not (and/[null x for x in rest signature]) => compDefWhereClause(form,m,e)
  signature.target=$Category =>
    compDefineCategory(form,m,e,nil,$formalArgList)
  isDomainForm(rhs,e) and not $insideFunctorIfTrue =>
    if null signature.target then signature:=
      [getTargetFromRhs(lhs,rhs,giveFormalParametersValues(rest lhs,e)),:
          rest signature]
    rhs:= addEmptyCapsuleIfNecessary(signature.target,rhs)
    compDefineFunctor(['DEF,lhs,signature,specialCases,rhs],m,e,nil,
      $formalArgList)
  null $form => stackAndThrow ['"bad == form ",form]
  newPrefix:=
    $prefix => INTERN STRCONC(encodeItem $prefix,'",",encodeItem $op)
    getAbbreviation($op,#rest $form)
  compDefineCapsuleFunction(form,m,e,newPrefix,$formalArgList)
 
compDefineAddSignature([op,:argl],signature,e) ==
  (sig:= hasFullSignature(argl,signature,e)) and
   not ASSOC(['$,:sig],LASSOC('modemap,getProplist(op,e))) =>
     declForm:=
       [":",[op,:[[":",x,m] for x in argl for m in rest sig]],first signature]
     [.,.,e]:= comp(declForm,$EmptyMode,e)
     e
  e
 
hasFullSignature(argl,[target,:ml],e) ==
  target =>
    u:= [m or get(x,"mode",e) or return 'failed for x in argl for m in ml]
    u^='failed => [target,:u]
 
addEmptyCapsuleIfNecessary(target,rhs) ==
  MEMQ(KAR rhs,$SpecialDomainNames) => rhs
  ['add,rhs,['CAPSULE]]
 
getTargetFromRhs(lhs,rhs,e) ==
  --undeclared target mode obtained from rhs expression
  rhs is ['CAPSULE,:.] =>
    stackSemanticError(['"target category of ",lhs,
      '" cannot be determined from definition"],nil)
  rhs is ['SubDomain,D,:.] => getTargetFromRhs(lhs,D,e)
  rhs is ['add,D,['CAPSULE,:.]] => getTargetFromRhs(lhs,D,e)
  rhs is ['Record,:l] => ['RecordCategory,:l]
  rhs is ['Union,:l] => ['UnionCategory,:l]
  rhs is ['List,:l] => ['ListCategory,:l]
  rhs is ['Vector,:l] => ['VectorCategory,:l]
  [.,target,.]:= compOrCroak(rhs,$EmptyMode,e)
  target
 
giveFormalParametersValues(argl,e) ==
  for x in argl repeat
    e:= put(x,'value,[genSomeVariable(),get(x,'mode,e),nil],e)
  e
 
macroExpandInPlace(x,e) ==
  y:= macroExpand(x,e)
  atom x or atom y => y
  RPLACA(x,first y)
  RPLACD(x,rest y)
  x
 
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)]
  macroExpandList(x,e)
 
macroExpandList(l,e) ==
  -- macros should override niladic props
  (l is [name]) and IDENTP name and GETDATABASE(name, 'NILADIC) and
	(u := get(name, 'macro, e)) => macroExpand(u,e)
  [macroExpand(x,e) for x in l]
 
compDefineCategory1(df is ['DEF,form,sig,sc,body],m,e,prefix,fal) ==
  categoryCapsule :=
--+
    body is ['add,cat,capsule] =>
      body := cat
      capsule
    nil
  [d,m,e]:= compDefineCategory2(form,sig,sc,body,m,e,prefix,fal)
--+ next two lines
  if categoryCapsule and not $bootStrapMode then [.,.,e] :=
    $insideCategoryPackageIfTrue: local := true  --see NRTmakeSlot1
-->
    $categoryPredicateList: local :=
        makeCategoryPredicates(form,$lisplibCategory)
    compDefine1(mkCategoryPackage(form,cat,categoryCapsule),$EmptyMode,e)
  [d,m,e]
 
makeCategoryPredicates(form,u) ==
      $tvl := TAKE(#rest form,$TriangleVariableList)
      $mvl := TAKE(#rest form,rest $FormalMapVariableList)
      fn(u,nil) where
        fn(u,pl) ==
          u is ['Join,:.,a] => fn(a,pl)
          u is ['has,:.] => insert(EQSUBSTLIST($mvl,$tvl,u),pl)
          u is [op,:.] and MEMQ(op,'(SIGNATURE ATTRIBUTE)) => pl
          atom u => pl
          fnl(u,pl)
        fnl(u,pl) ==
          for x in u repeat pl := fn(x,pl)
          pl
 
--+ the following function
mkCategoryPackage(form is [op,:argl],cat,def) ==
  packageName:= INTERN(STRCONC(PNAME op,'"&"))
  packageAbb := INTERN(STRCONC(GETDATABASE(op,'ABBREVIATION),'"-"))
  $options:local := []
  -- This stops the next line from becoming confused
  abbreviationsSpad2Cmd ['domain,packageAbb,packageName]
  -- This is a little odd, but the parser insists on calling
  -- domains, rather than packages
  nameForDollar := first SETDIFFERENCE('(S A B C D E F G H I),argl)
  packageArgl := [nameForDollar,:argl]
  capsuleDefAlist := fn(def,nil) where fn(x,oplist) ==
    atom x => oplist
    x is ['DEF,y,:.] => [y,:oplist]
    fn(rest x,fn(first x,oplist))
  explicitCatPart := gn cat where gn cat ==
    cat is ['CATEGORY,:.] => rest rest cat
    cat is ['Join,:u] => gn last u
    nil
  catvec := eval mkEvalableCategoryForm form
  fullCatOpList:=JoinInner([catvec],$e).1
  catOpList :=
    --note: this gets too many modemaps in general
    --   this is cut down in NRTmakeSlot1
    [['SIGNATURE,op1,sig] for [[op1,sig],:.] in fullCatOpList
         --above line calls the category constructor just compiled
        | ASSOC(op1,capsuleDefAlist)]
  null catOpList => nil
  packageCategory := ['CATEGORY,'domain,
                     :SUBLISLIS(argl,$FormalMapVariableList,catOpList)]
  nils:= [nil for x in argl]
  packageSig := [packageCategory,form,:nils]
  $categoryPredicateList := SUBST(nameForDollar,'$,$categoryPredicateList)
  SUBST(nameForDollar,'$,
      ['DEF,[packageName,:packageArgl],packageSig,[nil,:nils],def])
 
compDefineCategory2(form,signature,specialCases,body,m,e,
  $prefix,$formalArgList) ==
    --1. bind global variables
    $insideCategoryIfTrue: local:= true
    $TOP__LEVEL: local
    $definition: local
                 --used by DomainSubstitutionFunction
    $form: local
    $op: local
    $extraParms: local
             --Set in DomainSubstitutionFunction, used further down
--  1.1  augment e to add declaration $: <form>
    [$op,:argl]:= $definition:= form
    e:= addBinding("$",[['mode,:$definition]],e)
 
--  2. obtain signature
    signature':=
      [first signature,:[getArgumentModeOrMoan(a,$definition,e) for a in argl]]
    e:= giveFormalParametersValues(argl,e)
 
--   3. replace arguments by $1,..., substitute into body,
--     and introduce declarations into environment
    sargl:= TAKE(# argl, $TriangleVariableList)
    $functorForm:= $form:= [$op,:sargl]
    $formalArgList:= [:sargl,:$formalArgList]
    aList:= [[a,:sa] for a in argl for sa in sargl]
    formalBody:= SUBLIS(aList,body)
    signature' := SUBLIS(aList,signature')
--Begin lines for category default definitions
    $functionStats: local:= [0,0]
    $functorStats: local:= [0,0]
    $frontier: local := 0
    $getDomainCode: local := nil
    $addForm: local:= nil
    for x in sargl for t in rest signature' repeat
      [.,.,e]:= compMakeDeclaration([":",x,t],m,e)
 
--   4. compile body in environment of %type declarations for arguments
    op':= $op
    -- following line causes cats with no with or Join to be fresh copies
    if opOf(formalBody)^='Join and opOf(formalBody)^='mkCategory then
           formalBody := ['Join, formalBody]
    body:= optFunctorBody (compOrCroak(formalBody,signature'.target,e)).expr
    if $extraParms then
      formals:=actuals:=nil
      for u in $extraParms repeat
        formals:=[CAR u,:formals]
        actuals:=[MKQ CDR u,:actuals]
      body := ['sublisV,['PAIR,['QUOTE,formals],['LIST,:actuals]],body]
    if argl then body:=  -- always subst for args after extraparms
        ['sublisV,['PAIR,['QUOTE,sargl],['LIST,:
          [['devaluate,u] for u in sargl]]],body]
    body:=
      ['PROG1,['LET,g:= GENSYM(),body],['SETELT,g,0,mkConstructor $form]]
    fun:= compile [op',['LAM,sargl,body]]
 
--  5. give operator a 'modemap property
    pairlis:= [[a,:v] for a in argl for v in $FormalMapVariableList]
    parSignature:= SUBLIS(pairlis,signature')
    parForm:= SUBLIS(pairlis,form)
    lisplibWrite('"compilerInfo",
      removeZeroOne ['SETQ,'$CategoryFrame,
       ['put,['QUOTE,op'],'
        (QUOTE isCategory),true,['addModemap,MKQ op',MKQ parForm,
          MKQ parSignature,true,MKQ fun,'$CategoryFrame]]],$libFile)
    --Equivalent to the following two lines, we hope
    if null sargl then
      evalAndRwriteLispForm('NILADIC,
            ['MAKEPROP,['QUOTE,op'],'(QUOTE NILADIC),true])
 
--   6. put modemaps into InteractiveModemapFrame
    $domainShell := eval [op',:MAPCAR('MKQ,sargl)]
    $lisplibCategory:= formalBody
    if $LISPLIB then
      $lisplibForm:= form
      $lisplibKind:= 'category
      modemap:= [[parForm,:parSignature],[true,op']]
      $lisplibModemap:= modemap
      $lisplibParents  :=         
        getParentsFor($op,$FormalMapVariableList,$lisplibCategory)
      $lisplibAncestors := computeAncestorsOf($form,nil)
      $lisplibAbbreviation := constructor? $op
      form':=[op',:sargl]
      augLisplibModemapsFromCategory(form',formalBody,signature')
    [fun,'(Category),e]
 
mkConstructor form ==
  atom form => ['devaluate,form]
  null rest form => ['QUOTE,[first form]]
  ['LIST,MKQ first form,:[mkConstructor x for x in rest form]]
 
compDefineCategory(df,m,e,prefix,fal) ==
  $domainShell: local -- holds the category of the object being compiled
  $lisplibCategory: local
  not $insideFunctorIfTrue and $LISPLIB =>
    compDefineLisplib(df,m,e,prefix,fal,'compDefineCategory1)
  compDefineCategory1(df,m,e,prefix,fal)
 
compDefineFunctor(df,m,e,prefix,fal) ==
  $domainShell: local -- holds the category of the object being compiled
  $profileCompiler: local := true
  $profileAlist:    local := nil
  $LISPLIB => compDefineLisplib(df,m,e,prefix,fal,'compDefineFunctor1)
  compDefineFunctor1(df,m,e,prefix,fal)
 
compDefineFunctor1(df is ['DEF,form,signature,$functorSpecialCases,body],
  m,$e,$prefix,$formalArgList) ==
    if NRTPARSE = true then
      [lineNumber,:$functorSpecialCases] := $functorSpecialCases
--  1. bind global variables
    $addForm: local
    $viewNames: local:= nil
 
            --This list is only used in genDomainViewName, for generating names
            --for alternate views, if they do not already exist.
            --format: Alist: (domain name . sublist)
            --sublist is alist: category . name of view
    $functionStats: local:= [0,0]
    $functorStats: local:= [0,0]
    $form: local
    $op: local
    $signature: local
    $functorTarget: local
    $Representation: local
         --Set in doIt, accessed in the compiler - compNoStacking
    $LocalDomainAlist: local  --set in doIt, accessed in genDeltaEntry
    $LocalDomainAlist:= nil
    $functorForm: local
    $functorLocalParameters: local
    SETQ($myFunctorBody, body)
    $CheckVectorList: local
                  --prevents CheckVector from printing out same message twice
    $getDomainCode: local -- code for getting views
    $insideFunctorIfTrue: local:= true
    $functorsUsed: local --not currently used, finds dependent functors
    $setelt: local :=
      $QuickCode = true => 'QSETREFV
      'SETELT
    $TOP__LEVEL: local
    $genSDVar: local:= 0
    originale:= $e
    [$op,:argl]:= form
    $formalArgList:= [:argl,:$formalArgList]
    $pairlis := [[a,:v] for a in argl for v in $FormalMapVariableList]
    $mutableDomain: local :=
      -- all defaulting packages should have caching turned off
       isCategoryPackageName $op or   
         (if BOUNDP '$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]
    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
    $attributesName:local := INTERN STRCONC(PNAME $op,'";attributes")
    attributeList := disallowNilAttribute ds.2 --see below under "loadTimeAlist"
--+ 7 lines for $NRT follow
    $goGetList: local := nil
-->--these globals used by NRTmakeCategoryAlist, set by NRTsetVector4Part1
    $condAlist: local := nil
    $uncondAlist: local := nil
-->>-- next global initialized here, reset by NRTbuildFunctor
    $NRTslot1PredicateList: local :=
      REMDUP [CADR x for x in attributeList]
-->>-- next global initialized here, used by NRTgenAttributeAlist (NRUNOPT)
    $NRTattributeAlist: local := NRTgenInitialAttributeAlist attributeList
    $NRTslot1Info: local  --set in NRTmakeSlot1 called by NRTbuildFunctor
       --this is used below to set $lisplibSlot1 global
    $NRTbase: local := 6 -- equals length of $domainShell
    $NRTaddForm: local := nil   -- see compAdd; NRTmakeSlot1
    $NRTdeltaList: local := nil --list of misc. elts used in compiled fncts
    $NRTdeltaListComp: local := nil --list of COMP-ed forms for $NRTdeltaList
    $NRTaddList: local := nil --list of fncts not defined in capsule (added)
    $NRTdeltaLength: local := 0 -- =length of block of extra entries in vector
    $NRTloadTimeAlist: local := nil --used for things in slot4 (NRTsetVector4)
    $NRTdomainFormList: local := nil -- of form ((gensym . (Repe...)) ...
    -- the above optimizes the calls to local domains
    $template: local:= nil --stored in the lisplib (if $NRTvec = true)
    $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],m,$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 $insideCategoryPackageIfTrue^= true  then
      if body is ['add,ab:=[fn,:.],['CAPSULE,:cb]] and MEMQ(fn,'(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:=CDR 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
    if isPackageFunction() then $functorLocalParameters:=
      [nil,:
        [nil
          for i in 6..MAXINDEX $domainShell |
            $domainShell.i is [.,.,['ELT,'_$,.]]]]
    --leave space for vector ops and package name to be stored
--+
    $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)
    -- 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
--   if $functorsUsed then MAKEPROP(op',"NEEDS",$functorsUsed)
    if $LISPLIB then
      modemap:= [[parForm,:parSignature],[true,op']]
      $lisplibModemap:= modemap
      $lisplibCategory := modemap.mmTarget
      $lisplibParents  :=         
        getParentsFor($op,$FormalMapVariableList,$lisplibCategory)
      $lisplibAncestors := computeAncestorsOf($form,nil)
      $lisplibAbbreviation := constructor? $op
    $insideFunctorIfTrue:= false
    if $LISPLIB then
      $lisplibKind:=
------->This next line prohibits changing the KIND once given
--------kk:=GETDATABASE($op,'CONSTRUCTORKIND) => kk
        $functorTarget is ["CATEGORY",key,:.] and key^="domain" => 'package
        'domain
      $lisplibForm:= form
      if null $bootStrapMode then
        $NRTslot1Info := NRTmakeSlot1Info()
        $isOpPackageName: local := isCategoryPackageName $op
        if $isOpPackageName then lisplibWrite('"slot1DataBase",
          ['updateSlot1DataBase,MKQ $NRTslot1Info],$libFile)
        $lisplibFunctionLocations := SUBLIS($pairlis,$functionLocations)
        $lisplibCategoriesExtended := SUBLIS($pairlis,$lisplibCategoriesExtended)
        -- see NRTsetVector4 for initial setting of $lisplibCategoriesExtended
        libFn := GETDATABASE(op','ABBREVIATION)
        $lookupFunction: local :=
            NRTgetLookupFunction($functorForm,CADAR $lisplibModemap,$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
      $lisplibMissingFunctions:= $CheckVectorList
    lisplibWrite('"compilerInfo",
       removeZeroOne ['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]
 
disallowNilAttribute x == 
  res := [y for y in x | car y and car y ^= "nil"]
--HACK to get rid of nil attibutes ---NOTE: nil is RENAMED to NIL

compFunctorBody(body,m,e,parForm) ==
  $bootStrapMode = true =>
    [bootStrapError($functorForm, _/EDITFILE),m,e]
  T:= compOrCroak(body,m,e)
  body is [op,:.] and MEMQ(op,'(add CAPSULE)) => T
  $NRTaddForm :=
    body is ["SubDomain",domainForm,predicate] => domainForm
    body
  T
 
reportOnFunctorCompilation() ==
  displayMissingFunctions()
  if $semanticErrorStack then sayBrightly '" "
  displaySemanticErrors()
  if $warningStack then sayBrightly '" "
  displayWarnings()
  $functorStats:= addStats($functorStats,$functionStats)
  [byteCount,elapsedSeconds] := $functorStats
  sayBrightly ['%l,:bright '"  Cumulative Statistics for Constructor",
    $op]
  timeString := normalizeStatAndStringify elapsedSeconds
  sayBrightly ['"      Time:",:bright timeString,'"seconds"]
  sayBrightly '" "
  'done
 
displayMissingFunctions() ==
  null $CheckVectorList => nil
  loc := nil
  exp := nil
  for [[op,sig,:.],:pred] in $CheckVectorList  | null pred repeat
    null member(op,$formalArgList) and
      getmode(op,$env) is ['Mapping,:.] =>
        loc := [[op,sig],:loc]
    exp := [[op,sig],:exp]
  if loc then
    sayBrightly ['%l,:bright '"  Missing Local Functions:"]
    for [op,sig] in loc for i in 1.. repeat
      sayBrightly ['"      [",i,'"]",:bright op,
        ": ",:formatUnabbreviatedSig sig]
  if exp then
    sayBrightly ['%l,:bright '"  Missing Exported Functions:"]
    for [op,sig] in exp for i in 1.. repeat
      sayBrightly ['"      [",i,'"]",:bright op,
        ": ",:formatUnabbreviatedSig sig]
 
--% domain view code
 
makeFunctorArgumentParameters(argl,sigl,target) ==
  $alternateViewList: local:= nil
  $forceAdd: local:= true
  $ConditionalOperators: local
  ("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:=[CDR 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] => genDomainViewList0(a,rest s)
        [genDomainView(a,a,s,"getDomainView")]
      [a]
 
genDomainViewList0(id,catlist) ==
  l:= genDomainViewList(id,catlist,true)
  l
 
genDomainViewList(id,catlist,firsttime) ==
  null catlist => nil
  catlist is [y] and not isCategoryForm(y,$EmptyEnvironment) => nil
  [genDomainView(if firsttime then id else genDomainViewName(id,first catlist),
    id,first catlist,"getDomainView"),:genDomainViewList(id,rest catlist,nil)]
 
genDomainView(viewName,originalName,c,viewSelector) ==
  c is ['CATEGORY,.,:l] => genDomainOps(viewName,originalName,c)
  code:=
    c is ['SubsetCategory,c',.] => c'
    c
  $e:= augModemapsFromCategory(originalName,viewName,nil,c,$e)
  --$alternateViewList:= ((viewName,:code),:$alternateViewList)
  cd:= ['LET,viewName,[viewSelector,originalName,mkDomainConstructor code]]
  if null member(cd,$getDomainCode) then
          $getDomainCode:= [cd,:$getDomainCode]
  viewName
 
genDomainOps(viewName,dom,cat) ==
  oplist:= getOperationAlist(dom,dom,cat)
  siglist:= [sig for [sig,:.] in oplist]
  oplist:= substNames(dom,viewName,dom,oplist)
  cd:=
    ['LET,viewName,['mkOpVec,dom,['LIST,:
      [['LIST,MKQ op,['LIST,:[mkDomainConstructor mode for mode in sig]]]
        for [op,sig] in siglist]]]]
  $getDomainCode:= [cd,:$getDomainCode]
  for [opsig,cond,:.] in oplist for i in 0.. repeat
    if opsig in $ConditionalOperators then cond:=nil
    [op,sig]:=opsig
    $e:= addModemap(op,dom,sig,cond,['ELT,viewName,i],$e)
  viewName
 
mkOpVec(dom,siglist) ==
  dom:= getPrincipalView dom
  substargs:= [['$,:dom.0],:
    [[a,:x] for a in $FormalMapVariableList for x in rest dom.0]]
  oplist:= getOperationAlistFromLisplib opOf dom.0
  --new form is (<op> <signature> <slotNumber> <condition> <kind>)
  ops:= MAKE_-VEC (#siglist)
  for (opSig:= [op,sig]) in siglist for i in 0.. repeat
    u:= ASSQ(op,oplist)
    ASSOC(sig,u) is [.,n,.,'ELT] => ops.i := dom.n
    noplist:= SUBLIS(substargs,u)
 -- following variation on ASSOC needed for GENSYMS in Mutable domains
    AssocBarGensym(SUBST(dom.0,'$,sig),noplist) is [.,n,.,'ELT] =>
                   ops.i := dom.n
    ops.i := [Undef,[dom.0,i],:opSig]
  ops
 
genDomainViewName(a,category) ==
--+
  a
 
compDefWhereClause(['DEF,form,signature,specialCases,body],m,e) ==
-- form is lhs (f a1 ... an) of definition; body is rhs;
-- signature is (t0 t1 ... tn) where t0= target type, ti=type of ai, i > 0;
-- specialCases is (NIL l1 ... ln) where li is list of special cases
-- which can be given for each ti
 
-- removes declarative and assignment information from form and
-- signature, placing it in list L, replacing form by ("where",form',:L),
-- signature by a list of NILs (signifying declarations are in e)
  $sigAlist: local
  $predAlist: local
 
-- 1. create sigList= list of all signatures which have embedded
--    declarations moved into global variable $sigAlist
  sigList:=
    [transformType fetchType(a,x,e,form) for a in rest form for x in rest signature]
       where
        fetchType(a,x,e,form) ==
          x => x
          getmode(a,e) or userError concat(
            '"There is no mode for argument",a,'"of function",first form)
        transformType x ==
          atom x => x
          x is [":",R,Rtype] =>
            ($sigAlist:= [[R,:transformType Rtype],:$sigAlist]; x)
          x is ['Record,:.] => x --RDJ 8/83
          [first x,:[transformType y for y in rest x]]
 
-- 2. replace each argument of the form (|| x p) by x, recording
--    the given predicate in global variable $predAlist
  argList:=
    [removeSuchthat a for a in rest form] where
      removeSuchthat x ==
        x is ["|",y,p] => ($predAlist:= [[y,:p],:$predAlist]; y)
        x
 
-- 3. obtain a list of parameter identifiers (x1 .. xn) ordered so that
--       the type of xi is independent of xj if i < j
  varList:=
    orderByDependency(ASSOCLEFT argDepAlist,ASSOCRIGHT argDepAlist) where
      argDepAlist:=
        [[x,:dependencies] for [x,:y] in argSigAlist] where
          dependencies() ==
            setUnion(listOfIdentifiersIn y,
              delete(x,listOfIdentifiersIn LASSOC(x,$predAlist)))
          argSigAlist:= [:$sigAlist,:pairList(argList,sigList)]
 
-- 4. construct a WhereList which declares and/or defines the xi's in
--    the order constructed in step 3
  (whereList:= [addSuchthat(x,[":",x,LASSOC(x,argSigAlist)]) for x in varList])
     where addSuchthat(x,y) == (p:= LASSOC(x,$predAlist) => ["|",y,p]; y)
 
-- 5. compile new ('DEF,("where",form',:WhereList),:.) where
--    all argument parameters of form' are bound/declared in WhereList
  comp(form',m,e) where
    form':=
      ["where",defform,:whereList] where
        defform:=
          ['DEF,form'',signature',specialCases,body] where
            form'':= [first form,:argList]
            signature':= [first signature,:[nil for x in rest signature]]
 
orderByDependency(vl,dl) ==
  -- vl is list of variables, dl is list of dependency-lists
  selfDependents:= [v for v in vl for d in dl | MEMQ(v,d)]
  for v in vl for d in dl | MEMQ(v,d) repeat
    (SAY(v," depends on itself"); fatalError:= true)
  fatalError => userError '"Parameter specification error"
  until (null vl) repeat
    newl:=
      [v for v in vl for d in dl | null setIntersection(d,vl)] or return nil
    orderedVarList:= [:newl,:orderedVarList]
    vl':= setDifference(vl,newl)
    dl':= [setDifference(d,newl) for x in vl for d in dl | member(x,vl')]
    vl:= vl'
    dl:= dl'
  REMDUP NREVERSE orderedVarList --ordered so ith is indep. of jth if i < j
 
compDefineCapsuleFunction(df is ['DEF,form,signature,specialCases,body],
  m,oldE,$prefix,$formalArgList) ==
    [lineNumber,:specialCases] := specialCases
    e := oldE
    --1. bind global variables
    $form: local
    $op: local
    $functionStats: local:= [0,0]
    $argumentConditionList: local
    $finalEnv: local
             --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 :=
      null member($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]
 
    if $newComp = true then
      wholeBody := ['DEF, form, signature', specialCases, body]
      T := CATCH('compCapsuleBody, newComp(wholeBody,$NoValueMode,e))
           or ["",rettype,e]
      T := [T.expr.2.2, rettype, T.env]
      if $newCompCompare=true then
         oldT := CATCH('compCapsuleBody, compOrCroak(body,rettype,e))
              or ["",rettype,e]
         SAY '"The old compiler generates:"
         prTriple oldT
         SAY '"The new compiler generates:"
         prTriple T
    else
      T := CATCH('compCapsuleBody, compOrCroak(body,rettype,e))
           or ["",rettype,e]
--+
      NRTassignCapsuleFunctionSlot($op,signature')
      if $newCompCompare=true then
         SAY '"The old compiler generates:"
         prTriple T
--  A THROW to the above CATCH occurs if too many semantic errors occur
--  see stackSemanticError
    catchTag:= MKQ GENSYM()
    fun:=
      body':= replaceExitEtc(T.expr,catchTag,"TAGGEDreturn",$returnMode)
      body':= addArgumentConditions(body',$op)
      finalBody:= ["CATCH",catchTag,body']
      compileCases([$op,["LAM",[:argl,'_$],finalBody]],oldE)
    $functorStats:= addStats($functorStats,$functionStats)
 
 
--  7. give operator a 'value property
    val:= [fun,signature',e]
    [fun,['Mapping,:signature'],oldE] -- oldE:= put($op,'value,removeEnv val,e)
 
getSignatureFromMode(form,e) ==
  getmode(opOf form,e) is ['Mapping,:signature] =>
    #form^=#signature => stackAndThrow ["Wrong number of arguments: ",form]
    EQSUBSTLIST(rest form,take(#rest form,$FormalMapVariableList),signature)
 
hasSigInTargetCategory(argl,form,opsig,e) ==
  mList:= [getArgumentMode(x,e) for x in argl]
    --each element is a declared mode for the variable or nil if none exists
  potentialSigList:=
    REMDUP
      [sig
        for [[opName,sig,:.],:.] in $domainShell.(1) |
          fn(opName,sig,opsig,mList,form)] where
            fn(opName,sig,opsig,mList,form) ==
              opName=$op and #sig=#form and (null opsig or opsig=first sig) and
                (and/[compareMode2Arg(x,m) for x in mList for m in rest sig])
  c:= #potentialSigList
  1=c => first potentialSigList
    --accept only those signatures op right length which match declared modes
  0=c => (#(sig:= getSignatureFromMode(form,e))=#form => sig; nil)
  1<c =>
    sig:= first potentialSigList
    stackWarning ["signature of lhs not unique:",:bright sig,"chosen"]
    sig
  nil --this branch will force all arguments to be declared
 
compareMode2Arg(x,m) == null x or modeEqual(x,m)
 
getArgumentModeOrMoan(x,form,e) ==
  getArgumentMode(x,e) or
    stackSemanticError(["argument ",x," of ",form," is not declared"],nil)
 
getArgumentMode(x,e) ==
  STRINGP x => x
  m:= get(x,'mode,e) => m
 
checkAndDeclare(argl,form,sig,e) ==
 
-- arguments with declared types must agree with those in sig;
-- those that don't get declarations put into e
  for a in argl for m in rest sig repeat
    m1:= getArgumentMode(a,e) =>
      ^modeEqual(m1,m) =>
        stack:= ["   ",:bright a,'"must have type ",m,
          '" not ",m1,'%l,:stack]
    e:= put(a,'mode,m,e)
  if stack then
    sayBrightly ['"   Parameters of ",:bright first form,
      '" are of wrong type:",'%l,:stack]
  e
 
getSignature(op,argModeList,$e) ==
  1=#
    (sigl:=
      REMDUP
        [sig
          for [[dc,:sig],[pred,:.]] in (mmList:= get(op,'modemap,$e)) | dc='_$
            and rest sig=argModeList and knownInfo pred]) => first sigl
  null sigl =>
    (u:= getmode(op,$e)) is ['Mapping,:sig] => sig
    SAY '"************* USER ERROR **********"
    SAY("available signatures for ",op,": ")
    if null mmList
       then SAY "    NONE"
       else for [[dc,:sig],:.] in mmList repeat printSignature("     ",op,sig)
    printSignature("NEED ",op,["?",:argModeList])
    nil
  for u in sigl repeat
    for v in sigl | not (u=v) repeat
      if SourceLevelSubsume(u,v) then sigl:= delete(v,sigl)
              --before we complain about duplicate signatures, we should
              --check that we do not have for example, a partial - as
              --well as a total one.  SourceLevelSubsume (from CATEGORY BOOT)
              --should do this
  1=#sigl => first sigl
  stackSemanticError(["duplicate signatures for ",op,": ",argModeList],nil)
 
--% ARGUMENT CONDITION CODE
 
stripOffArgumentConditions argl ==
  [f for x in argl for i in 1..] where
    f() ==
      x is ["|",arg,condition] =>
        condition:= SUBST('_#1,arg,condition)
        -- in case conditions are given in terms of argument names, replace
        $argumentConditionList:= [[i,arg,condition],:$argumentConditionList]
        arg
      x
 
stripOffSubdomainConditions(margl,argl) ==
  [f for x in margl for arg in argl for i in 1..] where
    f ==
      x is ['SubDomain,marg,condition] =>
        pair:= ASSOC(i,$argumentConditionList) =>
          (RPLAC(CADR pair,MKPF([condition,CADR pair],'AND)); marg)
        $argumentConditionList:= [[i,arg,condition],:$argumentConditionList]
        marg
      x
 
compArgumentConditions e ==
  $argumentConditionList:=
    [f for [n,a,x] in $argumentConditionList] where
      f ==
        y:= SUBST(a,'_#1,x)
        T := [.,.,e]:= compOrCroak(y,$Boolean,e)
        [n,x,T.expr]
  e
 
addArgumentConditions($body,$functionName) ==
  $argumentConditionList =>
               --$body is only used in this function
    fn $argumentConditionList where
      fn clist ==
        clist is [[n,untypedCondition,typedCondition],:.] =>
          ['COND,[typedCondition,fn rest clist],
            [$true,["argumentDataError",n,
              MKQ untypedCondition,MKQ $functionName]]]
        null clist => $body
        systemErrorHere '"addArgumentConditions"
  $body
 
putInLocalDomainReferences (def := [opName,[lam,varl,body]]) ==
  $elt: local := ($QuickCode => 'QREFELT; 'ELT)
--+
  NRTputInTail CDDADR def
  def
 
 
canCacheLocalDomain(dom,elt)==
   dom is [op,'_$,n] and MEMQ(op,'(ELT QREFELT)) => nil
   domargsglobal(dom) =>
        $functorLocalParameters:= [:$functorLocalParameters,dom]
        PUSH([dom,GENVAR(),[elt,$selector,$funcLocLen]],$usedDomList)
        $selcount:= $selcount+1
        $funcLocLen:= $funcLocLen+1
   nil
  where
     domargsglobal(dom) ==
       dom='_$ => true
       IDENTP dom => MEMQ(dom,$functorLocalParameters)
       ATOM dom => true
       and/[domargsglobal(arg) for arg in rest dom]
 
 
compileCases(x,$e) == -- $e is referenced in compile
  $specialCaseKeyList: local
  not ($insideFunctorIfTrue=true) => compile x
  specialCaseAssoc:=
    [y for y in getSpecialCaseAssoc() | not get(first y,"specialCase",$e) and
          ([R,R']:= y) and isEltArgumentIn(FindNamesFor(R,R'),x)] where
        FindNamesFor(R,R') ==
          [R,:
            [v
              for ['LET,v,u,:.] in $getDomainCode | CADR u=R and
                eval substitute(R',R,u)]]
        isEltArgumentIn(Rlist,x) ==
          atom x => nil
          x is ['ELT,R,.] => MEMQ(R,Rlist) or isEltArgumentIn(Rlist,rest x)
          x is ["QREFELT",R,.] => MEMQ(R,Rlist) or isEltArgumentIn(Rlist,rest x)
          isEltArgumentIn(Rlist,first x) or isEltArgumentIn(Rlist,rest x)
  null specialCaseAssoc => compile x
  listOfDomains:= ASSOCLEFT specialCaseAssoc
  listOfAllCases:= outerProduct ASSOCRIGHT specialCaseAssoc
  cl:=
    [u for l in listOfAllCases] where
      u() ==
        $specialCaseKeyList:= [[D,:C] for D in listOfDomains for C in l]
        [MKPF([["EQUAL",D,C] for D in listOfDomains for C in l],"AND"),
          compile COPY x]
  $specialCaseKeyList:= nil
  ["COND",:cl,[$true,compile x]]
 
getSpecialCaseAssoc() ==
  [[R,:l] for R in rest $functorForm
    for l in rest $functorSpecialCases | l]
 
compile u ==
  [op,lamExpr] := u
  if $suffix then
    $suffix:= $suffix+1
    op':=
      opexport:=nil
      opmodes:=
        [sel
          for [[DC,:sig],[.,sel]] in get(op,'modemap,$e) |
            DC='_$ and (opexport:=true) and
             (and/[modeEqual(x,y) for x in sig for y in $signatureOfForm])]
      isLocalFunction op =>
        if opexport then userError ['%b,op,'%d,'" is local and exported"]
        INTERN STRCONC(encodeItem $prefix,'";",encodeItem op) where
          isLocalFunction op ==
            null member(op,$formalArgList) and
              getmode(op,$e) is ['Mapping,:.]
      isPackageFunction() and KAR $functorForm^="CategoryDefaults" =>
        if null opmodes then userError ['"no modemap for ",op]
        opmodes is [['PAC,.,name]] => name
        encodeFunctionName(op,$functorForm,$signatureOfForm,";",$suffix)
      encodeFunctionName(op,$functorForm,$signatureOfForm,";",$suffix)
    u:= [op',lamExpr]
  -- If just updating certain functions, check for previous existence.
  -- Deduce old sequence number and use it (items have been skipped).
  if $LISPLIB and $compileOnlyCertainItems then
    parts := splitEncodedFunctionName(u.0, ";")
--  Next line JHD/SMWATT 7/17/86 to deal with inner functions
    parts='inner => $savableItems:=[u.0,:$savableItems]
    unew  := nil
    for [s,t] in $splitUpItemsAlreadyThere repeat
       if parts.0=s.0 and parts.1=s.1 and parts.2=s.2 then unew := t
    null unew =>
      sayBrightly ['"   Error: Item did not previously exist"]
      sayBrightly ['"   Item not saved: ", :bright u.0]
      sayBrightly ['"   What's there is: ", $lisplibItemsAlreadyThere]
      nil
    sayBrightly ['"   Renaming ", u.0, '" as ", unew]
    u := [unew, :rest u]
    $savableItems := [unew, :$saveableItems] -- tested by embedded RWRITE
  optimizedBody:= optimizeFunctionDef u
  stuffToCompile:=
    if null $insideCapsuleFunctionIfTrue
       then optimizedBody
       else putInLocalDomainReferences optimizedBody
  $doNotCompileJustPrint=true => (PRETTYPRINT stuffToCompile; op')
  $macroIfTrue => constructMacro stuffToCompile
  result:= spadCompileOrSetq stuffToCompile
  functionStats:=[0,elapsedTime()]
  $functionStats:= addStats($functionStats,functionStats)
  printStats functionStats
  result
 
spadCompileOrSetq (form is [nam,[lam,vl,body]]) ==
        --bizarre hack to take account of the existence of "known" functions
        --good for performance (LISPLLIB size, BPI size, NILSEC)
  CONTAINED("",body) => sayBrightly ['"  ",:bright nam,'" not compiled"]
  if vl is [:vl',E] and body is [nam',: =vl'] then
      LAM_,EVALANDFILEACTQ ['PUT,MKQ nam,MKQ 'SPADreplace,MKQ nam']
      sayBrightly ['"     ",:bright nam,'"is replaced by",:bright nam']
  else if (ATOM body or and/[ATOM x for x in body])
         and vl is [:vl',E] and not CONTAINED(E,body) then
           macform := ['XLAM,vl',body]
           LAM_,EVALANDFILEACTQ ['PUT,MKQ nam,MKQ 'SPADreplace,MKQ macform]
           sayBrightly ['"     ",:bright nam,'"is replaced by",:bright body]
  $insideCapsuleFunctionIfTrue => first COMP LIST form
  compileConstructor form
 
compileConstructor form ==
  u:= compileConstructor1 form
  clearClams()                  --clear all CLAMmed functions
  u
 
compileConstructor1 (form:=[fn,[key,vl,:bodyl]]) ==
-- fn is the name of some category/domain/package constructor;
-- we will cache all of its values on $ConstructorCache with reference
-- counts
  $clamList: local
  lambdaOrSlam :=
    GETDATABASE(fn,'CONSTRUCTORKIND) = 'category => 'SPADSLAM
    $mutableDomain => 'LAMBDA
    $clamList:=
      [[fn,"$ConstructorCache",'domainEqualList,'count],:$clamList]
    'LAMBDA
  compForm:= LIST [fn,[lambdaOrSlam,vl,:bodyl]]
  if GETDATABASE(fn,'CONSTRUCTORKIND) = 'category
      then u:= compAndDefine compForm
      else u:=COMP compForm
  clearConstructorCache fn      --clear cache for constructor
  first u
 
constructMacro (form is [nam,[lam,vl,body]]) ==
  ^(and/[atom x for x in vl]) =>
    stackSemanticError(["illegal parameters for macro: ",vl],nil)
  ["XLAM",vl':= [x for x in vl | IDENTP x],body]
 
listInitialSegment(u,v) ==
  null u => true
  null v => nil
  first u=first v and listInitialSegment(rest u,rest v)
  --returns true iff u.i=v.i for i in 1..(#u)-1
 
modemap2Signature [[.,:sig],:.] == sig
 
uncons x ==
  atom x => x
  x is ["CONS",a,b] => [a,:uncons b]
 
--% CAPSULE
 
bootStrapError(functorForm,sourceFile) ==
  ['COND, _
    ['$bootStrapMode, _
        ['VECTOR,mkDomainConstructor functorForm,nil,nil,nil,nil,nil]],
    [''T, ['systemError,['LIST,''%b,MKQ CAR functorForm,''%d,'"from", _
      ''%b,MKQ namestring sourceFile,''%d,'"needs to be compiled"]]]]
 
compAdd(['add,$addForm,capsule],m,e) ==
  $bootStrapMode = true =>
    if $addForm is ['Tuple,:.] then code := nil
       else [code,m,e]:= comp($addForm,m,e)
    [['COND, _
       ['$bootStrapMode, _
           code],_
       [''T, ['systemError,['LIST,''%b,MKQ CAR $functorForm,''%d,'"from", _
         ''%b,MKQ namestring _/EDITFILE,''%d,'"needs to be compiled"]]]],m,e]
  $addFormLhs: local:= $addForm
  if $addForm is ["SubDomain",domainForm,predicate] then
    $packagesUsed := [domainForm,:$packagesUsed]
--+
    $NRTaddForm := domainForm
    NRTgetLocalIndex domainForm
    --need to generate slot for add form since all $ go-get
    --  slots will need to access it
    [$addForm,.,e]:= compSubDomain1(domainForm,predicate,m,e)
  else
    $packagesUsed :=
      $addForm is ['Tuple,:u] => [:u,:$packagesUsed]
      [$addForm,:$packagesUsed]
--+
    $NRTaddForm := $addForm
    [$addForm,.,e]:=
      $addForm is ['Tuple,:.] =>
        $NRTaddForm := ['Tuple,:[NRTgetLocalIndex x for x in rest $addForm]]
        compOrCroak(compTuple2Record $addForm,$EmptyMode,e)
      compOrCroak($addForm,$EmptyMode,e)
  compCapsule(capsule,m,e)
 
compTuple2Record u == ['Record,:[[":",i,x] for i in 1.. for x in rest u]]
 
compCapsule(['CAPSULE,:itemList],m,e) ==
  $bootStrapMode = true =>
    [bootStrapError($functorForm, _/EDITFILE),m,e]
  $insideExpressionIfTrue: local:= false
  compCapsuleInner(itemList,m,addDomain('_$,e))
 
compSubDomain(["SubDomain",domainForm,predicate],m,e) ==
  $addFormLhs: local:= domainForm
  $addForm: local
  $NRTaddForm := domainForm
  [$addForm,.,e]:= compSubDomain1(domainForm,predicate,m,e)
--+
  compCapsule(['CAPSULE],m,e)
 
compSubDomain1(domainForm,predicate,m,e) ==
  [.,.,e]:=
    compMakeDeclaration([":","#1",domainForm],$EmptyMode,addDomain(domainForm,e))
  u:=
    compOrCroak(predicate,$Boolean,e) or
      stackSemanticError(["predicate: ",predicate,
        " cannot be interpreted with #1: ",domainForm],nil)
  prefixPredicate:= lispize u.expr
  $lisplibSuperDomain:=
    [domainForm,predicate]
  evalAndRwriteLispForm('evalOnLoad2,
    ['SETQ,'$CategoryFrame,['put,op':= ['QUOTE,$op],'
     (QUOTE SuperDomain),dF':= ['QUOTE,domainForm],['put,dF','(QUOTE SubDomain),[
       'CONS,['QUOTE,[$op,:prefixPredicate]],['DELASC,op',['get,dF','
         (QUOTE SubDomain),'$CategoryFrame]]],'$CategoryFrame]]])
  [domainForm,m,e]
 
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)
  localParList:= $functorLocalParameters
  if $addForm then data:= ['add,$addForm,data]
  code:=
    $insideCategoryIfTrue and not $insideCategoryPackageIfTrue => data
    processFunctorOrPackage($form,$signature,data,localParList,m,e)
  [MKPF([:$getDomainCode,code],"PROGN"),m,e]
 
--% PROCESS FUNCTOR CODE
 
processFunctor(form,signature,data,localParList,e) ==
  form is ["CategoryDefaults"] =>
    error "CategoryDefaults is a reserved name"
  buildFunctor(form,signature,data,localParList,e)
 
<<compCapsuleItems>>
compSingleCapsuleItem(item,$predl,$e) ==
  doIt(macroExpandInPlace(item,$e),$predl)
  $e
 
doIt(item,$predl) ==
  $GENNO: local:= 0
  item is ['SEQ,:l,['exit,1,x]] =>
    RPLACA(item,"PROGN")
    RPLACA(LASTNODE item,x)
    for it1 in rest item repeat $e:= compSingleCapsuleItem(it1,$predl,$e)
        --This will RPLAC as appropriate
  isDomainForm(item,$e) =>
     -- convert naked top level domains to import
    u:= ['import, [first item,:rest item]]
    stackWarning ["Use: import ", [first item,:rest item]]
    RPLACA(item,first u)
    RPLACD(item,rest u)
    doIt(item,$predl)
  item is ['LET,lhs,rhs,:.] =>
    not (compOrCroak(item,$EmptyMode,$e) is [code,.,$e]) =>
      stackSemanticError(["cannot compile assigned value to",:bright lhs],nil)
    not (code is ['LET,lhs',rhs',:.] and atom lhs') =>
      code is ["PROGN",:.] =>
         stackSemanticError(["multiple assignment ",item," not allowed"],nil)
      RPLACA(item,first code)
      RPLACD(item,rest code)
    lhs:= lhs'
    if not member(KAR rhs,$NonMentionableDomainNames) and
      not MEMQ(lhs, $functorLocalParameters) then
         $functorLocalParameters:= [:$functorLocalParameters,lhs]
    if code is ['LET,.,rhs',:.] and isDomainForm(rhs',$e) then
      if isFunctor rhs' then
        $functorsUsed:= insert(opOf rhs',$functorsUsed)
        $packagesUsed:= insert([opOf rhs'],$packagesUsed)
      if lhs="Rep" then
        $Representation:= (get("Rep",'value,$e)).(0)
           --$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]
--+
    code is ['LET,:.] =>
      RPLACA(item,($QuickCode => 'QSETREFV;'SETELT))
      rhsCode:=
       rhs'
      RPLACD(item,['$,NRTgetLocalIndexClear lhs,rhsCode])
    RPLACA(item,first code)
    RPLACD(item,rest code)
  item is [":",a,t] => [.,.,$e]:= compOrCroak(item,$EmptyMode,$e)
  item is ['import,:doms] =>
     for dom in doms repeat
       sayBrightly ['"   importing ",:formatUnabbreviated dom]
     [.,.,$e] := compOrCroak(item,$EmptyMode,$e)
     RPLACA(item,'PROGN)
     RPLACD(item,NIL) -- creates a no-op
  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,[op,:.],:.] =>
    body:= isMacro(item,$e) => $e:= put(op,'macro,body,$e)
    [.,.,$e]:= t:= compOrCroak(item,$EmptyMode,$e)
    RPLACA(item,"CodeDefine")
        --Note that DescendCode, in CodeDefine, is looking for this
    RPLACD(CADR item,[$signatureOfForm])
      --This is how the signature is updated for buildFunctor to recognise
--+
    functionPart:= ['dispatchFunction,t.expr]
    RPLACA(CDDR item,functionPart)
    RPLACD(CDDR item,nil)
  u:= compOrCroak(item,$EmptyMode,$e) =>
    ([code,.,$e]:= u; RPLACA(item,first code); RPLACD(item,rest code))
  true => cannotDo()
 
isMacro(x,e) ==
  x is ['DEF,[op,:args],signature,specialCases,body] and
    null get(op,'modemap,e) and null args and null get(op,'mode,e)
      and signature is [nil] => body
 
doItIf(item is [.,p,x,y],$predl,$e) ==
  olde:= $e
  [p',.,$e]:= comp(p,$Boolean,$e) or userError ['"not a Boolean:",p]
  oldFLP:=$functorLocalParameters
  if x^="noBranch" then
    compSingleCapsuleItem(x,$predl,getSuccessEnvironment(p,$e))
    x':=localExtras(oldFLP)
          where localExtras(oldFLP) ==
            EQ(oldFLP,$functorLocalParameters) => NIL
            flp1:=$functorLocalParameters
            oldFLP':=oldFLP
            n:=0
            while oldFLP' repeat
              oldFLP':=CDR oldFLP'
              flp1:=CDR 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,:NREVERSE nils]
            NREVERSE ans
  oldFLP:=$functorLocalParameters
  if y^="noBranch" then
    compSingleCapsuleItem(y,$predl,getInverseEnvironment(p,olde))
    y':=localExtras(oldFLP)
  RPLACA(item,"COND")
  RPLACD(item,[[p',x,:x'],['(QUOTE T),y,:y']])
 
--compSingleCapsuleIf(x,predl,e,$functorLocalParameters) ==
--  compSingleCapsuleItem(x,predl,e)
 
--% CATEGORY AND DOMAIN FUNCTIONS
compContained(["CONTAINED",a,b],m,e) ==
  [a,ma,e]:= comp(a,$EmptyMode,e) or return nil
  [b,mb,e]:= comp(b,$EmptyMode,e) or return nil
  isCategoryForm(ma,e) and isCategoryForm(mb,e) =>
    (T:= [["CONTAINED",a,b],$Boolean,e]; convert(T,m))
  nil
 
compJoin(["Join",:argl],m,e) ==
  catList:= [(compForMode(x,$Category,e) or return 'failed).expr for x in argl]
  catList='failed => stackSemanticError(["cannot form Join of: ",argl],nil)
  catList':=
    [extract for x in catList] where
      extract() ==
        isCategoryForm(x,e) =>
          parameters:=
            union("append"/[getParms(y,e) for y in rest x],parameters)
              where getParms(y,e) ==
                atom y =>
                  isDomainForm(y,e) => LIST y
                  nil
                y is ['LENGTH,y'] => [y,y']
                LIST y
          x
        x is ["DomainSubstitutionMacro",pl,body] =>
          (parameters:= union(pl,parameters); body)
        x is ["mkCategory",:.] => x
        atom x and getmode(x,e)=$Category => x
        stackSemanticError(["invalid argument to Join: ",x],nil)
        x
  T:= [wrapDomainSub(parameters,["Join",:catList']),$Category,e]
  convert(T,m)
 
compForMode(x,m,e) ==
  $compForModeIfTrue: local:= true
  comp(x,m,e)
 
compMakeCategoryObject(c,$e) ==
  not isCategoryForm(c,$e) => nil
  u:= mkEvalableCategoryForm c => [eval u,$Category,$e]
  nil
 
quotifyCategoryArgument x == MKQ x
 
makeCategoryForm(c,e) ==
  not isCategoryForm(c,e) => nil
  [x,m,e]:= compOrCroak(c,$EmptyMode,e)
  [x,e]
 
compCategory(x,m,e) ==
  $TOP__LEVEL: local:= true
  (m:= resolve(m,["Category"]))=["Category"] and x is ['CATEGORY,
    domainOrPackage,:l] =>
      $sigList: local
      $atList: local
      $sigList:= $atList:= nil
      for x in l repeat compCategoryItem(x,nil)
      rep:= mkExplicitCategoryFunction(domainOrPackage,$sigList,$atList)
    --if inside compDefineCategory, provide for category argument substitution
      [rep,m,e]
  systemErrorHere '"compCategory"
 
mkExplicitCategoryFunction(domainOrPackage,sigList,atList) ==
  body:=
    ["mkCategory",MKQ domainOrPackage,['LIST,:REVERSE sigList],['LIST,:
      REVERSE atList],MKQ domList,nil] where
        domList() ==
          ("union"/[fn sig for ["QUOTE",[[.,sig,:.],:.]] in sigList]) where
            fn sig == [D for D in sig | mustInstantiate D]
  parameters:=
    REMDUP
      ("append"/
        [[x for x in sig | IDENTP x and x^='_$]
          for ["QUOTE",[[.,sig,:.],:.]] in sigList])
  wrapDomainSub(parameters,body)
 
wrapDomainSub(parameters,x) ==
   ["DomainSubstitutionMacro",parameters,x]
 
mustInstantiate D ==
  D is [fn,:.] and ^(MEMQ(fn,$DummyFunctorNames) or GETL(fn,"makeFunctionList"))
 
DomainSubstitutionFunction(parameters,body) ==
  --see definition of DomainSubstitutionMacro in SPAD LISP
  if parameters then
    (body:= Subst(parameters,body)) where
      Subst(parameters,body) ==
        ATOM body =>
          MEMQ(body,parameters) => MKQ body
          body
        member(body,parameters) =>
          g:=GENSYM()
          $extraParms:=PUSH([g,:body],$extraParms)
           --Used in SetVector12 to generate a substitution list
           --bound in buildFunctor
           --For categories, bound and used in compDefineCategory
          MKQ g
        first body="QUOTE" => body
        PAIRP $definition and
            isFunctor first body and
              first body ^= first $definition
          =>  ['QUOTE,optimize body]
        [Subst(parameters,u) for u in body]
  not (body is ["Join",:.]) => body
  atom $definition => body
  null rest $definition => body
           --should not bother if it will only be called once
  name:= INTERN STRCONC(KAR $definition,";CAT")
  SETANDFILE(name,nil)
  body:= ["COND",[name],['(QUOTE T),['SETQ,name,body]]]
  body
 
compCategoryItem(x,predl) ==
  x is nil => nil
  --1. if x is a conditional expression, recurse; otherwise, form the predicate
  x is ["COND",[p,e]] =>
    predl':= [p,:predl]
    e is ["PROGN",:l] => for y in l repeat compCategoryItem(y,predl')
    compCategoryItem(e,predl')
  x is ["IF",a,b,c] =>
    predl':= [a,:predl]
    if b^="noBranch" then
      b is ["PROGN",:l] => for y in l repeat compCategoryItem(y,predl')
      compCategoryItem(b,predl')
    c="noBranch" => nil
    predl':= [["not",a],:predl]
    c is ["PROGN",:l] => for y in l repeat compCategoryItem(y,predl')
    compCategoryItem(c,predl')
  pred:= (predl => MKPF(predl,"AND"); true)
 
  --2. if attribute, push it and return
  x is ["ATTRIBUTE",y] => PUSH(MKQ [y,pred],$atList)
 
  --3. it may be a list, with PROGN as the CAR, and some information as the CDR
  x is ["PROGN",:l] => for u in l repeat compCategoryItem(u,predl)
 
-- 4. otherwise, x gives a signature for a
--    single operator name or a list of names; if a list of names,
--    recurse
  ["SIGNATURE",op,:sig]:= x
  null atom op =>
    for y in op repeat compCategoryItem(["SIGNATURE",y,:sig],predl)
 
  --4. branch on a single type or a signature %with source and target
  PUSH(MKQ [rest x,pred],$sigList)
 







@
\eject
\begin{thebibliography}{99}
\bibitem{1} nothing
\end{thebibliography}
\end{document}