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