1-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
2-- All rights reserved.
3--
4-- Redistribution and use in source and binary forms, with or without
5-- modification, are permitted provided that the following conditions are
6-- met:
7--
8--     - Redistributions of source code must retain the above copyright
9--       notice, this list of conditions and the following disclaimer.
10--
11--     - Redistributions in binary form must reproduce the above copyright
12--       notice, this list of conditions and the following disclaimer in
13--       the documentation and/or other materials provided with the
14--       distribution.
15--
16--     - Neither the name of The Numerical ALgorithms Group Ltd. nor the
17--       names of its contributors may be used to endorse or promote products
18--       derived from this software without specific prior written permission.
19--
20-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
21-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
22-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
23-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
24-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
25-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
26-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
27-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
28-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
29-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
30-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31
32)package "BOOT"
33
34DEFPARAMETER($newCompCompare, false)
35
36--% FUNCTIONS WHICH MUNCH ON == STATEMENTS
37
38compDefine(form,m,e) ==
39  result:= compDefine1(form,m,e)
40  result
41
42compDefine1(form,m,e) ==
43  --1. decompose after macro-expanding form
44  ['DEF,lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e)
45  $insideWhereIfTrue and isMacro(form,e) and (m=$EmptyMode or m=$NoValueMode)
46     => [lhs,m,put(first lhs,'macro,rhs,e)]
47  null signature.target and not MEMQ(IFCAR rhs, $ConstructorNames) and
48    (sig:= getSignatureFromMode(lhs,e)) =>
49  -- here signature of lhs is determined by a previous declaration
50      compDefine1(['DEF,lhs,[first sig,:rest signature],specialCases,rhs],m,e)
51  $insideCapsuleFunctionIfTrue =>
52      compInternalFunction(form, m, e)
53  if signature.target=$Category then $insideCategoryIfTrue:= true
54
55-- RDJ (11/83): when argument and return types are all declared,
56--  or arguments have types declared in the environment,
57--  and there is no existing modemap for this signature, add
58--  the modemap by a declaration, then strip off declarations and recurse
59  e := compDefineAddSignature(lhs,signature,e)
60-- 2. if signature list for arguments is not empty, replace ('DEF,..) by
61--       ('where,('DEF,..),..) with an empty signature list;
62--     otherwise, fill in all NILs in the signature
63  not (and/[null x for x in rest signature]) => compDefWhereClause(form,m,e)
64  signature.target=$Category =>
65      compDefineCategory(form, m, e, nil, $formalArgList)
66  isDomainForm(rhs,e) and not $insideFunctorIfTrue =>
67    if null signature.target then signature:=
68      [getTargetFromRhs(lhs,rhs,giveFormalParametersValues(rest lhs,e)),:
69          rest signature]
70    rhs:= addEmptyCapsuleIfNecessary(signature.target,rhs)
71    new_prefix := getAbbreviation(first(lhs), #(rest(lhs)))
72    compDefineFunctor(['DEF, lhs, signature, specialCases, rhs], m, e,
73                      new_prefix, $formalArgList)
74  null($functorForm) => stackAndThrow ['"bad == form ",form]
75  compDefineCapsuleFunction(form, m, e, $prefix, $formalArgList)
76
77compDefineAddSignature([op,:argl],signature,e) ==
78  (sig:= hasFullSignature(argl,signature,e)) and
79   not assoc(['$,:sig],LASSOC('modemap,getProplist(op,e))) =>
80     declForm:=
81       [":",[op,:[[":",x,m] for x in argl for m in rest sig]],first signature]
82     [.,.,e]:= comp(declForm,$EmptyMode,e)
83     e
84  e
85
86hasFullSignature(argl,[target,:ml],e) ==
87  target =>
88    u:= [m or get(x,"mode",e) or return 'failed for x in argl for m in ml]
89    u~='failed => [target,:u]
90
91addEmptyCapsuleIfNecessary(target,rhs) ==
92  MEMQ(IFCAR rhs, $SpecialDomainNames) => rhs
93  ['add,rhs,['CAPSULE]]
94
95getTargetFromRhs(lhs,rhs,e) ==
96  --undeclared target mode obtained from rhs expression
97  rhs is ['CAPSULE,:.] =>
98    stackSemanticError(['"target category of ",lhs,
99      '" cannot be determined from definition"],nil)
100  rhs is ['SubDomain,D,:.] => getTargetFromRhs(lhs,D,e)
101  rhs is ['add,D,['CAPSULE,:.]] => getTargetFromRhs(lhs,D,e)
102  rhs is ['Record,:l] => ['RecordCategory,:l]
103  rhs is ['Union,:l] => ['UnionCategory,:l]
104  [.,target,.]:= compOrCroak(rhs,$EmptyMode,e)
105  target is ["Category"] =>
106      stackAndThrow(['"Only domains and packages can get mode form target",
107                     lhs])
108  target
109
110giveFormalParametersValues(argl,e) ==
111  for x in argl repeat
112    e:= put(x,'value,[genSomeVariable(),get(x,'mode,e),nil],e)
113  e
114
115macroExpandInPlace(x,e) ==
116  y:= macroExpand(x,e)
117  atom x or atom y => y
118  RPLACA(x,first y)
119  RPLACD(x,rest y)
120  x
121
122macroExpand(x,e) ==   --not worked out yet
123  atom x =>
124      u := get(x, 'macro, e) =>
125          null(rest(u)) =>
126              macroExpand(first u, e)
127          SAY(["u =", u])
128          userError("macro call needs arguments")
129      x
130  x is ['DEF,lhs,sig,spCases,rhs] =>
131    ['DEF,macroExpand(lhs,e),macroExpandList(sig,e),macroExpandList(spCases,e),
132      macroExpand(rhs,e)]
133  x is [op, :args] =>
134      ATOM(op) =>
135          u := get(op, 'macro, e) =>
136              margs := rest(u)
137              u := first(u)
138              null(margs) => [macroExpand(u, e), :macroExpandList(args, e)]
139              #args = #margs =>
140                  macroExpand(SUBLISLIS(args, margs, u), e)
141              userError("invalid macro call, #args ~= #margs")
142          [op, :macroExpandList(args, e)]
143      macroExpandList(x,e)
144  macroExpandList(x,e)
145
146macroExpandList(l,e) ==
147  [macroExpand(x,e) for x in l]
148
149compDefineCategory1(df is ['DEF,form,sig,sc,body],m,e,prefix,fal) ==
150  categoryCapsule :=
151--+
152    body is ['add,cat,capsule] =>
153      body := cat
154      capsule
155    nil
156  [d,m,e]:= compDefineCategory2(form,sig,sc,body,m,e,prefix,fal)
157--+ next two lines
158  if categoryCapsule and not $bootStrapMode then [.,.,e] :=
159    $insideCategoryPackageIfTrue: local := true  --see NRTmakeSlot1
160-->
161    $categoryPredicateList: local :=
162        makeCategoryPredicates(form,$lisplibCategory)
163    compDefine1(mkCategoryPackage(form, cat, categoryCapsule, e),
164                $EmptyMode, e)
165  [d,m,e]
166
167makeCategoryPredicates(form,u) ==
168      $tvl := TAKE(#rest form,$TriangleVariableList)
169      $mvl := TAKE(#rest form,rest $FormalMapVariableList)
170      fn(u,nil) where
171        fn(u,pl) ==
172          u is ['Join,:.,a] => fn(a,pl)
173          u is ['has,:.] => insert(EQSUBSTLIST($mvl,$tvl,u),pl)
174          u is [op, :.] and MEMQ(op, ["SIGNATURE", "ATTRIBUTE"]) =>
175               -- EQ(op, 'ATTRIBUTE) => BREAK()
176               pl
177          atom u => pl
178          fnl(u,pl)
179        fnl(u,pl) ==
180          for x in u repeat pl := fn(x,pl)
181          pl
182
183--+ the following function
184mkCategoryPackage(form is [op, :argl], cat, def, e) ==
185  packageName:= INTERN(STRCONC(PNAME op,'"&"))
186  packageAbb := INTERN(STRCONC(GETDATABASE(op,'ABBREVIATION),'"-"))
187  $options:local := []
188  -- This stops the next line from becoming confused
189  abbreviationsSpad2Cmd ['domain,packageAbb,packageName]
190  -- This is a little odd, but the parser insists on calling
191  -- domains, rather than packages
192  nameForDollar := first SETDIFFERENCE('(S A B C D E F G H I),argl)
193  packageArgl := [nameForDollar,:argl]
194  capsuleDefAlist := fn(def,nil) where fn(x,oplist) ==
195    atom x => oplist
196    x is ['DEF,y,:.] => [y,:oplist]
197    fn(rest x,fn(first x,oplist))
198  explicitCatPart := gn cat where gn cat ==
199    cat is ['CATEGORY,:.] => rest rest cat
200    cat is ['Join,:u] => gn last u
201    nil
202  catvec := eval mkEvalableCategoryForm(form, e)
203  fullCatOpList := (JoinInner([catvec])).1
204  catOpList :=
205    --note: this gets too many modemaps in general
206    --   this is cut down in NRTmakeSlot1
207    [['SIGNATURE,op1,sig] for [[op1,sig],:.] in fullCatOpList
208         --above line calls the category constructor just compiled
209        | assoc(op1,capsuleDefAlist)]
210  null catOpList => nil
211  packageCategory := ['CATEGORY,'domain,
212                     :SUBLISLIS(argl,$FormalMapVariableList,catOpList)]
213  nils:= [nil for x in argl]
214  packageSig := [packageCategory,form,:nils]
215  $categoryPredicateList := SUBST(nameForDollar,'$,$categoryPredicateList)
216  SUBST(nameForDollar,'$,
217      ['DEF,[packageName,:packageArgl],packageSig,[nil,:nils],def])
218
219compDefineCategory2(form,signature,specialCases,body,m,e,
220  $prefix,$formalArgList) ==
221    --1. bind global variables
222    $insideCategoryIfTrue: local:= true
223    $definition : local := form
224                 --used by DomainSubstitutionFunction
225    $extraParms: local := nil
226             --Set in DomainSubstitutionFunction, used further down
227--  1.1  augment e to add declaration $: <form>
228    $op: local := nil
229    [$op, :argl] := form
230    e := addBinding("$", [['mode, :form]],e)
231
232--  2. obtain signature
233    signature':=
234        [first signature, :[getArgumentModeOrMoan(a, form, e) for a in argl]]
235    e:= giveFormalParametersValues(argl,e)
236
237--   3. replace arguments by $1,..., substitute into body,
238--     and introduce declarations into environment
239    sargl:= TAKE(# argl, $TriangleVariableList)
240    sform := [$op, :sargl]
241    $functorForm : local := sform
242    $formalArgList:= [:sargl,:$formalArgList]
243    aList:= [[a,:sa] for a in argl for sa in sargl]
244    formalBody:= SUBLIS(aList,body)
245    signature' := SUBLIS(aList,signature')
246--Begin lines for category default definitions
247    $functionStats: local:= [0,0]
248    $functorStats: local:= [0,0]
249    $addForm: local:= nil
250    $functor_cosig1 : local := [categoryForm?(t) for t in rest(signature')]
251    for x in sargl for t in rest signature' repeat
252      [.,.,e]:= compMakeDeclaration([":",x,t],m,e)
253
254--   4. compile body in environment of type declarations for arguments
255    op':= $op
256    -- following line causes cats with no with or Join to be fresh copies
257    if opOf(formalBody)~='Join and opOf(formalBody)~='mkCategory then
258           formalBody := ['Join, formalBody]
259    body:= optFunctorBody (compOrCroak(formalBody,signature'.target,e)).expr
260    if $extraParms then
261      formals:=actuals:=nil
262      for u in $extraParms repeat
263        formals := [first u, :formals]
264        actuals:=[MKQ CDR u,:actuals]
265      body := ['sublisV, ['MAKE_PAIRS, ['QUOTE, formals],
266                                       ['LIST, :actuals]], body]
267    if argl then body:=  -- always subst for args after extraparms
268        ['sublisV, ['MAKE_PAIRS, ['QUOTE, sargl], ['LIST, :sargl]], body]
269    -- FIXME: generate call to 'devaluate' only for domains
270    body:=
271        ['PROG1, ['LET, g:= GENSYM(), body],
272                 ['SETELT, g, 0, mkConstructor(sform)]]
273    fun := do_compile([op', ['category_functor, sargl, body]], e)
274
275--  5. give operator a 'modemap property
276    pairlis:= [[a,:v] for a in argl for v in $FormalMapVariableList]
277    parSignature:= SUBLIS(pairlis,signature')
278    parForm:= SUBLIS(pairlis,form)
279    --Equivalent to the following two lines, we hope
280    if null sargl then
281      evalAndRwriteLispForm('NILADIC,
282            ['MAKEPROP,['QUOTE,op'],'(QUOTE NILADIC),true])
283
284--   6. put modemaps into InteractiveModemapFrame
285    $lisplibCategory:= formalBody
286    if $LISPLIB then
287      $lisplibForm:= form
288      $lisplibKind:= 'category
289      modemap:= [[parForm,:parSignature],[true,op']]
290      $lisplibModemap:= modemap
291      $lisplibParents  :=
292        getParentsFor($op,$FormalMapVariableList,$lisplibCategory)
293      $lisplibAncestors := computeAncestorsOf(sform, nil)
294      $lisplibAbbreviation := constructor? $op
295      domainShell := eval [op', :MAPCAR('MKQ, sargl)]
296      augLisplibModemapsFromCategory(sform, formalBody, signature',
297                                     domainShell)
298    [fun, '(Category), e]
299
300mkConstructor form ==
301  atom form => BREAK()
302  null rest form => ['QUOTE,[first form]]
303  ['LIST, MKQ first form, :rest(form)]
304
305compDefineCategory(df,m,e,prefix,fal) ==
306  $lisplibCategory: local := nil
307  not $insideFunctorIfTrue and $LISPLIB =>
308    compDefineLisplib(df,m,e,prefix,fal,'compDefineCategory1)
309  compDefineCategory1(df,m,e,prefix,fal)
310
311compDefineFunctor(df,m,e,prefix,fal) ==
312  $domainShell: local -- holds the category of the object being compiled
313  $LISPLIB => compDefineLisplib(df,m,e,prefix,fal,'compDefineFunctor1)
314  compDefineFunctor1(df,m,e,prefix,fal)
315
316compDefineFunctor1(df is ['DEF,form,signature,$functorSpecialCases,body],
317  m, e, $prefix, $formalArgList) ==
318--  1. bind global variables
319    $addForm: local := nil
320
321    $functionStats: local:= [0,0]
322    $functorStats: local:= [0,0]
323    $signature: local := nil
324    $Representation: local := nil
325         --Set in doIt, accessed in the compiler - compNoStacking
326    $functorLocalParameters: local := nil
327    $CheckVectorList: local := nil
328                  --prevents CheckVector from printing out same message twice
329    $insideFunctorIfTrue: local:= true
330    $genSDVar: local:= 0
331    originale := e
332    $op: local := nil
333    [$op,:argl]:= form
334    $formalArgList:= [:argl,:$formalArgList]
335    $pairlis := [[a,:v] for a in argl for v in $FormalMapVariableList]
336    $mutableDomain: local :=
337      -- all defaulting packages should have caching turned off
338       isCategoryPackageName $op or
339         (if BOUNDP '$mutableDomains then MEMQ($op,$mutableDomains)
340            else false )   --true if domain has mutable state
341    signature':=
342      [first signature, :[getArgumentModeOrMoan(a, form, e) for a in argl]]
343    $functorForm : local := form
344    if null first signature' then BREAK()
345    target:= first signature'
346    e := giveFormalParametersValues(argl, e)
347    [ds, ., e] := compMakeCategoryObject(target, e) or
348      sayBrightly '"   cannot produce category object:"
349      pp target
350      userError '"cannot produce category object"
351--+ copy needed since slot1 is reset; compMake.. can return a cached vector
352    base_shell := COPY_-SEQ ds
353    $domainShell := base_shell
354--+ 7 lines for $NRT follow
355-->--these globals used by NRTmakeCategoryAlist, set by NRTsetVector4Part1
356    $condAlist: local := nil
357    $uncondAlist: local := nil
358-->>-- next global initialized here, reset by NRTbuildFunctor
359    $NRTslot1PredicateList: local := nil
360       --this is used below to set $lisplibSlot1 global
361    $NRTbase: local := 6 -- equals length of $domainShell
362    $NRTaddForm: local := nil   -- see compAdd; NRTmakeSlot1
363    $NRTdeltaLength: local := 0 -- length of $NRTdeltaList
364    $NRTdeltaList: local := nil --list of misc. elts used in compiled fncts
365    -- parallel to $NRTdeltaList, list of COMP-ed forms for $NRTdeltaList
366    $NRTdeltaListComp: local := nil
367    -- the above optimizes the calls to local domains
368    $template: local:= nil --stored in the lisplib (if $NRTvec = true)
369    $functionLocations: local := nil --locations of defined functions in source
370    $functor_cosig1 : local := [categoryForm?(t) for t in rest(signature')]
371    -- generate slots for arguments first, then for $NRTaddForm in compAdd
372    for x in argl repeat NRTgetLocalIndex(x, e)
373    [., ., e] := compMakeDeclaration([":", '_$, target], m, e)
374
375
376    if $insideCategoryPackageIfTrue~= true  then
377        e := augModemapsFromCategory('_$, '_$, '_$, target, e)
378    $signature:= signature'
379    parSignature:= SUBLIS($pairlis,signature')
380    parForm:= SUBLIS($pairlis,form)
381
382--  (3.1) now make a list of the functor's local parameters; for
383--  domain D in argl,check its signature: if domain, its type is Join(A1,..,An);
384--  in this case, D is replaced by D1,..,Dn (gensyms) which are set
385--  to the A1,..,An view of D
386--+
387    $functorLocalParameters := argl
388    e := makeFunctorArgumentParameters(argl, rest signature',
389                                        first signature', e)
390 -- must do above to bring categories into scope --see line 5 of genDomainView
391--  4. compile body in environment of type declarations for arguments
392    op':= $op
393    rettype:= signature'.target
394    T := compFunctorBody(body, rettype, e, parForm, base_shell)
395
396    body':= T.expr
397    lamOrSlam :=
398        $mutableDomain => 'mutable_domain_functor
399        'domain_functor
400    fun := do_compile(SUBLIS($pairlis, [op', [lamOrSlam, argl, body']]), e)
401    --The above statement stops substitutions getting in one another's way
402--+
403    operationAlist := SUBLIS($pairlis,$lisplibOperationAlist)
404    if $LISPLIB then
405      augmentLisplibModemapsFromFunctor(parForm,operationAlist,parSignature)
406    $functorStats := addStats($functorStats, $functionStats)
407    reportOnFunctorCompilation($functorStats)
408
409--  5. give operator a 'modemap property
410    if $LISPLIB then
411      modemap:= [[parForm,:parSignature],[true,op']]
412      $lisplibModemap:= modemap
413      $lisplibCategory := modemap.mmTarget
414      $lisplibParents  :=
415        getParentsFor($op,$FormalMapVariableList,$lisplibCategory)
416      $lisplibAncestors := computeAncestorsOf(form, nil)
417      $lisplibAbbreviation := constructor? $op
418    $insideFunctorIfTrue:= false
419    if $LISPLIB then
420      $lisplibKind:=
421------->This next line prohibits changing the KIND once given
422--------kk:=GETDATABASE($op,'CONSTRUCTORKIND) => kk
423        target is ["CATEGORY",key,:.] and key~="domain" => 'package
424        'domain
425      $lisplibForm:= form
426      if null $bootStrapMode then
427        NRTslot1Info := NRTmakeSlot1Info(form, base_shell)
428        libFn := GETDATABASE(op','ABBREVIATION)
429        $lookupFunction: local :=
430            NRTgetLookupFunction(form, CADAR $lisplibModemap, $NRTaddForm)
431            --either lookupComplete (for forgetful guys) or lookupIncomplete
432        $byteAddress :local := 0
433        $byteVec :local := nil
434        $NRTslot1PredicateList :=
435          [simpBool x for x in $NRTslot1PredicateList]
436        output_lisp_form(['MAKEPROP, MKQ $op, ''infovec,
437                          getInfovecCode(NRTslot1Info, e)])
438      $lisplibOperationAlist:= operationAlist
439      $lisplibMissingFunctions:= $CheckVectorList
440    if null argl then
441      evalAndRwriteLispForm('NILADIC,
442            ['MAKEPROP, ['QUOTE,op'], ['QUOTE,'NILADIC], true])
443    [fun, ['Mapping, :signature'], originale]
444
445compFunctorBody(body, m, e, parForm, base_shell) ==
446  $bootStrapMode = true =>
447    genOperationAlist(base_shell)
448    [bootStrapError($functorForm, $edit_file), m, e]
449  T:= compOrCroak(body,m,e)
450  body is [op,:.] and MEMQ(op,'(add CAPSULE)) => T
451  $NRTaddForm :=
452    body is ["SubDomain",domainForm,predicate] => domainForm
453    body
454  T
455
456reportOnFunctorCompilation(functorStats) ==
457  displayMissingFunctions()
458  if $semanticErrorStack then sayBrightly '" "
459  displaySemanticErrors()
460  if $warningStack then sayBrightly '" "
461  displayWarnings()
462  [byteCount, elapsedSeconds] := functorStats
463  sayBrightly ['%l,:bright '"  Cumulative Statistics for Constructor",
464    $op]
465  timeString := normalizeStatAndStringify elapsedSeconds
466  sayBrightly ['"      Time:",:bright timeString,'"seconds"]
467  sayBrightly '" "
468  'done
469
470displayMissingFunctions() ==
471  null $CheckVectorList => nil
472  loc := nil
473  exp := nil
474  for [[op,sig,:.],:pred] in $CheckVectorList  | null pred repeat
475    null member(op,$formalArgList) and
476      getmode(op,$env) is ['Mapping,:.] =>
477        loc := [[op,sig],:loc]
478    exp := [[op,sig],:exp]
479  if loc then
480    sayBrightly ['%l,:bright '"  Missing Local Functions:"]
481    for [op,sig] in loc for i in 1.. repeat
482      sayBrightly ['"      [",i,'"]",:bright op,
483        ": ",:formatUnabbreviatedSig sig]
484  if exp then
485    sayBrightly ['%l,:bright '"  Missing Exported Functions:"]
486    for [op,sig] in exp for i in 1.. repeat
487      sayBrightly ['"      [",i,'"]",:bright op,
488        ": ",:formatUnabbreviatedSig sig]
489
490--% domain view code
491
492makeFunctorArgumentParameters(argl, sigl, target, e) ==
493  $forceAdd: local:= true
494  $ConditionalOperators: local := nil
495  $tmp_e := e
496  for a in argl for s in sigl repeat fn(a,augmentSig(s,findExtras(a,target)))
497          where
498    findExtras(a,target) ==
499      --  see if conditional information implies anything else
500      --  in the signature of a
501      target is ['Join,:l] => "union"/[findExtras(a,x) for x in l]
502      target is ['CATEGORY,.,:l] => "union"/[findExtras1(a,x) for x in l] where
503        findExtras1(a,x) ==
504          x is ['AND,:l] => "union"/[findExtras1(a,y) for y in l]
505          x is ['OR,:l] => "union"/[findExtras1(a,y) for y in l]
506          x is ['IF,c,p,q] =>
507            union(findExtrasP(a,c),
508                  union(findExtras1(a,p),findExtras1(a,q))) where
509              findExtrasP(a,x) ==
510                x is ['AND,:l] => "union"/[findExtrasP(a,y) for y in l]
511                x is ['OR,:l] => "union"/[findExtrasP(a,y) for y in l]
512                x is ['has,=a,y] and y is ['SIGNATURE,:.] => [y]
513                nil
514        nil
515    augmentSig(s,ss) ==
516       -- if we find something extra, add it to the signature
517      null ss => s
518      for u in ss repeat
519        $ConditionalOperators:=[CDR u,:$ConditionalOperators]
520      s is ['Join,:sl] =>
521        u := ASSQ('CATEGORY, ss) => BREAK()
522        ['Join,:sl,['CATEGORY,'package,:ss]]
523      ['Join,s,['CATEGORY,'package,:ss]]
524    fn(a,s) ==
525      not(ATOM(a)) => BREAK()
526      if isCategoryForm(s) then
527        s is ["Join", :catlist] => genDomainViewList(a, rest s)
528        genDomainView(a, s, "getDomainView")
529  $tmp_e
530
531genDomainViewList(id, catlist) ==
532  null catlist => nil
533  catlist is [y] and not isCategoryForm(y) => nil
534  for c in catlist repeat
535      genDomainView(id, c, "getDomainView")
536
537genDomainView(viewName, c, viewSelector) ==
538  c is ['CATEGORY, ., :l] => genDomainOps(viewName, viewName, c)
539  $tmp_e := augModemapsFromCategory(viewName, viewName, nil, c, $tmp_e)
540
541genDomainOps(viewName,dom,cat) ==
542  oplist := getOperationAlist(dom, dom, cat)
543  siglist:= [sig for [sig,:.] in oplist]
544  oplist:= substNames(dom,viewName,dom,oplist)
545  for [opsig,cond,:.] in oplist for i in 0.. repeat
546    if opsig in $ConditionalOperators then cond:=nil
547    [op,sig]:=opsig
548    $tmp_e:= addModemap(op,dom,sig,cond,['ELT,viewName,i],$tmp_e)
549
550compDefWhereClause(['DEF,form,signature,specialCases,body],m,e) ==
551-- form is lhs (f a1 ... an) of definition; body is rhs;
552-- signature is (t0 t1 ... tn) where t0= target type, ti=type of ai, i > 0;
553-- specialCases is (NIL l1 ... ln) where li is list of special cases
554-- which can be given for each ti
555
556-- removes declarative and assignment information from form and
557-- signature, placing it in list L, replacing form by ("where",form',:L),
558-- signature by a list of NILs (signifying declarations are in e)
559  $sigAlist: local := nil
560  $predAlist: local := nil
561
562-- 1. create sigList= list of all signatures which have embedded
563--    declarations moved into global variable $sigAlist
564  sigList:=
565    [transformType(x) for a in rest form for x in rest signature]
566       where
567        transformType x ==
568          atom x => x
569          x is [":",R,Rtype] =>
570            ($sigAlist:= [[R,:transformType Rtype],:$sigAlist]; x)
571          x is ['Record,:.] => x --RDJ 8/83
572          [first x,:[transformType y for y in rest x]]
573
574-- 2. replace each argument of the form (|| x p) by x, recording
575--    the given predicate in global variable $predAlist
576  argList:=
577    [removeSuchthat a for a in rest form] where
578      removeSuchthat x ==
579        x is ["|",y,p] =>
580            BREAK()
581            ($predAlist:= [[y,:p],:$predAlist]; y)
582        x
583
584  argList2 := [a for a in argList for t in sigList | not(NULL(t))]
585  sigList2 := [t for t in sigList | not(NULL(t))]
586
587-- 3. obtain a list of parameter identifiers (x1 .. xn) ordered so that
588--       the type of xi is independent of xj if i < j
589  varList:=
590    orderByDependency(ASSOCLEFT argDepAlist,ASSOCRIGHT argDepAlist) where
591      argDepAlist:=
592        [[x,:dependencies] for [x,:y] in argSigAlist] where
593          dependencies() ==
594            union(listOfIdentifiersIn y,
595              delete(x,listOfIdentifiersIn LASSOC(x,$predAlist)))
596          argSigAlist:= [:$sigAlist,:pairList(argList2, sigList2)]
597
598-- 4. construct a WhereList which declares and/or defines the xi's in
599--    the order constructed in step 3
600  (whereList:= [addSuchthat(x,[":",x,LASSOC(x,argSigAlist)]) for x in varList])
601     where addSuchthat(x,y) == (p:= LASSOC(x,$predAlist) => ["|",y,p]; y)
602
603-- 5. compile new ('DEF,("where",form',:WhereList),:.) where
604--    all argument parameters of form' are bound/declared in WhereList
605  comp(form',m,e) where
606    form':=
607      ["where",defform,:whereList] where
608        defform:=
609          ['DEF,form'',signature',specialCases,body] where
610            form'':= [first form,:argList]
611            signature':= [first signature,:[nil for x in rest signature]]
612
613orderByDependency(vl,dl) ==
614  -- vl is list of variables, dl is list of dependency-lists
615  selfDependents:= [v for v in vl for d in dl | MEMQ(v,d)]
616  for v in vl for d in dl | MEMQ(v,d) repeat
617    (SAY(v," depends on itself"); fatalError:= true)
618  fatalError => userError '"Parameter specification error"
619  until (null vl) repeat
620    newl:=
621      [v for v in vl for d in dl | null intersection(d,vl)] or return nil
622    orderedVarList:= [:newl,:orderedVarList]
623    vl':= setDifference(vl,newl)
624    dl':= [setDifference(d,newl) for x in vl for d in dl | member(x,vl')]
625    vl:= vl'
626    dl:= dl'
627  REMDUP NREVERSE orderedVarList --ordered so ith is indep. of jth if i < j
628
629compInternalFunction(df is ['DEF,form,signature,specialCases,body], m, e) ==
630    [op, :argl] := form
631    not(IDENTP(op)) =>
632        stackAndThrow ['"Bad name for internal function:", op]
633    nbody := ["+->", argl, body]
634    fmode := ["Mapping", :signature]
635    [., ., e'] := compMakeDeclaration([":", op, fmode], $EmptyMode, e)
636    T := compWithMappingMode(nbody, fmode, e')
637    T or return nil
638    currentProplist := getProplist(op, e)
639    finish_setq_single(T, fmode, op, nbody, currentProplist)
640
641compDefineCapsuleFunction(df is ['DEF,form,signature,specialCases,body],
642  m,oldE,$prefix,$formalArgList) ==
643    [lineNumber,:specialCases] := specialCases
644    e := oldE
645    --1. bind global variables
646    $functionStats: local:= [0,0]
647    $finalEnv: local := nil
648             --used by ReplaceExitEtc to get a common environment
649    $locVarsTypes: local := []
650    $initCapsuleErrorCount: local:= #$semanticErrorStack
651    $insideCapsuleFunctionIfTrue: local:= true
652    $CapsuleModemapFrame: local:= e
653    $CapsuleDomainsInScope: local:= get("$DomainsInScope","special",e)
654    $returnMode:= m
655    $op: local := nil
656    [$op,:argl]:= form
657    $formalArgList:= [:argl,:$formalArgList]
658
659    --let target and local signatures help determine modes of arguments
660    argModeList:=
661      identSig:= hasSigInTargetCategory(argl,form,first signature,e) =>
662        (e:= checkAndDeclare(argl,form,identSig,e); rest identSig)
663      [getArgumentModeOrMoan(a,form,e) for a in argl]
664    signature':= [first signature,:argModeList]
665    if null identSig then  --make $op a local function
666      oldE := put($op,'mode,['Mapping,:signature'],oldE)
667
668    --obtain target type if not given
669    if null first signature' then signature':=
670      identSig => identSig
671      getSignature($op,rest signature',e) or return nil
672
673    --replace ##1,.. in signature by arguments
674--    pp signature'
675--  pp '"------after----"
676--  pp signature'
677    e:= giveFormalParametersValues(argl,e)
678
679    $signatureOfForm:= signature' --this global is bound in compCapsuleItems
680    $functionLocations := [[[$op, signature'], :lineNumber],
681      :$functionLocations]
682    e:= addDomain(first signature',e)
683
684    --4. introduce needed domains into extendedEnv
685    for domain in signature' repeat e:= addDomain(domain,e)
686
687    --6. compile body in environment with extended environment
688    rettype := resolve(signature'.target, $returnMode)
689
690    localOrExported :=
691      null member($op,$formalArgList) and
692        getmode($op,e) is ['Mapping,:.] => 'local
693      'exported
694
695    --6a skip if compiling only certain items but not this one
696    -- could be moved closer to the top
697    formattedSig := formatUnabbreviated ['Mapping,:signature']
698    sayBrightly ['"   compiling ",localOrExported,
699      :bright $op,'": ",:formattedSig]
700
701    T := CATCH('compCapsuleBody, compOrCroak(body,rettype,e))
702           or ["",rettype,e]
703--+
704    NRTassignCapsuleFunctionSlot($op, signature', $domainShell, e)
705    if $newCompCompare=true then
706         SAY '"The old compiler generates:"
707         prTriple T
708--  A THROW to the above CATCH occurs if too many semantic errors occur
709--  see stackSemanticError
710    catchTag:= MKQ GENSYM()
711    fun:=
712      body':= replaceExitEtc(T.expr,catchTag,"TAGGEDreturn",$returnMode)
713      finalBody:= ["CATCH",catchTag,body']
714      do_compile([$op, ["LAMBDA", [:argl, '_$], finalBody]], oldE)
715    $functorStats:= addStats($functorStats,$functionStats)
716
717
718--  7. give operator a 'value property
719    val:= [fun,signature',e]
720    [fun,['Mapping,:signature'],oldE] -- oldE:= put($op,'value,removeEnv val,e)
721
722getSignatureFromMode(form,e) ==
723  getmode(opOf form,e) is ['Mapping,:signature] =>
724    #form~=#signature => stackAndThrow ["Wrong number of arguments: ",form]
725    EQSUBSTLIST(rest form,take(#rest form,$FormalMapVariableList),signature)
726
727hasSigInTargetCategory(argl,form,opsig,e) ==
728  mList:= [getArgumentMode(x,e) for x in argl]
729    --each element is a declared mode for the variable or nil if none exists
730  potentialSigList:=
731    REMDUP
732      [sig
733        for [[opName,sig,:.],:.] in $domainShell.(1) |
734          fn(opName,sig,opsig,mList,form)] where
735            fn(opName,sig,opsig,mList,form) ==
736              opName=$op and #sig=#form and (null opsig or opsig=first sig) and
737                (and/[compareMode2Arg(x,m) for x in mList for m in rest sig])
738  c:= #potentialSigList
739  1=c => first potentialSigList
740    --accept only those signatures op right length which match declared modes
741  0=c => (#(sig:= getSignatureFromMode(form,e))=#form => sig; nil)
742  1<c =>
743    sig:= first potentialSigList
744    stackWarning ["signature of lhs not unique:",:bright sig,"chosen"]
745    sig
746  nil --this branch will force all arguments to be declared
747
748compareMode2Arg(x,m) == null x or modeEqual(x,m)
749
750getArgumentModeOrMoan(x,form,e) ==
751  getArgumentMode(x,e) or
752    stackSemanticError(["argument ",x," of ",form," is not declared"],nil)
753
754getArgumentMode(x,e) ==
755  STRINGP x => x
756  m:= get(x,'mode,e) => m
757
758checkAndDeclare(argl,form,sig,e) ==
759
760-- arguments with declared types must agree with those in sig;
761-- those that don't get declarations put into e
762  for a in argl for m in rest sig repeat
763    m1:= getArgumentMode(a,e) =>
764      not modeEqual(m1,m) =>
765        stack:= ["   ",:bright a,'"must have type ",m,
766          '" not ",m1,'%l,:stack]
767    e:= put(a,'mode,m,e)
768  if stack then
769    sayBrightly ['"   Parameters of ",:bright first form,
770      '" are of wrong type:",'%l,:stack]
771  e
772
773getSignature(op, argModeList, e) ==
774  1=#
775    (sigl:=
776      REMDUP
777        [sig for [[dc, :sig], [pred, :.]]
778           in (mmList := get(op, 'modemap, e)) | dc='_$ and
779               rest sig=argModeList and known_in_env(pred, e)]) => first sigl
780  null sigl =>
781    (u := getmode(op, e)) is ['Mapping, :sig] => sig
782    SAY '"************* USER ERROR **********"
783    SAY("available signatures for ",op,": ")
784    if null mmList
785       then SAY "    NONE"
786       else for [[dc,:sig],:.] in mmList repeat printSignature("     ",op,sig)
787    printSignature("NEED ",op,["?",:argModeList])
788    nil
789  for u in sigl repeat
790    for v in sigl | not (u=v) repeat
791      if SourceLevelSubsume(u,v) then sigl:= delete(v,sigl)
792              --before we complain about duplicate signatures, we should
793              --check that we do not have for example, a partial - as
794              --well as a total one.  SourceLevelSubsume (from CATEGORY BOOT)
795              --should do this
796  1=#sigl => first sigl
797  stackSemanticError(["duplicate signatures for ",op,": ",argModeList],nil)
798
799
800putInLocalDomainReferences (def := [opName,[lam,varl,body]]) ==
801  $elt: local := ($QuickCode => 'QREFELT; 'ELT)
802--+
803  NRTputInTail CDDADR def
804  def
805
806
807isLocalFunction(op, e) ==
808    null member(op, $formalArgList) and
809        getmode(op, e) is ['Mapping, :.]
810
811do_compile(u, e) ==
812  [op,lamExpr] := u
813  if $suffix then
814    $suffix:= $suffix+1
815    op':=
816      opexport:=nil
817      opmodes:=
818        [sel
819          for [[DC, :sig], [., sel]] in get(op, 'modemap, e) |
820            DC='_$ and (opexport:=true) and
821             (and/[modeEqual(x,y) for x in sig for y in $signatureOfForm])]
822      isLocalFunction(op, e) =>
823        if opexport then userError ['%b,op,'%d,'" is local and exported"]
824        INTERN STRCONC(encodeItem $prefix, '";", encodeItem op)
825      encodeFunctionName(op,$functorForm,$signatureOfForm,";",$suffix)
826    u:= [op',lamExpr]
827  optimizedBody:= optimizeFunctionDef u
828  stuffToCompile:=
829    if null $insideCapsuleFunctionIfTrue
830       then optimizedBody
831       else putInLocalDomainReferences optimizedBody
832  $doNotCompileJustPrint=true => (PRETTYPRINT stuffToCompile; op')
833  result:= spadCompileOrSetq stuffToCompile
834  functionStats:=[0,elapsedTime()]
835  $functionStats:= addStats($functionStats,functionStats)
836  printStats functionStats
837  result
838
839spadCompileOrSetq (form is [nam,[lam,vl,body]]) ==
840        --bizarre hack to take account of the existence of "known" functions
841        --good for performance (LISPLLIB size, BPI size, NILSEC)
842  CONTAINED("",body) => sayBrightly ['"  ",:bright nam,'" not compiled"]
843  if vl is [:vl',E] and body is [nam',: =vl'] then
844      output_lisp_form(['PUT,MKQ nam,MKQ 'SPADreplace,MKQ nam'])
845      sayBrightly ['"     ",:bright nam,'"is replaced by",:bright nam']
846  else if (ATOM body or and/[ATOM x for x in body])
847         and vl is [:vl',E] and not CONTAINED(E,body) then
848           macform := ['XLAM,vl',body]
849           output_lisp_form(['PUT,MKQ nam,MKQ 'SPADreplace,MKQ macform])
850           sayBrightly ['"     ",:bright nam,'"is replaced by",:bright body]
851  $insideCapsuleFunctionIfTrue => first COMP form
852  compileConstructor form
853
854compileConstructor form ==
855  u:= compileConstructor1 form
856  clearClams()                  --clear all CLAMmed functions
857  u
858
859compileConstructor1 (form:=[fn,[key,vl,:bodyl]]) ==
860-- fn is the name of some category/domain/package constructor;
861-- we will cache all of its values on $ConstructorCache with reference
862-- counts
863  auxfn := INTERNL1(fn, '";")
864  output_lisp_form(["DECLAIM", ["NOTINLINE", auxfn]])
865  if key = 'category_functor
866      then u := compAndDefine form
867      else u := COMP form
868  clearConstructorCache fn      --clear cache for constructor
869  first u
870
871constructMacro (form is [nam,[lam,vl,body]]) ==
872  not (and/[atom x for x in vl]) =>
873    stackSemanticError(["illegal parameters for macro: ",vl],nil)
874  ["XLAM",vl':= [x for x in vl | IDENTP x],body]
875
876uncons x ==
877  atom x => x
878  x is ["CONS",a,b] => [a,:uncons b]
879
880--% CAPSULE
881
882bootStrapError(functorForm,sourceFile) ==
883  ['COND, _
884    ['$bootStrapMode, _
885        ['VECTOR,mkDomainConstructor functorForm,nil,nil,nil,nil,nil]],
886    [''T, ['systemError, ['LIST, ''%b, MKQ first functorForm, ''%d, '"from", _
887      ''%b,MKQ namestring sourceFile,''%d,'"needs to be compiled"]]]]
888
889compAdd(['add,$addForm,capsule],m,e) ==
890  $bootStrapMode = true =>
891    if $addForm is ["@Tuple", :.] then code := nil
892       else [code,m,e]:= comp($addForm,m,e)
893    [['COND, _
894       ['$bootStrapMode, _
895           code],_
896       [''T, ['systemError, ['LIST, ''%b, MKQ first $functorForm, ''%d,
897         '"from", ''%b, MKQ namestring($edit_file), ''%d, _
898         '"needs to be compiled"]]]],
899     m, e]
900  $addFormLhs: local:= $addForm
901  addForm := $addForm
902  if $addForm is ["SubDomain",domainForm,predicate] then
903--+
904    $NRTaddForm := domainForm
905    NRTgetLocalIndex(domainForm, e)
906    --need to generate slot for add form since all $ go-get
907    --  slots will need to access it
908    [$addForm, m1, e] := compSubDomain1(domainForm, predicate, m, e)
909  else
910--+
911    $NRTaddForm := $addForm
912    [$addForm, m1, e]:=
913      $addForm is ["@Tuple", :.] => BREAK()
914      compOrCroak($addForm,$EmptyMode,e)
915  not(isCategoryForm(m1)) or m1 = '(Category) =>
916      userError(concat('"need domain before 'add', got", addForm,
917                       '"of type", m1))
918  compCapsule(capsule,m,e)
919
920compTuple2Record u == ['Record,:[[":",i,x] for i in 1.. for x in rest u]]
921
922compCapsule(['CAPSULE,:itemList],m,e) ==
923  $bootStrapMode = true =>
924      [bootStrapError($functorForm, $edit_file), m, e]
925  compCapsuleInner(itemList,m,addDomain('_$,e))
926
927compSubDomain(["SubDomain",domainForm,predicate],m,e) ==
928  $addFormLhs: local:= domainForm
929  $addForm: local := nil
930  $NRTaddForm := domainForm
931  [$addForm,.,e]:= compSubDomain1(domainForm,predicate,m,e)
932--+
933  compCapsule(['CAPSULE],m,e)
934
935compSubDomain1(domainForm,predicate,m,e) ==
936  [.,.,e]:=
937    compMakeDeclaration([":","#1",domainForm],$EmptyMode,addDomain(domainForm,e))
938  u:=
939    compOrCroak(predicate,$Boolean,e) or
940      stackSemanticError(["predicate: ",predicate,
941        " cannot be interpreted with #1: ",domainForm],nil)
942  prefixPredicate:= lispize u.expr
943  $lisplibSuperDomain:=
944    [domainForm,predicate]
945  evalAndRwriteLispForm('evalOnLoad2,
946    ['SETQ,'$CategoryFrame,['put,op':= ['QUOTE,$op],'
947     (QUOTE SuperDomain),dF':= ['QUOTE,domainForm],['put,dF','(QUOTE SubDomain),[
948       'CONS,['QUOTE,[$op,:prefixPredicate]],['DELASC,op',['get,dF','
949         (QUOTE SubDomain),'$CategoryFrame]]],'$CategoryFrame]]])
950  [domainForm,m,e]
951
952compCapsuleInner(itemList,m,e) ==
953  e:= addInformation(m,e)
954           --puts a new 'special' property of $Information
955  data:= ["PROGN",:itemList]
956      --RPLACd by compCapsuleItems and Friends
957  e:= compCapsuleItems(itemList,nil,e)
958  localParList:= $functorLocalParameters
959  code:=
960    $insideCategoryIfTrue and not $insideCategoryPackageIfTrue => BREAK()
961    processFunctor($functorForm, $signature, data, localParList, e)
962  [MKPF([code],"PROGN"),m,e]
963
964--% PROCESS FUNCTOR CODE
965
966processFunctor(form,signature,data,localParList,e) ==
967  buildFunctor(form, signature, data, localParList, $domainShell, e)
968
969compCapsuleItems(itemlist, $predl, e) ==
970  $signatureOfForm: local := nil
971  $suffix: local:= 0
972  for item in itemlist repeat e := compSingleCapsuleItem(item, $predl, e)
973  e
974
975compSingleCapsuleItem(item, $predl, e) ==
976  doIt(macroExpandInPlace(item, e), $predl, e)
977
978doIt(item, $predl, e) ==
979  $GENNO: local:= 0
980  item is ['SEQ,:l,['exit,1,x]] =>
981    RPLACA(item,"PROGN")
982    RPLACA(LASTNODE item,x)
983    for it1 in rest item repeat e := compSingleCapsuleItem(it1, $predl, e)
984        --This will RPLAC as appropriate
985    e
986  isDomainForm(item, e) =>
987     -- convert naked top level domains to import
988    u:= ['import, [first item,:rest item]]
989    userError ["Use: import ", [first item,:rest item]]
990    RPLACA(item,first u)
991    RPLACD(item,rest u)
992    doIt(item, $predl, e)
993  item is [":=", lhs, rhs, :.] =>
994    not (compOrCroak(item, $EmptyMode, e) is [code, ., e]) =>
995      stackSemanticError(["cannot compile assigned value to",:bright lhs],nil)
996      e
997    not (code is ['LET,lhs',rhs',:.] and atom lhs') =>
998      code is ["PROGN",:.] =>
999         stackSemanticError(["multiple assignment ",item," not allowed"],nil)
1000         e
1001      RPLACA(item,first code)
1002      RPLACD(item,rest code)
1003      e
1004    lhs:= lhs'
1005    if not member(IFCAR rhs, $NonMentionableDomainNames) and
1006      not MEMQ(lhs, $functorLocalParameters) then
1007         $functorLocalParameters:= [:$functorLocalParameters,lhs]
1008    if code is ['LET, ., rhs', :.] and isDomainForm(rhs', e) then
1009      if lhs="Rep" then
1010        -- FIXME: $Representation is set unconditionally, but
1011        -- assignment to Rep may be conditional ...
1012        $Representation := (get("Rep", 'value, e)).(0)
1013           --$Representation bound by compDefineFunctor, used in compNoStacking
1014--+
1015--+
1016--+
1017    code is ['LET, :.] =>
1018      RPLACA(item,($QuickCode => 'QSETREFV;'SETELT))
1019      rhsCode:=
1020       rhs'
1021      RPLACD(item, ['$, NRTgetLocalIndex(lhs, e), rhsCode])
1022      e
1023    RPLACA(item,first code)
1024    RPLACD(item,rest code)
1025    e
1026  item is [":", a, t] =>
1027      [., ., e] := compOrCroak(item, $EmptyMode, e)
1028      e
1029  item is ['import,:doms] =>
1030     for dom in doms repeat
1031       sayBrightly ['"   importing ",:formatUnabbreviated dom]
1032     [., ., e] := compOrCroak(item, $EmptyMode, e)
1033     RPLACA(item,'PROGN)
1034     RPLACD(item,NIL) -- creates a no-op
1035     e
1036  item is ["IF", :.] => doItIf(item, $predl, e)
1037  item is ["where", b, :l] => doItWhere(item, $predl, e)
1038  item is ["MDEF", :.] =>
1039      [., ., e] := compOrCroak(item, $EmptyMode, e)
1040      e
1041  item is ['DEF,[op,:.],:.] =>
1042    [., ., e] := t := compOrCroak(item, $EmptyMode, e)
1043    RPLACA(item,"CodeDefine")
1044        --Note that DescendCode, in CodeDefine, is looking for this
1045    RPLACD(CADR item,[$signatureOfForm])
1046      --This is how the signature is updated for buildFunctor to recognise
1047--+
1048    functionPart:= ['dispatchFunction,t.expr]
1049    RPLACA(CDDR item,functionPart)
1050    RPLACD(CDDR item,nil)
1051    e
1052  u := compOrCroak(item, $EmptyMode, e) =>
1053    ([code, ., e] := u; RPLACA(item, first code); RPLACD(item, rest code))
1054    e
1055  true => cannotDo()
1056
1057isMacro(x,e) ==
1058  x is ['DEF,[op,:args],signature,specialCases,body] and
1059    null get(op,'modemap,e) and null args and null get(op,'mode,e)
1060      and signature is [nil] => body
1061
1062-- FIXME: we ignore effects of computation of condition and
1063-- do not merge branches
1064doItIf(item is [., p, x, y], $predl, e) ==
1065    olde := e
1066    [p', ., e] := comp(p, $Boolean, e) or userError ['"not a Boolean:", p]
1067    if x ~= "noBranch" then
1068        compSingleCapsuleItem(x, $predl, getSuccessEnvironment(p, e))
1069    if y ~= "noBranch" then
1070        compSingleCapsuleItem(y, $predl, getInverseEnvironment(p, olde))
1071    RPLACA(item, "COND")
1072    RPLACD(item, [[p', x], ['(QUOTE T), y]])
1073    olde
1074
1075doItWhere(item is [.,form,:exprList], $predl, eInit) ==
1076  $insideWhereIfTrue: local:= true
1077  e:= eInit
1078  u:=
1079    for it1 in exprList repeat
1080      e := compSingleCapsuleItem(it1, $predl, e)
1081  $insideWhereIfTrue:= false
1082  form1 := macroExpand(form, eBefore := e)
1083  eAfter := compSingleCapsuleItem(form1, $predl, e)
1084  eFinal:=
1085    del:= deltaContour(eAfter, eBefore) => addContour(del, eInit)
1086    eInit
1087  RPLACA(item, "PROGN")
1088  RPLACD(item, [["PROGN", :exprList], form1])
1089  eFinal
1090
1091
1092--% CATEGORY AND DOMAIN FUNCTIONS
1093
1094compJoin(["Join",:argl],m,e) ==
1095  catList:= [(compForMode(x,$Category,e) or return 'failed).expr for x in argl]
1096  catList='failed => stackSemanticError(["cannot form Join of: ",argl],nil)
1097  catList':=
1098    [extract for x in catList] where
1099      extract() ==
1100        x is ["Join", ["mkCategory",:y]] => ["mkCategory",:y]
1101        isCategoryForm(x) =>
1102          parameters:=
1103            union("append"/[getParms(y,e) for y in rest x],parameters)
1104              where getParms(y,e) ==
1105                atom y =>
1106                  isDomainForm(y,e) => LIST y
1107                  nil
1108                y is ['LENGTH,y'] =>
1109                  BREAK()
1110                  [y,y']
1111                LIST y
1112          x
1113        x is ["DomainSubstitutionMacro",pl,body] =>
1114            parameters := union(pl, parameters)
1115            body is ["Join", ["mkCategory",:y]] => ["mkCategory",:y]
1116            body
1117        x is ["mkCategory",:.] => x
1118        atom x and getmode(x,e)=$Category => x
1119        stackSemanticError(["invalid argument to Join: ",x],nil)
1120        x
1121  T:= [wrapDomainSub(parameters,["Join",:catList']),$Category,e]
1122  convert(T,m)
1123
1124compForMode(x,m,e) ==
1125  $compForModeIfTrue: local:= true
1126  comp(x,m,e)
1127
1128compMakeCategoryObject(c, e) ==
1129  not isCategoryForm(c) => nil
1130  u := mkEvalableCategoryForm(c, e) => [c_eval u, $Category, e]
1131  nil
1132
1133quotifyCategoryArgument x == MKQ x
1134
1135makeCategoryForm(c,e) ==
1136  not isCategoryForm(c) => nil
1137  [x,m,e]:= compOrCroak(c,$EmptyMode,e)
1138  [x,e]
1139
1140mk_acc() == [[], []]
1141
1142push_at_list(ati, acc) == acc.1 := [ati, :acc.1]
1143
1144get_at_list(acc) == acc.1
1145
1146push_sig_list(sig, acc) == acc.0 := [sig, :acc.0]
1147
1148get_sigs_list(acc) == acc.0
1149
1150compCategory(x,m,e) ==
1151  (m:= resolve(m,["Category"]))=["Category"] and x is ['CATEGORY,
1152    domainOrPackage,:l] =>
1153      acc := mk_acc()
1154      for x in l repeat compCategoryItem(x, nil, acc)
1155      rep := mkExplicitCategoryFunction(get_sigs_list(acc), get_at_list(acc))
1156    --if inside compDefineCategory, provide for category argument substitution
1157      [rep,m,e]
1158  systemErrorHere '"compCategory"
1159
1160mkExplicitCategoryFunction(sigList, atList) ==
1161  ["Join",
1162    ["mkCategory", ['LIST, :REVERSE sigList], ['LIST,
1163      :REVERSE atList], nil, nil]]
1164
1165wrapDomainSub(parameters,x) ==
1166   ["DomainSubstitutionMacro",parameters,x]
1167
1168DomainSubstitutionFunction(definition, parameters,body) ==
1169  --see optFunctorBody
1170  if parameters then
1171    (body:= Subst(definition, parameters,body)) where
1172      Subst(definition, parameters,body) ==
1173        ATOM body =>
1174          MEMQ(body,parameters) => MKQ body
1175          body
1176        member(body,parameters) =>
1177          g:=GENSYM()
1178          $extraParms:=PUSH([g,:body],$extraParms)
1179           --Used in SetVector12 to generate a substitution list
1180           --bound in buildFunctor
1181           --For categories, bound and used in compDefineCategory
1182          MKQ g
1183        first body="QUOTE" => body
1184        PAIRP definition and
1185            isFunctor first body and
1186              first body ~= first definition
1187          =>  ['QUOTE,optimize body]
1188        [Subst(definition, parameters,u) for u in body]
1189  not (body is ["Join",:.]) => body
1190  body is ["Join", ["mkCategory", :.]] => body
1191  atom definition => body
1192  null rest definition => body
1193           --should not bother if it will only be called once
1194  name := INTERN STRCONC(IFCAR definition, ";CAT")
1195  output_lisp_defparameter(name, nil)
1196  body:= ["COND",[name],['(QUOTE T),['SETQ,name,body]]]
1197  body
1198
1199compCategoryItem(x, predl, acc) ==
1200  x is nil => nil
1201  --1. if x is a conditional expression, recurse; otherwise, form the predicate
1202  x is ["COND",[p,e]] =>
1203    predl':= [p,:predl]
1204    compCategoryItem(e, predl', acc)
1205  x is ["IF",a,b,c] =>
1206    predl':= [a,:predl]
1207    if b ~= "noBranch" then compCategoryItem(b, predl', acc)
1208    c="noBranch" => nil
1209    predl':= [["not",a],:predl]
1210    compCategoryItem(c, predl', acc)
1211  pred:= (predl => MKPF(predl,"AND"); true)
1212
1213  --2. if attribute, push it and return
1214  x is ["ATTRIBUTE", 'nil] => BREAK()
1215  x is ["ATTRIBUTE", y] =>
1216       -- should generate something else for conditional categories
1217       -- BREAK()
1218       push_at_list(MKQ [y, pred], acc)
1219
1220  --3. it may be a list, with PROGN as the CAR, and some information as the CDR
1221  x is ["PROGN", :l] => for u in l repeat compCategoryItem(u, predl, acc)
1222
1223-- 4. otherwise, x gives a signature for a
1224--    single operator name or a list of names; if a list of names,
1225--    recurse
1226  ["SIGNATURE",op,:sig]:= x
1227  null atom op =>
1228      for y in op repeat compCategoryItem(["SIGNATURE", y, :sig], predl, acc)
1229
1230  --4. branch on a single type or a signature with source and target
1231  push_sig_list(MKQ [rest x, pred], acc)
1232