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