1-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
2-- All rights reserved.
3--
4-- Redistribution and use in source and binary forms, with or without
5-- modification, are permitted provided that the following conditions are
6-- met:
7--
8--     - Redistributions of source code must retain the above copyright
9--       notice, this list of conditions and the following disclaimer.
10--
11--     - Redistributions in binary form must reproduce the above copyright
12--       notice, this list of conditions and the following disclaimer in
13--       the documentation and/or other materials provided with the
14--       distribution.
15--
16--     - Neither the name of The Numerical ALgorithms Group Ltd. nor the
17--       names of its contributors may be used to endorse or promote products
18--       derived from this software without specific prior written permission.
19--
20-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
21-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
22-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
23-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
24-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
25-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
26-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
27-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
28-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
29-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
30-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31
32)package "BOOT"
33
34-----------------------------NEW buildFunctor CODE-----------------------------
35NRTaddDeltaCode(kvec) ==
36--NOTES: This function is called from buildFunctor to initially
37--  fill slots in $template. The $template so created is stored in the
38--  NRLIB. On load, makeDomainTemplate is called on this $template to
39--  create a template which becomes slot 0 of the infovec for the constructor.
40--The template has 6 kinds of entries:
41--  (1) formal arguments and local variables, represented by (QUOTE <entry>)
42--      this conflicts by (5) but is ok since each is explicitly set by
43--      instantiator code;
44--  (2) domains, represented by lazy forms, e.g. (Foo 12 17 6)
45--  (3) latch slots, represented SPADCALLable forms which goGet an operation
46--      from a domain then cache the operation in the same slot
47--  (4) functions, represented by identifiers which are names of functions
48--  (5) identifiers/strings, parts of signatures (now parts of signatures
49--      now must all have slot numbers, represented by (QUOTE <entry>)
50--  (6) constants, like 0 and 1, represented by (CONS .. ) form
51  for i in $NRTbase.. for item in REVERSE $NRTdeltaList
52    for compItem in REVERSE $NRTdeltaListComp
53      |null (s:=kvec.i) repeat
54        $template.i:= deltaTran(item,compItem)
55  $template.5 :=
56    $NRTaddForm =>
57      $NRTaddForm is ["@Tuple", :y] => NREVERSE y
58      NRTencode($NRTaddForm,$addForm)
59    nil
60
61deltaTran(item,compItem) ==
62  item is ['domain,lhs,:.] => NRTencode(lhs,compItem)
63  --NOTE: all items but signatures are wrapped with domain forms
64  [op,:modemap] := item
65  [dcSig,[.,[kind,:.]]] := modemap
66  [dc,:sig] := dcSig
67  sig := substitute('$,dc,substitute("$$",'$,sig))
68  dcCode :=
69    dc = '$ => 0
70    NRTassocIndex dc or keyedSystemError("S2NR0004",[dc])
71  formalSig:= SUBLISLIS($FormalMapVariableList,$formalArgList,sig)
72  kindFlag:= (kind = 'CONST => 'CONST; nil)
73  newSig := [NRTassocIndex x or x for x in formalSig]
74  [newSig,dcCode,op,:kindFlag]
75
76NRTreplaceAllLocalReferences(form) ==
77  $devaluateList :local := []
78  NRTputInLocalReferences form
79
80NRTencode(x,y) == encode(x,y,true, true) where
81  encode(x, compForm, firstTime, domain) ==
82      -- converts a domain form to a lazy domain form; everything other than
83      -- the operation name should be assigned a slot
84      not(firstTime) and (k := NRTassocIndex x) =>
85          not(domain) and INTEGERP(k) =>
86              ['NRTEVAL, [($QuickCode => 'QREFELT; 'ELT), "$", k]]
87          k
88      VECP(x) => systemErrorHere '"NRTencode"
89      PAIRP(x) =>
90          QCAR(x) = 'Record or x is ['Union, ['_:, a, b], :.] =>
91              [QCAR(x), :[['_:, a, encode(b, c, false, true)]
92               for [., a, b] in QCDR(x) for [., =a, c] in rest compForm]]
93          constructor?(QCAR(x)) or MEMQ(QCAR x, '(Union Mapping)) =>
94              cosig := rest GETDATABASE(QCAR(x), 'COSIG)
95              if NULL(cosig) then
96                  cosig := [true for y in QCDR(x)]
97              [QCAR x, :[encode(y, z, false, cdom) for y in QCDR(x)
98                          for z in rest compForm for cdom in cosig]]
99          ['NRTEVAL, NRTreplaceAllLocalReferences(
100                             COPY_-TREE(lispize(compForm)))]
101      MEMQ(x, $formalArgList) =>
102          v := $FormalMapVariableList.(POSN1(x, $formalArgList))
103          firstTime => ['local, v]
104          domain => v
105          ['NRTEVAL, [($QuickCode => 'QREFELT; 'ELT), "$", v]]
106      x = '$ => x
107      x = "$$" => x
108      ['QUOTE, x]
109
110--------------FUNCTIONS CALLED DURING CAPSULE FUNCTION COMPILATION-------------
111listOfBoundVars(form, e) ==
112-- Only called from the function genDeltaEntry below
113  form = '$ => []
114  IDENTP form and (u := get(form, 'value, e)) =>
115    u:=u.expr
116    MEMQ(IFCAR u, '(Union Record)) => listOfBoundVars(u, e)
117    [form]
118  atom form => []
119  first form = 'QUOTE => []
120  EQ(first form, ":") => listOfBoundVars(CADDR form, e)
121  -- We don't want to pick up the tag, only the domain
122  "union"/[listOfBoundVars(x, e) for x in rest form]
123
124optDeltaEntry(op, sig, dc, eltOrConst, e) ==
125  $killOptimizeIfTrue = true => nil
126  $bootstrapDomains = true =>
127    nil
128  ndc :=
129    dc = '$ => $functorForm
130    atom dc and (dcval := get(dc, 'value, e)) => dcval.expr
131    dc
132  sig := substitute(ndc, dc, sig)
133  not MEMQ(IFCAR ndc, $optimizableConstructorNames) => nil
134  dcval := optCallEval ndc
135  -- substitute guarantees to use EQUAL testing
136  sig := substitute(devaluate dcval, ndc, sig)
137  if rest ndc then
138     for new in rest devaluate dcval for old in rest ndc repeat
139       sig := substitute(new, old, sig)
140     -- optCallEval sends (List X) to (List (Integer)) etc,
141     -- so we should make the same transformation
142  fn := compiledLookup(op,sig,dcval)
143  if null fn then
144    -- following code is to handle selectors like first, rest
145     nsig := [quoteSelector(tt, e) for tt in sig] where
146       quoteSelector(x, e) ==
147         not(IDENTP x) => x
148         get(x, 'value, e) => x
149         x='$ => x
150         MKQ x
151     fn := compiledLookup(op,nsig,dcval)
152     if null fn then return nil
153  eltOrConst="CONST" => ['XLAM,'ignore,MKQ SPADCALL fn]
154  spadreplace := GETL(compileTimeBindingOf first fn,'SPADreplace)
155  if CONSP spadreplace and first spadreplace = 'XLAM then
156      -- if the optimization is a XLAM form, make sure it's a "proper macro",
157      -- i.e. doesn't ignore its argument or evaluate it more than once.
158      lhs := CADR spadreplace
159      rhs := CADDR spadreplace
160      if # lhs = 1 and countXLAM(var := first lhs, rhs) = 0 then
161          -- deal with cases like "minIndex l == 0", which translates to
162          -- "(XLAM (|l|) 0)", prevents argument from evaluation.
163          return ['XLAM, lhs, ['PROGN, var, rhs]]
164      for var in lhs repeat
165          -- ignore argument that is string, e.g. 'elt(x, "first")'
166          if not STRINGP var and (n := countXLAM(var, rhs)) ~= 1 then
167              -- in current code base there are no cases like "f(x, y) == x"
168              -- so throw an error if such case emerges.
169              stackAndThrow [op, " can not be properly inline optimized"]
170              return nil
171  spadreplace
172
173countXLAM(var, rhs) ==
174    -- return how many times does var appear in rhs
175    not CONSP rhs => if var = rhs then 1 else 0
176    COUNT(var, rhs)
177
178genDeltaEntry(opMmPair, e) ==
179--called from compApplyModemap
180--$NRTdeltaLength=0.. always equals length of $NRTdeltaList
181  $compUniquelyIfTrue: local:= false
182  [op,[dc,:sig],[.,cform:=[eltOrConst,.,nsig]]] := opMmPair
183  eltOrConst = 'XLAM => cform
184  if atom dc then
185    dc = "$" => nsig := sig
186    if NUMBERP nsig then nsig := substitute('$,dc,substitute("$$","$",sig))
187    -- following hack needed to invert Rep to $ substitution
188--  if odc = 'Rep and cform is [.,.,osig] then sig:=osig
189  newimp := optDeltaEntry(op, nsig, dc, eltOrConst, e) => newimp
190  setDifference(listOfBoundVars(dc, e), $functorLocalParameters) ~= [] =>
191    ['applyFun,['compiledLookupCheck,MKQ op,
192         mkList consSig(nsig, dc, e), consDomainForm(dc, nil, e)]]
193  odc := dc
194  if null atom dc then dc := substitute("$$",'$,dc)
195 --   sig := substitute('$,dc,sig)
196 --   cform := substitute('$,dc,cform)
197  opModemapPair :=
198    -- force pred to T
199    [op, [dc, :[genDeltaSig(x, e) for x in nsig]], ['T,cform]]
200  if null NRTassocIndex dc and dc ~= $NRTaddForm and
201    (member(dc,$functorLocalParameters) or null atom dc) then
202    --create "domain" entry to $NRTdeltaList
203      $NRTdeltaList := [['domain, NRTaddInner(dc, e), :dc], :$NRTdeltaList]
204      saveNRTdeltaListComp:= $NRTdeltaListComp:=[nil,:$NRTdeltaListComp]
205      $NRTdeltaLength := $NRTdeltaLength+1
206      compEntry := (compOrCroak(odc, $EmptyMode, e)).expr
207      RPLACA(saveNRTdeltaListComp,compEntry)
208  u :=
209    [eltOrConst,'$,$NRTbase+$NRTdeltaLength-index] where index ==
210      (n:= POSN1(opModemapPair,$NRTdeltaList)) => n + 1
211        --n + 1 since $NRTdeltaLength is 1 too large
212      $NRTdeltaList:= [opModemapPair,:$NRTdeltaList]
213      $NRTdeltaListComp:=[nil,:$NRTdeltaListComp]
214      $NRTdeltaLength := $NRTdeltaLength+1
215      0
216  u
217
218genDeltaSig(x, e) ==
219  NRTgetLocalIndex(x, e)
220
221NRTassocIndex x == --returns index of "domain" entry x in al
222  NULL x => x
223  x = $NRTaddForm => 5
224  k := or/[i for i in 1.. for y in $NRTdeltaList
225            | first(y) = 'domain and NTH(1, y) = x] =>
226    $NRTbase + $NRTdeltaLength - k
227  nil
228
229NRTgetLocalIndex(item, e) ==
230  k := NRTassocIndex item => k
231  item = $NRTaddForm => 5
232  item = '$ => 0
233  item = '_$_$ => 2
234  value:=
235    MEMQ(item,$formalArgList) => item
236    nil
237  atom item and null MEMQ(item,'($ _$_$))
238   and null value =>  --give slots to atoms
239    $NRTdeltaList := [['domain, NRTaddInner(item, e), :value], :$NRTdeltaList]
240    $NRTdeltaListComp:=[item,:$NRTdeltaListComp]
241    $NRTdeltaLength := $NRTdeltaLength+1
242    $NRTbase + $NRTdeltaLength - 1
243  $NRTdeltaList := [['domain, NRTaddInner(item, e), :value], :$NRTdeltaList]
244  saveNRTdeltaListComp:= $NRTdeltaListComp:=[nil,:$NRTdeltaListComp]
245  saveIndex := $NRTbase + $NRTdeltaLength
246  $NRTdeltaLength := $NRTdeltaLength+1
247  compEntry := comp_delta_entry(item, e)
248  RPLACA(saveNRTdeltaListComp,compEntry)
249  saveIndex
250
251DEFVAR($generatingCall, nil)
252
253comp_delta_entry(item, e) ==
254    $generatingCall and cheap_comp_delta_entry(item) => item
255    (compOrCroak(item, $EmptyMode, e)).expr
256
257cheap_comp_delta_entry(item) ==
258    item is [op, :args] =>
259        not(ATOM(op)) => false
260        null(cosig := GETDATABASE(op, 'COSIG)) => false
261        ok := true
262        for arg in args for tp in rest(cosig) while ok repeat
263            ok :=
264                not(tp) => false
265                arg = '$ => true
266                MEMBER(arg, $functorLocalParameters) => true
267                cheap_comp_delta_entry(arg)
268        ok
269    false
270
271NRTassignCapsuleFunctionSlot(op, sig, base_shell, e) ==
272--called from compDefineCapsuleFunction
273  opSig := [op,sig]
274  [., ., implementation] := NRTisExported?(opSig, base_shell) or return nil
275    --if opSig is not exported, it is local and need not be assigned
276  if $insideCategoryPackageIfTrue then
277      sig := substitute('$,CADR($functorForm),sig)
278  sig := [genDeltaSig(x, e) for x in sig]
279  opModemapPair := [op,['_$,:sig],['T,implementation]]
280  POSN1(opModemapPair,$NRTdeltaList) => nil   --already there
281  $NRTdeltaList:= [opModemapPair,:$NRTdeltaList]
282  $NRTdeltaListComp := [nil,:$NRTdeltaListComp]
283  $NRTdeltaLength := $NRTdeltaLength+1
284
285NRTisExported?(opSig, base_shell) ==
286  or/[u for u in base_shell.1 | u.0 = opSig]
287
288consSig(sig, dc, e) == [consDomainName(sigpart, dc, e) for sigpart in sig]
289
290maybe_cons_dn(y, dc, e, c) ==
291    c => consDomainName(y, dc, e)
292    y
293
294consDomainName(x, dc, e) ==
295  x = dc => ''$
296  x = '$ => ''$
297  x = "$$" => ['devaluate,'$]
298  x is [op,:argl] =>
299    (op = 'Record) or (op = 'Union and argl is [[":",:.],:.])  =>
300       mkList [MKQ op,
301         :[['LIST, MKQ '_:, MKQ tag, consDomainName(dom, dc, e)]
302                   for [.,tag,dom] in argl]]
303    isFunctor op or op = 'Mapping or constructor? op =>
304         -- call to constructor? needed if op was compiled in $bootStrapMode
305        not(op = 'Mapping or op = 'Union) and
306          (cosig := GETDATABASE(op, 'COSIG)) =>
307            mkList([MKQ op, :[maybe_cons_dn(y, dc, e, c) for y in argl
308                              for c in rest(cosig)]])
309        mkList [MKQ op, :[consDomainName(y, dc, e) for y in argl]]
310    substitute('$,"$$",x)
311  x = [] => x
312  (y := LASSOC(x,$devaluateList)) => y
313  k:=NRTassocIndex x =>
314    ['devaluate,['ELT,'$,k]]
315  get(x, 'value, e) =>
316    isDomainForm(x, e) => ['devaluate, x]
317    x
318  MKQ x
319
320consDomainForm(x, dc, e) ==
321  x = '$ => '$
322  x is [op,:argl] =>
323      op = ":" and argl is [tag, value] =>
324          [op, tag, consDomainForm(value, dc, e)]
325      [op, :[consDomainForm(y, dc, e) for y in argl]]
326  x = [] => x
327  (y := LASSOC(x,$devaluateList)) => y
328  k:=NRTassocIndex x => ['ELT,'$,k]
329  get(x, 'value, e) or get(x, 'mode, e) => x
330  MKQ x
331
332-- First cut at resolving self-referential conditions.  FIXME: should
333-- handle cyclic dependencies and conditions requiring matching at
334-- runtime.
335
336get_self_preds2(p, acc) ==
337    p is [op, :l] =>
338        MEMQ(op, '(AND and OR or NOT not)) => get_self_preds1(l, acc)
339        op is "HasCategory" =>
340            first(l) = "$" => CONS(CADR(l), acc)
341            acc
342        acc
343    acc
344
345get_self_preds1(pl, acc) ==
346    for p in pl repeat
347        acc := get_self_preds2(p, acc)
348    acc
349
350get_self_preds(pl) == REMDUP get_self_preds1(pl, nil)
351
352boolean_subst_and(l, sub_data) ==
353    res := []
354    for cond in l repeat
355        nc := boolean_subst1(cond, sub_data)
356        nc = true => "iterate"
357        not(nc) =>
358            res := [nc]
359            return first(res)
360        res := cons(nc, res)
361    res = [] => true
362    #res = 1 => first(res)
363    ["AND", :nreverse(res)]
364
365boolean_subst_or(l, sub_data) ==
366    res := []
367    for cond in l repeat
368        nc := boolean_subst1(cond, sub_data)
369        nc = true =>
370            res := [nc]
371            return first(res)
372        not(nc) => "iterate"
373        res := cons(nc, res)
374    res = [] => false
375    #res = 1 => first(res)
376    ["OR", :nreverse(res)]
377
378boolean_subst_not(cond, sub_data) ==
379   sub_data1 := rest(rest(sub_data))
380   nc := boolean_subst1(cond, [FUNCTION boolean_substitute1, nil, :sub_data1])
381   nc = true => false
382   not(nc) => true
383   ["NOT", nc]
384
385boolean_do_subst1(cond, sub_data) ==
386    fun := first(sub_data)
387    FUNCALL(fun, cond, rest(sub_data))
388
389boolean_subst1(cond, sub_data) ==
390    cond = true => cond
391    cond is [op, :l] =>
392        MEMQ(op, '(AND and)) => boolean_subst_and(l, sub_data)
393        MEMQ(op, '(OR or)) => boolean_subst_or(l, sub_data)
394        MEMQ(op, '(NOT not)) => boolean_subst_not(first(l), sub_data)
395        boolean_do_subst1(cond, sub_data)
396    cond
397
398boolean_substitute1(cond, sub_data) ==
399    sub_data := rest(sub_data)
400    good_preds := first(rest(sub_data))
401    nc := LASSOC(cond, good_preds)
402    nc =>
403        RPLACA(sub_data, true)
404        first(nc)
405    cond
406
407boolean_substitute_cond(cond, sub_data) ==
408    cond = first(sub_data) =>
409        RPLACA(rest(sub_data), true)
410        false
411    boolean_substitute1(cond, sub_data)
412
413mk_has_dollar_quote(cat) ==
414    ["HasCategory", "$", ["QUOTE", cat]]
415
416boolean_subst(condCats, cats, sub_data1) ==
417    [boolean_subst1(cond, [FUNCTION boolean_substitute_cond,
418                           mk_has_dollar_quote(cat), :sub_data1])
419          for cond in condCats for cat in cats]
420
421simplify_self_preds1(catvecListMaker, condCats) ==
422    self_preds := get_self_preds(condCats)
423    self_preds := [cat for p in self_preds | p is ["QUOTE", cat]]
424    self_preds = [] => [condCats, false]
425    found_preds := []
426    false_preds := []
427    for c1 in self_preds repeat
428        op1 := opOf(c1)
429        hl := []
430        found := false
431        for c2 in catvecListMaker for cond in condCats repeat
432            c1 = c2 =>
433                found_preds := CONS([c1, cond], found_preds)
434                found := true
435            if op1 = opOf(c2) then
436                hl := CONS([c2, cond], hl)
437        if not(found) and not(hl) then
438            false_preds := CONS(c1, false_preds)
439    good_preds := [cc for cc in found_preds |
440                     cc is [cat, cond] and not(isHasDollarPred(cond))]
441    good_preds := [:[[mk_has_dollar_quote(cat), false] for cat in false_preds],
442                   :[[mk_has_dollar_quote(cat), cond] for cc in good_preds
443                      | cc is [cat, cond]]]
444    sub_data1 := [false, good_preds]
445    condCats := boolean_subst(condCats, catvecListMaker, sub_data1)
446    if not(first(sub_data1)) then
447        userError(["simplify_self_preds1: cannot simplify", $op, self_preds])
448    [condCats, first(sub_data1)]
449
450simplify_self_preds(catvecListMaker, condCats) ==
451    progress := true
452    while progress repeat
453        [condCats, progress] := simplify_self_preds1(catvecListMaker, condCats)
454    condCats
455
456buildFunctor(definition is [name, :args], sig, code, $locals,
457             base_shell, e) ==
458--PARAMETERS
459--  $definition: constructor form, e.g. (SquareMatrix 10 (RationalNumber))
460--  sig: signature of constructor form
461--  code: result of "doIt", converting body of capsule to CodeDefine forms, e.g.
462--       (PROGN (LET Rep ...)
463--              (: (ListOf x y) $)
464--              (CodeDefine (<op> <signature> <functionName>))
465--              (COND ((HasCategory $ ...) (PROGN ...))) ..)
466--  $locals: list of variables to go into slot 5, e.g. (R Rep R,1 R,2 R,3 R,4)
467--           same as $functorLocalParameters
468--           this list is not augmented by this function
469--GLOBAL VARIABLES REFERENCED:
470--  $QuickCode: compilation flag
471
472  $definition : local := definition
473
474  changeDirectoryInSlot1(base_shell, e)  --this extends $NRTslot1PredicateList
475
476  --pp '"=================="
477  --for item in $NRTdeltaList repeat pp item
478
479--LOCAL BOUND FLUID VARIABLES:
480  $GENNO: local:= 0     --bound in compDefineFunctor1, then as parameter here
481  $catvecList: local    --list of vectors v1..vn for each view
482  $SetFunctions: local  --copy of p view with preds telling when fnct defined
483  $MissingFunctionInfo: local --vector marking which functions are assigned
484  $ConstantAssignments: local --code for creation of constants
485  $epilogue: local := nil     --code to set slot 5, things to be done last
486  $extraParms:local  --Set in DomainSubstitutionFunction, used in setVector12
487  $devaluateList : local := [[arg,:b] for arg in args
488                                      for b in $ModeVariableList]
489------------------------
490  oldtime := get_run_time()
491  [catsig, :argsig] := sig
492  catvecListMaker:=REMDUP
493    [(comp(catsig, $EmptyMode, e)).expr,
494      :[compCategories(first u, e) for u in CADR base_shell.4]]
495  condCats := InvestigateConditions([catsig, :rest catvecListMaker],
496                                    base_shell, e)
497  -- a list, one for each element of catvecListMaker
498  -- indicating under what conditions this
499  -- category should be present.  true => always
500  makeCatvecCode:= first catvecListMaker
501  domainShell := GETREFV (6 + $NRTdeltaLength)
502  for i in 0..4 repeat domainShell.i := base_shell.i
503  $template := GETREFV (6 + $NRTdeltaLength)
504  $SetFunctions:= GETREFV SIZE domainShell
505  $MissingFunctionInfo:= GETREFV SIZE domainShell
506  catNames := ['$, :[GENVAR() for u in rest catvecListMaker]]
507  domname:='dv_$
508
509  condCats := [simpBool(cc) for cc in condCats]
510  condCats := simplify_self_preds(catvecListMaker, condCats)
511-->  Do this now to create predicate vector; then DescendCode can refer
512-->  to predicate vector if it can
513  [$uncondAlist,:$condAlist] :=    --bound in compDefineFunctor1
514      NRTsetVector4Part1(catNames, catvecListMaker, condCats, base_shell, e)
515  [$NRTslot1PredicateList,predBitVectorCode1,:predBitVectorCode2] :=
516      makePredicateBitVector([:ASSOCRIGHT($condAlist),
517                              :$NRTslot1PredicateList], e)
518
519  storeOperationCode := DescendCode(code, true, nil, first catNames,
520                                    domainShell, e)
521  outsideFunctionCode:= NRTaddDeltaCode(domainShell)
522  storeOperationCode:= NRTputInLocalReferences storeOperationCode
523  NRTdescendCodeTran(storeOperationCode,nil) --side effects storeOperationCode
524  codePart2:=
525      argStuffCode :=
526        [['QSETREFV, '$, i, v] for i in 6.. for v in $FormalMapVariableList
527          for arg in rest definition]
528      if MEMQ($NRTaddForm,$locals) then
529         addargname := $FormalMapVariableList.(POSN1($NRTaddForm,$locals))
530         argStuffCode := [['QSETREFV, '$, 5, addargname], :argStuffCode]
531      [['stuffDomainSlots,'$],:argStuffCode,
532         :predBitVectorCode2, ['SETF, 'pv_$, ['QREFELT, '$, 3]],
533            storeOperationCode]
534
535  $CheckVectorList := NRTcheckVector domainShell
536--CODE: part 1
537  devaluate_code := [['LET,b, maybe_devaluate(a, c)]
538                      for [a,:b] in $devaluateList for c in $functor_cosig1]
539  codePart1:= [:devaluate_code, createDomainCode,
540                createViewCode,setVector0Code, slot3Code,:slamCode] where
541    -- FIXME: should devaluate only domain arguments
542    createDomainCode:=
543        ['LET, domname, ['LIST, MKQ first definition,
544                         :ASSOCRIGHT $devaluateList]]
545    createViewCode:= ['LET,'$,['GETREFV, 6+$NRTdeltaLength]]
546    setVector0Code := ['QSETREFV, '$, 0, 'dv_$]
547    slot3Code := ['QSETREFV,'$,3,['LET,'pv_$,predBitVectorCode1]]
548    slamCode:=
549        isCategoryPackageName(opOf(definition)) => nil
550        [NRTaddToSlam(definition, '$)]
551
552--CODE: part 3
553  $ConstantAssignments :=
554      [NRTputInLocalReferences code for code in $ConstantAssignments]
555  codePart3:= [:$ConstantAssignments,:$epilogue]
556  ans :=
557    ['PROGN,:optFunctorPROGN [:codePart1,:codePart2,:codePart3], '$]
558  ans:= minimalise ans
559  SAY ['"time taken in buildFunctor: ", get_run_time() - oldtime]
560  --sayBrightly '"------------------functor code: -------------------"
561  --pp ans
562  ans
563
564NRTcheckVector domainShell ==
565--RETURNS: an alist (((op,sig),:pred) ...) of missing functions
566  alist := nil
567  for i in 6..MAXINDEX domainShell repeat
568--Vector elements can be one of
569-- (a) T           -- item was marked
570-- (b) NIL         -- item is a domain; will be filled in by setVector4part3
571-- (c) categoryForm-- it was a domain view; now irrelevant
572-- (d) op-signature-- store missing function info in $CheckVectorList
573    v:= domainShell.i
574    v=true => nil  --item is marked; ignore
575    null v => nil  --a domain, which setVector4part3 will fill in
576    atom v => systemErrorHere '"CheckVector"
577    atom first v => nil  --category form; ignore
578    assoc(first v,alist) => nil
579    alist:=
580      [[first v,:$SetFunctions.i],:alist]
581  alist
582
583NRTsetVector4Part1(sigs, forms, conds, base_shell, e) ==
584    uncond_list := nil
585    cond_list := nil
586    for sig in reverse sigs for form in reverse forms
587           for cond in reverse conds repeat
588        sig = '$ =>
589            domainList :=
590                [optimize COPY IFCAR comp(d, $EmptyMode, e) or
591                   d for d in base_shell.4.0]
592            uncond_list := APPEND(domainList, uncond_list)
593            if isCategoryForm(form) then
594                uncond_list := [form, :uncond_list]
595        evalform := eval mkEvalableCategoryForm(form, e)
596        cond = true =>
597            uncond_list := [form, :APPEND(evalform.4.0, uncond_list)]
598        cond_list := [[cond,[form, :evalform.4.0]], :cond_list]
599
600    reducedUncondlist := REMDUP uncond_list
601    reducedConlist := [[x, :y] for [x,z] in cond_list |
602                         y := SETDIFFERENCE(z, reducedUncondlist)]
603    revCondlist := reverseCondlist reducedConlist
604    orCondlist := [[x, :MKPF(y, 'OR)] for [x, :y] in revCondlist]
605    [reducedUncondlist, :orCondlist]
606
607reverseCondlist cl ==
608  alist := nil
609  for [x,:y] in cl repeat
610    for z in y repeat
611      u := assoc(z,alist)
612      null u => alist := [[z,x],:alist]
613      member(x, rest u) => nil
614      RPLACD(u, [x, :rest u])
615  alist
616
617NRTmakeSlot1Info(form, base_shell) ==
618-- 4 cases:
619-- a:T == b add c  --- slot1 directory has #s for entries defined in c
620-- a:T == b        --- slot1 has all slot #s = NIL (see compFunctorBody)
621-- a == b add c    --- not allowed (line 7 of getTargetFromRhs)
622  pairlis :=
623    $insideCategoryPackageIfTrue = true =>
624      [:argl, dollarName] := rest(form)
625      [[dollarName,:'_$],:mkSlot1sublis argl]
626    mkSlot1sublis(rest(form))
627  lisplibOpAlist := transformOperationAlist(SUBLIS(pairlis, base_shell.1))
628  opList :=
629    $insideCategoryPackageIfTrue = true => slot1Filter lisplibOpAlist
630    lisplibOpAlist
631  addList := SUBLIS(pairlis,$NRTaddForm)
632  [first(form), [addList, :opList]]
633
634mkSlot1sublis argl ==
635  [[a,:b] for a in argl for b in $FormalMapVariableList]
636
637slot1Filter opList ==
638--include only those ops which are defined within the capsule
639  [u for x in opList | u := fn x] where
640    fn [op,:l] ==
641      u := [entry for entry in l | INTEGERP CADR entry] => [op,:u]
642      nil
643
644NRTaddToSlam([name,:argnames],shell) ==
645  $mutableDomain => return nil
646  null argnames => addToConstructorCache(name,nil,shell)
647  args:= ['LIST,:ASSOCRIGHT $devaluateList]
648  addToConstructorCache(name,args,shell)
649
650genOperationAlist(base_shell) ==
651  $lisplibOperationAlist := [sigloc entry for entry in base_shell.1] where
652    sigloc [opsig,pred,fnsel] ==
653        if pred ~= 'T then
654          pred := simpBool pred
655          $NRTslot1PredicateList := insert(pred,$NRTslot1PredicateList)
656        fnsel is [op,a,:.] and (op = 'ELT or op = 'CONST) =>
657          if $insideCategoryPackageIfTrue then
658              opsig := substitute('$,CADR($functorForm),opsig)
659          [opsig,pred,[op,a,vectorLocation(first opsig,CADR opsig)]]
660        [opsig,pred,fnsel]
661
662changeDirectoryInSlot1(base_shell, e) ==  --called by buildFunctor
663  genOperationAlist(base_shell)
664  sortedOplist := listSort(function GLESSEQP,
665                           COPY_-LIST $lisplibOperationAlist,function CADR)
666  $lastPred :local := nil
667  $newEnv : local := e
668  base_shell.1 := [fn(entry, e) for entry in sortedOplist] where
669    fn([[op, sig], pred, fnsel], e) ==
670       if $lastPred ~= pred then
671            $newEnv := deepChaseInferences(pred, e)
672            $lastPred := pred
673       [[op, genSlotSig(sig, $newEnv)], pred, fnsel]
674
675genSlotSig(sig, e) ==
676   [genDeltaSig(t, e) for t in sig]
677
678DEFPARAMETER($infoHash, nil)
679
680deepChaseInferences(pred, e) ==
681    $infoHash : local := MAKE_HASHTABLE('EQUAL)
682    deepChaseInferences1(pred, e)
683
684deepChaseInferences1(pred, e) ==
685    pred is ['AND,:preds] or pred is ['and,:preds] =>
686        for p in preds repeat e := deepChaseInferences1(p, e)
687        e
688    pred is ['OR, pred1, :.] or pred is ['or, pred1, :.] => e
689    --    deepChaseInferences1(pred1, e)
690    pred is 'T or pred is ['NOT, :.] or pred is ['not, :.] => e
691    chaseInferences(pred, e)
692
693vectorLocation(op,sig) ==
694  u := or/[i for i in 1.. for u in $NRTdeltaList
695        | u is [=op,[='$,: xsig],:.] and sig=NRTsubstDelta(xsig) ]
696  u => $NRTdeltaLength - u + 6
697  nil    -- this signals that calls should be forwarded
698
699NRTsubstDelta(initSig) ==
700  sig := [replaceSlotTypes s for s in initSig] where
701     replaceSlotTypes(t) ==
702        atom t =>
703          not INTEGERP t => t
704          t = 0 => '$
705          t = 2 => '_$_$
706          t = 5 => $NRTaddForm
707          u:= $NRTdeltaList.($NRTdeltaLength+5-t)
708          first u = 'domain => CADR u
709          error "bad $NRTdeltaList entry"
710        MEMQ(first t, '(Mapping Union Record _:)) =>
711           [first t, :[replaceSlotTypes(x) for x in rest t]]
712        t
713-----------------------------SLOT1 DATABASE------------------------------------
714
715NRTputInLocalReferences bod ==
716  $elt: local := ($QuickCode => 'QREFELT; 'ELT)
717  NRTputInHead bod
718
719NRTputInHead bod ==
720  atom bod => bod
721  bod is ['SPADCALL,:args,fn] =>
722    NRTputInTail rest bod --NOTE: args = COPY of rest bod
723    -- The following test allows function-returning expressions
724    fn is [elt,dom,ind] and not (dom='$) and MEMQ(elt,'(ELT QREFELT CONST)) =>
725      k:= NRTassocIndex dom => RPLACA(LASTNODE bod,[$elt,'_$,k])
726      nil
727    NRTputInHead fn
728    bod
729  bod is ["COND",:clauses] =>
730    for cc in clauses repeat NRTputInTail cc
731    bod
732  bod is ["QUOTE",:.] => bod
733  bod is ["CLOSEDFN",:.] => bod
734  bod is ["SPADCONST", dom, ind] => BREAK()
735  NRTputInHead first bod
736  NRTputInTail rest bod
737  bod
738
739NRTputInTail x ==
740  for y in tails x repeat
741    atom (u := first y) =>
742      EQ(u,'$) or LASSOC(u,$devaluateList) => nil
743      k:= NRTassocIndex u =>
744        atom u => RPLACA(y,[$elt,'_$,k])
745        -- u atomic means that the slot will always contain a vector
746        BREAK()
747      --this reference must check that slot is a vector
748      nil
749    NRTputInHead u
750  x
751
752--=======================================================================
753--               Functions Creating Lisplib Information
754--=======================================================================
755NRTdescendCodeTran(u, condList) ==
756    -- buildFunctor calls NRTdescendCodeTran to fill $template slots
757    -- with names of compiled functions
758    null u => nil
759    u is ['LIST] => nil
760    u is [op, ., i, a] and MEMQ(op, '(SETELT QSETREFV)) =>
761        null condList and a is ['CONS, fn, :.] =>
762            RPLACA(u, 'LIST)
763            RPLACD(u, nil)
764            $template.i :=
765                fn = 'IDENTITY => a
766                fn is ['dispatchFunction, fn'] => fn'
767                fn
768        a is ['CONS, 'IDENTITY, ['FUNCALL, fn, "$"]] =>
769            na := [['FUNCTION, 'makeSpadConstant], ["LIST", fn, "$", i]]
770            RPLACD(a, na)
771            nil
772        nil   --code for this will be generated by the instantiator
773    u is ['COND, :c] =>
774        for [pred, :y] in c|y repeat
775            NRTdescendCodeTran(first y, [pred, :condList])
776    u is ['PROGN, :c] => for x in c repeat NRTdescendCodeTran(x, condList)
777    nil
778
779--=======================================================================
780--                  Miscellaneous Functions
781--=======================================================================
782NRTaddInner(x, e) ==
783--called by genDeltaEntry and others that affect $NRTdeltaList
784  PROGN
785    atom x => nil
786    x is ['Record, :l] =>
787        for [., ., y] in l repeat NRTinnerGetLocalIndex(y, e)
788    first x in '(Union Mapping) =>
789        for y in rest x repeat
790            y is [":", ., z] => NRTinnerGetLocalIndex(z, e)
791            NRTinnerGetLocalIndex(y, e)
792    x is ['SubDomain, y, :.] => NRTinnerGetLocalIndex(y, e)
793    getConstructorSignature x is [., :ml] =>
794        for y in rest x for m in ml | not (y = '$) repeat
795            isCategoryForm(m) => NRTinnerGetLocalIndex(y, e)
796    keyedSystemError("S2NR0003", [x])
797  x
798
799-- NRTaddInner should call following function instead of NRTgetLocalIndex
800-- This would prevent putting spurious items in $NRTdeltaList
801NRTinnerGetLocalIndex(x, e) ==
802    atom x => x
803    -- following test should skip Unions, Records, Mapping
804    MEMQ(opOf x, '(Union Record Mapping)) => NRTgetLocalIndex(x, e)
805    constructor?(x) => NRTgetLocalIndex(x, e)
806    NRTaddInner(x, e)
807