root/1.4.x/src/interp/define.boot @ 2655

Revision 2655, 95.9 KB (checked in by dos-reis, 2 years ago)
  • interp/define.boot (compileConstructor1): Don't call clearConstructorCache here. Simplify. (compileConstructor): Call clearConstructorCache here.
  • interp/c-util.boot (backendCompile2): Do not test for membership of $clamList.
  • interp/clam.boot (compHash): Use compQuietly instead of compileQuietly.
Line 
1-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
2-- All rights reserved.
3-- Copyright (C) 2007-2012, Gabriel Dos Reis.
4-- All rights reserved.
5--
6-- Redistribution and use in source and binary forms, with or without
7-- modification, are permitted provided that the following conditions are
8-- met:
9--
10--     - Redistributions of source code must retain the above copyright
11--       notice, this list of conditions and the following disclaimer.
12--
13--     - Redistributions in binary form must reproduce the above copyright
14--       notice, this list of conditions and the following disclaimer in
15--       the documentation and/or other materials provided with the
16--       distribution.
17--
18--     - Neither the name of The Numerical Algorithms Group Ltd. nor the
19--       names of its contributors may be used to endorse or promote products
20--       derived from this software without specific prior written permission.
21--
22-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
23-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
24-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
25-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
26-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
27-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
28-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
29-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
30-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
31-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
32-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
33
34import nruncomp
35import g_-error
36import c_-util
37import database
38
39namespace BOOT
40
41module define where
42  compDefine: (%Form,%Mode,%Env) -> %Maybe %Triple
43  compSubDomain: (%Form,%Mode,%Env) -> %Maybe %Triple
44  compCapsule: (%Form, %Mode, %Env) -> %Maybe %Triple
45  compJoin: (%Form,%Mode,%Env) -> %Maybe %Triple
46  compAdd: (%Form, %Mode, %Env) -> %Maybe %Triple
47  compCategory: (%Form,%Mode,%Env) -> %Maybe %Triple
48  evalCategoryForm: (%Form,%Env) -> %Maybe %Shell
49
50
51--%
52
53$doNotCompileJustPrint := false
54
55++ stack of pending capsule function definitions.
56$capsuleFunctionStack := []
57
58--%
59
60$forceAdd := false
61
62$functionStats := nil
63$functorStats := nil
64
65$functorTarget := nil
66$condAlist := []
67$uncondAlist := []
68$NRTslot1PredicateList := []
69$NRTattributeAlist := []
70$signature := nil
71$byteAddress := nil
72$sigAlist := []
73$predAlist := []
74$argumentConditionList := []
75$finalEnv := nil
76$initCapsuleErrorCount := nil
77$CapsuleModemapFrame := nil
78$CapsuleDomainsInScope := nil
79$signatureOfForm := nil
80$addFormLhs := nil
81
82++ True if the current functor definition refines a domain.
83$subdomain := false
84
85--%
86
87compDefineAddSignature: (%Form,%Sig,%Env) -> %Env
88
89
90--% ADDINFORMATION CODE
91--% This code adds various items to the special value of $Information,
92--% in order to keep track of all the compiler's information about
93--% various categories and similar objects
94--% An actual piece of (unconditional) information can have one of 3 forms:
95--%  (ATTRIBUTE domainname attribute)
96--%              --These are only stored here
97--%  (SIGNATURE domainname operator signature)
98--%              --These are also stored as 'modemap' properties
99--%  (has domainname categoryexpression)
100--%              --These are also stored as 'value' properties
101--% Conditional attributes are of the form
102--%  (%when
103--%  (condition info info ...)
104--%  ... )
105--% where the condition looks like a 'has' clause, or the 'and' of several
106--% 'has' clauses:
107--%   (has name categoryexpression)
108--%   (has name (ATTRIBUTE attribute))
109--%   (has name (SIGNATURE operator signature))
110--% The use of two representations is admitted to be clumsy
111
112
113liftCond (clause is [ante,conseq]) ==
114  conseq is ['%when,:l] =>
115    [[lcAnd(ante,a),:b] for [a,:b] in l] where
116      lcAnd(pred,conj) ==
117        conj is ["and",:ll] => ["and",pred,:ll]
118        ["and",pred,conj]
119  [clause]
120 
121formatPred(u,e) ==
122  u is ["has",a,b] =>
123    b isnt [.,:.] and isCategoryForm([b],e) => ["has",a,[b]]
124    b isnt [.,:.] => ["has",a,["ATTRIBUTE",b]]
125    isCategoryForm(b,e) => u
126    b is ["ATTRIBUTE",.] => u
127    b is ["SIGNATURE",:.] => u
128    ["has",a,["ATTRIBUTE",b]]
129  u isnt [.,:.] => u
130  u is ["and",:v] => ["and",:[formatPred(w,e) for w in v]]
131  systemError ['"formatPred",u]
132 
133formatInfo(u,e) ==
134  u isnt [.,:.] => u
135  u is ["SIGNATURE",:v] => ["SIGNATURE","$",:v]
136  u is ["PROGN",:l] => ["PROGN",:[formatInfo(v,e) for v in l]]
137  u is ["ATTRIBUTE",v] =>
138 
139    -- The parser can't tell between those attributes that really
140    -- are attributes, and those that are category names
141    v isnt [.,:.] and isCategoryForm([v],e) => ["has","$",[v]]
142    v isnt [.,:.] => ["ATTRIBUTE","$",v]
143    isCategoryForm(v,e) => ["has","$",v]
144    ["ATTRIBUTE","$",v]
145  u is ["IF",a,b,c] =>
146    c is "%noBranch" =>
147      ['%when,:liftCond [formatPred(a,e),formatInfo(b,e)]]
148    b is "%noBranch" =>
149      ['%when,:liftCond [["not",formatPred(a,e)],formatInfo(c,e)]]
150    ['%when,:liftCond [formatPred(a,e),formatInfo(b,e)],:
151      liftCond [["not",formatPred(a,e)],formatInfo(c,e)]]
152  systemError ['"formatInfo",u]
153 
154addInfo(u,e) ==
155  $Information:= [formatInfo(u,e),:$Information]
156 
157addInformation(m,e) ==
158  $Information: local := nil
159  info(m,e) where
160    info(m,e) ==
161      --Processes information from a mode declaration in compCapsule
162      m isnt [.,:.] => nil
163      m is ["CATEGORY",.,:stuff] => for u in stuff repeat addInfo(u,e)
164      m is ["Join",:stuff] => for u in stuff repeat info(u,e)
165      nil
166  put("$Information","special",
167       [:$Information,:get("$Information","special",e)],e)
168 
169hasToInfo (pred is ["has",a,b]) ==
170  b is ["SIGNATURE",:data] => ["SIGNATURE",a,:data]
171  b is ["ATTRIBUTE",c] => ["ATTRIBUTE",a,c]
172  pred
173 
174++ Return true if we are certain that the information
175++ denotated by `pred' is derivable from the current environment.
176knownInfo(pred,env) ==
177  pred=true => true
178  listMember?(pred,get("$Information","special",env)) => true
179  pred is ["OR",:l] => or/[knownInfo(u,env) for u in l]
180  pred is ["AND",:l] => and/[knownInfo(u,env) for u in l]
181  pred is ["or",:l] => or/[knownInfo(u,env) for u in l]
182  pred is ["and",:l] => and/[knownInfo(u,env) for u in l]
183  pred is ["ATTRIBUTE",name,attr] =>
184    v := compForMode(name,$EmptyMode,env) or return
185          stackAndThrow('"can't find category of %1pb",[name])
186    [vv,.,.] := compMakeCategoryObject(v.mode,env) or return
187                 stackAndThrow('"can't make category of %1pb",[name])
188    listMember?(attr,categoryAttributes vv) => true
189    x := assoc(attr,categoryAttributes vv) => knownInfo(second x,env)
190          --format is a list of two elements: information, predicate
191    false
192  pred is ["has",name,cat] =>
193    cat is ["ATTRIBUTE",:a] => knownInfo(["ATTRIBUTE",name,:a],env)
194    cat is ["SIGNATURE",:a] => knownInfo(["SIGNATURE",name,:a],env)
195    -- unnamed category expressions imply structural checks.
196    cat is ["Join",:.] => and/[knownInfo(["has",name,c],env) for c in cat.args]
197    cat is ["CATEGORY",.,:atts] =>
198      and/[knownInfo(hasToInfo ["has",name,att],env) for att in atts]
199    name is ['Union,:.] => false
200    -- we have a named category expression
201    v:= compForMode(name,$EmptyMode,env) or return
202          stackAndThrow('"can't find category of %1pb",[name])
203    vmode := v.mode
204    cat = vmode => true
205    vmode is ["Join",:l] and listMember?(cat,l) => true
206    [vv,.,.]:= compMakeCategoryObject(vmode,env) or return
207                 stackAndThrow('"cannot find category %1pb",[vmode])
208    listMember?(cat,categoryPrincipals vv) => true  --checks princ. ancestors
209    (u:=assoc(cat,categoryAncestors vv)) and knownInfo(second u,env) => true
210    -- previous line checks fundamental anscestors, we should check their
211    --   principal anscestors but this requires instantiating categories
212
213    or/[ancestor?(cat,[first u],env)
214         for u in categoryAncestors vv | knownInfo(second u,env)] => true
215    false
216  pred is ["SIGNATURE",name,op,sig,:.] =>
217    v:= get(op,"modemap",env)
218    for w in v repeat
219      ww := w.mmSignature  --the actual signature part
220      ww = sig =>
221        w.mmCondition  = true => return true
222        false
223        --error '"knownInfo"
224  false
225 
226mkJoin(cat,mode) ==
227  mode is ['Join,:cats] => ['Join,cat,:cats]
228  ['Join,cat,mode]
229 
230
231GetValue name ==
232  u:= get(name,"value",$e) => u
233  u:= comp(name,$EmptyMode,$e) => u  --name may be a form
234  systemError [name,'" is not bound in the current environment"]
235 
236actOnInfo(u,$e) ==
237  null u => $e
238  u is ["PROGN",:l] => (for v in l repeat $e:= actOnInfo(v,$e); $e)
239  $e:=
240    put("$Information","special",Info:= [u,:get("$Information","special",$e)],$e
241      )
242  u is ['%when,:l] =>
243      --there is nowhere %else that this sort of thing exists
244    for [ante,:conseq] in l repeat
245      if listMember?(hasToInfo ante,Info) then for v in conseq repeat
246        $e:= actOnInfo(v,$e)
247    $e
248  u is ["ATTRIBUTE",name,att] =>
249    [vval,vmode,.]:= GetValue name
250    compilerMessage('"augmenting %1: %2p", [name,["ATTRIBUTE",att]])
251    key :=
252      -- FIXME: there should be a better to tell whether name
253      --        designates a domain, as opposed to a package
254      CONTAINED("$",vmode) => 'domain
255      'package
256    cat := ["CATEGORY",key,["ATTRIBUTE",att]]
257    $e:= put(name,"value",[vval,mkJoin(cat,vmode),nil],$e)
258      --there is nowhere %else that this sort of thing exists
259  u is ["SIGNATURE",name,operator,modemap,:q] =>
260    kind :=
261      q is ["constant"] => "CONST"
262      "ELT"
263    implem:=
264      (implem:=ASSOC([name,:modemap],get(operator,'modemap,$e))) =>
265          CADADR implem
266      name = "$" => [kind,name,-1]
267      [kind,name,substitute('$,name,modemap)]
268    $e:= addModemap(operator,name,modemap,true,implem,$e)
269    [vval,vmode,.]:= GetValue name
270    compilerMessage('"augmenting %1: %2p",
271       [name,["SIGNATURE",operator,modemap,:q]])
272    key :=
273      -- FIXME: there should be a better to tell whether name
274      --        designates a domain, as opposed to a package
275      CONTAINED("$",vmode) => 'domain
276      'package
277    cat:= ["CATEGORY",key,["SIGNATURE",operator,modemap,:q]]
278    $e:= put(name,"value",[vval,mkJoin(cat,vmode),nil],$e)
279  u is ["has",name,cat] =>
280    [vval,vmode,.]:= GetValue name
281    cat=vmode => $e --stating the already known
282    u:= compMakeCategoryObject(cat,$e) =>
283         --we are adding information about a category
284      [catvec,.,$e]:= u
285      [ocatvec,.,$e]:= compMakeCategoryObject(vmode,$e)
286 
287      --we are adding a principal descendant of what was already known
288      listMember?(cat,categoryPrincipals ocatvec) or
289         assoc(cat,categoryAncestors ocatvec) is [.,"T",.] => $e
290             --what was being asserted is an ancestor of what was known
291      if name="$"
292        then $e:= augModemapsFromCategory(name,name,cat,$e)
293        else
294          genDomainView(name,cat,"HasCategory")
295          -- a domain upgrade at function level is local to that function.
296          if not $insideCapsuleFunctionIfTrue and
297            not symbolMember?(name,$functorLocalParameters) then
298              $functorLocalParameters:=[:$functorLocalParameters,name]
299      compilerMessage('"augmenting %1: %2p", [name,cat])
300      $e:= put(name,"value",[vval,mkJoin(cat,vmode),nil],$e)
301    SAY("extension of ",vval," to ",cat," ignored")
302    $e
303  systemError ['"actOnInfo",u]
304 
305infoToHas a ==
306  a is ["SIGNATURE",b,:data] => ["has",b,["SIGNATURE",:data]]
307  a is ["ATTRIBUTE",b,c] => ["has",b,["ATTRIBUTE",c]]
308  a
309
310chaseInferences(pred,$e) ==
311  foo hasToInfo pred where
312    foo pred ==
313      knownInfo(pred,$e) => nil
314      $e:= actOnInfo(pred,$e)
315      pred:= infoToHas pred
316      for u in get("$Information","special",$e) repeat
317        u is ['%when,:l] =>
318          for [ante,:conseq] in l repeat
319            ante=pred => [foo w for w in conseq]
320            ante is ["and",:ante'] and listMember?(pred,ante') =>
321              ante':= remove(ante',pred)
322              v':=
323                # ante'=1 => first ante'
324                ["and",:ante']
325              v':= ['%when,[v',:conseq]]
326              listMember?(v',get("$Information","special",$e)) => nil
327              $e:=
328                put("$Information","special",[v',:
329                  get("$Information","special",$e)],$e)
330            nil
331  $e
332 
333--%
334
335--=======================================================================
336--            Generate Code to Create Infovec
337--=======================================================================
338++ Called by compDefineFunctor1 to create infovec at compile time
339getInfovecCode(db,e) ==
340  $byteAddress: local := 0
341  ['LIST,
342    MKQ makeDomainTemplate db,
343      MKQ makeCompactDirect(db,NRTmakeSlot1Info db),
344        MKQ NRTgenFinalAttributeAlist(db,e),
345          NRTmakeCategoryAlist(db,e),
346            MKQ dbLookupFunction db]
347
348--=======================================================================
349--         Generation of Domain Vector Template (Compile Time)
350--=======================================================================
351makeDomainTemplate db ==   
352--NOTES: This function is called at compile time to create the template
353--  (slot 0 of the infovec); called by getInfovecCode from compDefineFunctor1
354  vec := dbTemplate db
355  for index in 0..maxIndex vec repeat
356    item := domainRef(vec,index)
357    item = nil => nil
358    domainRef(vec,index) :=
359      item isnt [.,:.] => item
360      cons? first item => makeGoGetSlot(db,item,index)
361      item   
362  dbByteList(db) := "append"/reverse! dbByteList db
363  vec
364 
365makeGoGetSlot(db,item,index) ==
366--NOTES: creates byte vec strings for LATCH slots
367--these parts of the dbByteList are created first; see also makeCompactDirect
368  [sig,whereToGo,op,:flag] := item
369  n := #sig - 1
370  newcode := [n,whereToGo,:makeCompactSigCode sig,index]
371  dbByteList(db) := [newcode,:dbByteList db]
372  curAddress := $byteAddress
373  $byteAddress := $byteAddress + n + 4
374  [curAddress,:op]
375 
376--=======================================================================
377--                Generate OpTable at Compile Time
378--=======================================================================
379--> called by getInfovecCode (see top of this file) from compDefineFunctor1
380makeCompactDirect(db,u) ==
381  $predListLength :local := # $NRTslot1PredicateList
382  $byteVecAcc: local := nil
383  [nam,[addForm,:opList]] := u
384  --pp opList
385  d := [[op,y] for [op,:items] in opList | y := makeCompactDirect1(db,op,items)]
386  dbByteList(db) := [:dbByteList db,:"append"/reverse! $byteVecAcc]
387  vector("append"/d)
388 
389makeCompactDirect1(db,op,items) ==
390--NOTES: creates byte codes for ops implemented by the domain
391    curAddress := $byteAddress
392    $op: local := op  --temp hack by RDJ 8/90 (see orderBySubsumption)
393    newcodes := "append"/[u for y in orderBySubsumption items |
394                            u := fn(db,y)] or return nil
395    $byteVecAcc := [newcodes,:$byteVecAcc]
396    curAddress
397 where fn(db,y) ==
398  [sig,:r] := y
399  r = ['Subsumed] =>
400    n := #sig - 1
401    $byteAddress := $byteAddress + n + 4
402    [n,0,:makeCompactSigCode sig,0]  --always followed by subsuming signature
403    --identified by a 0 in slot position
404  if r is [n,:s] then
405    slot :=
406      n is [p,:.] => p  --the rest is linenumber of function definition
407      n
408    predCode :=
409      s is [pred,:.] => predicateBitIndex(pred,$e)
410      0
411  --> drop items which are not present (predCode = -1)
412  predCode = -1 => return nil
413  --> drop items with nil slots if lookup function is incomplete
414  if null slot then
415     dbLookupFunction db is 'lookupIncomplete => return nil
416     slot := 1   --signals that operation is not present
417  n := #sig - 1
418  $byteAddress := $byteAddress + n + 4
419  res := [n,predCode,:makeCompactSigCode sig,slot]
420  res
421 
422orderBySubsumption items ==
423  acc := subacc := nil
424  for x in items repeat
425    not ($op in '(Zero One)) and x is [.,.,.,'Subsumed] =>
426      subacc := [x,:subacc]
427    acc := [x,:acc]
428  y := z := nil
429  for [a,b,:.] in subacc | b repeat   
430  --NOTE: b = nil means that the signature a will appear in acc, that this
431  --  entry is be ignored (e.g. init: -> $ in ULS)
432    while (u := assoc(b,subacc)) repeat b := second u
433    u := assoc(b,acc) or systemError nil
434    if null second u then u := [first u,1] --mark as missing operation
435    y := [[a,'Subsumed],u,:y] --makes subsuming signature follow one subsumed
436    z := insert(b,z)  --mark a signature as already present
437  [:y,:[w for (w := [c,:.]) in acc | not listMember?(c,z)]] --add those not subsuming
438 
439makeCompactSigCode sig == [fn for x in sig] where
440  fn() ==
441    x is "$$" => 2
442    x is "$" => 0
443    not integer? x =>
444      systemError ['"code vector slot is ",x,'"; must be number"]
445    x
446 
447--=======================================================================
448--               Generate Slot 4 Constructor Vectors
449--=======================================================================
450depthAssocList(u,cache) ==
451  u := removeSymbol(u,'DomainSubstitutionMacro)  --hack by RDJ 8/90
452  removeDuplicates ("append"/[depthAssoc(y,cache) for y in u])
453 
454depthAssoc(x,cache) ==
455  y := tableValue(cache,x) => y
456  x is ['Join,:u] or (u := ASSOCLEFT parentsOfForm x) =>
457    v := depthAssocList(u,cache)
458    tableValue(cache,x) := [[x,:n],:v]
459      where n() == 1 + "MAX"/[rest y for y in v]
460  tableValue(cache,x) := [[x,:0]]
461 
462NRTmakeCategoryAlist(db,e) ==
463  pcAlist := [:[[x,:true] for x in $uncondAlist],:$condAlist]
464  levelAlist := depthAssocList(ASSOCLEFT pcAlist,hashTable 'EQUAL)
465  opcAlist := sortBy(function(x +-> LASSOC(first x,levelAlist)),pcAlist)
466  newPairlis := [[5 + i,:b] for [.,:b] in dbFormalSubst db for i in 1..]
467  slot1 := [[a,:k] for [a,:b] in dbSubstituteAllQuantified(db,opcAlist)
468                   | (k := predicateBitIndex(b,e)) ~= -1]
469  slot0 := [hasDefaultPackage a.op for [a,:b] in slot1]
470  sixEtc := [5 + i for i in 1..dbArity db]
471  formals := ASSOCRIGHT dbFormalSubst db
472  for x in slot1 repeat
473    x.first := applySubst(pairList(['$,:formals],["$$",:sixEtc]),first x)
474  -----------code to make a new style slot4 -----------------
475  predList := ASSOCRIGHT slot1  --is list of predicate indices
476  maxPredList := "MAX"/predList
477  catformvec := ASSOCLEFT slot1
478  maxElement := "MAX"/dbByteList db
479  ['CONS, ['makeByteWordVec2,MAX(maxPredList,1),MKQ predList],
480    ['CONS, MKQ vector slot0,
481      ['CONS, MKQ vector [encodeCatform(db,x) for x in catformvec],
482        ['makeByteWordVec2,maxElement,MKQ dbByteList db]]]]
483  --NOTE: this is new form: old form satisfies vector? CDDR form
484
485encodeCatform(db,x) ==
486  x is '$ => x
487  k := assocIndex(db,x) => k
488  x isnt [.,:.] or rest x isnt [.,:.] => x
489  [first x,:[encodeCatform(db,y) for y in rest x]]
490 
491hasDefaultPackage catname ==
492  defname := makeDefaultPackageName symbolName catname
493  constructor? defname => defname
494  nil
495 
496++ Like getmode, except that if the mode is local variable with
497++ defined value, we want that value instead.
498getXmode(x,e) ==
499  m := getmode(x,e) or return nil
500  ident? m and get(m,'%macro,e) or m
501
502 
503--=======================================================================
504--              Compute the lookup function (complete or incomplete)
505--=======================================================================
506NRTgetLookupFunction(db,addForm,env) ==
507  $why: local := nil
508  domform := dbSubstituteFormals(db,dbConstructorForm db)
509  cat := dbCategory db
510  addForm isnt [.,:.] =>
511    ident? addForm and (m := getmode(addForm,env)) ~= nil and
512      isCategoryForm(m,env) and
513        extendsCategory(db,domform,cat,dbSubstituteFormals(db,m),env) =>
514          'lookupIncomplete
515    'lookupComplete
516  addForm := dbSubstituteFormals(db,addForm)
517  NRTextendsCategory1(db,domform,cat,getBaseExports(db,addForm),env) =>
518    'lookupIncomplete
519  [u,msg,:v] := $why
520  SAY '"--------------non extending category----------------------"
521  sayPatternMsg('"%1p of category %2p", [domform,u])
522  if v ~= nil then
523    sayPatternMsg('"%1b %2p",[msg,first v])
524  else
525    sayPatternMsg('"%1b",[msg])
526  SAY '"----------------------------------------------------------"
527  'lookupComplete
528
529getBaseExports(db,form) ==
530  [op,:argl] := form
531  op is 'Record => ['RecordCategory,:argl]
532  op is 'Union => ['UnionCategory,:argl]
533  op is 'Enumeration => ['EnumerationCategory,:argl]
534  op is 'Mapping => ['MappingCategory,:argl]
535  op is '%Comma => ['Join,
536    :[getBaseExports(db,substSlotNumbers(x,dbTemplate db,dbConstructorForm db))
537        for x in argl]]
538  [[.,target,:tl],:.] := getConstructorModemap op
539  applySubst(pairList($FormalMapVariableList,argl),target)
540 
541NRTextendsCategory1(db,domform,exCategory,addForm,env) ==
542  addForm is ["%Comma",:r] =>
543    and/[extendsCategory(db,domform,exCategory,x,env) for x in r]
544  extendsCategory(db,domform,exCategory,addForm,env)
545
546--=======================================================================
547--         Compute if a domain constructor is forgetful functor
548--=======================================================================
549extendsCategory(db,dom,u,v,env) ==
550  --does category u extend category v (yes iff u contains everything in v)
551  --is dom of category u also of category v?
552  u=v => true
553  v is ["Join",:l] => and/[extendsCategory(db,dom,u,x,env) for x in l]
554  v is ["CATEGORY",.,:l] => and/[extendsCategory(db,dom,u,x,env) for x in l]
555  v is ["SubsetCategory",cat,d] =>
556    extendsCategory(db,dom,u,cat,env) and isSubset(dom,d,env)
557  v := substSlotNumbers(v,dbTemplate db,dbConstructorForm db)
558  extendsCategoryBasic(dom,u,v,env) => true
559  $why :=
560    v is ['SIGNATURE,op,sig,:.] =>
561      [u,['"  has no ",:formatOpSignature(op,sig)]]
562    [u,'" has no",v]
563  nil
564 
565extendsCategoryBasic(dom,u,v,env) ==
566  v is ['IF,p,['ATTRIBUTE,c],.] =>
567    uVec := compMakeCategoryObject(u,env).expr or return false
568    cons? c and isCategoryForm(c,env) =>
569      LASSOC(c,categoryAncestors uVec) is [=p,:.]
570    LASSOC(c,categoryAttributes uVec) is [=p,:.]
571  u is ["Join",:l] => or/[extendsCategoryBasic(dom,x,v,env) for x in l]
572  u = v => true
573  v is ['ATTRIBUTE,c] =>
574    cons? c and isCategoryForm(c,env) => extendsCategoryBasic(dom,u,c,env)
575    u is ['CATEGORY,.,:l] => or/[extendsCategoryBasic(dom,x,v,env) for x in l]
576    uVec := compMakeCategoryObject(u,env).expr or return false
577    LASSOC(c,categoryAttributes uVec) is [=true]
578  isCategoryForm(v,env) => catExtendsCat?(u,v,env)
579  v is ['SIGNATURE,op,sig,:.] =>
580    uVec := compMakeCategoryObject(u,env).expr or return false
581    or/[categoryRef(uVec,i) is [[=op,=sig],:.] for i in 6..maxIndex uVec]
582  u is ['CATEGORY,.,:l] =>
583    v is ['IF,:.] => listMember?(v,l)
584    false
585  false
586 
587catExtendsCat?(u,v,env) ==
588  u = v => true
589  uvec := compMakeCategoryObject(u,env).expr
590  prinAncestorList := categoryPrincipals uvec
591  listMember?(v,prinAncestorList) => true
592  vOp := KAR v
593  if similarForm := assoc(vOp,prinAncestorList) then
594    PRINT u
595    sayBrightlyNT '"   extends "
596    PRINT similarForm
597    sayBrightlyNT '"   but not "
598    PRINT v
599  or/[catExtendsCat?(x,v,env) for x in ASSOCLEFT categoryAncestors uvec]
600 
601substSlotNumbers(form,template,domain) ==
602  form is [op,:.] and
603    symbolMember?(op,allConstructors()) => expandType(form,template,domain)
604  form is ['SIGNATURE,op,sig,:q] =>
605    ['SIGNATURE,op,[substSlotNumbers(x,template,domain) for x in sig],:q]
606  form is ['CATEGORY,k,:u] =>
607    ['CATEGORY,k,:[substSlotNumbers(x,template,domain) for x in u]]
608  expandType(form,template,domain)
609 
610expandType(lazyt,template,domform) ==
611  lazyt isnt [.,:.] => expandTypeArgs(lazyt,template,domform)
612  [functorName,:argl] := lazyt
613  functorName is ":" =>
614    [functorName,first argl,expandTypeArgs(second argl,template,domform)]
615  lazyt is ['local,x] =>
616    n := symbolPosition(x,$FormalMapVariableList)
617    domform.(1 + n)
618  [functorName,:[expandTypeArgs(a,template,domform) for a in argl]]
619 
620expandTypeArgs(u,template,domform) ==
621  u is '$ => u
622  integer? u => expandType(vectorRef(template,u),template,domform)
623  u is [.,y] and u.op in '(%eval QUOTE) => y
624  u isnt [.,:.] => u
625  expandType(u,template,domform)
626
627folks u == --called by getParentsFor
628  u isnt [.,:.] => nil
629  u is [op,:v] and op in '(Join PROGN)
630    or u is ['CATEGORY,.,:v] => "append"/[folks x for x in v]
631  u is ['SIGNATURE,:.] => nil
632  u is ['ATTRIBUTE,a] =>
633    a is [.,:.] and constructor? a.op => folks a
634    nil
635  u is ['IF,p,q,r] =>
636    q1 := folks q
637    r1 := folks r
638    q1 or r1 => [['IF,p,q1,r1]]
639    nil
640  [u]
641
642explodeIfs x == main where  --called by getParentsFor
643  main() ==
644    x is ['IF,p,a,b] => fn(p,a,b)
645    [[x,:true]]
646  fn(p,a,b) ==
647    [:"append"/[gn(p,y) for y in a],:"append"/[gn(['NOT,p],y) for y in b]]
648  gn(p,a) ==
649    a is ['IF,q,b,:.] => fn(MKPF([p,q],'AND),b,nil)
650    [[a,:p]]
651
652getParentsFor db ==
653  constructorForm := dbConstructorForm db
654  n := #constructorForm.args
655  s1 := pairList(take(n,$TriangleVariableList),$FormalMapVariableList)
656  s2 := pairList($FormalMapVariableList,constructorForm.args)
657  [:explodeIfs applySubst(s2,applySubst(s1,x)) for x in folks dbCategory db]
658
659--% Subdomains
660
661++ We are defining a functor with head given by `form', as a subdomain
662++ of the domain designated by the domain form `super', and predicate
663++ `pred' (a VM instruction form).  Emit appropriate info into the
664++ databases.
665emitSubdomainInfo(form,super,pred) ==
666  pred := applySubst!(pairList(form.args,$AtVariables),pred)
667  super := applySubst!(pairList(form.args,$AtVariables),super)
668  dbSuperDomain(constructorDB form.op) := [super,pred]
669
670++ List of operations defined in a given capsule
671++ Each item on this list is of the form
672++    (op sig pred)
673++ where
674++   op:   name of the operation
675++   sig:  signature of the operation
676++   pred: scope predicate of the operation.
677$capsuleFunctions := nil
678
679++ record that the operation `op' with signature `sig' and predicate
680++ `pred' is defined in the current capsule of the current domain
681++ being compiled.
682noteCapsuleFunctionDefinition(op,sig,pred) ==
683  listMember?([op,sig,pred],$capsuleFunctions) =>
684    stackAndThrow('"redefinition of %1b: %2 %3",
685      [op,formatUnabbreviated ["Mapping",:sig],formatIf pred])
686  $capsuleFunctions := [[op,sig,pred],:$capsuleFunctions]
687
688++ Clear the list of functions defined in the last domain capsule.
689clearCapsuleFunctionTable() ==
690  $capsuleFunctions := nil
691
692
693++ List of exports (paireed with scope predicate) declared in
694++ the category of the currend domain or package.
695++ Note: for category packages, this list is nil.
696$exports := nil
697
698noteExport(form,pred) ==
699  -- don't recheck category package exports; we just check
700  -- them when defining the category.  Plus, we might actually
701  -- get indirect duplicates, which is OK.
702  $insideCategoryPackageIfTrue => nil
703  listMember?([form,pred],$exports) =>
704    stackAndThrow('"redeclaration of %1 %2",
705      [form,formatIf pred])
706  $exports := [[form,pred],:$exports]
707
708clearExportsTable() ==
709  $exports := nil
710
711makePredicate l ==
712  null l => true
713  MKPF(l,"and")
714
715--% FUNCTIONS WHICH MUNCH ON == STATEMENTS
716
717++ List of reserved identifiers for which the compiler has special
718++ meanings and that shall not be redefined.
719$reservedNames == '(per rep _$)
720
721++ Check that `var' (a variable of parameter name) is not a reversed name.
722checkVariableName var ==
723  symbolMember?(var,$reservedNames) =>
724    stackAndThrow('"You cannot use reserved name %1b as variable",[var])
725  var
726
727checkParameterNames parms ==
728  for p in parms repeat
729    checkVariableName p
730
731compDefine(form,m,e) ==
732  $macroIfTrue: local := false
733  compDefine1(form,m,e)
734
735++ We are about to process the body of a capsule.  Check the form of
736++ `Rep' definition, and whether it is appropriate to activate the
737++ implicitly generated morphisms
738++     per: Rep -> %
739++     rep: % -> Rep
740++ as local inline functions.
741checkRepresentation: (%Thing, %Form,%List %Form,%Env) -> %Env
742checkRepresentation(db,addForm,body,env) ==
743  domainRep := nil
744  hasAssignRep := false        -- assume code does not assign to Rep.
745  viewFuns := nil
746
747  null body => env             -- Don't be too hard on nothing.
748 
749  -- Locate possible Rep definition
750  for [stmt,:.] in tails body repeat
751    stmt is [":=","Rep",val] =>
752      domainRep ~= nil =>
753        stackAndThrow('"You cannot assign to constant domain %1b",["Rep"])
754      if addForm = val then
755        stackWarning('"OpenAxiom suggests removing assignment to %1b",["Rep"])
756      else if addForm ~= nil then
757        stackWarning('"%1b differs from the base domain",["Rep"])
758      return hasAssignRep := true
759    stmt is ["MDEF","Rep",:.] =>
760      stackWarning('"Consider using == definition for %1b",["Rep"])
761      return hasAssignRep := true
762    stmt is ["IF",.,:l] or stmt is ["SEQ",:l] or stmt is ["exit",:l] =>
763      checkRepresentation(db,nil,l,env)
764    stmt isnt ["DEF",lhs,sig,val] => nil -- skip for now.
765    op := opOf lhs
766    op in '(rep per) =>
767      domainRep ~= nil =>
768        stackAndThrow('"You cannot define implicitly generated %1b",[op])
769      viewFuns := [op,:viewFuns]
770    op ~= "Rep" => nil        -- we are only interested in Rep definition
771    domainRep := val
772    viewFuns ~= nil =>
773      stackAndThrow('"You cannot define both %1b and %2b",["Rep",:viewFuns])
774    -- A package has no "%".
775    dbConstructorKind db = "package" =>
776      stackAndThrow('"You cannot define %1b in a package",["Rep"])
777    -- It is a mistake to define Rep in category defaults
778    $insideCategoryPackageIfTrue =>
779      stackAndThrow('"You cannot define %1b in category defaults",["Rep"])
780    if lhs is [.,.,:.] then   --FIXME: ideally should be 'lhs is [.,:.]'
781      stackAndThrow('"%1b does take arguments",["Rep"])
782    if sig.target ~= nil then
783      stackAndThrow('"You cannot specify type for %1b",["Rep"])
784    -- Now, trick the rest of the compiler into believing that
785    -- `Rep' was defined the Old Way, for lookup purpose.
786    stmt.op := ":="
787    stmt.args := ["Rep",domainRep]
788    $useRepresentationHack := false          -- Don't confuse `Rep' and `%'.
789
790  -- Shall we perform the dirty tricks?
791  if hasAssignRep then
792    $useRepresentationHack := true
793  -- Domain extensions with no explicit Rep definition have the
794  -- the base domain as representation (at least operationally).
795  else if null domainRep and addForm ~= nil then
796    if dbConstructorKind db = "domain" and addForm isnt ["%Comma",:.] then
797      domainRep :=
798        addForm is ["SubDomain",dom,.] =>
799          $subdomain := true
800          dom
801        addForm
802      $useRepresentationHack := false
803      env := putMacro('Rep,domainRep,env)
804  env
805
806
807getSignatureFromMode(form,e) ==
808  getXmode(opOf form,e) is ['Mapping,:signature] =>
809    #form~=#signature => stackAndThrow ["Wrong number of arguments: ",form]
810    applySubst(pairList($FormalMapVariableList,form.args),signature)
811
812compDefine1: (%Form,%Mode,%Env) -> %Maybe %Triple
813compDefine1(form,m,e) ==
814  $insideExpressionIfTrue: local:= false
815  --1. decompose after macro-expanding form
816  ['DEF,lhs,signature,rhs] := form := macroExpand(form,e)
817  $insideWhereIfTrue and isMacro(form,e) and (m=$EmptyMode or m=$NoValueMode)
818     => [lhs,m,putMacro(lhs.op,rhs,e)]
819  if lhs is [.,:.] then
820    checkParameterNames lhs.args
821  null signature.target and symbol? KAR rhs and not builtinConstructor? KAR rhs and
822    (sig := getSignatureFromMode(lhs,e)) =>
823  -- here signature of lhs is determined by a previous declaration
824      compDefine1(['DEF,lhs,[sig.target,:signature.source],rhs],m,e)
825  if signature.target=$Category then $insideCategoryIfTrue:= true
826 
827-- RDJ (11/83): when argument and return types are all declared,
828--  or arguments have types declared in the environment,
829--  and there is no existing modemap for this signature, add
830--  the modemap by a declaration, then strip off declarations and recurse
831  if lhs is [.,:.] then
832    e := compDefineAddSignature(lhs,signature,e)
833-- 2. if signature list for arguments is not empty, replace ('DEF,..) by
834--       ('where,('DEF,..),..) with an empty signature list;
835--     otherwise, fill in all NILs in the signature
836  lhs is [.,:.] and (or/[x ~= nil for x in signature.source]) =>
837    compDefWhereClause(form,m,e)
838  signature.target=$Category =>
839    compDefineCategory(form,m,e,$formalArgList)
840  isDomainForm(rhs,e) and not $insideFunctorIfTrue =>
841    if lhs is [.,:.] then
842      e := giveFormalParametersValues(lhs.args,e)
843    if signature.target = nil then
844      signature := [getTargetFromRhs(lhs,rhs,e),:signature.source]
845    rhs := addEmptyCapsuleIfNecessary(signature.target,rhs)
846    compDefineFunctor(['DEF,lhs,signature,rhs],m,e,$formalArgList)
847  $form = nil => stackAndThrow ['"bad == form ",form]
848  db := constructorDB $op
849  newPrefix :=
850    $prefix => makeSymbol strconc(symbolName $prefix,'",",symbolName $op)
851    dbAbbreviation db
852  compDefineCapsuleFunction(db,form,m,e,newPrefix,$formalArgList)
853
854compDefineAddSignature([op,:argl],signature,e) ==
855  (sig:= hasFullSignature(argl,signature,e)) and
856   null assoc(['$,:sig],symbolTarget('modemap,getProplist(op,e))) =>
857     declForm:=
858       [":",[op,:[[":",x,m] for x in argl for m in sig.source]],signature.target]
859     [.,.,e]:= comp(declForm,$EmptyMode,e)
860     e
861  e
862 
863hasFullSignature(argl,[target,:ml],e) ==
864  target =>
865    u := [m or get(x,"mode",e) or return 'failed for x in argl for m in ml]
866    u is 'failed => nil
867    [target,:u]
868  nil
869 
870addEmptyCapsuleIfNecessary: (%Form,%Form) -> %Form
871addEmptyCapsuleIfNecessary(target,rhs) ==
872  symbolMember?(KAR rhs,$SpecialDomainNames) => rhs
873  ['add,rhs,['CAPSULE]]
874
875++ We are about to elaborate a functor definition, but there
876++ is no source-level user-supplied target mode on the result.
877++ Attempt to infer the target type by compiling the body.
878getTargetFromRhs: (%Form, %Form, %Env) -> %Form
879getTargetFromRhs(lhs,rhs,e) ==
880  --undeclared target mode obtained from rhs expression
881  rhs is ['CAPSULE,:.] =>
882    stackSemanticError(['"target category of ",lhs,
883      '" cannot be determined from definition"],nil)
884  rhs is ['SubDomain,D,:.] => getTargetFromRhs(lhs,D,e)
885  rhs is ['add,D,['CAPSULE,:.]] => getTargetFromRhs(lhs,D,e)
886  rhs is ['Record,:l] => ['RecordCategory,:l]
887  rhs is ['Union,:l] => ['UnionCategory,:l]
888  mode(rhs,e) where
889    mode(x,e) ==
890      $onlyAbstractSlot: local := true -- not yet in codegen phase.
891      compOrCroak(x,$EmptyMode,e).mode
892 
893giveFormalParametersValues(argl,e) ==
894  for x in argl | ident? x repeat
895    e := giveVariableSomeValue(x,get(x,'mode,e),e)
896  e
897
898
899macroExpandInPlace: (%Form,%Env) -> %Form
900macroExpandInPlace(x,e) ==
901  y:= macroExpand(x,e)
902  x isnt [.,:.] or y isnt [.,:.] => y
903  x.first := first y
904  x.rest := rest y
905  x
906
907macroExpand: (%Form,%Env) -> %Form
908macroExpand(x,e) ==   --not worked out yet
909  x isnt [.,:.] =>
910    not ident? x or (u := get(x,"macro",e)) = nil => x
911    -- Don't expand a functional macro name by itself.
912    u is ['%mlambda,:.] => x
913    macroExpand(u,e)
914  x is ['DEF,lhs,sig,rhs] =>
915    ['DEF,macroExpand(lhs,e),macroExpandList(sig,e),macroExpand(rhs,e)]
916  -- macros should override niladic props
917  [op,:args] := x
918  ident? op and args = nil and niladicConstructor? op and
919    (u := get(op,"macro", e)) => macroExpand(u,e)
920  ident? op and (get(op,"macro",e) is ['%mlambda,parms,body]) =>
921    nargs := #args
922    nparms := #parms
923    msg :=
924      nargs < nparms => '"Too few arguments"
925      nargs > nparms => '"Too many arguments"
926      nil
927    msg => (stackMessage(strconc(msg,'" to macro %1bp"),[op]); x)
928    args' := macroExpandList(args,e)
929    applySubst(pairList(parms,args'),body)
930  macroExpandList(x,e)
931 
932macroExpandList(l,e) ==
933  [macroExpand(x,e) for x in l]
934
935--% constructor evaluation
936 
937mkEvalableCategoryForm c ==
938  c is [op,:argl] =>
939    op is "DomainSubstitutionMacro" => mkEvalableCategoryForm second argl
940    op in '(QUOTE mkCategory EnumerationCategory) => c
941    op is ":" => [op,second c,mkEvalableCategoryForm third c]
942    op in '(CATEGORY SubsetCategory) =>
943      [x,m,$e] := compOrCroak(c,$EmptyMode,$e)
944      m = $Category => x
945      MKQ c
946    categoryConstructor? op =>
947      [op,:[mkEvalableCategoryForm x for x in argl]]
948    MKQ c
949  MKQ c
950 
951evalCategoryForm(x,e) ==
952  eval mkEvalableCategoryForm x
953
954++ Return true if we should skip compilation of category package.
955++ This situation happens either when there is no default, of we are in
956++ bootstrap mode.
957skipCategoryPackage? capsule ==
958  null capsule or $bootStrapMode
959
960compDefineCategory1(df is ['DEF,form,sig,body],m,e,fal) ==
961  categoryCapsule :=
962    body is ['add,cat,capsule] =>
963      body := cat
964      capsule
965    nil
966  if form isnt [.,:.] then
967    form := [form]
968  [d,m,e]:= compDefineCategory2(form,sig,body,m,e,fal)
969  if not skipCategoryPackage? categoryCapsule then [.,.,e] :=
970    $insideCategoryPackageIfTrue: local := true
971    $categoryPredicateList: local :=
972        makeCategoryPredicates(form,dbCategory constructorDB form.op)
973    T := compDefine1(mkCategoryPackage(form,cat,categoryCapsule),$EmptyMode,e)
974           or return stackSemanticError(
975                        ['"cannot compile defaults of",:bright opOf form],nil)
976  [d,m,e]
977
978makeCategoryPredicates(form,u) ==
979      $tvl: local := take(#rest form,$TriangleVariableList)
980      $mvl: local := take(#rest form,rest $FormalMapVariableList)
981      fn(u,nil) where
982        fn(u,pl) ==
983          u is ['Join,:.,a] => fn(a,pl)
984          u is ["IF",p,:x] =>
985            fnl(x,insert(applySubst(pairList($tvl,$mvl),p),pl))
986          u is ["has",:.] =>
987            insert(applySubst(pairList($tvl,$mvl),u),pl)
988          u is [op,:.] and op in '(SIGNATURE ATTRIBUTE) => pl
989          u isnt [.,:.] => pl
990          fnl(u,pl)
991        fnl(u,pl) ==
992          for x in u repeat pl := fn(x,pl)
993          pl
994 
995++ Subroutine of mkCategoryPackage.
996++ Return a category-level declaration of an operation described by `desc'.
997mkExportFromDescription desc ==
998  t :=
999    desc.mapKind = 'CONST => ['constant]
1000    nil
1001  ['SIGNATURE,desc.mapOperation,desc.mapSignature,:t]
1002
1003mkCategoryPackage(form is [op,:argl],cat,def) ==
1004  catdb := constructorDB op
1005  packageName:= makeDefaultPackageName symbolName op
1006  packageAbb := makeSymbol strconc(symbolName dbAbbreviation catdb,'"-")
1007  $options:local := []
1008  -- This stops the next line from becoming confused
1009  abbreviationsSpad2Cmd ['package,packageAbb,packageName]
1010  -- This is a little odd, but the parser insists on calling
1011  -- domains, rather than packages
1012  nameForDollar := first setDifference('(S A B C D E F G H I),argl)
1013  packageArgl := [nameForDollar,:argl]
1014  capsuleDefAlist := fn(def,nil) where fn(x,oplist) ==
1015    x isnt [.,:.] => oplist
1016    x is ['DEF,y,:.] => [opOf y,:oplist]
1017    fn(x.args,fn(x.op,oplist))
1018  catvec := evalCategoryForm(form,$e)
1019  fullCatOpList := categoryExports JoinInner([catvec],$e)
1020  catOpList :=
1021    [mkExportFromDescription desc for desc in fullCatOpList
1022        | symbolMember?(desc.mapOperation,capsuleDefAlist)]
1023  null catOpList => nil
1024  packageCategory :=
1025    ['CATEGORY,'package,
1026       :applySubst(pairList($FormalMapVariableList,argl),catOpList)]
1027  nils:= [nil for x in argl]
1028  packageSig := [packageCategory,form,:nils]
1029  $categoryPredicateList := substitute(nameForDollar,'$,$categoryPredicateList)
1030  substitute(nameForDollar,'$,['DEF,[packageName,:packageArgl],packageSig,def])
1031 
1032++ Return the typing constraint operator for `t' in the environment `e'.
1033typingKind(t,e) ==
1034  isCategoryForm(t,e) => 'ofCategory
1035  'ofType
1036
1037++ Subroutine of compDefineFunctor1 and compDefineCategory2.
1038++ Given a constructor definition defining `db', compute implicit
1039++ parameters and store that list in `db'.
1040deduceImplicitParameters(db,e) ==
1041  parms := dbParameters db
1042  nonparms := [x for [x,:.] in get('%compilerData,'%whereDecls,e)
1043                 | not symbolMember?(x,parms)]
1044  nonparms = nil => true
1045  -- Collect all first-order dependencies.
1046  preds := nil
1047  qvars := $QueryVariables
1048  subst := nil
1049  for p in parms for i in 1.. repeat
1050    m := getXmode(p,e)
1051    ident? m and symbolMember?(m,nonparms) =>
1052      stackAndThrow('"Parameter %1b cannot be of type implicit parameter %2pb",
1053                      [p,m])
1054    m isnt [.,:.] => nil
1055    preds := [[typingKind(m,e),dbSubstituteFormals(db,p),m],:preds]
1056    st := [qpair for a in m.args for [v,:qvars] in tails qvars
1057            | ident? a and symbolMember?(a,nonparms)] where
1058                 qpair() ==
1059                   t := getXmode(a,e)
1060                   preds := [[typingKind(t,e),a,t],:preds]
1061                   [a,:v]
1062    subst := [:st,:subst]
1063  -- Now, build the predicate for implicit parameters.
1064  for s in nonparms repeat
1065    x := [rest y for y in subst | symbolEq?(s,first y)]
1066    x = nil =>
1067      stackAndThrow('"Implicit parameter %1b has no visible constraint",[s])
1068    x is [.] => nil -- OK.
1069    stackAndThrow('"Too many constraints for implicit parameter %1b",[s])
1070  dbImplicitData(db) := [subst,preds]
1071   
1072buildConstructorCondition db ==
1073  dbImplicitData db is [subst,cond] =>
1074    ['%exist,ASSOCRIGHT subst,mkpf(applySubst(subst,cond),'AND)]
1075  true
1076
1077getArgumentMode: (%Form,%Env) -> %Maybe %Mode
1078getArgumentMode(x,e) ==
1079  string? x => x
1080  get(x,'mode,e)
1081 
1082getArgumentModeOrMoan: (%Form, %Form, %Env) -> %Mode
1083getArgumentModeOrMoan(x,form,e) ==
1084  getArgumentMode(x,e) or
1085    stackSemanticError(["argument ",x," of ",form," is not declared"],nil)
1086
1087compDefineCategory2(form,signature,body,m,e,$formalArgList) ==
1088    --1. bind global variables
1089    $prefix: local := nil
1090    $op: local := form.op
1091    $insideCategoryIfTrue: local := true
1092    $definition: local := form   --used by DomainSubstitutionFunction
1093    $form: local := nil
1094    $extraParms: local := nil
1095    -- Remember the body for checking the current instantiation.
1096    $currentCategoryBody : local := body
1097         --Set in DomainSubstitutionFunction, used further down
1098    -- 1.1  augment e to add declaration $: <form>
1099    db := constructorDB $op
1100    dbCompilerData(db) := makeCompilationData()
1101    dbFormalSubst(db) := pairList(form.args,$TriangleVariableList)
1102    dbInstanceCache(db) := true
1103    deduceImplicitParameters(db,e)
1104    e:= addBinding("$",[['mode,:form]],e)
1105 
1106    -- 2. obtain signature
1107    signature':=
1108      [signature.target,
1109        :[getArgumentModeOrMoan(a,form,e) for a in form.args]]
1110    e := giveFormalParametersValues(form.args,e)
1111    dbDualSignature(db) :=
1112      [true,:[isCategoryForm(t,e) for t in signature'.source]]
1113
1114    -- 3. replace arguments by $1,..., substitute into body,
1115    --    and introduce declarations into environment
1116    sargl := take(# form.args, $TriangleVariableList)
1117    $functorForm:= $form:= [$op,:sargl]
1118    $formalArgList:= [:sargl,:$formalArgList]
1119    formalBody := dbSubstituteFormals(db,body)
1120    signature' := dbSubstituteFormals(db,signature')
1121    --Begin lines for category default definitions
1122    $functionStats: local:= [0,0]
1123    $functorStats: local:= [0,0]
1124    $getDomainCode: local := nil
1125    $addForm: local:= nil
1126    for x in sargl for t in signature'.source repeat
1127      [.,.,e]:= compMakeDeclaration(x,t,e)
1128 
1129    -- 4. compile body in environment of %type declarations for arguments
1130    op':= $op
1131    -- following line causes cats with no with or Join to be fresh copies
1132    if opOf(formalBody)~='Join and opOf(formalBody)~='mkCategory then
1133           formalBody := ['Join, formalBody]
1134    dbCategory(db) := formalBody
1135    body := optFunctorBody compOrCroak(formalBody,signature'.target,e).expr
1136    if $extraParms ~= nil then
1137      formals := nil
1138      actuals := nil
1139      for [u,:v] in $extraParms repeat
1140        formals := [u,:formals]
1141        actuals := [MKQ v,:actuals]
1142      body := ['sublisV,['pairList,quote formals,['%list,:actuals]],body]
1143    if form.args then body :=  -- always subst for args after extraparms
1144        ['sublisV,['pairList,quote sargl,['%list,:
1145          [['devaluate,u] for u in sargl]]],body]
1146    body:=
1147      ["%bind",[[g:= gensym(),body]],
1148         ['%seq,['%store,['%tref,g,0],mkConstructor $form],g]]
1149    fun := compile(db,[op',["LAMBDA",sargl,body]],signature')
1150 
1151    -- 5. give operator a 'modemap property
1152    pairlis := pairList(form.args,$FormalMapVariableList)
1153    parSignature := applySubst(pairlis,dbSubstituteQueries(db,signature'))
1154    parForm := applySubst(pairlis,form)
1155 
1156    -- 6. put modemaps into InteractiveModemapFrame
1157    $domainShell := eval [op',:[MKQ f for f in sargl]]
1158    dbConstructorModemap(db) :=
1159      [[parForm,:parSignature],[buildConstructorCondition db,$op]]
1160    dbPrincipals(db) := getParentsFor db
1161    dbAncestors(db) := computeAncestorsOf(form,nil)
1162    dbModemaps(db) := modemapsFromCategory(db,[op',:sargl],formalBody,signature')
1163    dbCompilerData(db) := nil
1164    [fun,$Category,e]
1165
1166mkConstructor: %Form -> %Form
1167mkConstructor form ==
1168  form isnt [.,:.] => ['devaluate,form]
1169  null form.args => quote [form.op]
1170  ['%list,MKQ form.op,:[mkConstructor x for x in form.args]]
1171 
1172compDefineCategory(df,m,e,fal) ==
1173  $domainShell: local := nil -- holds the category of the object being compiled
1174  -- since we have so many ways to say state the kind of a constructor,
1175  -- make sure we do have some minimal internal coherence.
1176  lhs := second df
1177  ctor := opOf lhs
1178  db := constructorDB ctor
1179  kind := dbConstructorKind db
1180  kind ~= "category" => throwKeyedMsg("S2IC0016",[ctor,"category",kind])
1181  dbConstructorForm(db) := lhs
1182  $insideFunctorIfTrue => compDefineCategory1(df,m,e,fal)
1183  compDefineLisplib(df,m,e,fal,'compDefineCategory1)
1184
1185
1186%CatObjRes                   -- result of compiling a category
1187  <=> [%Shell,:[%Mode,:[%Env,:null]]]
1188 
1189compMakeCategoryObject: (%Form,%Env) -> %Maybe %CatObjRes
1190compMakeCategoryObject(c,$e) ==
1191  not isCategoryForm(c,$e) => nil
1192  u := evalCategoryForm(c,$e) => [u,$Category,$e]
1193  nil
1194
1195predicatesFromAttributes: %List %Form -> %List %Form
1196predicatesFromAttributes attrList ==
1197  removeDuplicates [second x for x in attrList]
1198
1199getModemap(x is [op,:.],e) ==
1200  for modemap in get(op,'modemap,e) repeat
1201    if u:= compApplyModemap(x,modemap,e) then return
1202      ([.,.,sl]:= u; applySubst(sl,modemap))
1203 
1204addModemap(op,mc,sig,pred,fn,$e) ==
1205  $InteractiveMode => $e
1206  if knownInfo(pred,$e) then pred:=true
1207  $insideCapsuleFunctionIfTrue =>
1208    $CapsuleModemapFrame :=
1209      addModemap0(op,mc,sig,pred,fn,$CapsuleModemapFrame)
1210    $e
1211  addModemap0(op,mc,sig,pred,fn,$e)
1212 
1213addModemapKnown(op,mc,sig,pred,fn,$e) ==
1214  $insideCapsuleFunctionIfTrue =>
1215    $CapsuleModemapFrame :=
1216      addModemap0(op,mc,sig,pred,fn,$CapsuleModemapFrame)
1217    $e
1218  addModemap0(op,mc,sig,pred,fn,$e)
1219 
1220addModemap0(op,mc,sig,pred,fn,e) ==
1221  --mc is the "mode of computation"; fn the "implementation"
1222  --fn is ['Subsumed,:.] => e  -- don't skip subsumed modemaps
1223                               -- breaks -:($,$)->U($,failed) in DP
1224  op='elt or op='setelt => addEltModemap(op,mc,sig,pred,fn,e)
1225  addModemap1(op,mc,sig,pred,fn,e)
1226 
1227addEltModemap(op,mc,sig,pred,fn,e) ==
1228   --hack to change selectors from strings to identifiers; and to
1229   --add flag identifiers as literals in the envir
1230  op='elt and sig is [:lt,sel] =>
1231    string? sel =>
1232      id:= makeSymbol sel
1233      if $insideCapsuleFunctionIfTrue
1234         then $e:= makeLiteral(id,$e)
1235         else e:= makeLiteral(id,e)
1236      addModemap1(op,mc,[:lt,id],pred,fn,e)
1237    -- sel isnt [.,:.] => systemErrorHere '"addEltModemap"
1238    addModemap1(op,mc,sig,pred,fn,e)
1239  op='setelt and sig is [:lt,sel,v] =>
1240    string? sel =>
1241      id:= makeSymbol sel
1242      if $insideCapsuleFunctionIfTrue
1243         then $e:= makeLiteral(id,$e)
1244         else e:= makeLiteral(id,e)
1245      addModemap1(op,mc,[:lt,id,v],pred,fn,e)
1246    -- sel isnt [.,:.] => systemError '"addEltModemap"
1247    addModemap1(op,mc,sig,pred,fn,e)
1248  systemErrorHere '"addEltModemap"
1249 
1250mergeModemap(entry is [[mc,:sig],[pred,:.],:.],modemapList,e) ==
1251  for (mmtail:= [[[mc',:sig'],[pred',:.],:.],:.]) in tails modemapList repeat
1252    mc=mc' or isSubset(mc,mc',e) =>
1253      newmm:= nil
1254      mm:= modemapList
1255      while (not sameObject?(mm,mmtail)) repeat (newmm:= [first mm,:newmm]; mm:= rest mm)
1256      if (mc=mc') and (sig=sig') then
1257        --We only need one of these, unless the conditions are hairy
1258        not $forceAdd and TruthP pred' =>
1259          entry:=nil
1260              --the new predicate buys us nothing
1261          return modemapList
1262        TruthP pred => mmtail:=rest mmtail
1263          --the thing we matched against is useless, by comparison
1264      modemapList:= append!(reverse! newmm,[entry,:mmtail])
1265      entry:= nil
1266      return modemapList
1267  if entry then [:modemapList,entry] else modemapList
1268 
1269insertModemap(new,mmList) ==
1270  null mmList => [new]
1271--isMoreSpecific(new,old:= first mmList) => [new,:mmList]
1272--[old,:insertModemap(new,rest mmList)]
1273  [new,:mmList]
1274
1275mkNewModemapList(mc,sig,pred,fn,curModemapList,e,filenameOrNil) ==
1276  entry:= [map:= [mc,:sig],[pred,fn],:filenameOrNil]
1277  listMember?(entry,curModemapList) => curModemapList
1278  (oldMap:= assoc(map,curModemapList)) and oldMap is [.,[opred, =fn],:.] =>
1279    $forceAdd => mergeModemap(entry,curModemapList,e)
1280    opred=true => curModemapList
1281    if pred ~= true and pred ~= opred then pred:= ["OR",pred,opred]
1282    [if x=oldMap then [map,[pred,fn],:filenameOrNil] else x
1283 
1284  --if new modemap less general, put at end; otherwise, at front
1285      for x in curModemapList]
1286  $InteractiveMode => insertModemap(entry,curModemapList)
1287  mergeModemap(entry,curModemapList,e)
1288 
1289addModemap1(op,mc,sig,pred,fn,e) ==
1290   --mc is the "mode of computation"; fn the "implementation"
1291  if mc="Rep" then sig := substituteDollarIfRepHack sig
1292  currentProplist:= getProplist(op,e) or nil
1293  newModemapList:=
1294    mkNewModemapList(mc,sig,pred,fn,symbolTarget('modemap,currentProplist),e,nil)
1295  newProplist:= augProplist(currentProplist,'modemap,newModemapList)
1296  newProplist':= augProplist(newProplist,"FLUID",true)
1297  unErrorRef op
1298        --There may have been a warning about op having no value
1299  addBinding(op,newProplist',e)
1300 
1301getDomainsInScope e ==
1302  $insideCapsuleFunctionIfTrue => $CapsuleDomainsInScope
1303  get("$DomainsInScope","special",e)
1304 
1305putDomainsInScope(x,e) ==
1306  l:= getDomainsInScope e
1307  if $verbose and listMember?(x,l) then
1308    sayBrightly ['" Note: Domain ",x," already in scope"]
1309  newValue := [x,:remove(l,x)]
1310  $insideCapsuleFunctionIfTrue => ($CapsuleDomainsInScope:= newValue; e)
1311  put("$DomainsInScope","special",newValue,e)
1312
1313getOperationAlist(name,functorForm,form) ==
1314  if ident? name and niladicConstructor? name then
1315    functorForm := [functorForm]
1316  (u:= get(functorForm,'isFunctor,$CategoryFrame)) and not
1317    ($insideFunctorIfTrue and first functorForm=first $functorForm) => u
1318  $insideFunctorIfTrue and name is "$" =>
1319    $domainShell => categoryExports $domainShell
1320    systemError '"$ has no shell now"
1321  T:= compMakeCategoryObject(form,$e) => ([.,.,$e]:= T; categoryExports T.expr)
1322  stackMessage('"not a category form: %1bp",[form])
1323 
1324substNames(domainName,functorForm,opalist) ==
1325  functorForm := substitute("$$","$", functorForm)
1326  nameForDollar :=
1327    isCategoryPackageName functorForm => second functorForm
1328    domainName
1329  [[:substitute("$","$$",substitute(nameForDollar,"$",modemapform)),
1330       [sel, domainName,if domainName is "$" then pos else
1331                                         modemapform.mmTarget]]
1332     for [:modemapform,[sel,"$",pos]] in
1333       applySubst(pairList($FormalMapVariableList,KDR functorForm),opalist)]
1334 
1335evalAndSub(domainName,functorForm,form,$e) ==
1336  $lhsOfColon: local:= domainName
1337  categoryObject? form =>
1338    [substNames(domainName,functorForm,categoryExports form),$e]
1339  --next lines necessary-- see MPOLY for which $ is actual arg. --- RDJ 3/83
1340  if CONTAINED("$$",form) then $e:= put("$$","mode",get("$","mode",$e),$e)
1341  opAlist:= getOperationAlist(domainName,functorForm,form)
1342  substAlist:= substNames(domainName,functorForm,opAlist)
1343  [substAlist,$e]
1344 
1345augModemapsFromCategory(domainName,functorForm,categoryForm,e) ==
1346  [fnAlist,e]:= evalAndSub(domainName,functorForm,categoryForm,e)
1347  compilerMessage('"Adding %1p modemaps",[domainName])
1348  e:= putDomainsInScope(domainName,e)
1349  condlist:=[]
1350  for [[op,sig,:.],cond,fnsel] in fnAlist repeat
1351    e:= addModemapKnown(op,domainName,sig,cond,fnsel,e) -- cond was cond1
1352  e
1353 
1354addConstructorModemaps(name,form is [functorName,:.],e) ==
1355  $InteractiveMode: local:= nil
1356  e:= putDomainsInScope(name,e) --frame
1357  fn := property(functorName,"makeFunctionList")
1358  [funList,e]:= FUNCALL(fn,name,form,e)
1359  for [op,sig,opcode] in funList repeat
1360    if opcode is [sel,dc,n] and sel='ELT then
1361          nsig := substitute("$$$",name,sig)
1362          nsig := substitute('$,"$$$",substitute("$$",'$,nsig))
1363          opcode := [sel,dc,nsig]
1364    e:= addModemap(op,name,sig,true,opcode,e)
1365  e
1366 
1367augModemapsFromDomain1(name,functorForm,e) ==
1368  property(KAR functorForm,"makeFunctionList") =>
1369    addConstructorModemaps(name,functorForm,e)
1370  functorForm isnt [.,:.] and (catform := getmode(functorForm,e)) =>
1371    augModemapsFromCategory(name,functorForm,catform,e)
1372  mappingForm := getmodeOrMapping(KAR functorForm,e) =>
1373    ["Mapping",categoryForm,:functArgTypes] := mappingForm
1374    catform := substituteCategoryArguments(rest functorForm,categoryForm)
1375    augModemapsFromCategory(name,functorForm,catform,e)
1376  stackMessage('"%1pb is an unknown mode",[functorForm])
1377  e
1378 
1379AMFCR_,redefinedList(op,l) == "OR"/[AMFCR_,redefined(op,u) for u in l]
1380 
1381AMFCR_,redefined(opname,u) ==
1382  not(u is [op,:l]) => nil
1383  op = 'DEF => opname = CAAR l
1384  op in '(PROGN SEQ) => AMFCR_,redefinedList(opname,l)
1385  op = '%when => "OR"/[AMFCR_,redefinedList(opname,rest u) for u in l]
1386
1387substituteCategoryArguments(argl,catform) ==
1388  argl := substitute("$$","$",argl)
1389  applySubst(pairList($FormalMapVariableList,argl),catform)
1390 
1391compDefineFunctor(df,m,e,fal) ==
1392  $domainShell: local := nil -- holds the category of the object being compiled
1393  $profileCompiler: local := true
1394  $profileAlist:    local := nil
1395  compDefineLisplib(df,m,e,fal,'compDefineFunctor1)
1396 
1397compDefineFunctor1(df is ['DEF,form,signature,body],m,$e,$formalArgList) ==
1398    -- 0.  Make `form' a constructor instantiation form
1399    if form isnt [.,:.] then
1400      form := [form]
1401    --  1. bind global variables
1402    $prefix: local := nil
1403    $op: local := form.op
1404    $addForm: local := nil
1405    $subdomain: local := false
1406    $functionStats: local:= [0,0]
1407    $functorStats: local:= [0,0]
1408    $form: local := form
1409    $signature: local := nil
1410    $functorTarget: local := nil
1411    $Representation: local := nil
1412         --Set in doIt, accessed in the compiler - compNoStacking
1413    $functorForm: local := form
1414    $functorLocalParameters: local := nil
1415    $getDomainCode: local := nil -- code for getting views
1416    $insideFunctorIfTrue: local:= true
1417    $genSDVar: local:= 0
1418    originale:= $e
1419    db := constructorDB $op
1420    dbConstructorForm(db) := form
1421    dbCompilerData(db) := makeCompilationData()
1422    dbFormalSubst(db) := pairList(form.args,$FormalMapVariableList)
1423    dbTemplate(db) := nil
1424    dbLookupFunction(db) := nil
1425    dbCapsuleDefinitions(db) := nil
1426    $e := registerConstructor($op,$e)
1427    deduceImplicitParameters(db,$e)
1428    $formalArgList:= [:form.args,:$formalArgList]
1429    -- all defaulting packages should have caching turned off
1430    dbInstanceCache(db) := not isCategoryPackageName $op
1431    signature':=
1432      [signature.target,:[getArgumentModeOrMoan(a,form,$e) for a in form.args]]
1433    if signature'.target = nil then
1434      signature' := modemap2Signature getModemap($form,$e)
1435    dbDualSignature(db) :=
1436      [false,:[isCategoryForm(t,$e) for t in signature'.source]]
1437
1438    $functorTarget := target := signature'.target
1439    $e := giveFormalParametersValues(form.args,$e)
1440    [ds,.,$e] := compMakeCategoryObject(target,$e) or return
1441       stackAndThrow('"   cannot produce category object: %1pb",[target])
1442    $domainShell: local := copyVector ds
1443    attributeList := categoryAttributes ds --see below under "loadTimeAlist"
1444    $condAlist: local := nil
1445    $uncondAlist: local := nil
1446    $NRTslot1PredicateList: local := predicatesFromAttributes attributeList
1447    $NRTattributeAlist: local := NRTgenInitialAttributeAlist(db,attributeList)
1448    $NRTaddForm: local := nil   -- see compAdd
1449    -- Generate slots for arguments first, then implicit parameters,
1450    -- then for $NRTaddForm (if any) in compAdd
1451    for x in form.args repeat getLocalIndex(db,x)
1452    for x in dbImplicitParameters db repeat getLocalIndex(db,x)
1453    [.,.,$e] := compMakeDeclaration("$",target,$e)
1454    if not $insideCategoryPackageIfTrue  then
1455      $e := augModemapsFromCategory('_$,'_$,target,$e)
1456      $e := put('$,'%dc,form,$e)
1457    $signature := signature'
1458    parSignature := dbSubstituteAllQuantified(db,signature')
1459    parForm := dbSubstituteAllQuantified(db,form)
1460 
1461    --  3. give operator a 'modemap property
1462    modemap := [[parForm,:parSignature],[buildConstructorCondition db,$op]]
1463    dbConstructorModemap(db) := modemap
1464    dbCategory(db) := modemap.mmTarget
1465
1466    --  (3.1) now make a list of the functor's local parameters; for
1467    --  domain D in form.args,check its signature: if domain, its type is Join(A1,..,An);
1468    --  in this case, D is replaced by D1,..,Dn (gensyms) which are set
1469    --  to the A1,..,An view of D
1470    makeFunctorArgumentParameters(form.args,signature'.source,signature'.target)
1471    $functorLocalParameters := form.args
1472
1473    --  4. compile body in environment of %type declarations for arguments
1474    op':= $op
1475    rettype:= signature'.target
1476    -- If this functor is defined as instantiation of a functor
1477    -- that is a subdomain of `D', then make this functor also a subdomain
1478    -- of that super domain `D'.
1479    if body is ["add",[rhsCtor,:rhsArgs],["CAPSULE"]]
1480        and constructor? rhsCtor
1481         and (u := getSuperDomainFromDB rhsCtor) then
1482           u := sublisFormal(rhsArgs,u,$AtVariables)
1483           emitSubdomainInfo($form,first u, second u)
1484    T:= compFunctorBody(db,body,rettype,$e)
1485    body':= T.expr
1486    lamOrSlam :=
1487      dbInstanceCache db = nil => 'LAMBDA
1488      'SPADSLAM
1489    fun := compile(db,dbSubstituteFormals(db,[op',[lamOrSlam,form.args,body']]),signature')
1490    --The above statement stops substitutions gettting in one another's way
1491    operationAlist := dbSubstituteAllQuantified(db,$lisplibOperationAlist)
1492    dbModemaps(db) := modemapsFromFunctor(db,parForm,operationAlist)
1493    reportOnFunctorCompilation()
1494 
1495    --  5.
1496    dbPrincipals(db) := getParentsFor db
1497    dbAncestors(db) := computeAncestorsOf($form,nil)
1498    $insideFunctorIfTrue:= false
1499    if not $bootStrapMode then
1500      dbLookupFunction(db) := NRTgetLookupFunction(db,$NRTaddForm,$e)
1501          --either lookupComplete (for forgetful guys) or lookupIncomplete
1502      $NRTslot1PredicateList :=
1503        [simpBool x for x in $NRTslot1PredicateList]
1504      LAM_,FILEACTQ('loadTimeStuff,
1505        ['MAKEPROP,MKQ $op,''infovec,getInfovecCode(db,$e)])
1506    $lisplibOperationAlist:= operationAlist
1507    dbBeingDefined?(db) := nil
1508    [fun,['Mapping,:signature'],originale]
1509
1510
1511++ Finish the incomplete compilation of a functor body.
1512incompleteFunctorBody(db,m,body,e) ==
1513  -- The slot numbers from the category shell are bogus at this point.
1514  -- Nullify them so people don't think they bear any meaningful
1515  -- semantics (well, they should not think these are forwarding either).
1516  ops := nil
1517  for [opsig,pred,funsel] in categoryExports $domainShell repeat
1518    if pred isnt true then
1519      pred := simpBool pred
1520    if funsel is [op,.,.] and op in '(ELT CONST) then
1521      third(funsel) := nil
1522    ops := [[opsig,pred,funsel],:ops]
1523  $lisplibOperationAlist := listSort(function GGREATERP,ops,function first)
1524  dbSuperDomain(db) :=
1525    body is ['SubDomain,dom,pred] => [dom,pred]
1526    body is ['add,['SubDomain,dom,pred],:.] => [dom,pred]
1527    nil
1528  [bootStrapError(dbConstructorForm db, _/EDITFILE),m,e]
1529
1530++ Subroutine of compDefineFunctor1.  Called to generate backend code
1531++ for a functor definition.
1532compFunctorBody(db,body,m,e) ==
1533  $bootStrapMode => incompleteFunctorBody(db,m,body,e)
1534  clearCapsuleDirectory()        -- start collecting capsule functions.
1535  T:= compOrCroak(body,m,e)
1536  $capsuleFunctionStack := reverse! $capsuleFunctionStack
1537  -- ??? Don't resolve default definitions, yet.
1538  backendCompile
1539    $insideCategoryPackageIfTrue => $capsuleFunctionStack
1540    foldExportedFunctionReferences $capsuleFunctionStack
1541  clearCapsuleDirectory()        -- release storage.
1542  body is [op,:.] and op in '(add CAPSULE) => T
1543  $NRTaddForm :=
1544    body is ["SubDomain",domainForm,predicate] => domainForm
1545    body
1546  T
1547 
1548reportOnFunctorCompilation() ==
1549  if $semanticErrorStack then sayBrightly '" "
1550  displaySemanticErrors()
1551  if $warningStack then sayBrightly '" "
1552  displayWarnings()
1553  $functorStats:= addStats($functorStats,$functionStats)
1554  [byteCount,elapsedSeconds] := $functorStats
1555  sayBrightly ['%l,:bright '"  Cumulative Statistics for Constructor",$op]
1556  timeString := normalizeStatAndStringify elapsedSeconds
1557  sayBrightly ['"      Time:",:bright timeString,'"seconds"]
1558  sayBrightly '" "
1559  'done
1560 
1561--% domain view code
1562 
1563makeFunctorArgumentParameters(argl,sigl,target) ==
1564  $forceAdd: local:= true
1565  $ConditionalOperators: local := nil
1566  ("append"/[fn(a,augmentSig(s,findExtras(a,target)))
1567              for a in argl for s in sigl]) where
1568    findExtras(a,target) ==
1569      --  see if conditional information implies anything else
1570      --  in the signature of a
1571      target is ['Join,:l] => "union"/[findExtras(a,x) for x in l]
1572      target is ['CATEGORY,.,:l] => "union"/[findExtras1(a,x) for x in l] where
1573        findExtras1(a,x) ==
1574          x is ['AND,:l] => "union"/[findExtras1(a,y) for y in l]
1575          x is ['OR,:l] => "union"/[findExtras1(a,y) for y in l]
1576          x is ['IF,c,p,q] =>
1577            union(findExtrasP(a,c),
1578                  union(findExtras1(a,p),findExtras1(a,q))) where
1579              findExtrasP(a,x) ==
1580                x is ['AND,:l] => "union"/[findExtrasP(a,y) for y in l]
1581                x is ['OR,:l] => "union"/[findExtrasP(a,y) for y in l]
1582                x is ["has",=a,y] and y is ['SIGNATURE,:.] => [y]
1583                nil
1584        nil
1585    augmentSig(s,ss) ==
1586       -- if we find something extra, add it to the signature
1587      null ss => s
1588      for u in ss repeat
1589        $ConditionalOperators:=[rest u,:$ConditionalOperators]
1590      s is ['Join,:sl] =>
1591        u := objectAssoc('CATEGORY,ss) =>
1592          MSUBST([:u,:ss],u,s)
1593        ['Join,:sl,['CATEGORY,'package,:ss]]
1594      ['Join,s,['CATEGORY,'package,:ss]]
1595    fn(a,s) ==
1596      isCategoryForm(s,$CategoryFrame) =>
1597        s is ["Join",:catlist] => genDomainViewList(a,s.args)
1598        [genDomainView(a,s,"getDomainView")]
1599      [a]
1600 
1601genDomainOps(dom,cat) ==
1602  oplist:= getOperationAlist(dom,dom,cat)
1603  siglist:= [sig for [sig,:.] in oplist]
1604  oplist:= substNames(dom,dom,oplist)
1605  cd:=
1606    ["%LET",dom,['mkOpVec,dom,['%list,:
1607      [['%list,MKQ op,['%list,:[mkTypeForm mode for mode in sig]]]
1608        for [op,sig] in siglist]]]]
1609  $getDomainCode:= [cd,:$getDomainCode]
1610  for [opsig,cond,:.] in oplist for i in 0.. repeat
1611    if listMember?(opsig,$ConditionalOperators) then cond:=nil
1612    [op,sig]:=opsig
1613    $e := addModemap(op,dom,sig,cond,['ELT,dom,i],$e)
1614  dom
1615 
1616genDomainView(viewName,c,viewSelector) ==
1617  c is ['CATEGORY,.,:l] => genDomainOps(viewName,c)
1618  code:=
1619    c is ['SubsetCategory,c',.] => c'
1620    c
1621  $e:= augModemapsFromCategory(viewName,nil,c,$e)
1622  cd:= ["%LET",viewName,[viewSelector,viewName,mkTypeForm code]]
1623  if not listMember?(cd,$getDomainCode) then
1624          $getDomainCode:= [cd,:$getDomainCode]
1625  viewName
1626
1627genDomainViewList: (%Symbol,%List %Form) -> %List %Code
1628genDomainViewList(id,catlist) ==
1629  [genDomainView(id,cat,"getDomainView")
1630     for cat in catlist | isCategoryForm(cat,$EmptyEnvironment)]
1631 
1632mkOpVec(dom,siglist) ==
1633  dom:= getPrincipalView dom
1634  substargs := [['$,:canonicalForm dom],
1635                  :pairList($FormalMapVariableList,instantiationArgs dom)]
1636  oplist:= getConstructorOperationsFromDB instantiationCtor dom
1637  --new form is (<op> <signature> <slotNumber> <condition> <kind>)
1638  ops := newVector #siglist
1639  for (opSig:= [op,sig]) in siglist for i in 0.. repeat
1640    u := objectAssoc(op,oplist)
1641    assoc(sig,u) is [.,n,.,'ELT] =>
1642      vectorRef(ops,i) := vectorRef(dom,n)
1643    noplist := applySubst(substargs,u)
1644  -- following variation on assoc needed for GENSYMS in Mutable domains
1645    AssocBarGensym(substitute(dom.0,'$,sig),noplist) is [.,n,.,'ELT] =>
1646      vectorRef(ops,i) := vectorRef(dom,n)
1647    vectorRef(ops,i) := [function Undef,[dom.0,i],:opSig]
1648  ops
1649 
1650
1651++ form is lhs (f a1 ... an) of definition; body is rhs;
1652++ signature is (t0 t1 ... tn) where t0= target type, ti=type of ai, i > 0;
1653++ removes declarative and assignment information from form and
1654++ signature, placing it in list L, replacing form by ("where",form',:L),
1655++ signature by a list of NILs (signifying declarations are in e)
1656compDefWhereClause(['DEF,form,signature,body],m,e) ==
1657  $sigAlist: local := nil
1658  $predAlist: local := nil
1659  -- 1. create sigList= list of all signatures which have embedded
1660  --    declarations moved into global variable $sigAlist
1661  sigList:=
1662    [transformType fetchType(a,x,e,form)
1663      for a in form.args for x in signature.source] where
1664        fetchType(a,x,e,form) ==
1665          x => x
1666          getmode(a,e) or userError concat(
1667            '"There is no mode for argument",a,'"of function",form.op)
1668        transformType x ==
1669          x isnt [.,:.] => x
1670          x is [":",R,Rtype] =>
1671            ($sigAlist:= [[R,:transformType Rtype],:$sigAlist]; x)
1672          x is ['Record,:.] => x --RDJ 8/83
1673          [x.op,:[transformType y for y in x.args]]
1674 
1675  -- 2. replace each argument of the form (|| x p) by x, recording
1676  --    the given predicate in global variable $predAlist
1677  argList:=
1678    [removeSuchthat a for a in form.args] where
1679      removeSuchthat x ==
1680        x is ["|",y,p] => ($predAlist:= [[y,:p],:$predAlist]; y)
1681        x
1682 
1683  -- 3. obtain a list of parameter identifiers (x1 .. xn) ordered so that
1684  --       the type of xi is independent of xj if i < j
1685  varList :=
1686    orderByDependency(ASSOCLEFT argDepAlist,ASSOCRIGHT argDepAlist) where
1687      argDepAlist :=
1688        [[x,:dependencies] for [x,:y] in argSigAlist] where
1689          dependencies() ==
1690            setUnion(listOfIdentifiersIn y,
1691              remove(listOfIdentifiersIn LASSOC(x,$predAlist),x))
1692          argSigAlist := [:$sigAlist,:pairList(argList,sigList)]
1693 
1694  -- 4. construct a WhereList which declares and/or defines the xi's in
1695  --    the order constructed in step 3
1696  whereList := [addSuchthat(x,[":",x,symbolTarget(x,argSigAlist)]) for x in varList]
1697     where addSuchthat(x,y) ==
1698             p := LASSOC(x,$predAlist) => ["|",y,p]
1699             y
1700 
1701  -- 5. compile new ('DEF,("where",form',:WhereList),:.) where
1702  --    all argument parameters of form' are bound/declared in WhereList
1703  comp(form',m,e) where
1704    form' := ["where",defform,:whereList] where
1705      defform := ['DEF,form'',signature',body] where
1706        form'' := [form.op,:argList]
1707        signature' := [signature.target,:[nil for x in signature.source]]
1708 
1709orderByDependency(vl,dl) ==
1710  -- vl is list of variables, dl is list of dependency-lists
1711  selfDependents:= [v for v in vl for d in dl | symbolMember?(v,d)]
1712  for v in vl for d in dl | symbolMember?(v,d) repeat
1713    (SAY(v," depends on itself"); fatalError:= true)
1714  fatalError => userError '"Parameter specification error"
1715  until vl = nil repeat
1716    newl:=
1717      [v for v in vl for d in dl | setIntersection(d,vl) = nil] or return nil
1718    orderedVarList:= [:newl,:orderedVarList]
1719    vl' := setDifference(vl,newl)
1720    dl' := [setDifference(d,newl) for x in vl for d in dl
1721             | symbolMember?(x,vl')]
1722    vl := vl'
1723    dl := dl'
1724  removeDuplicates reverse! orderedVarList --ordered so ith is indep. of jth if i < j
1725 
1726++ Subroutine of compDefineCapsuleFunction.
1727assignCapsuleFunctionSlot(db,op,sig) ==
1728  kind := or/[u.mapKind for u in categoryExports $domainShell
1729                | symbolEq?(op,u.mapOperation) and sig = u.mapSignature]
1730  kind = nil => nil -- op is local and need not be assigned
1731  if $insideCategoryPackageIfTrue then
1732    sig := substitute('$,second dbConstructorForm db,sig)
1733  desc := [op,'$,:[getLocalIndex(db,x) for x in sig],kind]
1734  n := dbEntitySlot(db,desc) => n   --already there
1735  n := dbEntityCount db + $NRTbase
1736  dbUsedEntities(db) := [[desc,op,'$,:sig,kind],:dbUsedEntities db]
1737  dbEntityCount(db) := dbEntityCount db + 1
1738  n
1739
1740localOperation?(op,e) ==
1741  not symbolMember?(op,$formalArgList) and getXmode(op,e) is ['Mapping,:.]
1742
1743++ Subroutine of hasSigInTargetCategory. 
1744candidateSignatures(op,nmodes,slot1) ==
1745  [sig for [[=op,sig,:.],:.] in slot1 | #sig = nmodes]
1746
1747compareMode2Arg(x,m) == null x or modeEqual(x,m)
1748 
1749++ Subroutine of compDefineCapsuleFunction. 
1750++ We are compiling a capsule function definition with head given by `form'.
1751++ Determine whether the function with possibly partial signature `target'
1752++ is exported.  Return the complete signature if yes; otherwise
1753++ return nil, with diagnostic in ambiguity case.
1754hasSigInTargetCategory(form,target,e) ==
1755  sigs := candidateSignatures(form.op,#form,categoryExports $domainShell)
1756  cc := checkCallingConvention(sigs,#form.args)
1757  mList:= [(cc.i > 0 => quasiquote x; getArgumentMode(x,e))
1758            for x in form.args for i in 0..]
1759    --each element is a declared mode for the variable or nil if none exists
1760  potentialSigList :=
1761    removeDuplicates [sig for sig in sigs | fn(sig,target,mList)] where
1762      fn(sig,target,mList) ==
1763        (target = nil or target=sig.target) and
1764          "and"/[compareMode2Arg(x,m) for x in mList for m in sig.source]
1765  potentialSigList is [sig] => sig
1766  potentialSigList = nil => nil
1767  ambiguousSignatureError(form.op,potentialSigList)
1768  first potentialSigList
1769 
1770++ Subroutine of compDefineCapsuleFunction.
1771checkAndDeclare(form,sig,e) ==
1772-- arguments with declared types must agree with those in sig;
1773-- those that don't get declarations put into e
1774  for a in form.args for m in sig.source repeat
1775    isQuasiquote m => nil         -- we just built m from a.
1776    m1:= getArgumentMode(a,e) =>
1777      not modeEqual(m1,m) =>
1778        stack:= ["   ",:bright a,'"must have type ",m,
1779          '" not ",m1,'"%l",:stack]
1780    e:= put(a,'mode,m,e)
1781  if stack then
1782    sayBrightly ['"   Parameters of ",:bright form.op,
1783      '" are of wrong type:",'"%l",:stack]
1784  e
1785
1786++ Subroutine of compDefineCapsuleFunction. 
1787addArgumentConditions($body,$functionName) ==
1788  $argumentConditionList =>
1789               --$body is only used in this function
1790    fn $argumentConditionList where
1791      fn clist ==
1792        clist is [[n,untypedCondition,typedCondition],:.] =>
1793          ['%when,[typedCondition,fn rest clist],
1794            ['%otherwise,["argumentDataError",n,
1795              MKQ untypedCondition,MKQ $functionName]]]
1796        null clist => $body
1797        systemErrorHere ["addArgumentConditions",clist]
1798  $body
1799 
1800++ Subroutine of compDefineCapsuleFunction.
1801compArgumentConditions: %Env -> %Env
1802compArgumentConditions e ==
1803  $argumentConditionList:=
1804    [f for [n,a,x] in $argumentConditionList] where
1805      f() ==
1806        y:= substitute(a,"#1",x)
1807        T := [.,.,e]:= compOrCroak(y,$Boolean,e)
1808        [n,x,T.expr]
1809  e
1810
1811++ Subroutine of compDefineCapsuleFunction.
1812++ We are about to elaborate a definition with `form' as head, and
1813++ parameter types specified in `signature'.  Refine that signature
1814++ in case some or all of the parameter types are missing.
1815refineDefinitionSignature(form,signature,e) ==
1816  --let target and local signatures help determine modes of arguments
1817  signature' :=
1818    x := hasSigInTargetCategory(form,signature.target,e) => x
1819    x := getSignatureFromMode(form,e) => x
1820    [signature.target,:[getArgumentModeOrMoan(a,form,e) for a in form.args]]
1821  signature'.source := stripOffSubdomainConditions(signature'.source,form.args)
1822  --obtain target type if not given
1823  if signature'.target = nil then
1824    signature'.target :=
1825      getSignature(form.op,signature'.source,e).target or return nil
1826  signature'
1827
1828++ Subroutine of compDefineCapsuleFunction.
1829processDefinitionParameters(form,signature,e) ==
1830  e := checkAndDeclare(form,signature,e)
1831  e := giveFormalParametersValues(form.args,e)
1832  e := addDomain(signature.target,e)
1833  e := compArgumentConditions e
1834  if $profileCompiler then
1835    for x in form.args for t in signature.source repeat
1836      profileRecord('arguments,x,t)
1837  for domain in signature repeat
1838    e := addDomain(domain,e)
1839  e
1840 
1841mkRepititionAssoc l ==
1842  mkRepfun(l,1) where
1843    mkRepfun(l,n) ==
1844      null l => nil
1845      l is [x] => [[n,:x]]
1846      l is [x, =x,:l'] => mkRepfun(rest l,n+1)
1847      [[n,:first l],:mkRepfun(rest l,1)]
1848 
1849encodeItem x ==
1850  x is [op,:argl] => getCaps op
1851  ident? x => symbolName x
1852  STRINGIMAGE x
1853 
1854getCaps x ==
1855  s := symbolName x
1856  clist := [c for i in 0..maxIndex s | upperCase? (c := stringChar(s,i))]
1857  clist = nil => '"__"
1858  strconc/[charString first clist,
1859             :[charString charDowncase u for u in rest clist]]
1860
1861encodeFunctionName(db,fun,signature,count) ==
1862    if dbDefaultPackage? db then
1863      signature := substitute('$,first dbParameters db,signature)
1864    reducedSig := mkRepititionAssoc [:signature.source,signature.target]
1865    encodedSig :=
1866      (strconc/[encodedPair for [n,:x] in reducedSig]) where
1867        encodedPair() ==
1868          n=1 => encodeItem x
1869          strconc(toString n,encodeItem x)
1870    encodedName:= makeSymbol strconc(symbolName dbAbbreviation db,'";",
1871        symbolName fun,'";",encodedSig,'";",toString count)
1872    dbCapsuleDefinitions(db) :=
1873      [[encodedName,signature],:dbCapsuleDefinitions db]
1874    encodedName
1875
1876compDefineCapsuleFunction(db,df is ['DEF,form,signature,body],
1877  m,$e,$prefix,$formalArgList) ==
1878    e := $e
1879    --1. bind global variables
1880    $form: local := nil
1881    $op: local := nil
1882    $functionStats: local:= [0,0]
1883    $argumentConditionList: local := nil
1884    $finalEnv: local := nil
1885             --used by ReplaceExitEtc to get a common environment
1886    $initCapsuleErrorCount: local:= #$semanticErrorStack
1887    $insideCapsuleFunctionIfTrue: local:= true
1888    $CapsuleModemapFrame: local:= e
1889    $CapsuleDomainsInScope: local:= get("$DomainsInScope","special",e)
1890    $insideExpressionIfTrue: local:= true
1891    $returnMode: local := m
1892    $suffix := $suffix + 1
1893    -- Change "^" to "**" in definitions.  All other places have
1894    -- been changed before we get here.
1895    if form is ["^",:.] then
1896      sayBrightly ['"Replacing", :bright '"^", '"with",:bright '"**"]
1897      form.op := "**"
1898    [$op,:argl] := form
1899    $form := [$op,:argl]
1900    argl:= stripOffArgumentConditions argl
1901    $formalArgList:= [:argl,:$formalArgList]
1902    signature := refineDefinitionSignature(form,signature,e) or return nil
1903    $signatureOfForm := signature --this global is bound in compCapsuleItems
1904    e := processDefinitionParameters(form,signature,e)
1905    rettype := resolve(signature.target,$returnMode)
1906 
1907    localOrExported :=
1908      localOperation?($op,e) => 'local
1909      'exported
1910    formattedSig := formatUnabbreviatedSig signature
1911    sayBrightly ['"   compiling ",localOrExported,
1912      :bright $op,'": ",:formattedSig]
1913
1914    pred := makePredicate $predl
1915    noteCapsuleFunctionDefinition($op,signature,pred)
1916    T := CATCH('compCapsuleBody, compOrCroak(body,rettype,e))
1917         or [$ClearBodyToken,rettype,e]
1918    --  A THROW to the above CATCH occurs if too many semantic errors occur
1919    --  see stackSemanticError
1920    n := assignCapsuleFunctionSlot(db,$op,signature)
1921    -- Build a name for the implementation.
1922    op' :=
1923      localOperation?($op,e) =>
1924        -- object if the operation is both local and exported.
1925        if or/[mm.mmDC is '$ for mm in get($op,'modemap,e)] then
1926          userError ['"%b",$op,'"%d",'" is local and exported"]
1927        makeSymbol strconc(symbolName $prefix,'";",symbolName $op)
1928      encodeFunctionName(db,$op,signature,$suffix)
1929    if n ~= nil and not $insideCategoryPackageIfTrue then
1930      updateCapsuleDirectory([n,:op'],pred)
1931    -- Let the backend know about this function's type
1932    if $optProclaim then
1933      proclaimCapsuleFunction(op',signature)
1934    clearReplacement op'   -- Make sure we have fresh info
1935    -- Finally, build a lambda expression for this function.
1936    fun :=
1937      catchTag := MKQ gensym()
1938      body' := replaceExitEtc(T.expr,catchTag,"TAGGEDreturn",$returnMode)
1939      body' := addArgumentConditions(body',$op)
1940      finalBody := ['%scope,catchTag,body']
1941      compile(db,[op',["LAMBDA",[:argl,'_$],finalBody]],signature)
1942    $functorStats:= addStats($functorStats,$functionStats)
1943 
1944    --7. give operator a 'value property
1945    [fun,['Mapping,:signature],$e]
1946 
1947domainMember(dom,domList) ==
1948  or/[modeEqual(dom,d) for d in domList]
1949 
1950augModemapsFromDomain(name,functorForm,e) ==
1951  symbolMember?(KAR name or name,$DummyFunctorNames) => e
1952  name = $Category or isCategoryForm(name,e) => e
1953  listMember?(name,getDomainsInScope e) => e
1954  if super := superType functorForm then
1955    e := addNewDomain(super,e)
1956  if name is ["Union",:dl] then for d in stripTags dl
1957                         repeat e:= addDomain(d,e)
1958  augModemapsFromDomain1(name,functorForm,e)
1959
1960addNewDomain(domain,e) ==
1961  augModemapsFromDomain(domain,domain,e)
1962
1963addDomain(domain,e) ==
1964  domain isnt [.,:.] =>
1965    domain="$EmptyMode" => e
1966    domain="$NoValueMode" => e
1967    not ident? domain or 2 < #(s:= symbolName domain) and
1968      char "#" = stringChar(s,0) and char "#" = stringChar(s,1) => e
1969    symbolMember?(domain,getDomainsInScope e) => e
1970    isLiteral(domain,e) => e
1971    addNewDomain(domain,e)
1972  (name:= first domain)='Category => e
1973  domainMember(domain,getDomainsInScope e) => e
1974  getXmode(name,e) is ["Mapping",target,:.] and isCategoryForm(target,e) =>
1975      addNewDomain(domain,e)
1976    -- constructor? test needed for domains compiled with $bootStrapMode=true
1977  isDomainForm(domain,e) => addNewDomain(domain,e)
1978  -- ??? we should probably augment $DummyFunctorNames with CATEGORY
1979  -- ??? so that we don't have to do this special check here.  Investigate.
1980  isQuasiquote domain => e
1981  if not isCategoryForm(domain,e) and name ~= "Mapping" then
1982    unknownTypeError name
1983  e        --is not a functor
1984 
1985
1986getSignature(op,argModeList,$e) ==
1987  1=#
1988    (sigl:=
1989      removeDuplicates
1990        [sig
1991          for [[dc,:sig],[pred,:.]] in (mmList:= get(op,'modemap,$e)) | dc='_$
1992            and sig.source = argModeList and knownInfo(pred,$e)]) => first sigl
1993  null sigl =>
1994    (u:= getXmode(op,$e)) is ['Mapping,:sig] => sig
1995    SAY '"************* USER ERROR **********"
1996    SAY("available signatures for ",op,": ")
1997    if null mmList
1998       then SAY "    NONE"
1999       else for [[dc,:sig],:.] in mmList repeat printSignature("     ",op,sig)
2000    printSignature("NEED ",op,["?",:argModeList])
2001    nil
2002  1=#sigl => first sigl
2003  stackSemanticError(["duplicate signatures for ",op,": ",argModeList],nil)
2004 
2005--% ARGUMENT CONDITION CODE
2006 
2007stripOffArgumentConditions argl ==
2008  [f for x in argl for i in 1..] where
2009    f() ==
2010      x is ["|",arg,condition] =>
2011        condition:= substitute('_#1,arg,condition)
2012        -- in case conditions are given in terms of argument names, replace
2013        $argumentConditionList:= [[i,arg,condition],:$argumentConditionList]
2014        arg
2015      x
2016 
2017stripOffSubdomainConditions(margl,argl) ==
2018  [f for x in margl for arg in argl for i in 1..] where
2019    f() ==
2020      x is ['SubDomain,marg,condition] =>
2021        pair:= assoc(i,$argumentConditionList) =>
2022          (pair.rest.first := MKPF([condition,second pair],'AND); marg)
2023        $argumentConditionList:= [[i,arg,condition],:$argumentConditionList]
2024        marg
2025      x
2026 
2027putInLocalDomainReferences(db,def := [opName,[lam,varl,body]]) ==
2028  NRTputInTail(db,CDDADR def)
2029  def
2030 
2031 
2032compile(db,u,signature) ==
2033  optimizedBody := optimizeFunctionDef u
2034  stuffToCompile :=
2035    $insideCapsuleFunctionIfTrue =>
2036      putInLocalDomainReferences(db,optimizedBody)
2037    optimizedBody
2038  $doNotCompileJustPrint => (PRETTYPRINT stuffToCompile; first u)
2039  $macroIfTrue => constructMacro stuffToCompile
2040  try spadCompileOrSetq(db,stuffToCompile)
2041  finally
2042    functionStats := [0,elapsedTime()]
2043    $functionStats := addStats($functionStats,functionStats)
2044    printStats functionStats
2045
2046++ Subroutine of compile.  Called to generate backend code for
2047++ items defined directly or indirectly at capsule level.   This is
2048++ also used to compile functors.
2049spadCompileOrSetq(db,form is [nam,[lam,vl,body]]) ==
2050        --bizarre hack to take account of the existence of "known" functions
2051        --good for performance (LISPLLIB size, BPI size, NILSEC)
2052  CONTAINED($ClearBodyToken,body) => sayBrightly ['"  ",:bright nam,'" not compiled"]
2053
2054  -- flag parameters needs to be made atomic, otherwise Lisp is confused.
2055  -- We try our best to preserve
2056  -- Note that we don't need substitution in the body because flag
2057  -- parameters are never used in the body.
2058  vl := [ renameParameter for v in vl] where
2059    renameParameter() ==
2060      integer? v or ident? v or string? v => v
2061      gensym '"flag"
2062  if $optReplaceSimpleFunctions then
2063    body := replaceSimpleFunctions body
2064
2065  if nam' := forwardingCall?(vl,body) then
2066      registerFunctionReplacement(nam,nam')
2067      sayBrightly ['"     ",:bright nam,'"is replaced by",:bright nam']
2068  else if macform := expandableDefinition?(vl,body) then
2069    registerFunctionReplacement(nam,macform)
2070    [:vl',.] := vl
2071    sayBrightly ['"     ",:bright prefix2String [nam,:vl'],
2072                   '"is replaced by",:bright prefix2String body]
2073
2074  form :=
2075    getFunctionReplacement nam =>
2076      [nam,[lam,vl,["DECLARE",["IGNORE",last vl]],body]]
2077    [nam,[lam,vl,body]]
2078
2079  $insideCapsuleFunctionIfTrue =>
2080    $optExportedFunctionReference =>
2081      $capsuleFunctionStack := [form,:$capsuleFunctionStack]
2082      first form
2083    first backendCompile [form]
2084  compileConstructor(db,form)
2085 
2086compileConstructor(db,form) ==
2087  u := compileConstructor1(db,form)
2088  clearClams()                  --clear all CLAMmed functions
2089  clearConstructorCache u      --clear cache for constructor
2090  u
2091 
2092compileConstructor1(db,form:=[fn,[key,vl,:bodyl]]) ==
2093-- fn is the name of some category/domain/package constructor;
2094-- we will cache all of its values on $ConstructorCache with reference
2095-- counts
2096  dbConstructorKind db = 'category =>
2097    first compAndDefine [[fn,['SPADSLAM,vl,:bodyl]]]
2098  dbInstanceCache db = nil =>
2099    first backendCompile [[fn,['LAMBDA,vl,:bodyl]]]
2100  compClam(fn,vl,bodyl,[[fn,"$ConstructorCache",'domainEqualList,'count]])
2101 
2102constructMacro: %Form -> %Form
2103constructMacro (form is [nam,[lam,vl,body]]) ==
2104  not (and/[x isnt [.,:.] for x in vl]) =>
2105    stackSemanticError(["illegal parameters for macro: ",vl],nil)
2106  ["XLAM",vl':= [x for x in vl | ident? x],body]
2107 
2108listInitialSegment(u,v) ==
2109  null u => true
2110  null v => nil
2111  first u=first v and listInitialSegment(rest u,rest v)
2112  --returns true iff u.i=v.i for i in 1..(#u)-1
2113 
2114modemap2Signature [[.,:sig],:.] == sig
2115
2116uncons: %Form -> %Form
2117uncons x ==
2118  x isnt [.,:.] => x
2119  x is ["CONS",a,b] => [a,:uncons b]
2120 
2121--% CAPSULE
2122 
2123bootStrapError(functorForm,sourceFile) ==
2124  ['%when, _
2125    ['$bootStrapMode, _
2126        ['%vector,mkTypeForm functorForm,nil,nil,nil,nil,nil]],
2127    ['%otherwise, ['systemError,['%list,'"%b",MKQ functorForm.op,'"%d",'"from", _
2128      '"%b",MKQ namestring sourceFile,'"%d",'"needs to be compiled"]]]]
2129
2130registerInlinableDomain x ==
2131  x is [ctor,:.] =>
2132    constructor? ctor =>
2133      nominateForInlining ctor
2134      cosig := getDualSignature ctor or return nil
2135      for a in x.args for t in cosig.source | t and a is [.,:.] repeat
2136        registerInlinableDomain a
2137    ctor is ":" => registerInlinableDomain third x
2138    ctor is 'Enumeration => nil
2139    builtinFunctorName? ctor =>
2140      for t in x.args repeat
2141        registerInlinableDomain t
2142    nil
2143  nil
2144
2145compAdd(['add,$addForm,capsule],m,e) ==
2146  $bootStrapMode =>
2147    if $addForm is ["%Comma",:.] then code := nil
2148       else [code,m,e]:= comp($addForm,m,e)
2149    [['%when, _
2150       ['$bootStrapMode, _
2151           code],_
2152       ['%otherwise, ['systemError,['%list,'"%b",MKQ $functorForm.op,'"%d",'"from", _
2153         '"%b",MKQ namestring _/EDITFILE,'"%d",'"needs to be compiled"]]]],m,e]
2154  $addFormLhs: local:= $addForm
2155  db := constructorDB currentConstructor e
2156  if $addForm is ["SubDomain",domainForm,predicate] then
2157    $NRTaddForm := domainForm
2158    getLocalIndex(db,domainForm)
2159    registerInlinableDomain domainForm
2160    --need to generate slot for add form since all $ go-get
2161    --  slots will need to access it
2162    [$addForm,.,e]:= compSubDomain1(domainForm,predicate,m,e)
2163  else
2164    $NRTaddForm := $addForm
2165    [$addForm,.,e]:=
2166      $addForm is ["%Comma",:.] =>
2167        $NRTaddForm := ["%Comma",:[getLocalIndex(db,x) for x in $addForm.args]]
2168        for x in $addForm.args repeat
2169          registerInlinableDomain x
2170        compOrCroak(compTuple2Record $addForm,$EmptyMode,e)
2171      registerInlinableDomain $addForm
2172      compOrCroak($addForm,$EmptyMode,e)
2173  compCapsule(capsule,m,e)
2174 
2175compTuple2Record u ==
2176  ['Record,:[[":",i,x] for i in 1.. for x in u.args]]
2177
2178compCapsule(['CAPSULE,:itemList],m,e) ==
2179  $bootStrapMode =>
2180    [bootStrapError($functorForm, _/EDITFILE),m,e]
2181  $insideExpressionIfTrue: local:= false
2182  $useRepresentationHack := true
2183  clearCapsuleFunctionTable()
2184  e := checkRepresentation(constructorDB $form.op,$addFormLhs,itemList,e)
2185  compCapsuleInner(constructorDB $form.op,itemList,m,addDomain('_$,e))
2186 
2187compSubDomain(["SubDomain",domainForm,predicate],m,e) ==
2188  $addFormLhs: local:= domainForm
2189  $addForm: local := nil
2190  $NRTaddForm := domainForm
2191  [$addForm,.,e]:= compSubDomain1(domainForm,predicate,m,e)
2192  compCapsule(['CAPSULE],m,e)
2193 
2194compSubDomain1(domainForm,predicate,m,e) ==
2195  [.,.,e]:=
2196    compMakeDeclaration("#1",domainForm,addDomain(domainForm,e))
2197  u:=
2198    compCompilerPredicate(predicate,e) or
2199      stackSemanticError(["predicate: ",predicate,
2200        " cannot be interpreted with #1: ",domainForm],nil)
2201  pred := simplifyVMForm u.expr
2202  -- For now, reject predicates that directly reference domains
2203  usesVariable?(pred,'$) =>
2204    stackAndThrow('"predicate %1pb is not simple enough",[predicate])
2205  emitSubdomainInfo($form,domainForm,pred)
2206  [domainForm,m,e]
2207
2208compCapsuleInner(db,itemList,m,e) ==
2209  e:= addInformation(m,e)
2210           --puts a new 'special' property of $Information
2211  data := ["PROGN",:itemList]
2212      --RPLACd by compCapsuleItems and Friends
2213  e := compCapsuleItems(itemList,nil,e)
2214  localParList:= $functorLocalParameters
2215  if $addForm ~= nil then
2216    data := ['add,$addForm,data]
2217  code :=
2218    $insideCategoryIfTrue and not $insideCategoryPackageIfTrue => data
2219    buildFunctor(db,$signature,data,localParList,e)
2220  [MKPF([:$getDomainCode,code],"PROGN"),m,e]
2221 
2222--% PROCESS FUNCTOR CODE
2223 
2224compCapsuleItems(itemlist,$predl,$e) ==
2225  $signatureOfForm: local := nil
2226  $suffix: local:= 0
2227  for item in itemlist repeat
2228    $e:= compSingleCapsuleItem(item,$predl,$e)
2229  $e
2230 
2231compSingleCapsuleItem(item,$predl,$e) ==
2232  doIt(macroExpandInPlace(item,$e),$predl)
2233  $e
2234 
2235
2236++ subroutine of doIt.  Called to generate runtime noop insn.
2237mutateToNothing item ==
2238  item.op := 'PROGN
2239  item.rest := nil
2240
2241doIt(item,$predl) ==
2242  $GENNO: local:= 0
2243  item is ['SEQ,:l,['exit,1,x]] =>
2244    item.op := "PROGN"
2245    lastNode(item).first := x
2246    for it1 in rest item repeat $e:= compSingleCapsuleItem(it1,$predl,$e)
2247        --This will RPLAC as appropriate
2248  isDomainForm(item,$e) =>
2249    -- convert naked top level domains to import.
2250    -- Note: The apparent useless destructing of `item' below is necessary
2251    -- because it is subject to RPLACA/RPLACD, which would create
2252    -- a cycle otherwise.
2253    u:= ["import", [first item,:rest item]]
2254    stackWarning('"Use: import %1p",[[first item,:rest item]])
2255    item.op := u.op
2256    item.rest := rest u
2257    doIt(item,$predl)
2258  item is [":=",lhs,rhs,:.] =>
2259    compOrCroak(item,$EmptyMode,$e) isnt [code,.,$e] =>
2260      stackSemanticError(["cannot compile assigned value to",:bright lhs],nil)
2261    not (code is ["%LET",lhs',rhs',:.] and lhs' isnt [.,:.]) =>
2262      code is ["PROGN",:.] =>
2263         stackSemanticError(["multiple assignment ",item," not allowed"],nil)
2264      item.first := first code
2265      item.rest := rest code
2266    lhs:= lhs'
2267    if not symbolMember?(KAR rhs,$NonMentionableDomainNames) and
2268      not symbolMember?(lhs, $functorLocalParameters) then
2269         $functorLocalParameters:= [:$functorLocalParameters,lhs]
2270    if code is ["%LET",.,rhs',:.] and isDomainForm(rhs',$e) then
2271      if lhs="Rep" then
2272        --$Representation bound by compDefineFunctor, used in compNoStacking
2273        $Representation := getRepresentation $e
2274        if $optimizeRep then
2275          registerInlinableDomain $Representation
2276    code is ["%LET",:.] =>
2277      db := constructorDB currentConstructor $e
2278      item.op := '%store
2279      rhsCode := rhs'
2280      item.args := [['%tref,'$,getLocalIndex(db,lhs)],rhsCode]
2281    item.op := code.op
2282    item.rest := rest code
2283  item is [":",a,t] => [.,.,$e]:= compOrCroak(item,$EmptyMode,$e)
2284  item is ["import",:doms] =>
2285     for dom in doms repeat
2286       sayBrightly ['"   importing ",:formatUnabbreviated dom]
2287     [.,.,$e] := compOrCroak(item,$EmptyMode,$e)
2288     mutateToNothing item
2289  item is ["%Inline",type] =>
2290    processInlineRequest(type,$e)
2291    mutateToNothing item
2292  item is ["%SignatureImport",:.] =>
2293    [.,.,$e] := compSignatureImport(item,$EmptyMode,$e)
2294    mutateToNothing item
2295  item is ["IF",p,x,y] => doItConditionally(item,$predl)
2296  item is ["where",b,:l] => compOrCroak(item,$EmptyMode,$e)
2297  item is ["MDEF",:.] => [.,.,$e]:= compOrCroak(item,$EmptyMode,$e)
2298  item is ['DEF,lhs,:.] =>
2299    op := opOf lhs
2300    body := isMacro(item,$e) => $e := putMacro(op,body,$e)
2301    [.,.,$e] := t := compOrCroak(item,$EmptyMode,$e)
2302    item.op := "CodeDefine"
2303        --Note that DescendCode, in CodeDefine, is looking for this
2304    second(item) := [op,$signatureOfForm]
2305      --This is how the signature is updated for buildFunctor to recognise
2306    third(item) := ['dispatchFunction,t.expr]
2307    item.rest.rest.rest := nil
2308  u := compOrCroak(item,$EmptyMode,$e) =>
2309    ([code,.,$e]:= u; item.first := first code; item.rest := rest code)
2310  systemErrorHere ["doIt", item]
2311 
2312isMacro(x,e) ==
2313  x is ['DEF,[op],[nil],body] and
2314    get(op,'modemap,e) = nil and get(op,'mode,e) = nil => body
2315  nil
2316
2317++ Compile capsule-level `item' which is a conditional expression.
2318++ OpenAxiom's take on prepositional logical is a constructive
2319++ interpretation of logical connectives, in terms of IF-expresions.
2320++ In particular, a negation is positively interpretated by swapping
2321++ branches, and- and or-expressions are decomposed into nested
2322++ IF-expressions.  -- gdr, 2009-06-15.
2323doItConditionally(item,predl) ==
2324  item isnt ["IF",p,x,y] => systemErrorHere ["doItConditionally",item]
2325  p is ["not",p'] =>
2326    -- swap branches and recurse for positive interpretation.
2327    item.rest.first := p'
2328    item.rest.rest.first := y
2329    item.rest.rest.rest.first := x
2330    doItConditionally(item,predl)
2331  p is ["and",p',p''] =>
2332    item.rest.first := p'
2333    item.rest.rest.first := ["IF",p'',x,copyTree y]
2334    doItConditionally(item,predl)
2335  p is ["or",p',p''] =>
2336    item.rest.first := p'
2337    item.rest.rest.rest.first := ["IF",p'',copyTree x,y]
2338    doItConditionally(item,predl)
2339  doItIf(item,predl,$e)
2340   
2341 
2342doItIf(item is [.,p,x,y],$predl,$e) ==
2343  olde:= $e
2344  [p',.,$e]:= compCompilerPredicate(p,$e) or userError ['"not a Boolean:",p]
2345  oldFLP:=$functorLocalParameters
2346  if x~="%noBranch" then
2347    compSingleCapsuleItem(x,[p,:$predl],getSuccessEnvironment(p,$e))
2348    x':=localExtras(oldFLP)
2349  oldFLP:=$functorLocalParameters
2350  if y~="%noBranch" then
2351    compSingleCapsuleItem(y,[["not",p],:$predl],getInverseEnvironment(p,olde))
2352    y':=localExtras(oldFLP)
2353  item.op := '%when
2354  item.args := [[p',x,:x'],['%otherwise,y,:y']]
2355 where localExtras(oldFLP) ==
2356   sameObject?(oldFLP,$functorLocalParameters) => nil
2357   flp1:=$functorLocalParameters
2358   oldFLP':=oldFLP
2359   n:=0
2360   while oldFLP' repeat
2361     oldFLP':=rest oldFLP'
2362     flp1:=rest flp1
2363     n:=n+1
2364   -- Now we have to add code to compile all the elements
2365   -- of functorLocalParameters that were added during the
2366   -- conditional compilation
2367   nils:=ans:=[]
2368   for u in flp1 repeat -- is =u form always an atom?
2369     if u isnt [.,:.] or (or/[v is [.,=u,:.] for v in $getDomainCode])
2370       then
2371         nils:=[u,:nils]
2372       else
2373         gv := gensym()
2374         ans:=[["%LET",gv,u],:ans]
2375         nils:=[gv,:nils]
2376     n:=n+1
2377   $functorLocalParameters:=[:oldFLP,:reverse! nils]
2378   reverse! ans
2379 
2380--% CATEGORY AND DOMAIN FUNCTIONS
2381
2382compJoin(["Join",:argl],m,e) ==
2383  catList:= [(compForMode(x,$Category,e) or return 'failed).expr for x in argl]
2384  catList='failed => stackSemanticError(["cannot form Join of: ",argl],nil)
2385  catList':=
2386    [extract for x in catList] where
2387      extract() ==
2388        isCategoryForm(x,e) =>
2389          parameters:=
2390            union("append"/[getParms(y,e) for y in rest x],parameters)
2391              where getParms(y,e) ==
2392                y isnt [.,:.] =>
2393                  isDomainForm(y,e) => [y]
2394                  nil
2395                y is [op,y'] and op in '(LENGTH %llength) => [y,y']
2396                [y]
2397          x
2398        x is ["DomainSubstitutionMacro",pl,body] =>
2399          (parameters:= union(pl,parameters); body)
2400        x is ["mkCategory",:.] => x
2401        ident? x and getXmode(x,e) = $Category => x
2402        stackSemanticError(["invalid argument to Join: ",x],nil)
2403        x
2404  T := [['DomainSubstitutionMacro,parameters,["Join",:catList']],$Category,e]
2405  convert(T,m)
2406
2407compForMode: (%Form,%Mode,%Env) -> %Maybe %Triple
2408compForMode(x,m,e) ==
2409  $compForModeIfTrue: local:= true
2410  comp(x,m,e)
2411
2412makeCategoryForm(c,e) ==
2413  not isCategoryForm(c,e) => nil
2414  [x,m,e]:= compOrCroak(c,$EmptyMode,e)
2415  [x,e]
2416
2417mustInstantiate: %Form -> %Thing
2418mustInstantiate D ==
2419  D is [fn,:.] and
2420    not (symbolMember?(fn,$DummyFunctorNames) or property(fn,"makeFunctionList"))
2421
2422mkExplicitCategoryFunction(domainOrPackage,sigList,atList) ==
2423  body:=
2424    ["mkCategory",MKQ domainOrPackage,['%list,:reverse sigList],
2425      ['%list,:reverse atList],MKQ domList,nil] where
2426        domList() ==
2427          ("union"/[fn sig for ['QUOTE,[[.,sig,:.],:.]] in sigList]) where
2428            fn sig == [D for D in sig | mustInstantiate D]
2429  parameters:=
2430    removeDuplicates
2431      ("append"/
2432        [[x for x in sig | ident? x and x~='_$]
2433          for ['QUOTE,[[.,sig,:.],:.]] in sigList])
2434  ['DomainSubstitutionMacro,parameters,body]
2435
2436DomainSubstitutionFunction(parameters,body) ==
2437  if parameters ~= nil then
2438    (body := Subst(parameters,body)) where
2439      Subst(parameters,body) ==
2440        body isnt [.,:.] =>
2441          objectMember?(body,parameters) => MKQ body
2442          body
2443        listMember?(body,parameters) =>
2444          g := gensym()
2445          $extraParms := [[g,:body],:$extraParms]
2446           --Used in SetVector12 to generate a substitution list
2447           --bound in buildFunctor
2448           --For categories, bound and used in compDefineCategory
2449          MKQ g
2450        first body is 'QUOTE => body
2451        cons? $definition and isFunctor body.op and
2452          body.op ~= $definition.op => quote simplifyVMForm body
2453        [Subst(parameters,u) for u in body]
2454  body isnt ["Join",:.] => body
2455  $definition isnt [.,:.] => body
2456  $definition.args = nil => body
2457  g := gensym()
2458  ['%bind,[[g,['constructorDB,quote $definition.op]]],
2459    ['%when,[['dbTemplate,g]],
2460      ['%otherwise,['%store,['dbTemplate,g],body]]]]
2461
2462
2463++ Subroutine of compCategoryItem.
2464++ Compile exported signature `opsig' under predicate `pred' in
2465++ environment `env'. The parameters `sigs' is a reference to a list
2466++ of signatures elaborated so far.
2467compSignature(opsig,pred,env,sigs) ==
2468  [op,:sig] := opsig
2469  cons? op =>
2470    for y in op repeat
2471      compSignature([y,:sig],pred,env,sigs)
2472  op in '(per rep) =>
2473    stackSemanticError(['"cannot export signature for", :bright op],nil)
2474    nil
2475  noteExport(opsig,pred)
2476  deref(sigs) := [MKQ [opsig,pred],:deref sigs]
2477 
2478++ Subroutine of comCategory.
2479++ Elaborate a category-level item `x' under the predicates `predl'.
2480++ The parameters `sigs' and `atts' are references to list of
2481++ signatures and attributes elaborated so far.
2482compCategoryItem(x,predl,env,sigs,atts) ==
2483  x is nil => nil
2484  --1. if x is a conditional expression, recurse; otherwise, form the predicate
2485  x is ['%when,[p,e]] =>
2486    predl':= [p,:predl]
2487    e is ["PROGN",:l] =>
2488      for y in l repeat compCategoryItem(y,predl',env,sigs,atts)
2489    compCategoryItem(e,predl',env,sigs,atts)
2490  x is ["IF",a,b,c] =>
2491    a is ["not",p] => compCategoryItem(["IF",p,c,b],predl,env,sigs,atts)
2492    a is ["and",p,q] =>
2493      compCategoryItem(["IF",p,["IF",q,b,c],copyTree c],predl,env,sigs,atts)
2494    a is ["or",p,q] =>
2495      compCategoryItem(["IF",p,b,["IF",q,copyTree b,c]],predl,env,sigs,atts)
2496    predl':= [a,:predl]
2497    if b~="%noBranch" then
2498      b is ["PROGN",:l] =>
2499        for y in l repeat compCategoryItem(y,predl',env,sigs,atts)
2500      compCategoryItem(b,predl',env,sigs,atts)
2501    c="%noBranch" => nil
2502    predl':= [["not",a],:predl]
2503    c is ["PROGN",:l] =>
2504      for y in l repeat
2505        compCategoryItem(y,predl',env,sigs,atts)
2506    compCategoryItem(c,predl',env,sigs,atts)
2507  pred := (predl => MKPF(predl,"AND"); true)
2508 
2509  --2. if attribute, push it and return
2510  x is ["ATTRIBUTE",y] =>
2511    -- Attribute 'nil' carries no semantics.
2512    y = "nil" => nil
2513    noteExport(y,pred)
2514    deref(atts) := [MKQ [y,pred],:deref atts]
2515 
2516  --3. it may be a list, with PROGN as the first, and some information as the rest
2517  x is ["PROGN",:l] =>
2518    for u in l repeat
2519      compCategoryItem(u,predl,env,sigs,atts)
2520 
2521  -- 4. otherwise, x gives a signature for a
2522  --    single operator name or a list of names; if a list of names,
2523  --    recurse
2524  x is ["SIGNATURE",:opsig] => compSignature(opsig,pred,env,sigs)
2525  systemErrorHere ["compCategoryItem",x]
2526
2527compCategory: (%Form,%Mode,%Env) -> %Maybe %Triple
2528compCategory(x,m,e) ==
2529  clearExportsTable()
2530  m := resolve(m,$Category)
2531  m = $Category and x is ['CATEGORY,kind,:l] =>
2532      sigs := ref nil
2533      atts := ref nil
2534      for x in l repeat
2535        compCategoryItem(x,nil,e,sigs,atts)
2536      rep := mkExplicitCategoryFunction(kind,deref sigs,deref atts)
2537    --if inside compDefineCategory, provide for category argument substitution
2538      [rep,m,e]
2539  systemErrorHere ["compCategory",x]
2540
2541--%
Note: See TracBrowser for help on using the browser.