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--% EXTERNAL ROUTINES
35
36--These functions are called from outside this file to add a domain
37--   or to get the current domains in scope;
38
39addDomain(domain,e) ==
40  atom domain =>
41    EQ(domain,"$EmptyMode") => e
42    EQ(domain,"$NoValueMode") => e
43    not IDENTP domain or 2<#(s:= STRINGIMAGE domain) and
44      EQ(char "#",s.(0)) and EQ(char "#",s.(1)) => e
45    MEMQ(domain,getDomainsInScope e) => e
46    isLiteral(domain,e) => e
47    addNewDomain(domain,e)
48  (name:= first domain)='Category => e
49  domainMember(domain,getDomainsInScope e) => e
50  getmode(name, e) is ["Mapping", target, :.] and isCategoryForm(target) =>
51      addNewDomain(domain,e)
52    -- constructor? test needed for domains compiled with $bootStrapMode=true
53  isFunctor name or constructor? name => addNewDomain(domain,e)
54  if not isCategoryForm(domain) and
55    not member(name,'(Mapping CATEGORY)) then
56      unknownTypeError name
57  e        --is not a functor
58
59domainMember(dom,domList) == or/[modeEqual(dom,d) for d in domList]
60
61--% MODEMAP FUNCTIONS
62
63getModemapList(op,numOfArgs,e) ==
64  op is ['Sel, D, op'] => getModemapListFromDomain(op', numOfArgs, D, e)
65  [mm for
66    (mm:= [[.,.,:sigl],:.]) in get(op,'modemap,e) | numOfArgs=#sigl]
67
68getModemapListFromDomain(op,numOfArgs,D,e) ==
69  [mm
70    for (mm:= [[dc,:sig],:.]) in get(op,'modemap,e) | dc=D and #rest sig=
71      numOfArgs]
72
73addModemapKnown(op, mc, sig, pred, fn, e) ==
74--  if knownInfo pred then pred:=true
75--  that line is handled elsewhere
76  $insideCapsuleFunctionIfTrue=true =>
77    $CapsuleModemapFrame :=
78      addModemap0(op,mc,sig,pred,fn,$CapsuleModemapFrame)
79    e
80  addModemap0(op, mc, sig, pred, fn, e)
81
82addModemap0(op,mc,sig,pred,fn,e) ==
83  --mc is the "mode of computation"; fn the "implementation"
84  op = 'elt or op = "setelt!" => addEltModemap(op, mc, sig, pred, fn, e)
85  addModemap1(op,mc,sig,pred,fn,e)
86
87addEltModemap(op,mc,sig,pred,fn,e) ==
88   --hack to change selectors from strings to identifiers; and to
89   --add flag identifiers as literals in the envir
90  op='elt and sig is [:lt,sel] =>
91    STRINGP sel =>
92      id:= INTERN sel
93      e := makeLiteral(id, e)
94      addModemap1(op,mc,[:lt,id],pred,fn,e)
95    -- atom sel => systemErrorHere '"addEltModemap"
96    addModemap1(op,mc,sig,pred,fn,e)
97  op = "setelt!" and sig is [:lt, sel, v] =>
98    STRINGP sel =>
99      id:= INTERN sel
100      e := makeLiteral(id, e)
101      addModemap1(op,mc,[:lt,id,v],pred,fn,e)
102    -- atom sel => systemError '"addEltModemap"
103    addModemap1(op,mc,sig,pred,fn,e)
104  systemErrorHere '"addEltModemap"
105
106addModemap1(op,mc,sig,pred,fn,e) ==
107   --mc is the "mode of computation"; fn the "implementation"
108  if mc='Rep then
109--     if fn is [kind,'Rep,.] and
110               -- save old sig for NRUNTIME
111--       (kind = 'ELT or kind = 'CONST) then fn:=[kind,'Rep,sig]
112     sig:= substitute("$",'Rep,sig)
113  currentProplist:= getProplist(op,e) or nil
114  newModemapList:=
115    mkNewModemapList(mc,sig,pred,fn,LASSOC('modemap,currentProplist),e,nil)
116  newProplist:= augProplist(currentProplist,'modemap,newModemapList)
117  unErrorRef op
118        --There may have been a warning about op having no value
119  addBinding(op, newProplist, e)
120
121mkNewModemapList(mc,sig,pred,fn,curModemapList,e,filenameOrNil) ==
122  entry:= [map:= [mc,:sig],[pred,fn],:filenameOrNil]
123  member(entry,curModemapList) => curModemapList
124  (oldMap:= assoc(map,curModemapList)) and oldMap is [.,[opred, =fn],:.] =>
125    $forceAdd => mergeModemap(entry,curModemapList,e)
126    opred=true => curModemapList
127    if pred~=true and pred~=opred then pred:= ["OR",pred,opred]
128    [if x=oldMap then [map,[pred,fn],:filenameOrNil] else x
129
130  --if new modemap less general, put at end; otherwise, at front
131      for x in curModemapList]
132  mergeModemap(entry,curModemapList,e)
133
134mergeModemap(entry is [[mc,:sig],[pred,:.],:.],modemapList,e) ==
135  for (mmtail:= [[[mc',:sig'],[pred',:.],:.],:.]) in tails modemapList repeat
136    mc=mc' or isSuperDomain(mc',mc,e) =>
137      newmm:= nil
138      mm:= modemapList
139      while (not EQ(mm,mmtail)) repeat (newmm:= [first mm,:newmm]; mm:= rest mm)
140      if (mc=mc') and (sig=sig') then
141        --We only need one of these, unless the conditions are hairy
142        not $forceAdd and TruthP pred' =>
143          entry:=nil
144              --the new predicate buys us nothing
145          return modemapList
146        TruthP pred => mmtail:=rest mmtail
147          --the thing we matched against is useless, by comparison
148      modemapList:= NCONC(NREVERSE newmm,[entry,:mmtail])
149      entry:= nil
150      return modemapList
151  if entry then [:modemapList,entry] else modemapList
152
153isSuperDomain(domainForm,domainForm',e) ==
154  isSubset(domainForm',domainForm,e) => true
155  domainForm='Rep and domainForm'="$" => true --regard $ as a subdomain of Rep
156  LASSOC(opOf domainForm',get(domainForm,"SubDomain",e))
157
158addNewDomain(domain,e) ==
159  augModemapsFromDomain(domain,domain,e)
160
161augModemapsFromDomain(name,functorForm,e) ==
162  member(IFCAR name or name, $DummyFunctorNames) => e
163  name = $Category or isCategoryForm(name) => e
164  member(name, getDomainsInScope e) => e
165  if u:= GETDATABASE(opOf functorForm,'SUPERDOMAIN) then
166    e:= addNewDomain(first u,e)
167    --need code to handle parameterized SuperDomains
168  if innerDom:= listOrVectorElementMode name then e:= addDomain(innerDom,e)
169  if name is ["Union",:dl] then for d in stripUnionTags dl
170                         repeat e:= addDomain(d,e)
171  augModemapsFromDomain1(name,functorForm,e)
172     --see LISPLIB BOOT
173
174substituteCategoryArguments(argl,catform) ==
175  argl:= substitute("$$","$",argl)
176  arglAssoc := [[INTERNL1("#", STRINGIMAGE i), :a] for i in 1.. for a in argl]
177  SUBLIS(arglAssoc,catform)
178
179augModemapsFromCategory(domainName,domainView,functorForm,categoryForm,e) ==
180  [fnAlist,e]:= evalAndSub(domainName,domainView,functorForm,categoryForm,e)
181  compilerMessage ["Adding ",domainName," modemaps"]
182  e:= putDomainsInScope(domainName,e)
183  condlist:=[]
184  for [[op,sig,:.],cond,fnsel] in fnAlist repeat
185      e:= addModemapKnown(op,domainName,sig,cond,fnsel,e)
186  e
187
188evalAndSub(domainName, viewName, functorForm, form, e) ==
189  $tmp_e : local := e
190  --next lines necessary-- see MPOLY for which $ is actual arg. --- RDJ 3/83
191  if CONTAINED("$$",form) then
192      e := put("$$", "mode", get("$", "mode", e), e)
193  $tmp_e : local := e
194  opAlist:= getOperationAlist(domainName,functorForm,form)
195  substAlist:= substNames(domainName,viewName,functorForm,opAlist)
196  [substAlist, $tmp_e]
197
198getOperationAlist(name,functorForm,form) ==
199  if atom name and GETDATABASE(name,'NILADIC) then functorForm:= [functorForm]
200  (u:= isFunctor functorForm) and not
201    ($insideFunctorIfTrue and first functorForm=first $functorForm) => u
202  $insideFunctorIfTrue and name="$" =>
203    ($domainShell => $domainShell.(1); systemError '"$ has no shell now")
204  T := compMakeCategoryObject(form, $tmp_e) =>
205      ([., ., $tmp_e] := T; T.expr.(1))
206  stackMessage ["not a category form: ",form]
207
208substNames(domainName,viewName,functorForm,opalist) ==
209  functorForm := SUBSTQ("$$","$", functorForm)
210  nameForDollar :=
211    isCategoryPackageName functorForm => CADR functorForm
212    domainName
213
214       -- following calls to SUBSTQ must copy to save RPLAC's in
215       -- putInLocalDomainReferences
216  [[:SUBSTQ("$","$$",SUBSTQ(nameForDollar,"$",modemapform)),
217       [sel, viewName,if domainName = "$" then pos else
218                                         CADAR modemapform]]
219     for [:modemapform,[sel,"$",pos]] in
220          EQSUBSTLIST(IFCDR functorForm, $FormalMapVariableList, opalist)]
221
222
223compCat(form is [functorName,:argl],m,e) ==
224  fn := get_oplist_maker(functorName) or return nil
225  [funList,e]:= FUNCALL(fn,form,form,e)
226  catForm:=
227    ["Join",'(SetCategory),["CATEGORY","domain",:
228      [["SIGNATURE",op,sig] for [op,sig,.] in funList | op~="="]]]
229  --RDJ: for coercion purposes, it necessary to know it's a Set; I'm not
230  --sure if it uses any of the other signatures(see extendsCategoryForm)
231  [form,catForm,e]
232
233addModemap(op, mc, sig, pred, fn, e) ==
234    $InteractiveMode => e
235    if known_info_in_env(pred, e) then pred := true
236    $insideCapsuleFunctionIfTrue = true =>
237        $CapsuleModemapFrame :=
238          addModemap0(op, mc, sig, pred, fn, $CapsuleModemapFrame)
239        e
240    addModemap0(op, mc, sig, pred, fn, e)
241
242add_builtin_modemaps(name,form is [functorName,:.],e) ==
243  $InteractiveMode => BREAK()
244  e:= putDomainsInScope(name,e) --frame
245  fn := get_oplist_maker(functorName)
246  [funList,e]:= FUNCALL(fn,name,form,e)
247  for [op,sig,opcode] in funList repeat
248    if opcode is [sel,dc,n] and sel='ELT then
249          nsig := substitute("$$$",name,sig)
250          nsig := substitute('$,"$$$",substitute("$$",'$,nsig))
251          opcode := [sel,dc,nsig]
252    e:= addModemap(op,name,sig,true,opcode,e)
253  e
254
255
256--The way XLAMs work:
257--  ((XLAM ($1 $2 $3) (SETELT $1 0 $3)) X "c" V) ==> (SETELT X 0 V)
258
259getDomainsInScope e ==
260  $insideCapsuleFunctionIfTrue=true => $CapsuleDomainsInScope
261  get("$DomainsInScope","special",e)
262
263putDomainsInScope(x,e) ==
264  l:= getDomainsInScope e
265  if member(x,l) then SAY("****** Domain: ",x," already in scope")
266  newValue:= [x,:delete(x,l)]
267  $insideCapsuleFunctionIfTrue => ($CapsuleDomainsInScope:= newValue; e)
268  put("$DomainsInScope","special",newValue,e)
269