| 1 | -- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. |
|---|
| 2 | -- All rights reserved. |
|---|
| 3 | -- Copyright (C) 2007-2011, 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 | |
|---|
| 34 | import nruncomp |
|---|
| 35 | import g_-error |
|---|
| 36 | import database |
|---|
| 37 | import modemap |
|---|
| 38 | |
|---|
| 39 | namespace BOOT |
|---|
| 40 | |
|---|
| 41 | module 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 | |
|---|
| 49 | |
|---|
| 50 | --% |
|---|
| 51 | |
|---|
| 52 | $newCompCompare := false |
|---|
| 53 | |
|---|
| 54 | ++ List of mutable domains. |
|---|
| 55 | $mutableDomains := nil |
|---|
| 56 | |
|---|
| 57 | ++ True if the current constructor being compiled instantiates |
|---|
| 58 | ++ mutable domains or packages. Default is `false'. |
|---|
| 59 | $mutableDomain := false |
|---|
| 60 | |
|---|
| 61 | ++ when non nil, holds the declaration number of a function in a capsule. |
|---|
| 62 | $suffix := nil |
|---|
| 63 | |
|---|
| 64 | $doNotCompileJustPrint := false |
|---|
| 65 | |
|---|
| 66 | ++ stack of pending capsule function definitions. |
|---|
| 67 | $capsuleFunctionStack := [] |
|---|
| 68 | |
|---|
| 69 | $functionStats := nil |
|---|
| 70 | $functorStats := nil |
|---|
| 71 | |
|---|
| 72 | $lisplibCategory := nil |
|---|
| 73 | $lisplibAncestors := nil |
|---|
| 74 | $lisplibAbbreviation := nil |
|---|
| 75 | $CheckVectorList := [] |
|---|
| 76 | $pairlis := [] |
|---|
| 77 | $functorTarget := nil |
|---|
| 78 | $condAlist := [] |
|---|
| 79 | $uncondAlist := [] |
|---|
| 80 | $NRTslot1PredicateList := [] |
|---|
| 81 | $NRTattributeAlist := [] |
|---|
| 82 | $NRTslot1Info := nil |
|---|
| 83 | $NRTdeltaListComp := [] |
|---|
| 84 | $template := nil |
|---|
| 85 | $signature := nil |
|---|
| 86 | $isOpPackageName := false |
|---|
| 87 | $lookupFunction := nil |
|---|
| 88 | $byteAddress := nil |
|---|
| 89 | $byteVec := nil |
|---|
| 90 | $lisplibSlot1 := nil |
|---|
| 91 | $sigAlist := [] |
|---|
| 92 | $predAlist := [] |
|---|
| 93 | $argumentConditionList := [] |
|---|
| 94 | $finalEnv := nil |
|---|
| 95 | $initCapsuleErrorCount := nil |
|---|
| 96 | $CapsuleModemapFrame := nil |
|---|
| 97 | $CapsuleDomainsInScope := nil |
|---|
| 98 | $signatureOfForm := nil |
|---|
| 99 | $addFormLhs := nil |
|---|
| 100 | $lisplibSuperDomain := nil |
|---|
| 101 | $sigList := [] |
|---|
| 102 | $atList := [] |
|---|
| 103 | |
|---|
| 104 | ++ List of declarations appearing as side conditions of a where-expression. |
|---|
| 105 | $whereDecls := nil |
|---|
| 106 | |
|---|
| 107 | ++ True if the current functor definition refines a domain. |
|---|
| 108 | $subdomain := false |
|---|
| 109 | |
|---|
| 110 | --% |
|---|
| 111 | |
|---|
| 112 | compDefineAddSignature: (%Form,%Sig,%Env) -> %Env |
|---|
| 113 | |
|---|
| 114 | |
|---|
| 115 | --% |
|---|
| 116 | |
|---|
| 117 | --======================================================================= |
|---|
| 118 | -- Generate Code to Create Infovec |
|---|
| 119 | --======================================================================= |
|---|
| 120 | getInfovecCode() == |
|---|
| 121 | --Function called by compDefineFunctor1 to create infovec at compile time |
|---|
| 122 | ['LIST, |
|---|
| 123 | MKQ makeDomainTemplate $template, |
|---|
| 124 | MKQ makeCompactDirect $NRTslot1Info, |
|---|
| 125 | MKQ NRTgenFinalAttributeAlist(), |
|---|
| 126 | NRTmakeCategoryAlist(), |
|---|
| 127 | MKQ $lookupFunction] |
|---|
| 128 | |
|---|
| 129 | --======================================================================= |
|---|
| 130 | -- Generation of Domain Vector Template (Compile Time) |
|---|
| 131 | --======================================================================= |
|---|
| 132 | makeDomainTemplate vec == |
|---|
| 133 | --NOTES: This function is called at compile time to create the template |
|---|
| 134 | -- (slot 0 of the infovec); called by getInfovecCode from compDefineFunctor1 |
|---|
| 135 | newVec := newShell # vec |
|---|
| 136 | for index in 0..maxIndex vec repeat |
|---|
| 137 | item := vectorRef(vec,index) |
|---|
| 138 | null item => nil |
|---|
| 139 | vectorRef(newVec,index) := |
|---|
| 140 | item isnt [.,:.] => item |
|---|
| 141 | cons? first item => makeGoGetSlot(item,index) |
|---|
| 142 | item |
|---|
| 143 | $byteVec := "append"/reverse! $byteVec |
|---|
| 144 | newVec |
|---|
| 145 | |
|---|
| 146 | makeGoGetSlot(item,index) == |
|---|
| 147 | --NOTES: creates byte vec strings for LATCH slots |
|---|
| 148 | --these parts of the $byteVec are created first; see also makeCompactDirect |
|---|
| 149 | [sig,whereToGo,op,:flag] := item |
|---|
| 150 | n := #sig - 1 |
|---|
| 151 | newcode := [n,whereToGo,:makeCompactSigCode sig,index] |
|---|
| 152 | $byteVec := [newcode,:$byteVec] |
|---|
| 153 | curAddress := $byteAddress |
|---|
| 154 | $byteAddress := $byteAddress + n + 4 |
|---|
| 155 | [curAddress,:op] |
|---|
| 156 | |
|---|
| 157 | --======================================================================= |
|---|
| 158 | -- Generate OpTable at Compile Time |
|---|
| 159 | --======================================================================= |
|---|
| 160 | --> called by getInfovecCode (see top of this file) from compDefineFunctor1 |
|---|
| 161 | makeCompactDirect u == |
|---|
| 162 | $predListLength :local := # $NRTslot1PredicateList |
|---|
| 163 | $byteVecAcc: local := nil |
|---|
| 164 | [nam,[addForm,:opList]] := u |
|---|
| 165 | --pp opList |
|---|
| 166 | d := [[op,y] for [op,:items] in opList | y := makeCompactDirect1(op,items)] |
|---|
| 167 | $byteVec := [:$byteVec,:"append"/reverse! $byteVecAcc] |
|---|
| 168 | LIST2VEC ("append"/d) |
|---|
| 169 | |
|---|
| 170 | makeCompactDirect1(op,items) == |
|---|
| 171 | --NOTES: creates byte codes for ops implemented by the domain |
|---|
| 172 | curAddress := $byteAddress |
|---|
| 173 | $op: local := op --temp hack by RDJ 8/90 (see orderBySubsumption) |
|---|
| 174 | newcodes := |
|---|
| 175 | "append"/[u for y in orderBySubsumption items | u := fn y] or return nil |
|---|
| 176 | $byteVecAcc := [newcodes,:$byteVecAcc] |
|---|
| 177 | curAddress |
|---|
| 178 | where fn y == |
|---|
| 179 | [sig,:r] := y |
|---|
| 180 | r = ['Subsumed] => |
|---|
| 181 | n := #sig - 1 |
|---|
| 182 | $byteAddress := $byteAddress + n + 4 |
|---|
| 183 | [n,0,:makeCompactSigCode sig,0] --always followed by subsuming signature |
|---|
| 184 | --identified by a 0 in slot position |
|---|
| 185 | if r is [n,:s] then |
|---|
| 186 | slot := |
|---|
| 187 | n is [p,:.] => p --the rest is linenumber of function definition |
|---|
| 188 | n |
|---|
| 189 | predCode := |
|---|
| 190 | s is [pred,:.] => predicateBitIndex pred |
|---|
| 191 | 0 |
|---|
| 192 | --> drop items which are not present (predCode = -1) |
|---|
| 193 | predCode = -1 => return nil |
|---|
| 194 | --> drop items with nil slots if lookup function is incomplete |
|---|
| 195 | if null slot then |
|---|
| 196 | $lookupFunction is 'lookupIncomplete => return nil |
|---|
| 197 | slot := 1 --signals that operation is not present |
|---|
| 198 | n := #sig - 1 |
|---|
| 199 | $byteAddress := $byteAddress + n + 4 |
|---|
| 200 | res := [n,predCode,:makeCompactSigCode sig,slot] |
|---|
| 201 | res |
|---|
| 202 | |
|---|
| 203 | orderBySubsumption items == |
|---|
| 204 | acc := subacc := nil |
|---|
| 205 | for x in items repeat |
|---|
| 206 | not ($op in '(Zero One)) and x is [.,.,.,'Subsumed] => |
|---|
| 207 | subacc := [x,:subacc] |
|---|
| 208 | acc := [x,:acc] |
|---|
| 209 | y := z := nil |
|---|
| 210 | for [a,b,:.] in subacc | b repeat |
|---|
| 211 | --NOTE: b = nil means that the signature a will appear in acc, that this |
|---|
| 212 | -- entry is be ignored (e.g. init: -> $ in ULS) |
|---|
| 213 | while (u := assoc(b,subacc)) repeat b := second u |
|---|
| 214 | u := assoc(b,acc) or systemError nil |
|---|
| 215 | if null second u then u := [first u,1] --mark as missing operation |
|---|
| 216 | y := [[a,'Subsumed],u,:y] --makes subsuming signature follow one subsumed |
|---|
| 217 | z := insert(b,z) --mark a signature as already present |
|---|
| 218 | [:y,:[w for (w := [c,:.]) in acc | not listMember?(c,z)]] --add those not subsuming |
|---|
| 219 | |
|---|
| 220 | makeCompactSigCode sig == [fn for x in sig] where |
|---|
| 221 | fn() == |
|---|
| 222 | x is "$$" => 2 |
|---|
| 223 | x is "$" => 0 |
|---|
| 224 | not integer? x => |
|---|
| 225 | systemError ['"code vector slot is ",x,'"; must be number"] |
|---|
| 226 | x |
|---|
| 227 | |
|---|
| 228 | --======================================================================= |
|---|
| 229 | -- Generate Slot 4 Constructor Vectors |
|---|
| 230 | --======================================================================= |
|---|
| 231 | NRTmakeCategoryAlist() == |
|---|
| 232 | $depthAssocCache: local := hashTable 'EQ |
|---|
| 233 | $catAncestorAlist: local := nil |
|---|
| 234 | pcAlist := [:[[x,:"T"] for x in $uncondAlist],:$condAlist] |
|---|
| 235 | $levelAlist: local := depthAssocList [CAAR x for x in pcAlist] |
|---|
| 236 | opcAlist := reverse! SORTBY(function NRTcatCompare,pcAlist) |
|---|
| 237 | newPairlis := [[5 + i,:b] for [.,:b] in $pairlis for i in 1..] |
|---|
| 238 | slot1 := [[a,:k] for [a,:b] in applySubst($pairlis,opcAlist) |
|---|
| 239 | | (k := predicateBitIndex b) ~= -1] |
|---|
| 240 | slot0 := [hasDefaultPackage opOf a for [a,:b] in slot1] |
|---|
| 241 | sixEtc := [5 + i for i in 1..#$pairlis] |
|---|
| 242 | formals := ASSOCRIGHT $pairlis |
|---|
| 243 | for x in slot1 repeat |
|---|
| 244 | x.first := applySubst(pairList(['$,:formals],["$$",:sixEtc]),first x) |
|---|
| 245 | -----------code to make a new style slot4 ----------------- |
|---|
| 246 | predList := ASSOCRIGHT slot1 --is list of predicate indices |
|---|
| 247 | maxPredList := "MAX"/predList |
|---|
| 248 | catformvec := ASSOCLEFT slot1 |
|---|
| 249 | maxElement := "MAX"/$byteVec |
|---|
| 250 | ['CONS, ['makeByteWordVec2,MAX(maxPredList,1),MKQ predList], |
|---|
| 251 | ['CONS, MKQ LIST2VEC slot0, |
|---|
| 252 | ['CONS, MKQ LIST2VEC [encodeCatform x for x in catformvec], |
|---|
| 253 | ['makeByteWordVec2,maxElement,MKQ $byteVec]]]] |
|---|
| 254 | --NOTE: this is new form: old form satisfies vector? CDDR form |
|---|
| 255 | |
|---|
| 256 | encodeCatform x == |
|---|
| 257 | k := NRTassocIndex x => k |
|---|
| 258 | x isnt [.,:.] or rest x isnt [.,:.] => x |
|---|
| 259 | [first x,:[encodeCatform y for y in rest x]] |
|---|
| 260 | |
|---|
| 261 | NRTcatCompare [catform,:pred] == LASSOC(first catform,$levelAlist) |
|---|
| 262 | |
|---|
| 263 | hasDefaultPackage catname == |
|---|
| 264 | defname := makeDefaultPackageName symbolName catname |
|---|
| 265 | constructor? defname => defname |
|---|
| 266 | nil |
|---|
| 267 | |
|---|
| 268 | |
|---|
| 269 | --======================================================================= |
|---|
| 270 | -- Compute the lookup function (complete or incomplete) |
|---|
| 271 | --======================================================================= |
|---|
| 272 | NRTgetLookupFunction(domform,exCategory,addForm,env) == |
|---|
| 273 | domform := applySubst($pairlis,domform) |
|---|
| 274 | addForm := applySubst($pairlis,addForm) |
|---|
| 275 | $why: local := nil |
|---|
| 276 | addForm isnt [.,:.] => 'lookupComplete |
|---|
| 277 | NRTextendsCategory1(domform,exCategory,getExportCategory addForm,env) => |
|---|
| 278 | 'lookupIncomplete |
|---|
| 279 | [u,msg,:v] := $why |
|---|
| 280 | SAY '"--------------non extending category----------------------" |
|---|
| 281 | sayPatternMsg('"%1p of category %2p", [domform,u]) |
|---|
| 282 | if v ~= nil then |
|---|
| 283 | sayPatternMsg('"%1b %2p",[msg,first v]) |
|---|
| 284 | else |
|---|
| 285 | sayPatternMsg('"%1b",[msg]) |
|---|
| 286 | SAY '"----------------------------------------------------------" |
|---|
| 287 | 'lookupComplete |
|---|
| 288 | |
|---|
| 289 | getExportCategory form == |
|---|
| 290 | [op,:argl] := form |
|---|
| 291 | op is 'Record => ['RecordCategory,:argl] |
|---|
| 292 | op is 'Union => ['UnionCategory,:argl] |
|---|
| 293 | op is 'Enumeration => ['EnumerationCategory,:argl] |
|---|
| 294 | op is 'Mapping => ['MappingCategory,:argl] |
|---|
| 295 | [[.,target,:tl],:.] := getConstructorModemapFromDB op |
|---|
| 296 | applySubst(pairList($FormalMapVariableList,argl),target) |
|---|
| 297 | |
|---|
| 298 | NRTextendsCategory1(domform,exCategory,addForm,env) == |
|---|
| 299 | addForm is ["%Comma",:r] => |
|---|
| 300 | and/[extendsCategory(domform,exCategory,x,env) for x in r] |
|---|
| 301 | extendsCategory(domform,exCategory,addForm,env) |
|---|
| 302 | |
|---|
| 303 | --======================================================================= |
|---|
| 304 | -- Compute if a domain constructor is forgetful functor |
|---|
| 305 | --======================================================================= |
|---|
| 306 | extendsCategory(dom,u,v,env) == |
|---|
| 307 | --does category u extend category v (yes iff u contains everything in v) |
|---|
| 308 | --is dom of category u also of category v? |
|---|
| 309 | u=v => true |
|---|
| 310 | v is ["Join",:l] => and/[extendsCategory(dom,u,x,env) for x in l] |
|---|
| 311 | v is ["CATEGORY",.,:l] => and/[extendsCategory(dom,u,x,env) for x in l] |
|---|
| 312 | v is ["SubsetCategory",cat,d] => |
|---|
| 313 | extendsCategory(dom,u,cat,env) and isSubset(dom,d,env) |
|---|
| 314 | v := substSlotNumbers(v,$template,$functorForm) |
|---|
| 315 | extendsCategoryBasic(dom,u,v,env) => true |
|---|
| 316 | $why := |
|---|
| 317 | v is ['SIGNATURE,op,sig] => [u,['" has no ",:formatOpSignature(op,sig)]] |
|---|
| 318 | [u,'" has no",v] |
|---|
| 319 | nil |
|---|
| 320 | |
|---|
| 321 | extendsCategoryBasic(dom,u,v,env) == |
|---|
| 322 | v is ['IF,p,['ATTRIBUTE,c],.] => |
|---|
| 323 | uVec := compMakeCategoryObject(u,env).expr |
|---|
| 324 | cons? c and isCategoryForm(c,env) => |
|---|
| 325 | LASSOC(c,second categoryHierarchy uVec) is [=p,:.] |
|---|
| 326 | LASSOC(c,categoryAttributes uVec) is [=p,:.] |
|---|
| 327 | u is ["Join",:l] => or/[extendsCategoryBasic(dom,x,v,env) for x in l] |
|---|
| 328 | u = v => true |
|---|
| 329 | isCategoryForm(v,env) => catExtendsCat?(u,v,env) |
|---|
| 330 | v is ['SIGNATURE,op,sig] => |
|---|
| 331 | uVec := compMakeCategoryObject(u,env).expr |
|---|
| 332 | or/[categoryRef(uVec,i) is [[=op,=sig],:.] for i in 6..maxIndex uVec] |
|---|
| 333 | u is ['CATEGORY,.,:l] => |
|---|
| 334 | v is ['IF,:.] => listMember?(v,l) |
|---|
| 335 | false |
|---|
| 336 | false |
|---|
| 337 | |
|---|
| 338 | catExtendsCat?(u,v,env) == |
|---|
| 339 | u = v => true |
|---|
| 340 | uvec := compMakeCategoryObject(u,env).expr |
|---|
| 341 | slot4 := categoryHierarchy uvec |
|---|
| 342 | prinAncestorList := first slot4 |
|---|
| 343 | listMember?(v,prinAncestorList) => true |
|---|
| 344 | vOp := KAR v |
|---|
| 345 | if similarForm := assoc(vOp,prinAncestorList) then |
|---|
| 346 | PRINT u |
|---|
| 347 | sayBrightlyNT '" extends " |
|---|
| 348 | PRINT similarForm |
|---|
| 349 | sayBrightlyNT '" but not " |
|---|
| 350 | PRINT v |
|---|
| 351 | or/[catExtendsCat?(x,v,env) for x in ASSOCLEFT second slot4] |
|---|
| 352 | |
|---|
| 353 | substSlotNumbers(form,template,domain) == |
|---|
| 354 | form is [op,:.] and |
|---|
| 355 | symbolMember?(op,allConstructors()) => expandType(form,template,domain) |
|---|
| 356 | form is ['SIGNATURE,op,sig] => |
|---|
| 357 | ['SIGNATURE,op,[substSlotNumbers(x,template,domain) for x in sig]] |
|---|
| 358 | form is ['CATEGORY,k,:u] => |
|---|
| 359 | ['CATEGORY,k,:[substSlotNumbers(x,template,domain) for x in u]] |
|---|
| 360 | expandType(form,template,domain) |
|---|
| 361 | |
|---|
| 362 | expandType(lazyt,template,domform) == |
|---|
| 363 | lazyt isnt [.,:.] => expandTypeArgs(lazyt,template,domform) |
|---|
| 364 | [functorName,:argl] := lazyt |
|---|
| 365 | functorName is ":" => |
|---|
| 366 | [functorName,first argl,expandTypeArgs(second argl,template,domform)] |
|---|
| 367 | lazyt is ['local,x] => |
|---|
| 368 | n := POSN1(x,$FormalMapVariableList) |
|---|
| 369 | domform.(1 + n) |
|---|
| 370 | [functorName,:[expandTypeArgs(a,template,domform) for a in argl]] |
|---|
| 371 | |
|---|
| 372 | expandTypeArgs(u,template,domform) == |
|---|
| 373 | u is '$ => u |
|---|
| 374 | integer? u => expandType(vectorRef(template,u),template,domform) |
|---|
| 375 | u is [.,y] and u.op in '(NRTEVAL QUOTE) => y |
|---|
| 376 | u isnt [.,:.] => u |
|---|
| 377 | expandType(u,template,domform) |
|---|
| 378 | |
|---|
| 379 | --% Subdomains |
|---|
| 380 | |
|---|
| 381 | ++ We are defining a functor with head given by `form', as a subdomain |
|---|
| 382 | ++ of the domain designated by the domain form `super', and predicate |
|---|
| 383 | ++ `pred' (a VM instruction form). Emit appropriate info into the |
|---|
| 384 | ++ databases. |
|---|
| 385 | emitSubdomainInfo(form,super,pred) == |
|---|
| 386 | pred := applySubst!(pairList(form.args,$AtVariables),pred) |
|---|
| 387 | super := applySubst!(pairList(form.args,$AtVariables),super) |
|---|
| 388 | evalAndRwriteLispForm("evalOnLoad2",["noteSubDomainInfo", |
|---|
| 389 | quoteForm form.op,quoteForm super, quoteForm pred]) |
|---|
| 390 | |
|---|
| 391 | |
|---|
| 392 | ++ List of operations defined in a given capsule |
|---|
| 393 | ++ Each item on this list is of the form |
|---|
| 394 | ++ (op sig pred) |
|---|
| 395 | ++ where |
|---|
| 396 | ++ op: name of the operation |
|---|
| 397 | ++ sig: signature of the operation |
|---|
| 398 | ++ pred: scope predicate of the operation. |
|---|
| 399 | $capsuleFunctions := nil |
|---|
| 400 | |
|---|
| 401 | ++ record that the operation `op' with signature `sig' and predicate |
|---|
| 402 | ++ `pred' is defined in the current capsule of the current domain |
|---|
| 403 | ++ being compiled. |
|---|
| 404 | noteCapsuleFunctionDefinition(op,sig,pred) == |
|---|
| 405 | listMember?([op,sig,pred],$capsuleFunctions) => |
|---|
| 406 | stackAndThrow('"redefinition of %1b: %2 %3", |
|---|
| 407 | [op,formatUnabbreviated ["Mapping",:sig],formatIf pred]) |
|---|
| 408 | $capsuleFunctions := [[op,sig,pred],:$capsuleFunctions] |
|---|
| 409 | |
|---|
| 410 | ++ Clear the list of functions defined in the last domain capsule. |
|---|
| 411 | clearCapsuleFunctionTable() == |
|---|
| 412 | $capsuleFunctions := nil |
|---|
| 413 | |
|---|
| 414 | |
|---|
| 415 | ++ List of exports (paireed with scope predicate) declared in |
|---|
| 416 | ++ the category of the currend domain or package. |
|---|
| 417 | ++ Note: for category packages, this list is nil. |
|---|
| 418 | $exports := nil |
|---|
| 419 | |
|---|
| 420 | noteExport(form,pred) == |
|---|
| 421 | -- don't recheck category package exports; we just check |
|---|
| 422 | -- them when defining the category. Plus, we might actually |
|---|
| 423 | -- get indirect duplicates, which is OK. |
|---|
| 424 | $insideCategoryPackageIfTrue => nil |
|---|
| 425 | listMember?([form,pred],$exports) => |
|---|
| 426 | stackAndThrow('"redeclaration of %1 %2", |
|---|
| 427 | [form,formatIf pred]) |
|---|
| 428 | $exports := [[form,pred],:$exports] |
|---|
| 429 | |
|---|
| 430 | clearExportsTable() == |
|---|
| 431 | $exports := nil |
|---|
| 432 | |
|---|
| 433 | makePredicate l == |
|---|
| 434 | null l => true |
|---|
| 435 | MKPF(l,"and") |
|---|
| 436 | |
|---|
| 437 | --% FUNCTIONS WHICH MUNCH ON == STATEMENTS |
|---|
| 438 | |
|---|
| 439 | ++ List of reserved identifiers for which the compiler has special |
|---|
| 440 | ++ meanings and that shall not be redefined. |
|---|
| 441 | $reservedNames == '(per rep _$) |
|---|
| 442 | |
|---|
| 443 | ++ Check that `var' (a variable of parameter name) is not a reversed name. |
|---|
| 444 | checkVariableName var == |
|---|
| 445 | symbolMember?(var,$reservedNames) => |
|---|
| 446 | stackAndThrow('"You cannot use reserved name %1b as variable",[var]) |
|---|
| 447 | var |
|---|
| 448 | |
|---|
| 449 | checkParameterNames parms == |
|---|
| 450 | for p in parms repeat |
|---|
| 451 | checkVariableName p |
|---|
| 452 | |
|---|
| 453 | compDefine(form,m,e) == |
|---|
| 454 | $macroIfTrue: local := false |
|---|
| 455 | compDefine1(form,m,e) |
|---|
| 456 | |
|---|
| 457 | ++ We are about to process the body of a capsule. Check the form of |
|---|
| 458 | ++ `Rep' definition, and whether it is appropriate to activate the |
|---|
| 459 | ++ implicitly generated morphisms |
|---|
| 460 | ++ per: Rep -> % |
|---|
| 461 | ++ rep: % -> Rep |
|---|
| 462 | ++ as local inline functions. |
|---|
| 463 | checkRepresentation: (%Form,%List %Form,%Env) -> %Env |
|---|
| 464 | checkRepresentation(addForm,body,env) == |
|---|
| 465 | domainRep := nil |
|---|
| 466 | hasAssignRep := false -- assume code does not assign to Rep. |
|---|
| 467 | viewFuns := nil |
|---|
| 468 | |
|---|
| 469 | null body => env -- Don't be too hard on nothing. |
|---|
| 470 | |
|---|
| 471 | -- Locate possible Rep definition |
|---|
| 472 | for [stmt,:.] in tails body repeat |
|---|
| 473 | stmt is ["%LET","Rep",val] => |
|---|
| 474 | domainRep ~= nil => |
|---|
| 475 | stackAndThrow('"You cannot assign to constant domain %1b",["Rep"]) |
|---|
| 476 | if addForm = val then |
|---|
| 477 | stackWarning('"OpenAxiom suggests removing assignment to %1b",["Rep"]) |
|---|
| 478 | else if addForm ~= nil then |
|---|
| 479 | stackWarning('"%1b differs from the base domain",["Rep"]) |
|---|
| 480 | return hasAssignRep := true |
|---|
| 481 | stmt is ["MDEF",["Rep",:.],:.] => |
|---|
| 482 | stackWarning('"Consider using == definition for %1b",["Rep"]) |
|---|
| 483 | return hasAssignRep := true |
|---|
| 484 | stmt is ["IF",.,:l] or stmt is ["SEQ",:l] or stmt is ["exit",:l] => |
|---|
| 485 | checkRepresentation(nil,l,env) |
|---|
| 486 | stmt isnt ["DEF",[op,:args],sig,.,val] => nil -- skip for now. |
|---|
| 487 | op in '(rep per) => |
|---|
| 488 | domainRep ~= nil => |
|---|
| 489 | stackAndThrow('"You cannot define implicitly generated %1b",[op]) |
|---|
| 490 | viewFuns := [op,:viewFuns] |
|---|
| 491 | op ~= "Rep" => nil -- we are only interested in Rep definition |
|---|
| 492 | domainRep := val |
|---|
| 493 | viewFuns ~= nil => |
|---|
| 494 | stackAndThrow('"You cannot define both %1b and %2b",["Rep",:viewFuns]) |
|---|
| 495 | -- A package has no "%". |
|---|
| 496 | $functorKind = "package" => |
|---|
| 497 | stackAndThrow('"You cannot define %1b in a package",["Rep"]) |
|---|
| 498 | -- It is a mistake to define Rep in category defaults |
|---|
| 499 | $insideCategoryPackageIfTrue => |
|---|
| 500 | stackAndThrow('"You cannot define %1b in category defaults",["Rep"]) |
|---|
| 501 | if args ~= nil then |
|---|
| 502 | stackAndThrow('"%1b does take arguments",["Rep"]) |
|---|
| 503 | if sig.target ~= nil then |
|---|
| 504 | stackAndThrow('"You cannot specify type for %1b",["Rep"]) |
|---|
| 505 | -- Now, trick the rest of the compiler into believing that |
|---|
| 506 | -- `Rep' was defined the Old Way, for lookup purpose. |
|---|
| 507 | stmt.op := "%LET" |
|---|
| 508 | stmt.rest := ["Rep",domainRep] |
|---|
| 509 | $useRepresentationHack := false -- Don't confuse `Rep' and `%'. |
|---|
| 510 | |
|---|
| 511 | -- Shall we perform the dirty tricks? |
|---|
| 512 | if hasAssignRep then |
|---|
| 513 | $useRepresentationHack := true |
|---|
| 514 | -- Domain extensions with no explicit Rep definition have the |
|---|
| 515 | -- the base domain as representation (at least operationally). |
|---|
| 516 | else if null domainRep and addForm ~= nil then |
|---|
| 517 | if $functorKind = "domain" and addForm isnt ["%Comma",:.] then |
|---|
| 518 | domainRep := |
|---|
| 519 | addForm is ["SubDomain",dom,.] => |
|---|
| 520 | $subdomain := true |
|---|
| 521 | dom |
|---|
| 522 | addForm |
|---|
| 523 | $useRepresentationHack := false |
|---|
| 524 | env := putMacro('Rep,domainRep,env) |
|---|
| 525 | env |
|---|
| 526 | |
|---|
| 527 | |
|---|
| 528 | compDefine1: (%Form,%Mode,%Env) -> %Maybe %Triple |
|---|
| 529 | compDefine1(form,m,e) == |
|---|
| 530 | $insideExpressionIfTrue: local:= false |
|---|
| 531 | --1. decompose after macro-expanding form |
|---|
| 532 | ['DEF,lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e) |
|---|
| 533 | $insideWhereIfTrue and isMacro(form,e) and (m=$EmptyMode or m=$NoValueMode) |
|---|
| 534 | => [lhs,m,putMacro(lhs.op,rhs,e)] |
|---|
| 535 | checkParameterNames lhs.args |
|---|
| 536 | null signature.target and symbol? KAR rhs and not builtinConstructor? KAR rhs and |
|---|
| 537 | (sig:= getSignatureFromMode(lhs,e)) => |
|---|
| 538 | -- here signature of lhs is determined by a previous declaration |
|---|
| 539 | compDefine1(['DEF,lhs,[sig.target,:signature.source],specialCases,rhs],m,e) |
|---|
| 540 | if signature.target=$Category then $insideCategoryIfTrue:= true |
|---|
| 541 | |
|---|
| 542 | -- RDJ (11/83): when argument and return types are all declared, |
|---|
| 543 | -- or arguments have types declared in the environment, |
|---|
| 544 | -- and there is no existing modemap for this signature, add |
|---|
| 545 | -- the modemap by a declaration, then strip off declarations and recurse |
|---|
| 546 | e := compDefineAddSignature(lhs,signature,e) |
|---|
| 547 | -- 2. if signature list for arguments is not empty, replace ('DEF,..) by |
|---|
| 548 | -- ('where,('DEF,..),..) with an empty signature list; |
|---|
| 549 | -- otherwise, fill in all NILs in the signature |
|---|
| 550 | or/[x ~= nil for x in signature.source] => compDefWhereClause(form,m,e) |
|---|
| 551 | signature.target=$Category => |
|---|
| 552 | compDefineCategory(form,m,e,nil,$formalArgList) |
|---|
| 553 | isDomainForm(rhs,e) and not $insideFunctorIfTrue => |
|---|
| 554 | if null signature.target then signature:= |
|---|
| 555 | [getTargetFromRhs(lhs,rhs,giveFormalParametersValues(lhs.args,e)),: |
|---|
| 556 | signature.source] |
|---|
| 557 | rhs:= addEmptyCapsuleIfNecessary(signature.target,rhs) |
|---|
| 558 | compDefineFunctor(['DEF,lhs,signature,specialCases,rhs],m,e,nil, |
|---|
| 559 | $formalArgList) |
|---|
| 560 | null $form => stackAndThrow ['"bad == form ",form] |
|---|
| 561 | newPrefix:= |
|---|
| 562 | $prefix => makeSymbol strconc(encodeItem $prefix,'",",encodeItem $op) |
|---|
| 563 | getConstructorAbbreviationFromDB $op |
|---|
| 564 | compDefineCapsuleFunction(form,m,e,newPrefix,$formalArgList) |
|---|
| 565 | |
|---|
| 566 | compDefineAddSignature([op,:argl],signature,e) == |
|---|
| 567 | (sig:= hasFullSignature(argl,signature,e)) and |
|---|
| 568 | null assoc(['$,:sig],symbolLassoc('modemap,getProplist(op,e))) => |
|---|
| 569 | declForm:= |
|---|
| 570 | [":",[op,:[[":",x,m] for x in argl for m in sig.source]],signature.target] |
|---|
| 571 | [.,.,e]:= comp(declForm,$EmptyMode,e) |
|---|
| 572 | e |
|---|
| 573 | e |
|---|
| 574 | |
|---|
| 575 | hasFullSignature(argl,[target,:ml],e) == |
|---|
| 576 | target => |
|---|
| 577 | u := [m or get(x,"mode",e) or return 'failed for x in argl for m in ml] |
|---|
| 578 | u is 'failed => nil |
|---|
| 579 | [target,:u] |
|---|
| 580 | nil |
|---|
| 581 | |
|---|
| 582 | addEmptyCapsuleIfNecessary: (%Form,%Form) -> %Form |
|---|
| 583 | addEmptyCapsuleIfNecessary(target,rhs) == |
|---|
| 584 | symbolMember?(KAR rhs,$SpecialDomainNames) => rhs |
|---|
| 585 | ['add,rhs,['CAPSULE]] |
|---|
| 586 | |
|---|
| 587 | getTargetFromRhs: (%Form, %Form, %Env) -> %Form |
|---|
| 588 | getTargetFromRhs(lhs,rhs,e) == |
|---|
| 589 | --undeclared target mode obtained from rhs expression |
|---|
| 590 | rhs is ['CAPSULE,:.] => |
|---|
| 591 | stackSemanticError(['"target category of ",lhs, |
|---|
| 592 | '" cannot be determined from definition"],nil) |
|---|
| 593 | rhs is ['SubDomain,D,:.] => getTargetFromRhs(lhs,D,e) |
|---|
| 594 | rhs is ['add,D,['CAPSULE,:.]] => getTargetFromRhs(lhs,D,e) |
|---|
| 595 | rhs is ['Record,:l] => ['RecordCategory,:l] |
|---|
| 596 | rhs is ['Union,:l] => ['UnionCategory,:l] |
|---|
| 597 | (compOrCroak(rhs,$EmptyMode,e)).mode |
|---|
| 598 | |
|---|
| 599 | giveFormalParametersValues(argl,e) == |
|---|
| 600 | for x in argl | ident? x repeat |
|---|
| 601 | e := giveVariableSomeValue(x,get(x,'mode,e),e) |
|---|
| 602 | e |
|---|
| 603 | |
|---|
| 604 | |
|---|
| 605 | macroExpandInPlace: (%Form,%Env) -> %Form |
|---|
| 606 | macroExpandInPlace(x,e) == |
|---|
| 607 | y:= macroExpand(x,e) |
|---|
| 608 | x isnt [.,:.] or y isnt [.,:.] => y |
|---|
| 609 | x.first := first y |
|---|
| 610 | x.rest := rest y |
|---|
| 611 | x |
|---|
| 612 | |
|---|
| 613 | macroExpand: (%Form,%Env) -> %Form |
|---|
| 614 | macroExpand(x,e) == --not worked out yet |
|---|
| 615 | x isnt [.,:.] => |
|---|
| 616 | not ident? x or (u := get(x,"macro",e)) = nil => x |
|---|
| 617 | -- Don't expand a functional macro name by itself. |
|---|
| 618 | u is ['%mlambda,:.] => x |
|---|
| 619 | macroExpand(u,e) |
|---|
| 620 | x is ['DEF,lhs,sig,spCases,rhs] => |
|---|
| 621 | ['DEF,macroExpand(lhs,e),macroExpandList(sig,e),macroExpandList(spCases,e), |
|---|
| 622 | macroExpand(rhs,e)] |
|---|
| 623 | -- macros should override niladic props |
|---|
| 624 | [op,:args] := x |
|---|
| 625 | ident? op and args = nil and niladicConstructorFromDB op and |
|---|
| 626 | (u := get(op,"macro", e)) => macroExpand(u,e) |
|---|
| 627 | ident? op and (get(op,"macro",e) is ['%mlambda,parms,body]) => |
|---|
| 628 | nargs := #args |
|---|
| 629 | nparms := #parms |
|---|
| 630 | msg := |
|---|
| 631 | nargs < nparms => '"Too few arguments" |
|---|
| 632 | nargs > nparms => '"Too many arguments" |
|---|
| 633 | nil |
|---|
| 634 | msg => (stackMessage(strconc(msg,'" to macro %1bp"),[op]); x) |
|---|
| 635 | args' := macroExpandList(args,e) |
|---|
| 636 | applySubst(pairList(parms,args'),body) |
|---|
| 637 | macroExpandList(x,e) |
|---|
| 638 | |
|---|
| 639 | macroExpandList(l,e) == |
|---|
| 640 | [macroExpand(x,e) for x in l] |
|---|
| 641 | |
|---|
| 642 | --% constructor evaluation |
|---|
| 643 | |
|---|
| 644 | mkEvalableCategoryForm c == |
|---|
| 645 | c is [op,:argl] => |
|---|
| 646 | op="Join" => ["Join",:[mkEvalableCategoryForm x for x in argl]] |
|---|
| 647 | op is "DomainSubstitutionMacro" => mkEvalableCategoryForm second argl |
|---|
| 648 | op is "mkCategory" => c |
|---|
| 649 | builtinCategoryName? op => |
|---|
| 650 | ([x,m,$e]:= compOrCroak(c,$EmptyMode,$e); m=$Category => x) |
|---|
| 651 | --loadIfNecessary op |
|---|
| 652 | getConstructorKindFromDB op = 'category or |
|---|
| 653 | get(op,"isCategory",$CategoryFrame) => |
|---|
| 654 | [op,:[MKQ x for x in argl]] |
|---|
| 655 | [x,m,$e]:= compOrCroak(c,$EmptyMode,$e) |
|---|
| 656 | m=$Category => x |
|---|
| 657 | MKQ c |
|---|
| 658 | |
|---|
| 659 | ++ Return true if we should skip compilation of category package. |
|---|
| 660 | ++ This situation happens either when there is no default, of we are in |
|---|
| 661 | ++ bootstrap mode, or we are compiling only for exports. |
|---|
| 662 | skipCategoryPackage? capsule == |
|---|
| 663 | null capsule or $bootStrapMode or $compileExportsOnly |
|---|
| 664 | |
|---|
| 665 | compDefineCategory1(df is ['DEF,form,sig,sc,body],m,e,prefix,fal) == |
|---|
| 666 | categoryCapsule := |
|---|
| 667 | body is ['add,cat,capsule] => |
|---|
| 668 | body := cat |
|---|
| 669 | capsule |
|---|
| 670 | nil |
|---|
| 671 | [d,m,e]:= compDefineCategory2(form,sig,sc,body,m,e,prefix,fal) |
|---|
| 672 | if not skipCategoryPackage? categoryCapsule then [.,.,e] := |
|---|
| 673 | $insideCategoryPackageIfTrue: local := true |
|---|
| 674 | $categoryPredicateList: local := |
|---|
| 675 | makeCategoryPredicates(form,$lisplibCategory) |
|---|
| 676 | T := compDefine1(mkCategoryPackage(form,cat,categoryCapsule),$EmptyMode,e) |
|---|
| 677 | or return stackSemanticError( |
|---|
| 678 | ['"cannot compile defaults of",:bright opOf form],nil) |
|---|
| 679 | if $compileDefaultsOnly then |
|---|
| 680 | [d,m,e] := T |
|---|
| 681 | [d,m,e] |
|---|
| 682 | |
|---|
| 683 | makeCategoryPredicates(form,u) == |
|---|
| 684 | $tvl: local := TAKE(#rest form,$TriangleVariableList) |
|---|
| 685 | $mvl: local := TAKE(#rest form,rest $FormalMapVariableList) |
|---|
| 686 | fn(u,nil) where |
|---|
| 687 | fn(u,pl) == |
|---|
| 688 | u is ['Join,:.,a] => fn(a,pl) |
|---|
| 689 | u is ["IF",p,:x] => |
|---|
| 690 | fnl(x,insert(applySubst(pairList($tvl,$mvl),p),pl)) |
|---|
| 691 | u is ["has",:.] => |
|---|
| 692 | insert(applySubst(pairList($tvl,$mvl),u),pl) |
|---|
| 693 | u is [op,:.] and op in '(SIGNATURE ATTRIBUTE) => pl |
|---|
| 694 | u isnt [.,:.] => pl |
|---|
| 695 | fnl(u,pl) |
|---|
| 696 | fnl(u,pl) == |
|---|
| 697 | for x in u repeat pl := fn(x,pl) |
|---|
| 698 | pl |
|---|
| 699 | |
|---|
| 700 | mkCategoryPackage(form is [op,:argl],cat,def) == |
|---|
| 701 | packageName:= makeDefaultPackageName symbolName op |
|---|
| 702 | packageAbb := makeSymbol(strconc(getConstructorAbbreviationFromDB op,'"-")) |
|---|
| 703 | $options:local := [] |
|---|
| 704 | -- This stops the next line from becoming confused |
|---|
| 705 | abbreviationsSpad2Cmd ['domain,packageAbb,packageName] |
|---|
| 706 | -- This is a little odd, but the parser insists on calling |
|---|
| 707 | -- domains, rather than packages |
|---|
| 708 | nameForDollar := first SETDIFFERENCE('(S A B C D E F G H I),argl) |
|---|
| 709 | packageArgl := [nameForDollar,:argl] |
|---|
| 710 | capsuleDefAlist := fn(def,nil) where fn(x,oplist) == |
|---|
| 711 | x isnt [.,:.] => oplist |
|---|
| 712 | x is ['DEF,y,:.] => [y,:oplist] |
|---|
| 713 | fn(x.args,fn(x.op,oplist)) |
|---|
| 714 | catvec := eval mkEvalableCategoryForm form |
|---|
| 715 | fullCatOpList := categoryExports JoinInner([catvec],$e) |
|---|
| 716 | catOpList := |
|---|
| 717 | [['SIGNATURE,op1,sig] for [[op1,sig],:.] in fullCatOpList |
|---|
| 718 | | assoc(op1,capsuleDefAlist)] |
|---|
| 719 | null catOpList => nil |
|---|
| 720 | packageCategory := |
|---|
| 721 | ['CATEGORY,'domain, |
|---|
| 722 | :applySubst(pairList($FormalMapVariableList,argl),catOpList)] |
|---|
| 723 | nils:= [nil for x in argl] |
|---|
| 724 | packageSig := [packageCategory,form,:nils] |
|---|
| 725 | $categoryPredicateList := substitute(nameForDollar,'$,$categoryPredicateList) |
|---|
| 726 | substitute(nameForDollar,'$, |
|---|
| 727 | ['DEF,[packageName,:packageArgl],packageSig,[nil,:nils],def]) |
|---|
| 728 | |
|---|
| 729 | compDefineCategory2(form,signature,specialCases,body,m,e, |
|---|
| 730 | $prefix,$formalArgList) == |
|---|
| 731 | --1. bind global variables |
|---|
| 732 | $insideCategoryIfTrue: local := true |
|---|
| 733 | $definition: local := form --used by DomainSubstitutionFunction |
|---|
| 734 | $form: local := nil |
|---|
| 735 | $op: local := nil |
|---|
| 736 | $extraParms: local := nil |
|---|
| 737 | -- Remember the body for checking the current instantiation. |
|---|
| 738 | $currentCategoryBody : local := body |
|---|
| 739 | --Set in DomainSubstitutionFunction, used further down |
|---|
| 740 | -- 1.1 augment e to add declaration $: <form> |
|---|
| 741 | [$op,:argl] := $definition |
|---|
| 742 | e:= addBinding("$",[['mode,:$definition]],e) |
|---|
| 743 | |
|---|
| 744 | -- 2. obtain signature |
|---|
| 745 | signature':= |
|---|
| 746 | [signature.target, |
|---|
| 747 | :[getArgumentModeOrMoan(a,$definition,e) for a in argl]] |
|---|
| 748 | e:= giveFormalParametersValues(argl,e) |
|---|
| 749 | |
|---|
| 750 | -- 3. replace arguments by $1,..., substitute into body, |
|---|
| 751 | -- and introduce declarations into environment |
|---|
| 752 | sargl:= TAKE(# argl, $TriangleVariableList) |
|---|
| 753 | $functorForm:= $form:= [$op,:sargl] |
|---|
| 754 | $formalArgList:= [:sargl,:$formalArgList] |
|---|
| 755 | aList := pairList(argl,sargl) |
|---|
| 756 | formalBody:= applySubst(aList,body) |
|---|
| 757 | signature' := applySubst(aList,signature') |
|---|
| 758 | --Begin lines for category default definitions |
|---|
| 759 | $functionStats: local:= [0,0] |
|---|
| 760 | $functorStats: local:= [0,0] |
|---|
| 761 | $getDomainCode: local := nil |
|---|
| 762 | $addForm: local:= nil |
|---|
| 763 | for x in sargl for t in signature'.source repeat |
|---|
| 764 | [.,.,e]:= compMakeDeclaration(x,t,e) |
|---|
| 765 | |
|---|
| 766 | -- 4. compile body in environment of %type declarations for arguments |
|---|
| 767 | op':= $op |
|---|
| 768 | -- following line causes cats with no with or Join to be fresh copies |
|---|
| 769 | if opOf(formalBody)~='Join and opOf(formalBody)~='mkCategory then |
|---|
| 770 | formalBody := ['Join, formalBody] |
|---|
| 771 | body:= optFunctorBody compOrCroak(formalBody,signature'.target,e).expr |
|---|
| 772 | if $extraParms then |
|---|
| 773 | formals:=actuals:=nil |
|---|
| 774 | for u in $extraParms repeat |
|---|
| 775 | formals:=[first u,:formals] |
|---|
| 776 | actuals:=[MKQ rest u,:actuals] |
|---|
| 777 | body := ['sublisV,['pairList,['QUOTE,formals],['%list,:actuals]],body] |
|---|
| 778 | if argl then body:= -- always subst for args after extraparms |
|---|
| 779 | ['sublisV,['pairList,['QUOTE,sargl],['%list,: |
|---|
| 780 | [['devaluate,u] for u in sargl]]],body] |
|---|
| 781 | body:= |
|---|
| 782 | ["%bind",[[g:= gensym(),body]], |
|---|
| 783 | ['%store,['%tref,g,0],mkConstructor $form],g] |
|---|
| 784 | fun:= compile [op',["LAM",sargl,body]] |
|---|
| 785 | |
|---|
| 786 | -- 5. give operator a 'modemap property |
|---|
| 787 | pairlis := pairList(argl,$FormalMapVariableList) |
|---|
| 788 | parSignature:= applySubst(pairlis,signature') |
|---|
| 789 | parForm:= applySubst(pairlis,form) |
|---|
| 790 | -- If we are only interested in the defaults, there is no point |
|---|
| 791 | -- in writing out compiler info and load-time stuff for |
|---|
| 792 | -- the category which is assumed to have already been translated. |
|---|
| 793 | if not $compileDefaultsOnly then |
|---|
| 794 | lisplibWrite('"compilerInfo", |
|---|
| 795 | removeZeroOne ['SETQ,'$CategoryFrame, |
|---|
| 796 | ['put,['QUOTE,op'],' |
|---|
| 797 | (QUOTE isCategory),true,['addModemap,MKQ op',MKQ parForm, |
|---|
| 798 | MKQ parSignature,true,MKQ fun,'$CategoryFrame]]],$libFile) |
|---|
| 799 | --Equivalent to the following two lines, we hope |
|---|
| 800 | if null sargl then |
|---|
| 801 | evalAndRwriteLispForm('NILADIC, |
|---|
| 802 | ['MAKEPROP,['QUOTE,op'],'(QUOTE NILADIC),true]) |
|---|
| 803 | |
|---|
| 804 | -- 6. put modemaps into InteractiveModemapFrame |
|---|
| 805 | $domainShell := eval [op',:[MKQ f for f in sargl]] |
|---|
| 806 | $lisplibCategory:= formalBody |
|---|
| 807 | if $LISPLIB then |
|---|
| 808 | $lisplibForm:= form |
|---|
| 809 | $lisplibKind:= 'category |
|---|
| 810 | modemap:= [[parForm,:parSignature],[true,op']] |
|---|
| 811 | $lisplibModemap:= modemap |
|---|
| 812 | $lisplibParents := |
|---|
| 813 | getParentsFor($op,$FormalMapVariableList,$lisplibCategory) |
|---|
| 814 | $lisplibAncestors := computeAncestorsOf($form,nil) |
|---|
| 815 | $lisplibAbbreviation := getConstructorAbbreviationFromDB $op |
|---|
| 816 | form':=[op',:sargl] |
|---|
| 817 | augLisplibModemapsFromCategory(form',formalBody,signature') |
|---|
| 818 | [fun,$Category,e] |
|---|
| 819 | |
|---|
| 820 | mkConstructor: %Form -> %Form |
|---|
| 821 | mkConstructor form == |
|---|
| 822 | form isnt [.,:.] => ['devaluate,form] |
|---|
| 823 | null form.args => ['QUOTE,[form.op]] |
|---|
| 824 | ['%list,MKQ form.op,:[mkConstructor x for x in form.args]] |
|---|
| 825 | |
|---|
| 826 | compDefineCategory(df,m,e,prefix,fal) == |
|---|
| 827 | $domainShell: local := nil -- holds the category of the object being compiled |
|---|
| 828 | $lisplibCategory: local := nil |
|---|
| 829 | -- since we have so many ways to say state the kind of a constructor, |
|---|
| 830 | -- make sure we do have some minimal internal coherence. |
|---|
| 831 | ctor := opOf second df |
|---|
| 832 | kind := getConstructorKindFromDB ctor |
|---|
| 833 | kind ~= "category" => throwKeyedMsg("S2IC0016",[ctor,"category",kind]) |
|---|
| 834 | $insideFunctorIfTrue or not $LISPLIB or $compileDefaultsOnly => |
|---|
| 835 | compDefineCategory1(df,m,e,prefix,fal) |
|---|
| 836 | compDefineLisplib(df,m,e,prefix,fal,'compDefineCategory1) |
|---|
| 837 | |
|---|
| 838 | |
|---|
| 839 | %CatObjRes -- result of compiling a category |
|---|
| 840 | <=> [%Shell,:[%Mode,:[%Env,:null]]] |
|---|
| 841 | |
|---|
| 842 | compMakeCategoryObject: (%Form,%Env) -> %Maybe %CatObjRes |
|---|
| 843 | compMakeCategoryObject(c,$e) == |
|---|
| 844 | not isCategoryForm(c,$e) => nil |
|---|
| 845 | u:= mkEvalableCategoryForm c => [eval u,$Category,$e] |
|---|
| 846 | nil |
|---|
| 847 | |
|---|
| 848 | predicatesFromAttributes: %List %Form -> %List %Form |
|---|
| 849 | predicatesFromAttributes attrList == |
|---|
| 850 | removeDuplicates [second x for x in attrList] |
|---|
| 851 | |
|---|
| 852 | ++ Subroutine of inferConstructorImplicitParameters. |
|---|
| 853 | typeDependencyPath(m,path,e) == |
|---|
| 854 | ident? m and assoc(m,$whereDecls) => |
|---|
| 855 | get(m,'value,e) => nil -- parameter was given value |
|---|
| 856 | [[m,:reverse path],:typeDependencyPath(getmode(m,e),path,e)] |
|---|
| 857 | atomic? m => nil |
|---|
| 858 | [ctor,:args] := m |
|---|
| 859 | -- We don't expect implicit parameters in builtin constructors. |
|---|
| 860 | builtinConstructor? ctor => nil |
|---|
| 861 | -- FIXME: assume constructors cannot be parameters |
|---|
| 862 | not constructor? ctor => nil |
|---|
| 863 | [:typeDependencyPath(m',[i,:path],e) for m' in args for i in 0..] |
|---|
| 864 | |
|---|
| 865 | ++ Given the list `parms' of explicit constructor parameters, compute |
|---|
| 866 | ++ a list of pairs `(p . path)' where `p' is a parameter implicitly |
|---|
| 867 | ++ introduced (either directly or indirectly) by a declaration of |
|---|
| 868 | ++ one of the explicit parameters. |
|---|
| 869 | inferConstructorImplicitParameters(parms,e) == |
|---|
| 870 | removeDuplicates |
|---|
| 871 | [:typeDependencyPath(getmode(p,e),[i],e) for p in parms for i in 0..] |
|---|
| 872 | |
|---|
| 873 | compDefineFunctor(df,m,e,prefix,fal) == |
|---|
| 874 | $domainShell: local := nil -- holds the category of the object being compiled |
|---|
| 875 | $profileCompiler: local := true |
|---|
| 876 | $profileAlist: local := nil |
|---|
| 877 | $mutableDomain: local := false |
|---|
| 878 | $compileExportsOnly or not $LISPLIB => |
|---|
| 879 | compDefineFunctor1(df,m,e,prefix,fal) |
|---|
| 880 | compDefineLisplib(df,m,e,prefix,fal,'compDefineFunctor1) |
|---|
| 881 | |
|---|
| 882 | compDefineFunctor1(df is ['DEF,form,signature,nils,body], |
|---|
| 883 | m,$e,$prefix,$formalArgList) == |
|---|
| 884 | -- 1. bind global variables |
|---|
| 885 | $addForm: local := nil |
|---|
| 886 | $subdomain: local := false |
|---|
| 887 | $functionStats: local:= [0,0] |
|---|
| 888 | $functorStats: local:= [0,0] |
|---|
| 889 | $form: local := nil |
|---|
| 890 | $op: local := nil |
|---|
| 891 | $signature: local := nil |
|---|
| 892 | $functorTarget: local := nil |
|---|
| 893 | $Representation: local := nil |
|---|
| 894 | --Set in doIt, accessed in the compiler - compNoStacking |
|---|
| 895 | $functorForm: local := nil |
|---|
| 896 | $functorLocalParameters: local := nil |
|---|
| 897 | $CheckVectorList: local := nil |
|---|
| 898 | $getDomainCode: local := nil -- code for getting views |
|---|
| 899 | $insideFunctorIfTrue: local:= true |
|---|
| 900 | $genSDVar: local:= 0 |
|---|
| 901 | originale:= $e |
|---|
| 902 | [$op,:argl]:= form |
|---|
| 903 | $formalArgList:= [:argl,:$formalArgList] |
|---|
| 904 | $pairlis: local := pairList(argl,$FormalMapVariableList) |
|---|
| 905 | $mutableDomain: local := |
|---|
| 906 | -- all defaulting packages should have caching turned off |
|---|
| 907 | isCategoryPackageName $op or symbolMember?($op,$mutableDomains) |
|---|
| 908 | --true if domain has mutable state |
|---|
| 909 | signature':= |
|---|
| 910 | [signature.target,:[getArgumentModeOrMoan(a,form,$e) for a in argl]] |
|---|
| 911 | $functorForm := $form := [$op,:argl] |
|---|
| 912 | if null signature'.target then signature':= |
|---|
| 913 | modemap2Signature getModemap($form,$e) |
|---|
| 914 | $functorTarget := target := signature'.target |
|---|
| 915 | $functorKind: local := |
|---|
| 916 | $functorTarget is ["CATEGORY",key,:.] => key |
|---|
| 917 | "domain" |
|---|
| 918 | $e := giveFormalParametersValues(argl,$e) |
|---|
| 919 | $implicitParameters: local := inferConstructorImplicitParameters(argl,$e) |
|---|
| 920 | [ds,.,$e]:= compMakeCategoryObject(target,$e) or return |
|---|
| 921 | stackAndThrow('" cannot produce category object: %1pb",[target]) |
|---|
| 922 | $compileExportsOnly => |
|---|
| 923 | compDefineExports(form, categoryExports ds, signature',$e) |
|---|
| 924 | $domainShell: local := copyVector ds |
|---|
| 925 | attributeList := categoryAttributes ds --see below under "loadTimeAlist" |
|---|
| 926 | $condAlist: local := nil |
|---|
| 927 | $uncondAlist: local := nil |
|---|
| 928 | $NRTslot1PredicateList: local := predicatesFromAttributes attributeList |
|---|
| 929 | $NRTattributeAlist: local := NRTgenInitialAttributeAlist attributeList |
|---|
| 930 | $NRTslot1Info: local := nil --set in NRTmakeSlot1Info |
|---|
| 931 | --this is used below to set $lisplibSlot1 global |
|---|
| 932 | $NRTaddForm: local := nil -- see compAdd |
|---|
| 933 | $NRTdeltaList: local := nil --list of misc. elts used in compiled fncts |
|---|
| 934 | $NRTdeltaListComp: local := nil --list of compiled forms for $NRTdeltaList |
|---|
| 935 | $NRTdeltaLength: local := 0 -- =length of block of extra entries in vector |
|---|
| 936 | $template: local:= nil --stored in the lisplib |
|---|
| 937 | $functionLocations: local := nil --locations of defined functions in source |
|---|
| 938 | -- generate slots for arguments first, then for $NRTaddForm in compAdd |
|---|
| 939 | for x in argl repeat NRTgetLocalIndex x |
|---|
| 940 | [.,.,$e]:= compMakeDeclaration("$",target,$e) |
|---|
| 941 | if not $insideCategoryPackageIfTrue then |
|---|
| 942 | $e:= augModemapsFromCategory('_$,'_$,'_$,target,$e) |
|---|
| 943 | $signature:= signature' |
|---|
| 944 | parSignature:= applySubst($pairlis,signature') |
|---|
| 945 | parForm:= applySubst($pairlis,form) |
|---|
| 946 | |
|---|
| 947 | -- (3.1) now make a list of the functor's local parameters; for |
|---|
| 948 | -- domain D in argl,check its signature: if domain, its type is Join(A1,..,An); |
|---|
| 949 | -- in this case, D is replaced by D1,..,Dn (gensyms) which are set |
|---|
| 950 | -- to the A1,..,An view of D |
|---|
| 951 | makeFunctorArgumentParameters(argl,signature'.source,signature'.target) |
|---|
| 952 | $functorLocalParameters := argl |
|---|
| 953 | |
|---|
| 954 | -- 4. compile body in environment of %type declarations for arguments |
|---|
| 955 | op':= $op |
|---|
| 956 | rettype:= signature'.target |
|---|
| 957 | -- If this functor is defined as instantiation of a functor |
|---|
| 958 | -- that is a subdomain of `D', then make this functor also a subdomain |
|---|
| 959 | -- of that super domain `D'. |
|---|
| 960 | if body is ["add",[rhsCtor,:rhsArgs],["CAPSULE"]] |
|---|
| 961 | and constructor? rhsCtor |
|---|
| 962 | and (u := getSuperDomainFromDB rhsCtor) then |
|---|
| 963 | u := sublisFormal(rhsArgs,u,$AtVariables) |
|---|
| 964 | emitSubdomainInfo($form,first u, second u) |
|---|
| 965 | T:= compFunctorBody(body,rettype,$e,parForm) |
|---|
| 966 | -- If only compiling certain items, then ignore the body shell. |
|---|
| 967 | $compileOnlyCertainItems => |
|---|
| 968 | reportOnFunctorCompilation() |
|---|
| 969 | [nil, ['Mapping, :signature'], originale] |
|---|
| 970 | |
|---|
| 971 | body':= T.expr |
|---|
| 972 | lamOrSlam:= if $mutableDomain then 'LAM else 'SPADSLAM |
|---|
| 973 | fun:= compile applySubst($pairlis, [op',[lamOrSlam,argl,body']]) |
|---|
| 974 | --The above statement stops substitutions gettting in one another's way |
|---|
| 975 | operationAlist := applySubst($pairlis,$lisplibOperationAlist) |
|---|
| 976 | if $LISPLIB then |
|---|
| 977 | augmentLisplibModemapsFromFunctor(parForm,operationAlist,parSignature) |
|---|
| 978 | reportOnFunctorCompilation() |
|---|
| 979 | |
|---|
| 980 | -- 5. give operator a 'modemap property |
|---|
| 981 | if $LISPLIB then |
|---|
| 982 | modemap:= [[parForm,:parSignature],[true,op']] |
|---|
| 983 | $lisplibModemap:= modemap |
|---|
| 984 | $lisplibCategory := modemap.mmTarget |
|---|
| 985 | $lisplibParents := |
|---|
| 986 | getParentsFor($op,$FormalMapVariableList,$lisplibCategory) |
|---|
| 987 | $lisplibAncestors := computeAncestorsOf($form,nil) |
|---|
| 988 | $lisplibAbbreviation := getConstructorAbbreviationFromDB $op |
|---|
| 989 | $insideFunctorIfTrue:= false |
|---|
| 990 | if $LISPLIB then |
|---|
| 991 | $lisplibKind:= |
|---|
| 992 | $functorTarget is ["CATEGORY",key,:.] and key~="domain" => 'package |
|---|
| 993 | 'domain |
|---|
| 994 | $lisplibForm:= form |
|---|
| 995 | if not $bootStrapMode then |
|---|
| 996 | $NRTslot1Info := NRTmakeSlot1Info() |
|---|
| 997 | $isOpPackageName: local := isCategoryPackageName $op |
|---|
| 998 | if $isOpPackageName then lisplibWrite('"slot1DataBase", |
|---|
| 999 | ['updateSlot1DataBase,MKQ $NRTslot1Info],$libFile) |
|---|
| 1000 | $lisplibFunctionLocations := applySubst($pairlis,$functionLocations) |
|---|
| 1001 | libFn := getConstructorAbbreviationFromDB op' |
|---|
| 1002 | $lookupFunction: local := |
|---|
| 1003 | NRTgetLookupFunction($functorForm,$lisplibModemap.mmTarget,$NRTaddForm,$e) |
|---|
| 1004 | --either lookupComplete (for forgetful guys) or lookupIncomplete |
|---|
| 1005 | $byteAddress :local := 0 |
|---|
| 1006 | $byteVec :local := nil |
|---|
| 1007 | $NRTslot1PredicateList := |
|---|
| 1008 | [simpBool x for x in $NRTslot1PredicateList] |
|---|
| 1009 | rwriteLispForm('loadTimeStuff, |
|---|
| 1010 | ['MAKEPROP,MKQ $op,''infovec,getInfovecCode()]) |
|---|
| 1011 | $lisplibSlot1 := $NRTslot1Info |
|---|
| 1012 | $lisplibOperationAlist:= operationAlist |
|---|
| 1013 | lisplibWrite('"compilerInfo", |
|---|
| 1014 | removeZeroOne ['SETQ,'$CategoryFrame, |
|---|
| 1015 | ['put,['QUOTE,op'],' |
|---|
| 1016 | (QUOTE isFunctor), |
|---|
| 1017 | ['QUOTE,operationAlist],['addModemap,['QUOTE,op'],[' |
|---|
| 1018 | QUOTE,parForm],['QUOTE,parSignature],true,['QUOTE,op'], |
|---|
| 1019 | ['put,['QUOTE,op' ],'(QUOTE mode), |
|---|
| 1020 | ['QUOTE,['Mapping,:parSignature]],'$CategoryFrame]]]],$libFile) |
|---|
| 1021 | if null argl then |
|---|
| 1022 | evalAndRwriteLispForm('NILADIC, |
|---|
| 1023 | ['MAKEPROP, ['QUOTE,op'], ['QUOTE,'NILADIC], true]) |
|---|
| 1024 | -- Functors are incomplete during bootstrap |
|---|
| 1025 | if $bootStrapMode then |
|---|
| 1026 | evalAndRwriteLispForm('%incomplete, |
|---|
| 1027 | ['MAKEPROP, ['QUOTE,op'], ['QUOTE,'%incomplete], true]) |
|---|
| 1028 | [fun,['Mapping,:signature'],originale] |
|---|
| 1029 | |
|---|
| 1030 | ++ Subroutine of compDefineFunctor1. Called to generate backend code |
|---|
| 1031 | ++ for a functor definition. |
|---|
| 1032 | compFunctorBody(body,m,e,parForm) == |
|---|
| 1033 | $bootStrapMode => |
|---|
| 1034 | [bootStrapError($functorForm, _/EDITFILE),m,e] |
|---|
| 1035 | clearCapsuleDirectory() -- start collecting capsule functions. |
|---|
| 1036 | T:= compOrCroak(body,m,e) |
|---|
| 1037 | $capsuleFunctionStack := reverse! $capsuleFunctionStack |
|---|
| 1038 | -- ??? Don't resolve default definitions, yet. |
|---|
| 1039 | if $insideCategoryPackageIfTrue then |
|---|
| 1040 | backendCompile $capsuleFunctionStack |
|---|
| 1041 | else |
|---|
| 1042 | backendCompile foldExportedFunctionReferences $capsuleFunctionStack |
|---|
| 1043 | clearCapsuleDirectory() -- release storage. |
|---|
| 1044 | body is [op,:.] and op in '(add CAPSULE) => T |
|---|
| 1045 | $NRTaddForm := |
|---|
| 1046 | body is ["SubDomain",domainForm,predicate] => domainForm |
|---|
| 1047 | body |
|---|
| 1048 | T |
|---|
| 1049 | |
|---|
| 1050 | reportOnFunctorCompilation() == |
|---|
| 1051 | displayMissingFunctions() |
|---|
| 1052 | if $semanticErrorStack then sayBrightly '" " |
|---|
| 1053 | displaySemanticErrors() |
|---|
| 1054 | if $warningStack then sayBrightly '" " |
|---|
| 1055 | displayWarnings() |
|---|
| 1056 | $functorStats:= addStats($functorStats,$functionStats) |
|---|
| 1057 | [byteCount,elapsedSeconds] := $functorStats |
|---|
| 1058 | sayBrightly ['%l,:bright '" Cumulative Statistics for Constructor",$op] |
|---|
| 1059 | timeString := normalizeStatAndStringify elapsedSeconds |
|---|
| 1060 | sayBrightly ['" Time:",:bright timeString,'"seconds"] |
|---|
| 1061 | sayBrightly '" " |
|---|
| 1062 | 'done |
|---|
| 1063 | |
|---|
| 1064 | displayMissingFunctions() == |
|---|
| 1065 | null $CheckVectorList => nil |
|---|
| 1066 | loc := nil -- list of local operation signatures |
|---|
| 1067 | exp := nil -- list of exported operation signatures |
|---|
| 1068 | for [[op,sig,:.],:pred] in $CheckVectorList | not pred repeat |
|---|
| 1069 | not symbolMember?(op,$formalArgList) and getmode(op,$e) is ['Mapping,:.] => |
|---|
| 1070 | loc := [[op,sig],:loc] |
|---|
| 1071 | exp := [[op,sig],:exp] |
|---|
| 1072 | if loc then |
|---|
| 1073 | sayBrightly ['"%l",:bright '" Missing Local Functions:"] |
|---|
| 1074 | for [op,sig] in loc for i in 1.. repeat |
|---|
| 1075 | sayBrightly ['" [",i,'"]",:bright op, |
|---|
| 1076 | ": ",:formatUnabbreviatedSig sig] |
|---|
| 1077 | if exp then |
|---|
| 1078 | sayBrightly ['"%l",:bright '" Missing Exported Functions:"] |
|---|
| 1079 | for [op,sig] in exp for i in 1.. repeat |
|---|
| 1080 | sayBrightly ['" [",i,'"]",:bright op, |
|---|
| 1081 | ": ",:formatUnabbreviatedSig sig] |
|---|
| 1082 | |
|---|
| 1083 | --% domain view code |
|---|
| 1084 | |
|---|
| 1085 | makeFunctorArgumentParameters(argl,sigl,target) == |
|---|
| 1086 | $forceAdd: local:= true |
|---|
| 1087 | $ConditionalOperators: local := nil |
|---|
| 1088 | ("append"/[fn(a,augmentSig(s,findExtras(a,target))) |
|---|
| 1089 | for a in argl for s in sigl]) where |
|---|
| 1090 | findExtras(a,target) == |
|---|
| 1091 | -- see if conditional information implies anything else |
|---|
| 1092 | -- in the signature of a |
|---|
| 1093 | target is ['Join,:l] => "union"/[findExtras(a,x) for x in l] |
|---|
| 1094 | target is ['CATEGORY,.,:l] => "union"/[findExtras1(a,x) for x in l] where |
|---|
| 1095 | findExtras1(a,x) == |
|---|
| 1096 | x is ['AND,:l] => "union"/[findExtras1(a,y) for y in l] |
|---|
| 1097 | x is ['OR,:l] => "union"/[findExtras1(a,y) for y in l] |
|---|
| 1098 | x is ['IF,c,p,q] => |
|---|
| 1099 | union(findExtrasP(a,c), |
|---|
| 1100 | union(findExtras1(a,p),findExtras1(a,q))) where |
|---|
| 1101 | findExtrasP(a,x) == |
|---|
| 1102 | x is ['AND,:l] => "union"/[findExtrasP(a,y) for y in l] |
|---|
| 1103 | x is ['OR,:l] => "union"/[findExtrasP(a,y) for y in l] |
|---|
| 1104 | x is ["has",=a,y] and y is ['SIGNATURE,:.] => [y] |
|---|
| 1105 | nil |
|---|
| 1106 | nil |
|---|
| 1107 | augmentSig(s,ss) == |
|---|
| 1108 | -- if we find something extra, add it to the signature |
|---|
| 1109 | null ss => s |
|---|
| 1110 | for u in ss repeat |
|---|
| 1111 | $ConditionalOperators:=[rest u,:$ConditionalOperators] |
|---|
| 1112 | s is ['Join,:sl] => |
|---|
| 1113 | u:=ASSQ('CATEGORY,ss) => |
|---|
| 1114 | MSUBST([:u,:ss],u,s) |
|---|
| 1115 | ['Join,:sl,['CATEGORY,'package,:ss]] |
|---|
| 1116 | ['Join,s,['CATEGORY,'package,:ss]] |
|---|
| 1117 | fn(a,s) == |
|---|
| 1118 | isCategoryForm(s,$CategoryFrame) => |
|---|
| 1119 | s is ["Join",:catlist] => genDomainViewList(a,s.args) |
|---|
| 1120 | [genDomainView(a,a,s,"getDomainView")] |
|---|
| 1121 | [a] |
|---|
| 1122 | |
|---|
| 1123 | genDomainOps(viewName,dom,cat) == |
|---|
| 1124 | oplist:= getOperationAlist(dom,dom,cat) |
|---|
| 1125 | siglist:= [sig for [sig,:.] in oplist] |
|---|
| 1126 | oplist:= substNames(dom,viewName,dom,oplist) |
|---|
| 1127 | cd:= |
|---|
| 1128 | ["%LET",viewName,['mkOpVec,dom,['%list,: |
|---|
| 1129 | [['%list,MKQ op,['%list,:[mkTypeForm mode for mode in sig]]] |
|---|
| 1130 | for [op,sig] in siglist]]]] |
|---|
| 1131 | $getDomainCode:= [cd,:$getDomainCode] |
|---|
| 1132 | for [opsig,cond,:.] in oplist for i in 0.. repeat |
|---|
| 1133 | if listMember?(opsig,$ConditionalOperators) then cond:=nil |
|---|
| 1134 | [op,sig]:=opsig |
|---|
| 1135 | $e:= addModemap(op,dom,sig,cond,['ELT,viewName,i],$e) |
|---|
| 1136 | viewName |
|---|
| 1137 | |
|---|
| 1138 | genDomainView(viewName,originalName,c,viewSelector) == |
|---|
| 1139 | c is ['CATEGORY,.,:l] => genDomainOps(viewName,originalName,c) |
|---|
| 1140 | code:= |
|---|
| 1141 | c is ['SubsetCategory,c',.] => c' |
|---|
| 1142 | c |
|---|
| 1143 | $e:= augModemapsFromCategory(originalName,viewName,nil,c,$e) |
|---|
| 1144 | cd:= ["%LET",viewName,[viewSelector,originalName,mkTypeForm code]] |
|---|
| 1145 | if not listMember?(cd,$getDomainCode) then |
|---|
| 1146 | $getDomainCode:= [cd,:$getDomainCode] |
|---|
| 1147 | viewName |
|---|
| 1148 | |
|---|
| 1149 | genDomainViewList: (%Symbol,%List %Form) -> %List %Code |
|---|
| 1150 | genDomainViewList(id,catlist) == |
|---|
| 1151 | [genDomainView(id,id,cat,"getDomainView") |
|---|
| 1152 | for cat in catlist | isCategoryForm(cat,$EmptyEnvironment)] |
|---|
| 1153 | |
|---|
| 1154 | mkOpVec(dom,siglist) == |
|---|
| 1155 | dom:= getPrincipalView dom |
|---|
| 1156 | substargs := [['$,:canonicalForm dom], |
|---|
| 1157 | :pairList($FormalMapVariableList,instantiationArgs dom)] |
|---|
| 1158 | oplist:= getConstructorOperationsFromDB instantiationCtor dom |
|---|
| 1159 | --new form is (<op> <signature> <slotNumber> <condition> <kind>) |
|---|
| 1160 | ops := newVector #siglist |
|---|
| 1161 | for (opSig:= [op,sig]) in siglist for i in 0.. repeat |
|---|
| 1162 | u:= ASSQ(op,oplist) |
|---|
| 1163 | assoc(sig,u) is [.,n,.,'ELT] => |
|---|
| 1164 | vectorRef(ops,i) := vectorRef(dom,n) |
|---|
| 1165 | noplist := applySubst(substargs,u) |
|---|
| 1166 | -- following variation on assoc needed for GENSYMS in Mutable domains |
|---|
| 1167 | AssocBarGensym(substitute(dom.0,'$,sig),noplist) is [.,n,.,'ELT] => |
|---|
| 1168 | vectorRef(ops,i) := vectorRef(dom,n) |
|---|
| 1169 | vectorRef(ops,i) := [function Undef,[dom.0,i],:opSig] |
|---|
| 1170 | ops |
|---|
| 1171 | |
|---|
| 1172 | |
|---|
| 1173 | ++ form is lhs (f a1 ... an) of definition; body is rhs; |
|---|
| 1174 | ++ signature is (t0 t1 ... tn) where t0= target type, ti=type of ai, i > 0; |
|---|
| 1175 | ++ specialCases is (NIL l1 ... ln) where li is list of special cases |
|---|
| 1176 | ++ which can be given for each ti |
|---|
| 1177 | ++ removes declarative and assignment information from form and |
|---|
| 1178 | ++ signature, placing it in list L, replacing form by ("where",form',:L), |
|---|
| 1179 | ++ signature by a list of NILs (signifying declarations are in e) |
|---|
| 1180 | compDefWhereClause(['DEF,form,signature,specialCases,body],m,e) == |
|---|
| 1181 | $sigAlist: local := nil |
|---|
| 1182 | $predAlist: local := nil |
|---|
| 1183 | -- 1. create sigList= list of all signatures which have embedded |
|---|
| 1184 | -- declarations moved into global variable $sigAlist |
|---|
| 1185 | sigList:= |
|---|
| 1186 | [transformType fetchType(a,x,e,form) |
|---|
| 1187 | for a in form.args for x in signature.source] where |
|---|
| 1188 | fetchType(a,x,e,form) == |
|---|
| 1189 | x => x |
|---|
| 1190 | getmode(a,e) or userError concat( |
|---|
| 1191 | '"There is no mode for argument",a,'"of function",form.op) |
|---|
| 1192 | transformType x == |
|---|
| 1193 | x isnt [.,:.] => x |
|---|
| 1194 | x is [":",R,Rtype] => |
|---|
| 1195 | ($sigAlist:= [[R,:transformType Rtype],:$sigAlist]; x) |
|---|
| 1196 | x is ['Record,:.] => x --RDJ 8/83 |
|---|
| 1197 | [x.op,:[transformType y for y in x.args]] |
|---|
| 1198 | |
|---|
| 1199 | -- 2. replace each argument of the form (|| x p) by x, recording |
|---|
| 1200 | -- the given predicate in global variable $predAlist |
|---|
| 1201 | argList:= |
|---|
| 1202 | [removeSuchthat a for a in form.args] where |
|---|
| 1203 | removeSuchthat x == |
|---|
| 1204 | x is ["|",y,p] => ($predAlist:= [[y,:p],:$predAlist]; y) |
|---|
| 1205 | x |
|---|
| 1206 | |
|---|
| 1207 | -- 3. obtain a list of parameter identifiers (x1 .. xn) ordered so that |
|---|
| 1208 | -- the type of xi is independent of xj if i < j |
|---|
| 1209 | varList := |
|---|
| 1210 | orderByDependency(ASSOCLEFT argDepAlist,ASSOCRIGHT argDepAlist) where |
|---|
| 1211 | argDepAlist := |
|---|
| 1212 | [[x,:dependencies] for [x,:y] in argSigAlist] where |
|---|
| 1213 | dependencies() == |
|---|
| 1214 | union(listOfIdentifiersIn y, |
|---|
| 1215 | remove(listOfIdentifiersIn LASSOC(x,$predAlist),x)) |
|---|
| 1216 | argSigAlist := [:$sigAlist,:pairList(argList,sigList)] |
|---|
| 1217 | |
|---|
| 1218 | -- 4. construct a WhereList which declares and/or defines the xi's in |
|---|
| 1219 | -- the order constructed in step 3 |
|---|
| 1220 | whereList := [addSuchthat(x,[":",x,LASSOC(x,argSigAlist)]) for x in varList] |
|---|
| 1221 | where addSuchthat(x,y) == |
|---|
| 1222 | p := LASSOC(x,$predAlist) => ["|",y,p] |
|---|
| 1223 | y |
|---|
| 1224 | |
|---|
| 1225 | -- 5. compile new ('DEF,("where",form',:WhereList),:.) where |
|---|
| 1226 | -- all argument parameters of form' are bound/declared in WhereList |
|---|
| 1227 | comp(form',m,e) where |
|---|
| 1228 | form' := ["where",defform,:whereList] where |
|---|
| 1229 | defform := ['DEF,form'',signature',specialCases,body] where |
|---|
| 1230 | form'' := [form.op,:argList] |
|---|
| 1231 | signature' := [signature.target,:[nil for x in signature.source]] |
|---|
| 1232 | |
|---|
| 1233 | orderByDependency(vl,dl) == |
|---|
| 1234 | -- vl is list of variables, dl is list of dependency-lists |
|---|
| 1235 | selfDependents:= [v for v in vl for d in dl | symbolMember?(v,d)] |
|---|
| 1236 | for v in vl for d in dl | symbolMember?(v,d) repeat |
|---|
| 1237 | (SAY(v," depends on itself"); fatalError:= true) |
|---|
| 1238 | fatalError => userError '"Parameter specification error" |
|---|
| 1239 | until vl = nil repeat |
|---|
| 1240 | newl:= |
|---|
| 1241 | [v for v in vl for d in dl | null intersection(d,vl)] or return nil |
|---|
| 1242 | orderedVarList:= [:newl,:orderedVarList] |
|---|
| 1243 | vl' := setDifference(vl,newl) |
|---|
| 1244 | dl' := [setDifference(d,newl) for x in vl for d in dl |
|---|
| 1245 | | symbolMember?(x,vl')] |
|---|
| 1246 | vl := vl' |
|---|
| 1247 | dl := dl' |
|---|
| 1248 | removeDuplicates reverse! orderedVarList --ordered so ith is indep. of jth if i < j |
|---|
| 1249 | |
|---|
| 1250 | compDefineCapsuleFunction(df is ['DEF,form,signature,specialCases,body], |
|---|
| 1251 | m,$e,$prefix,$formalArgList) == |
|---|
| 1252 | [lineNumber,:specialCases] := specialCases |
|---|
| 1253 | e := $e |
|---|
| 1254 | --1. bind global variables |
|---|
| 1255 | $form: local := nil |
|---|
| 1256 | $op: local := nil |
|---|
| 1257 | $functionStats: local:= [0,0] |
|---|
| 1258 | $argumentConditionList: local := nil |
|---|
| 1259 | $finalEnv: local := nil |
|---|
| 1260 | --used by ReplaceExitEtc to get a common environment |
|---|
| 1261 | $initCapsuleErrorCount: local:= #$semanticErrorStack |
|---|
| 1262 | $insideCapsuleFunctionIfTrue: local:= true |
|---|
| 1263 | $CapsuleModemapFrame: local:= e |
|---|
| 1264 | $CapsuleDomainsInScope: local:= get("$DomainsInScope","special",e) |
|---|
| 1265 | $insideExpressionIfTrue: local:= true |
|---|
| 1266 | $returnMode:= m |
|---|
| 1267 | -- Change "^" to "**" in definitions. All other places have |
|---|
| 1268 | -- been changed before we get here. |
|---|
| 1269 | if form.op = "^" then |
|---|
| 1270 | sayBrightly ['"Replacing", :bright '"^", '"with",:bright '"**"] |
|---|
| 1271 | form.op := "**" |
|---|
| 1272 | [$op,:argl]:= form |
|---|
| 1273 | $form:= [$op,:argl] |
|---|
| 1274 | argl:= stripOffArgumentConditions argl |
|---|
| 1275 | $formalArgList:= [:argl,:$formalArgList] |
|---|
| 1276 | |
|---|
| 1277 | --let target and local signatures help determine modes of arguments |
|---|
| 1278 | argModeList := |
|---|
| 1279 | identSig := hasSigInTargetCategory(argl,form,signature.target,e) => |
|---|
| 1280 | (e:= checkAndDeclare(argl,form,identSig,e); identSig.source) |
|---|
| 1281 | [getArgumentModeOrMoan(a,form,e) for a in argl] |
|---|
| 1282 | argModeList := stripOffSubdomainConditions(argModeList,argl) |
|---|
| 1283 | signature' := [signature.target,:argModeList] |
|---|
| 1284 | if null identSig then --make $op a local function |
|---|
| 1285 | $e := put($op,'mode,['Mapping,:signature'],$e) |
|---|
| 1286 | |
|---|
| 1287 | --obtain target type if not given |
|---|
| 1288 | if null signature'.target then signature':= |
|---|
| 1289 | identSig => identSig |
|---|
| 1290 | getSignature($op,signature'.source,e) or return nil |
|---|
| 1291 | e:= giveFormalParametersValues(argl,e) |
|---|
| 1292 | |
|---|
| 1293 | $signatureOfForm:= signature' --this global is bound in compCapsuleItems |
|---|
| 1294 | $functionLocations := [[[$op,$signatureOfForm],:lineNumber], |
|---|
| 1295 | :$functionLocations] |
|---|
| 1296 | e:= addDomain(signature'.target,e) |
|---|
| 1297 | e:= compArgumentConditions e |
|---|
| 1298 | |
|---|
| 1299 | if $profileCompiler then |
|---|
| 1300 | for x in argl for t in signature'.source repeat |
|---|
| 1301 | profileRecord('arguments,x,t) |
|---|
| 1302 | |
|---|
| 1303 | --4. introduce needed domains into extendedEnv |
|---|
| 1304 | for domain in signature' repeat e:= addDomain(domain,e) |
|---|
| 1305 | |
|---|
| 1306 | --6. compile body in environment with extended environment |
|---|
| 1307 | rettype:= resolve(signature'.target,$returnMode) |
|---|
| 1308 | |
|---|
| 1309 | localOrExported := |
|---|
| 1310 | not symbolMember?($op,$formalArgList) and |
|---|
| 1311 | getmode($op,e) is ['Mapping,:.] => 'local |
|---|
| 1312 | 'exported |
|---|
| 1313 | |
|---|
| 1314 | --6a skip if compiling only certain items but not this one |
|---|
| 1315 | -- could be moved closer to the top |
|---|
| 1316 | formattedSig := formatUnabbreviated ['Mapping,:signature'] |
|---|
| 1317 | $compileOnlyCertainItems and _ |
|---|
| 1318 | not symbolMember?($op, $compileOnlyCertainItems) => |
|---|
| 1319 | sayBrightly ['" skipping ", localOrExported,:bright $op] |
|---|
| 1320 | [nil,['Mapping,:signature'],$e] |
|---|
| 1321 | sayBrightly ['" compiling ",localOrExported, |
|---|
| 1322 | :bright $op,'": ",:formattedSig] |
|---|
| 1323 | |
|---|
| 1324 | noteCapsuleFunctionDefinition($op,signature', makePredicate $predl) |
|---|
| 1325 | T := CATCH('compCapsuleBody, compOrCroak(body,rettype,e)) |
|---|
| 1326 | or [$ClearBodyToken,rettype,e] |
|---|
| 1327 | NRTassignCapsuleFunctionSlot($op,signature') |
|---|
| 1328 | if $newCompCompare=true then |
|---|
| 1329 | SAY '"The old compiler generates:" |
|---|
| 1330 | prTriple T |
|---|
| 1331 | -- A THROW to the above CATCH occurs if too many semantic errors occur |
|---|
| 1332 | -- see stackSemanticError |
|---|
| 1333 | catchTag:= MKQ gensym() |
|---|
| 1334 | fun:= |
|---|
| 1335 | body':= replaceExitEtc(T.expr,catchTag,"TAGGEDreturn",$returnMode) |
|---|
| 1336 | body':= addArgumentConditions(body',$op) |
|---|
| 1337 | finalBody:= ["CATCH",catchTag,body'] |
|---|
| 1338 | compile [$op,["LAM",[:argl,'_$],finalBody]] |
|---|
| 1339 | $functorStats:= addStats($functorStats,$functionStats) |
|---|
| 1340 | |
|---|
| 1341 | --7. give operator a 'value property |
|---|
| 1342 | val:= [fun,signature',e] |
|---|
| 1343 | [fun,['Mapping,:signature'],$e] |
|---|
| 1344 | |
|---|
| 1345 | getSignatureFromMode(form,e) == |
|---|
| 1346 | getmode(opOf form,e) is ['Mapping,:signature] => |
|---|
| 1347 | #form~=#signature => stackAndThrow ["Wrong number of arguments: ",form] |
|---|
| 1348 | applySubst(pairList($FormalMapVariableList,form.args),signature) |
|---|
| 1349 | |
|---|
| 1350 | candidateSignatures(op,nmodes,slot1) == |
|---|
| 1351 | [sig for [[=op,sig,:.],:.] in slot1 | #sig = nmodes] |
|---|
| 1352 | |
|---|
| 1353 | ++ We are compiling a capsule function definition with head given by `form'. |
|---|
| 1354 | ++ Determine whether the function with possibly partial signature `opsig' |
|---|
| 1355 | ++ is exported. Return the complete signature if yes; otherwise |
|---|
| 1356 | ++ return nil, with diagnostic in ambiguity case. |
|---|
| 1357 | hasSigInTargetCategory(argl,form,opsig,e) == |
|---|
| 1358 | sigs := candidateSignatures($op,#form,categoryExports $domainShell) |
|---|
| 1359 | cc := checkCallingConvention(sigs,#argl) |
|---|
| 1360 | mList:= [(cc.i > 0 => quasiquote x; getArgumentMode(x,e)) |
|---|
| 1361 | for x in argl for i in 0..] |
|---|
| 1362 | --each element is a declared mode for the variable or nil if none exists |
|---|
| 1363 | potentialSigList:= |
|---|
| 1364 | removeDuplicates |
|---|
| 1365 | [sig for sig in sigs | |
|---|
| 1366 | fn(sig,opsig,mList)] where |
|---|
| 1367 | fn(sig,opsig,mList) == |
|---|
| 1368 | (null opsig or opsig=sig.target) and |
|---|
| 1369 | (and/[compareMode2Arg(x,m) for x in mList for m in sig.source]) |
|---|
| 1370 | c:= #potentialSigList |
|---|
| 1371 | 1=c => first potentialSigList |
|---|
| 1372 | --accept only those signatures op right length which match declared modes |
|---|
| 1373 | 0=c => (#(sig:= getSignatureFromMode(form,e))=#form => sig; nil) |
|---|
| 1374 | 1<c => |
|---|
| 1375 | ambiguousSignatureError($op,potentialSigList) |
|---|
| 1376 | first potentialSigList |
|---|
| 1377 | nil --this branch will force all arguments to be declared |
|---|
| 1378 | |
|---|
| 1379 | compareMode2Arg(x,m) == null x or modeEqual(x,m) |
|---|
| 1380 | |
|---|
| 1381 | getArgumentModeOrMoan: (%Form, %Form, %Env) -> %Mode |
|---|
| 1382 | getArgumentModeOrMoan(x,form,e) == |
|---|
| 1383 | getArgumentMode(x,e) or |
|---|
| 1384 | stackSemanticError(["argument ",x," of ",form," is not declared"],nil) |
|---|
| 1385 | |
|---|
| 1386 | getArgumentMode: (%Form,%Env) -> %Mode |
|---|
| 1387 | getArgumentMode(x,e) == |
|---|
| 1388 | string? x => x |
|---|
| 1389 | m:= get(x,'mode,e) => m |
|---|
| 1390 | |
|---|
| 1391 | checkAndDeclare(argl,form,sig,e) == |
|---|
| 1392 | -- arguments with declared types must agree with those in sig; |
|---|
| 1393 | -- those that don't get declarations put into e |
|---|
| 1394 | for a in argl for m in sig.source repeat |
|---|
| 1395 | isQuasiquote m => nil -- we just built m from a. |
|---|
| 1396 | m1:= getArgumentMode(a,e) => |
|---|
| 1397 | not modeEqual(m1,m) => |
|---|
| 1398 | stack:= [" ",:bright a,'"must have type ",m, |
|---|
| 1399 | '" not ",m1,'"%l",:stack] |
|---|
| 1400 | e:= put(a,'mode,m,e) |
|---|
| 1401 | if stack then |
|---|
| 1402 | sayBrightly ['" Parameters of ",:bright form.op, |
|---|
| 1403 | '" are of wrong type:",'"%l",:stack] |
|---|
| 1404 | e |
|---|
| 1405 | |
|---|
| 1406 | getSignature(op,argModeList,$e) == |
|---|
| 1407 | 1=# |
|---|
| 1408 | (sigl:= |
|---|
| 1409 | removeDuplicates |
|---|
| 1410 | [sig |
|---|
| 1411 | for [[dc,:sig],[pred,:.]] in (mmList:= get(op,'modemap,$e)) | dc='_$ |
|---|
| 1412 | and sig.source = argModeList and knownInfo pred]) => first sigl |
|---|
| 1413 | null sigl => |
|---|
| 1414 | (u:= getmode(op,$e)) is ['Mapping,:sig] => sig |
|---|
| 1415 | SAY '"************* USER ERROR **********" |
|---|
| 1416 | SAY("available signatures for ",op,": ") |
|---|
| 1417 | if null mmList |
|---|
| 1418 | then SAY " NONE" |
|---|
| 1419 | else for [[dc,:sig],:.] in mmList repeat printSignature(" ",op,sig) |
|---|
| 1420 | printSignature("NEED ",op,["?",:argModeList]) |
|---|
| 1421 | nil |
|---|
| 1422 | 1=#sigl => first sigl |
|---|
| 1423 | stackSemanticError(["duplicate signatures for ",op,": ",argModeList],nil) |
|---|
| 1424 | |
|---|
| 1425 | --% ARGUMENT CONDITION CODE |
|---|
| 1426 | |
|---|
| 1427 | stripOffArgumentConditions argl == |
|---|
| 1428 | [f for x in argl for i in 1..] where |
|---|
| 1429 | f() == |
|---|
| 1430 | x is ["|",arg,condition] => |
|---|
| 1431 | condition:= substitute('_#1,arg,condition) |
|---|
| 1432 | -- in case conditions are given in terms of argument names, replace |
|---|
| 1433 | $argumentConditionList:= [[i,arg,condition],:$argumentConditionList] |
|---|
| 1434 | arg |
|---|
| 1435 | x |
|---|
| 1436 | |
|---|
| 1437 | stripOffSubdomainConditions(margl,argl) == |
|---|
| 1438 | [f for x in margl for arg in argl for i in 1..] where |
|---|
| 1439 | f() == |
|---|
| 1440 | x is ['SubDomain,marg,condition] => |
|---|
| 1441 | pair:= assoc(i,$argumentConditionList) => |
|---|
| 1442 | (pair.rest.first := MKPF([condition,second pair],'AND); marg) |
|---|
| 1443 | $argumentConditionList:= [[i,arg,condition],:$argumentConditionList] |
|---|
| 1444 | marg |
|---|
| 1445 | x |
|---|
| 1446 | |
|---|
| 1447 | compArgumentConditions: %Env -> %Env |
|---|
| 1448 | compArgumentConditions e == |
|---|
| 1449 | $argumentConditionList:= |
|---|
| 1450 | [f for [n,a,x] in $argumentConditionList] where |
|---|
| 1451 | f() == |
|---|
| 1452 | y:= substitute(a,'_#1,x) |
|---|
| 1453 | T := [.,.,e]:= compOrCroak(y,$Boolean,e) |
|---|
| 1454 | [n,x,T.expr] |
|---|
| 1455 | e |
|---|
| 1456 | |
|---|
| 1457 | addArgumentConditions($body,$functionName) == |
|---|
| 1458 | $argumentConditionList => |
|---|
| 1459 | --$body is only used in this function |
|---|
| 1460 | fn $argumentConditionList where |
|---|
| 1461 | fn clist == |
|---|
| 1462 | clist is [[n,untypedCondition,typedCondition],:.] => |
|---|
| 1463 | ['%when,[typedCondition,fn rest clist], |
|---|
| 1464 | ['%otherwise,["argumentDataError",n, |
|---|
| 1465 | MKQ untypedCondition,MKQ $functionName]]] |
|---|
| 1466 | null clist => $body |
|---|
| 1467 | systemErrorHere ["addArgumentConditions",clist] |
|---|
| 1468 | $body |
|---|
| 1469 | |
|---|
| 1470 | putInLocalDomainReferences (def := [opName,[lam,varl,body]]) == |
|---|
| 1471 | NRTputInTail CDDADR def |
|---|
| 1472 | def |
|---|
| 1473 | |
|---|
| 1474 | |
|---|
| 1475 | $savableItems := nil |
|---|
| 1476 | |
|---|
| 1477 | compile u == |
|---|
| 1478 | [op,lamExpr] := u |
|---|
| 1479 | if $suffix then |
|---|
| 1480 | $suffix:= $suffix+1 |
|---|
| 1481 | op':= |
|---|
| 1482 | opexport:=nil |
|---|
| 1483 | opmodes:= |
|---|
| 1484 | [sel |
|---|
| 1485 | for [[DC,:sig],[.,sel]] in get(op,'modemap,$e) | |
|---|
| 1486 | DC='_$ and (opexport:=true) and |
|---|
| 1487 | (and/[modeEqual(x,y) for x in sig for y in $signatureOfForm])] |
|---|
| 1488 | isLocalFunction op => |
|---|
| 1489 | if opexport then userError ['"%b",op,'"%d",'" is local and exported"] |
|---|
| 1490 | makeSymbol strconc(encodeItem $prefix,'";",encodeItem op) |
|---|
| 1491 | encodeFunctionName(op,$functorForm,$signatureOfForm,";",$suffix) |
|---|
| 1492 | where |
|---|
| 1493 | isLocalFunction op == |
|---|
| 1494 | null symbolMember?(op,$formalArgList) and |
|---|
| 1495 | getmode(op,$e) is ['Mapping,:.] |
|---|
| 1496 | u:= [op',lamExpr] |
|---|
| 1497 | -- If just updating certain functions, check for previous existence. |
|---|
| 1498 | -- Deduce old sequence number and use it (items have been skipped). |
|---|
| 1499 | if $LISPLIB and $compileOnlyCertainItems then |
|---|
| 1500 | parts := splitEncodedFunctionName(u.op, ";") |
|---|
| 1501 | -- Next line JHD/SMWATT 7/17/86 to deal with inner functions |
|---|
| 1502 | parts='inner => $savableItems:=[u.op,:$savableItems] |
|---|
| 1503 | unew := nil |
|---|
| 1504 | for [s,t] in $splitUpItemsAlreadyThere repeat |
|---|
| 1505 | if parts.0=s.0 and parts.1=s.1 and parts.2=s.2 then unew := t |
|---|
| 1506 | null unew => |
|---|
| 1507 | sayBrightly ['" Error: Item did not previously exist"] |
|---|
| 1508 | sayBrightly ['" Item not saved: ", :bright u.op] |
|---|
| 1509 | sayBrightly ['" What's there is: ", $lisplibItemsAlreadyThere] |
|---|
| 1510 | nil |
|---|
| 1511 | sayBrightly ['" Renaming ", u.op, '" as ", unew] |
|---|
| 1512 | u := [unew, :rest u] |
|---|
| 1513 | $savableItems := [unew, :$saveableItems] -- tested by embedded RWRITE |
|---|
| 1514 | optimizedBody:= optimizeFunctionDef u |
|---|
| 1515 | stuffToCompile:= |
|---|
| 1516 | if not $insideCapsuleFunctionIfTrue |
|---|
| 1517 | then optimizedBody |
|---|
| 1518 | else putInLocalDomainReferences optimizedBody |
|---|
| 1519 | $doNotCompileJustPrint => (PRETTYPRINT stuffToCompile; op') |
|---|
| 1520 | $macroIfTrue => constructMacro stuffToCompile |
|---|
| 1521 | |
|---|
| 1522 | -- Let the backend know about this function's type |
|---|
| 1523 | if $insideCapsuleFunctionIfTrue and $optProclaim then |
|---|
| 1524 | proclaimCapsuleFunction(op',$signatureOfForm) |
|---|
| 1525 | |
|---|
| 1526 | result:= spadCompileOrSetq stuffToCompile |
|---|
| 1527 | functionStats:=[0,elapsedTime()] |
|---|
| 1528 | $functionStats:= addStats($functionStats,functionStats) |
|---|
| 1529 | printStats functionStats |
|---|
| 1530 | result |
|---|
| 1531 | |
|---|
| 1532 | ++ Subroutine of compile. Called to generate backend code for |
|---|
| 1533 | ++ items defined directly or indirectly at capsule level. This is |
|---|
| 1534 | ++ also used to compile functors. |
|---|
| 1535 | spadCompileOrSetq (form is [nam,[lam,vl,body]]) == |
|---|
| 1536 | --bizarre hack to take account of the existence of "known" functions |
|---|
| 1537 | --good for performance (LISPLLIB size, BPI size, NILSEC) |
|---|
| 1538 | CONTAINED($ClearBodyToken,body) => sayBrightly ['" ",:bright nam,'" not compiled"] |
|---|
| 1539 | |
|---|
| 1540 | -- flag parameters needs to be made atomic, otherwise Lisp is confused. |
|---|
| 1541 | -- We try our best to preserve |
|---|
| 1542 | -- Note that we don't need substitution in the body because flag |
|---|
| 1543 | -- parameters are never used in the body. |
|---|
| 1544 | vl := [ renameParameter for v in vl] where |
|---|
| 1545 | renameParameter() == |
|---|
| 1546 | integer? v or ident? v or string? v => v |
|---|
| 1547 | gensym '"flag" |
|---|
| 1548 | clearReplacement nam -- Make sure we have fresh info |
|---|
| 1549 | if $optReplaceSimpleFunctions then |
|---|
| 1550 | body := replaceSimpleFunctions body |
|---|
| 1551 | |
|---|
| 1552 | if nam' := forwardingCall?(vl,body) then |
|---|
| 1553 | registerFunctionReplacement(nam,nam') |
|---|
| 1554 | sayBrightly ['" ",:bright nam,'"is replaced by",:bright nam'] |
|---|
| 1555 | else if macform := expandableDefinition?(vl,body) then |
|---|
| 1556 | registerFunctionReplacement(nam,macform) |
|---|
| 1557 | sayBrightly ['" ",:bright nam,'"is replaced by",:bright body] |
|---|
| 1558 | |
|---|
| 1559 | form := |
|---|
| 1560 | getFunctionReplacement nam => |
|---|
| 1561 | [nam,[lam,vl,["DECLARE",["IGNORE",last vl]],body]] |
|---|
| 1562 | [nam,[lam,vl,body]] |
|---|
| 1563 | |
|---|
| 1564 | $insideCapsuleFunctionIfTrue => |
|---|
| 1565 | $optExportedFunctionReference => |
|---|
| 1566 | $capsuleFunctionStack := [form,:$capsuleFunctionStack] |
|---|
| 1567 | first form |
|---|
| 1568 | first backendCompile [form] |
|---|
| 1569 | compileConstructor form |
|---|
| 1570 | |
|---|
| 1571 | compileConstructor form == |
|---|
| 1572 | u:= compileConstructor1 form |
|---|
| 1573 | clearClams() --clear all CLAMmed functions |
|---|
| 1574 | u |
|---|
| 1575 | |
|---|
| 1576 | compileConstructor1 (form:=[fn,[key,vl,:bodyl]]) == |
|---|
| 1577 | -- fn is the name of some category/domain/package constructor; |
|---|
| 1578 | -- we will cache all of its values on $ConstructorCache with reference |
|---|
| 1579 | -- counts |
|---|
| 1580 | $clamList: local := nil |
|---|
| 1581 | lambdaOrSlam := |
|---|
| 1582 | getConstructorKindFromDB fn = "category" => 'SPADSLAM |
|---|
| 1583 | $mutableDomain => 'LAMBDA |
|---|
| 1584 | $clamList:= |
|---|
| 1585 | [[fn,"$ConstructorCache",'domainEqualList,'count],:$clamList] |
|---|
| 1586 | 'LAMBDA |
|---|
| 1587 | compForm:= [[fn,[lambdaOrSlam,vl,:bodyl]]] |
|---|
| 1588 | if getConstructorKindFromDB fn = "category" |
|---|
| 1589 | then u:= compAndDefine compForm |
|---|
| 1590 | else u:= backendCompile compForm |
|---|
| 1591 | clearConstructorCache fn --clear cache for constructor |
|---|
| 1592 | first u |
|---|
| 1593 | |
|---|
| 1594 | constructMacro: %Form -> %Form |
|---|
| 1595 | constructMacro (form is [nam,[lam,vl,body]]) == |
|---|
| 1596 | not (and/[x isnt [.,:.] for x in vl]) => |
|---|
| 1597 | stackSemanticError(["illegal parameters for macro: ",vl],nil) |
|---|
| 1598 | ["XLAM",vl':= [x for x in vl | ident? x],body] |
|---|
| 1599 | |
|---|
| 1600 | listInitialSegment(u,v) == |
|---|
| 1601 | null u => true |
|---|
| 1602 | null v => nil |
|---|
| 1603 | first u=first v and listInitialSegment(rest u,rest v) |
|---|
| 1604 | --returns true iff u.i=v.i for i in 1..(#u)-1 |
|---|
| 1605 | |
|---|
| 1606 | modemap2Signature [[.,:sig],:.] == sig |
|---|
| 1607 | |
|---|
| 1608 | uncons: %Form -> %Form |
|---|
| 1609 | uncons x == |
|---|
| 1610 | x isnt [.,:.] => x |
|---|
| 1611 | x is ["CONS",a,b] => [a,:uncons b] |
|---|
| 1612 | |
|---|
| 1613 | --% CAPSULE |
|---|
| 1614 | |
|---|
| 1615 | bootStrapError(functorForm,sourceFile) == |
|---|
| 1616 | ['%when, _ |
|---|
| 1617 | ['$bootStrapMode, _ |
|---|
| 1618 | ['%vector,mkTypeForm functorForm,nil,nil,nil,nil,nil]], |
|---|
| 1619 | ['%otherwise, ['systemError,['%list,'"%b",MKQ functorForm.op,'"%d",'"from", _ |
|---|
| 1620 | '"%b",MKQ namestring sourceFile,'"%d",'"needs to be compiled"]]]] |
|---|
| 1621 | |
|---|
| 1622 | registerInlinableDomain(x,e) == |
|---|
| 1623 | x := macroExpand(x,e) |
|---|
| 1624 | x is [ctor,:.] => |
|---|
| 1625 | constructor? ctor => nominateForInlining ctor |
|---|
| 1626 | ctor is ":" => registerInlinableDomain(third x,e) |
|---|
| 1627 | builtinFunctorName? ctor => |
|---|
| 1628 | for t in x.args repeat |
|---|
| 1629 | registerInlinableDomain(t,e) |
|---|
| 1630 | nil |
|---|
| 1631 | nil |
|---|
| 1632 | |
|---|
| 1633 | compAdd(['add,$addForm,capsule],m,e) == |
|---|
| 1634 | $bootStrapMode => |
|---|
| 1635 | if $addForm is ["%Comma",:.] then code := nil |
|---|
| 1636 | else [code,m,e]:= comp($addForm,m,e) |
|---|
| 1637 | [['%when, _ |
|---|
| 1638 | ['$bootStrapMode, _ |
|---|
| 1639 | code],_ |
|---|
| 1640 | ['%otherwise, ['systemError,['%list,'"%b",MKQ $functorForm.op,'"%d",'"from", _ |
|---|
| 1641 | '"%b",MKQ namestring _/EDITFILE,'"%d",'"needs to be compiled"]]]],m,e] |
|---|
| 1642 | $addFormLhs: local:= $addForm |
|---|
| 1643 | if $addForm is ["SubDomain",domainForm,predicate] then |
|---|
| 1644 | $NRTaddForm := domainForm |
|---|
| 1645 | NRTgetLocalIndex domainForm |
|---|
| 1646 | registerInlinableDomain(domainForm,e) |
|---|
| 1647 | --need to generate slot for add form since all $ go-get |
|---|
| 1648 | -- slots will need to access it |
|---|
| 1649 | [$addForm,.,e]:= compSubDomain1(domainForm,predicate,m,e) |
|---|
| 1650 | else |
|---|
| 1651 | $NRTaddForm := $addForm |
|---|
| 1652 | [$addForm,.,e]:= |
|---|
| 1653 | $addForm is ["%Comma",:.] => |
|---|
| 1654 | $NRTaddForm := ["%Comma",:[NRTgetLocalIndex x for x in $addForm.args]] |
|---|
| 1655 | for x in $addForm.args repeat registerInlinableDomain(x,e) |
|---|
| 1656 | compOrCroak(compTuple2Record $addForm,$EmptyMode,e) |
|---|
| 1657 | registerInlinableDomain($addForm,e) |
|---|
| 1658 | compOrCroak($addForm,$EmptyMode,e) |
|---|
| 1659 | compCapsule(capsule,m,e) |
|---|
| 1660 | |
|---|
| 1661 | compTuple2Record u == |
|---|
| 1662 | ['Record,:[[":",i,x] for i in 1.. for x in u.args]] |
|---|
| 1663 | |
|---|
| 1664 | compCapsule(['CAPSULE,:itemList],m,e) == |
|---|
| 1665 | $bootStrapMode => |
|---|
| 1666 | [bootStrapError($functorForm, _/EDITFILE),m,e] |
|---|
| 1667 | $insideExpressionIfTrue: local:= false |
|---|
| 1668 | $useRepresentationHack := true |
|---|
| 1669 | clearCapsuleFunctionTable() |
|---|
| 1670 | e := checkRepresentation($addFormLhs,itemList,e) |
|---|
| 1671 | compCapsuleInner(itemList,m,addDomain('_$,e)) |
|---|
| 1672 | |
|---|
| 1673 | compSubDomain(["SubDomain",domainForm,predicate],m,e) == |
|---|
| 1674 | $addFormLhs: local:= domainForm |
|---|
| 1675 | $addForm: local := nil |
|---|
| 1676 | $NRTaddForm := domainForm |
|---|
| 1677 | [$addForm,.,e]:= compSubDomain1(domainForm,predicate,m,e) |
|---|
| 1678 | compCapsule(['CAPSULE],m,e) |
|---|
| 1679 | |
|---|
| 1680 | compSubDomain1(domainForm,predicate,m,e) == |
|---|
| 1681 | [.,.,e]:= |
|---|
| 1682 | compMakeDeclaration("#1",domainForm,addDomain(domainForm,e)) |
|---|
| 1683 | u:= |
|---|
| 1684 | compCompilerPredicate(predicate,e) or |
|---|
| 1685 | stackSemanticError(["predicate: ",predicate, |
|---|
| 1686 | " cannot be interpreted with #1: ",domainForm],nil) |
|---|
| 1687 | pred := simplifyVMForm u.expr |
|---|
| 1688 | -- For now, reject predicates that directly reference domains |
|---|
| 1689 | CONTAINED("$",pred) => |
|---|
| 1690 | stackAndThrow('"predicate %1pb is not simple enough",[predicate]) |
|---|
| 1691 | emitSubdomainInfo($form,domainForm,pred) |
|---|
| 1692 | $lisplibSuperDomain := [domainForm,predicate] |
|---|
| 1693 | [domainForm,m,e] |
|---|
| 1694 | |
|---|
| 1695 | compCapsuleInner(itemList,m,e) == |
|---|
| 1696 | e:= addInformation(m,e) |
|---|
| 1697 | --puts a new 'special' property of $Information |
|---|
| 1698 | data:= ["PROGN",:itemList] |
|---|
| 1699 | --RPLACd by compCapsuleItems and Friends |
|---|
| 1700 | e:= compCapsuleItems(itemList,nil,e) |
|---|
| 1701 | localParList:= $functorLocalParameters |
|---|
| 1702 | if $addForm then data:= ['add,$addForm,data] |
|---|
| 1703 | code:= |
|---|
| 1704 | $insideCategoryIfTrue and not $insideCategoryPackageIfTrue => data |
|---|
| 1705 | processFunctor($form,$signature,data,localParList,e) |
|---|
| 1706 | [MKPF([:$getDomainCode,code],"PROGN"),m,e] |
|---|
| 1707 | |
|---|
| 1708 | --% PROCESS FUNCTOR CODE |
|---|
| 1709 | |
|---|
| 1710 | processFunctor(form,signature,data,localParList,e) == |
|---|
| 1711 | form is ["CategoryDefaults"] => |
|---|
| 1712 | error "CategoryDefaults is a reserved name" |
|---|
| 1713 | buildFunctor(form,signature,data,localParList,e) |
|---|
| 1714 | |
|---|
| 1715 | compCapsuleItems(itemlist,$predl,$e) == |
|---|
| 1716 | $signatureOfForm: local := nil |
|---|
| 1717 | $suffix: local:= 0 |
|---|
| 1718 | for item in itemlist repeat |
|---|
| 1719 | $e:= compSingleCapsuleItem(item,$predl,$e) |
|---|
| 1720 | $e |
|---|
| 1721 | |
|---|
| 1722 | compSingleCapsuleItem(item,$predl,$e) == |
|---|
| 1723 | doIt(macroExpandInPlace(item,$e),$predl) |
|---|
| 1724 | $e |
|---|
| 1725 | |
|---|
| 1726 | |
|---|
| 1727 | ++ subroutine of doIt. Called to generate runtime noop insn. |
|---|
| 1728 | mutateToNothing item == |
|---|
| 1729 | item.op := 'PROGN |
|---|
| 1730 | item.rest := nil |
|---|
| 1731 | |
|---|
| 1732 | doIt(item,$predl) == |
|---|
| 1733 | $GENNO: local:= 0 |
|---|
| 1734 | item is ['SEQ,:l,['exit,1,x]] => |
|---|
| 1735 | item.op := "PROGN" |
|---|
| 1736 | lastNode(item).first := x |
|---|
| 1737 | for it1 in rest item repeat $e:= compSingleCapsuleItem(it1,$predl,$e) |
|---|
| 1738 | --This will RPLAC as appropriate |
|---|
| 1739 | isDomainForm(item,$e) => |
|---|
| 1740 | -- convert naked top level domains to import. |
|---|
| 1741 | -- Note: The apparent useless destructing of `item' below is necessary |
|---|
| 1742 | -- because it is subject to RPLACA/RPLACD, which would create |
|---|
| 1743 | -- a cycle otherwise. |
|---|
| 1744 | u:= ["import", [first item,:rest item]] |
|---|
| 1745 | stackWarning('"Use: import %1p",[[first item,:rest item]]) |
|---|
| 1746 | item.op := u.op |
|---|
| 1747 | item.rest := rest u |
|---|
| 1748 | doIt(item,$predl) |
|---|
| 1749 | item is ["%LET",lhs,rhs,:.] => |
|---|
| 1750 | compOrCroak(item,$EmptyMode,$e) isnt [code,.,$e] => |
|---|
| 1751 | stackSemanticError(["cannot compile assigned value to",:bright lhs],nil) |
|---|
| 1752 | not (code is ["%LET",lhs',rhs',:.] and lhs' isnt [.,:.]) => |
|---|
| 1753 | code is ["PROGN",:.] => |
|---|
| 1754 | stackSemanticError(["multiple assignment ",item," not allowed"],nil) |
|---|
| 1755 | item.first := first code |
|---|
| 1756 | item.rest := rest code |
|---|
| 1757 | lhs:= lhs' |
|---|
| 1758 | if not symbolMember?(KAR rhs,$NonMentionableDomainNames) and |
|---|
| 1759 | not symbolMember?(lhs, $functorLocalParameters) then |
|---|
| 1760 | $functorLocalParameters:= [:$functorLocalParameters,lhs] |
|---|
| 1761 | if code is ["%LET",.,rhs',:.] and isDomainForm(rhs',$e) then |
|---|
| 1762 | if lhs="Rep" then |
|---|
| 1763 | --$Representation bound by compDefineFunctor, used in compNoStacking |
|---|
| 1764 | $Representation := getRepresentation $e |
|---|
| 1765 | if $optimizeRep then |
|---|
| 1766 | registerInlinableDomain($Representation,$e) |
|---|
| 1767 | code is ["%LET",:.] => |
|---|
| 1768 | item.op := '%store |
|---|
| 1769 | rhsCode := rhs' |
|---|
| 1770 | item.args := [['%tref,'$,NRTgetLocalIndex lhs],rhsCode] |
|---|
| 1771 | item.op := code.op |
|---|
| 1772 | item.rest := rest code |
|---|
| 1773 | item is [":",a,t] => [.,.,$e]:= compOrCroak(item,$EmptyMode,$e) |
|---|
| 1774 | item is ["import",:doms] => |
|---|
| 1775 | for dom in doms repeat |
|---|
| 1776 | sayBrightly ['" importing ",:formatUnabbreviated dom] |
|---|
| 1777 | [.,.,$e] := compOrCroak(item,$EmptyMode,$e) |
|---|
| 1778 | mutateToNothing item |
|---|
| 1779 | item is ["%Inline",type] => |
|---|
| 1780 | processInlineRequest(type,$e) |
|---|
| 1781 | mutateToNothing item |
|---|
| 1782 | item is ["%SignatureImport",:.] => |
|---|
| 1783 | [.,.,$e] := compSignatureImport(item,$EmptyMode,$e) |
|---|
| 1784 | mutateToNothing item |
|---|
| 1785 | item is ["IF",p,x,y] => doItConditionally(item,$predl) |
|---|
| 1786 | item is ["where",b,:l] => compOrCroak(item,$EmptyMode,$e) |
|---|
| 1787 | item is ["MDEF",:.] => [.,.,$e]:= compOrCroak(item,$EmptyMode,$e) |
|---|
| 1788 | item is ['DEF,[op,:.],:.] => |
|---|
| 1789 | body := isMacro(item,$e) => $e := putMacro(op,body,$e) |
|---|
| 1790 | [.,.,$e]:= t:= compOrCroak(item,$EmptyMode,$e) |
|---|
| 1791 | item.op := "CodeDefine" |
|---|
| 1792 | --Note that DescendCode, in CodeDefine, is looking for this |
|---|
| 1793 | second(item).rest := [$signatureOfForm] |
|---|
| 1794 | --This is how the signature is updated for buildFunctor to recognise |
|---|
| 1795 | functionPart:= ['dispatchFunction,t.expr] |
|---|
| 1796 | item.rest.rest.first := functionPart |
|---|
| 1797 | item.rest.rest.rest := nil |
|---|
| 1798 | u:= compOrCroak(item,$EmptyMode,$e) => |
|---|
| 1799 | ([code,.,$e]:= u; item.first := first code; item.rest := rest code) |
|---|
| 1800 | systemErrorHere ["doIt", item] |
|---|
| 1801 | |
|---|
| 1802 | isMacro(x,e) == |
|---|
| 1803 | x is ['DEF,[op,:args],signature,specialCases,body] and |
|---|
| 1804 | null get(op,'modemap,e) and null args and null get(op,'mode,e) |
|---|
| 1805 | and signature is [nil] => body |
|---|
| 1806 | |
|---|
| 1807 | ++ Compile capsule-level `item' which is a conditional expression. |
|---|
| 1808 | ++ OpenAxiom's take on prepositional logical is a constructive |
|---|
| 1809 | ++ interpretation of logical connectives, in terms of IF-expresions. |
|---|
| 1810 | ++ In particular, a negation is positively interpretated by swapping |
|---|
| 1811 | ++ branches, and- and or-expressions are decomposed into nested |
|---|
| 1812 | ++ IF-expressions. -- gdr, 2009-06-15. |
|---|
| 1813 | doItConditionally(item,predl) == |
|---|
| 1814 | item isnt ["IF",p,x,y] => systemErrorHere ["doItConditionally",item] |
|---|
| 1815 | p is ["not",p'] => |
|---|
| 1816 | -- swap branches and recurse for positive interpretation. |
|---|
| 1817 | item.rest.first := p' |
|---|
| 1818 | item.rest.rest.first := y |
|---|
| 1819 | item.rest.rest.rest.first := x |
|---|
| 1820 | doItConditionally(item,predl) |
|---|
| 1821 | p is ["and",p',p''] => |
|---|
| 1822 | item.rest.first := p' |
|---|
| 1823 | item.rest.rest.first := ["IF",p'',x,COPY y] |
|---|
| 1824 | doItConditionally(item,predl) |
|---|
| 1825 | p is ["or",p',p''] => |
|---|
| 1826 | item.rest.first := p' |
|---|
| 1827 | item.rest.rest.rest.first := ["IF",p'',COPY x,y] |
|---|
| 1828 | doItConditionally(item,predl) |
|---|
| 1829 | doItIf(item,predl,$e) |
|---|
| 1830 | |
|---|
| 1831 | |
|---|
| 1832 | doItIf(item is [.,p,x,y],$predl,$e) == |
|---|
| 1833 | olde:= $e |
|---|
| 1834 | [p',.,$e]:= compCompilerPredicate(p,$e) or userError ['"not a Boolean:",p] |
|---|
| 1835 | oldFLP:=$functorLocalParameters |
|---|
| 1836 | if x~="%noBranch" then |
|---|
| 1837 | compSingleCapsuleItem(x,[p,:$predl],getSuccessEnvironment(p,$e)) |
|---|
| 1838 | x':=localExtras(oldFLP) |
|---|
| 1839 | oldFLP:=$functorLocalParameters |
|---|
| 1840 | if y~="%noBranch" then |
|---|
| 1841 | compSingleCapsuleItem(y,[["not",p],:$predl],getInverseEnvironment(p,olde)) |
|---|
| 1842 | y':=localExtras(oldFLP) |
|---|
| 1843 | item.op := '%when |
|---|
| 1844 | item.args := [[p',x,:x'],['%otherwise,y,:y']] |
|---|
| 1845 | where localExtras(oldFLP) == |
|---|
| 1846 | sameObject?(oldFLP,$functorLocalParameters) => nil |
|---|
| 1847 | flp1:=$functorLocalParameters |
|---|
| 1848 | oldFLP':=oldFLP |
|---|
| 1849 | n:=0 |
|---|
| 1850 | while oldFLP' repeat |
|---|
| 1851 | oldFLP':=rest oldFLP' |
|---|
| 1852 | flp1:=rest flp1 |
|---|
| 1853 | n:=n+1 |
|---|
| 1854 | -- Now we have to add code to compile all the elements |
|---|
| 1855 | -- of functorLocalParameters that were added during the |
|---|
| 1856 | -- conditional compilation |
|---|
| 1857 | nils:=ans:=[] |
|---|
| 1858 | for u in flp1 repeat -- is =u form always an atom? |
|---|
| 1859 | if u isnt [.,:.] or (or/[v is [.,=u,:.] for v in $getDomainCode]) |
|---|
| 1860 | then |
|---|
| 1861 | nils:=[u,:nils] |
|---|
| 1862 | else |
|---|
| 1863 | gv := gensym() |
|---|
| 1864 | ans:=[["%LET",gv,u],:ans] |
|---|
| 1865 | nils:=[gv,:nils] |
|---|
| 1866 | n:=n+1 |
|---|
| 1867 | $functorLocalParameters:=[:oldFLP,:reverse! nils] |
|---|
| 1868 | reverse! ans |
|---|
| 1869 | |
|---|
| 1870 | --% CATEGORY AND DOMAIN FUNCTIONS |
|---|
| 1871 | |
|---|
| 1872 | compContained: (%Form, %Mode, %Env) -> %Maybe %Triple |
|---|
| 1873 | compContained(["CONTAINED",a,b],m,e) == |
|---|
| 1874 | [a,ma,e]:= comp(a,$EmptyMode,e) or return nil |
|---|
| 1875 | [b,mb,e]:= comp(b,$EmptyMode,e) or return nil |
|---|
| 1876 | isCategoryForm(ma,e) and isCategoryForm(mb,e) => |
|---|
| 1877 | (T:= [["CONTAINED",a,b],$Boolean,e]; convert(T,m)) |
|---|
| 1878 | nil |
|---|
| 1879 | |
|---|
| 1880 | compJoin(["Join",:argl],m,e) == |
|---|
| 1881 | catList:= [(compForMode(x,$Category,e) or return 'failed).expr for x in argl] |
|---|
| 1882 | catList='failed => stackSemanticError(["cannot form Join of: ",argl],nil) |
|---|
| 1883 | catList':= |
|---|
| 1884 | [extract for x in catList] where |
|---|
| 1885 | extract() == |
|---|
| 1886 | isCategoryForm(x,e) => |
|---|
| 1887 | parameters:= |
|---|
| 1888 | union("append"/[getParms(y,e) for y in rest x],parameters) |
|---|
| 1889 | where getParms(y,e) == |
|---|
| 1890 | y isnt [.,:.] => |
|---|
| 1891 | isDomainForm(y,e) => [y] |
|---|
| 1892 | nil |
|---|
| 1893 | y is [op,y'] and op in '(LENGTH %llength) => [y,y'] |
|---|
| 1894 | [y] |
|---|
| 1895 | x |
|---|
| 1896 | x is ["DomainSubstitutionMacro",pl,body] => |
|---|
| 1897 | (parameters:= union(pl,parameters); body) |
|---|
| 1898 | x is ["mkCategory",:.] => x |
|---|
| 1899 | x isnt [.,:.] and getmode(x,e) = $Category => x |
|---|
| 1900 | stackSemanticError(["invalid argument to Join: ",x],nil) |
|---|
| 1901 | x |
|---|
| 1902 | T:= [wrapDomainSub(parameters,["Join",:catList']),$Category,e] |
|---|
| 1903 | convert(T,m) |
|---|
| 1904 | |
|---|
| 1905 | compForMode: (%Form,%Mode,%Env) -> %Maybe %Triple |
|---|
| 1906 | compForMode(x,m,e) == |
|---|
| 1907 | $compForModeIfTrue: local:= true |
|---|
| 1908 | comp(x,m,e) |
|---|
| 1909 | |
|---|
| 1910 | makeCategoryForm(c,e) == |
|---|
| 1911 | not isCategoryForm(c,e) => nil |
|---|
| 1912 | [x,m,e]:= compOrCroak(c,$EmptyMode,e) |
|---|
| 1913 | [x,e] |
|---|
| 1914 | |
|---|
| 1915 | mustInstantiate: %Form -> %Thing |
|---|
| 1916 | mustInstantiate D == |
|---|
| 1917 | D is [fn,:.] and |
|---|
| 1918 | not (symbolMember?(fn,$DummyFunctorNames) or GET(fn,"makeFunctionList")) |
|---|
| 1919 | |
|---|
| 1920 | wrapDomainSub: (%List %Form, %Form) -> %Form |
|---|
| 1921 | wrapDomainSub(parameters,x) == |
|---|
| 1922 | ["DomainSubstitutionMacro",parameters,x] |
|---|
| 1923 | |
|---|
| 1924 | mkExplicitCategoryFunction(domainOrPackage,sigList,atList) == |
|---|
| 1925 | body:= |
|---|
| 1926 | ["mkCategory",MKQ domainOrPackage,['%list,:reverse sigList], |
|---|
| 1927 | ['%list,:reverse atList],MKQ domList,nil] where |
|---|
| 1928 | domList() == |
|---|
| 1929 | ("union"/[fn sig for ["QUOTE",[[.,sig,:.],:.]] in sigList]) where |
|---|
| 1930 | fn sig == [D for D in sig | mustInstantiate D] |
|---|
| 1931 | parameters:= |
|---|
| 1932 | removeDuplicates |
|---|
| 1933 | ("append"/ |
|---|
| 1934 | [[x for x in sig | ident? x and x~='_$] |
|---|
| 1935 | for ["QUOTE",[[.,sig,:.],:.]] in sigList]) |
|---|
| 1936 | wrapDomainSub(parameters,body) |
|---|
| 1937 | |
|---|
| 1938 | DomainSubstitutionFunction(parameters,body) == |
|---|
| 1939 | --see definition of DomainSubstitutionMacro in SPAD LISP |
|---|
| 1940 | if parameters then |
|---|
| 1941 | (body := Subst(parameters,body)) where |
|---|
| 1942 | Subst(parameters,body) == |
|---|
| 1943 | body isnt [.,:.] => |
|---|
| 1944 | symbolMember?(body,parameters) => MKQ body |
|---|
| 1945 | body |
|---|
| 1946 | listMember?(body,parameters) => |
|---|
| 1947 | g := gensym() |
|---|
| 1948 | $extraParms := PUSH([g,:body],$extraParms) |
|---|
| 1949 | --Used in SetVector12 to generate a substitution list |
|---|
| 1950 | --bound in buildFunctor |
|---|
| 1951 | --For categories, bound and used in compDefineCategory |
|---|
| 1952 | MKQ g |
|---|
| 1953 | body.op = "QUOTE" => body |
|---|
| 1954 | cons? $definition and |
|---|
| 1955 | isFunctor body.op and |
|---|
| 1956 | body.op ~= $definition.op |
|---|
| 1957 | => ['QUOTE,simplifyVMForm body] |
|---|
| 1958 | [Subst(parameters,u) for u in body] |
|---|
| 1959 | body isnt ["Join",:.] => body |
|---|
| 1960 | $definition isnt [.,:.] => body |
|---|
| 1961 | null $definition.args => body |
|---|
| 1962 | --should not bother if it will only be called once |
|---|
| 1963 | name := makeSymbol strconc(KAR $definition,";CAT") |
|---|
| 1964 | SETANDFILE(name,nil) |
|---|
| 1965 | body := ['%when,[name],['%otherwise,['%store,name,body]]] |
|---|
| 1966 | body |
|---|
| 1967 | |
|---|
| 1968 | |
|---|
| 1969 | ++ Subroutine of compCategoryItem. |
|---|
| 1970 | ++ Compile exported signature `opsig' under predicate `pred' in |
|---|
| 1971 | ++ environment `env'. |
|---|
| 1972 | compSignature(opsig,pred,env) == |
|---|
| 1973 | [op,:sig] := opsig |
|---|
| 1974 | cons? op => |
|---|
| 1975 | for y in op repeat |
|---|
| 1976 | compSignature([y,:sig],pred,env) |
|---|
| 1977 | op in '(per rep) => |
|---|
| 1978 | stackSemanticError(['"cannot export signature for", :bright op],nil) |
|---|
| 1979 | nil |
|---|
| 1980 | noteExport(opsig,pred) |
|---|
| 1981 | PUSH(MKQ [opsig,pred],$sigList) |
|---|
| 1982 | |
|---|
| 1983 | compCategoryItem(x,predl,env) == |
|---|
| 1984 | x is nil => nil |
|---|
| 1985 | --1. if x is a conditional expression, recurse; otherwise, form the predicate |
|---|
| 1986 | x is ['%when,[p,e]] => |
|---|
| 1987 | predl':= [p,:predl] |
|---|
| 1988 | e is ["PROGN",:l] => |
|---|
| 1989 | for y in l repeat compCategoryItem(y,predl',env) |
|---|
| 1990 | compCategoryItem(e,predl',env) |
|---|
| 1991 | x is ["IF",a,b,c] => |
|---|
| 1992 | a is ["not",p] => compCategoryItem(["IF",p,c,b],predl,env) |
|---|
| 1993 | a is ["and",p,q] => |
|---|
| 1994 | compCategoryItem(["IF",p,["IF",q,b,c],COPY c],predl,env) |
|---|
| 1995 | a is ["or",p,q] => |
|---|
| 1996 | compCategoryItem(["IF",p,b,["IF",q,COPY b,c]],predl,env) |
|---|
| 1997 | predl':= [a,:predl] |
|---|
| 1998 | if b~="%noBranch" then |
|---|
| 1999 | b is ["PROGN",:l] => |
|---|
| 2000 | for y in l repeat compCategoryItem(y,predl',env) |
|---|
| 2001 | compCategoryItem(b,predl',env) |
|---|
| 2002 | c="%noBranch" => nil |
|---|
| 2003 | predl':= [["not",a],:predl] |
|---|
| 2004 | c is ["PROGN",:l] => |
|---|
| 2005 | for y in l repeat compCategoryItem(y,predl',env) |
|---|
| 2006 | compCategoryItem(c,predl',env) |
|---|
| 2007 | pred := (predl => MKPF(predl,"AND"); true) |
|---|
| 2008 | |
|---|
| 2009 | --2. if attribute, push it and return |
|---|
| 2010 | x is ["ATTRIBUTE",y] => |
|---|
| 2011 | -- Attribute 'nil' carries no semantics. |
|---|
| 2012 | y = "nil" => nil |
|---|
| 2013 | noteExport(y,pred) |
|---|
| 2014 | PUSH(MKQ [y,pred],$atList) |
|---|
| 2015 | |
|---|
| 2016 | --3. it may be a list, with PROGN as the first, and some information as the rest |
|---|
| 2017 | x is ["PROGN",:l] => |
|---|
| 2018 | for u in l repeat |
|---|
| 2019 | compCategoryItem(u,predl,env) |
|---|
| 2020 | |
|---|
| 2021 | -- 4. otherwise, x gives a signature for a |
|---|
| 2022 | -- single operator name or a list of names; if a list of names, |
|---|
| 2023 | -- recurse |
|---|
| 2024 | x is ["SIGNATURE",:opsig] => compSignature(opsig,pred,env) |
|---|
| 2025 | systemErrorHere ["compCategoryItem",x] |
|---|
| 2026 | |
|---|
| 2027 | compCategory: (%Form,%Mode,%Env) -> %Maybe %Triple |
|---|
| 2028 | compCategory(x,m,e) == |
|---|
| 2029 | clearExportsTable() |
|---|
| 2030 | (m:= resolve(m,$Category))=$Category and x is ['CATEGORY, |
|---|
| 2031 | domainOrPackage,:l] => |
|---|
| 2032 | $sigList: local := nil |
|---|
| 2033 | $atList: local := nil |
|---|
| 2034 | for x in l repeat compCategoryItem(x,nil,e) |
|---|
| 2035 | rep:= mkExplicitCategoryFunction(domainOrPackage,$sigList,$atList) |
|---|
| 2036 | --if inside compDefineCategory, provide for category argument substitution |
|---|
| 2037 | [rep,m,e] |
|---|
| 2038 | systemErrorHere ["compCategory",x] |
|---|
| 2039 | |
|---|
| 2040 | --% |
|---|
