1-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. 2-- All rights reserved. 3-- 4-- Redistribution and use in source and binary forms, with or without 5-- modification, are permitted provided that the following conditions are 6-- met: 7-- 8-- - Redistributions of source code must retain the above copyright 9-- notice, this list of conditions and the following disclaimer. 10-- 11-- - Redistributions in binary form must reproduce the above copyright 12-- notice, this list of conditions and the following disclaimer in 13-- the documentation and/or other materials provided with the 14-- distribution. 15-- 16-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the 17-- names of its contributors may be used to endorse or promote products 18-- derived from this software without specific prior written permission. 19-- 20-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS 21-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED 22-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A 23-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER 24-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 25-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 26-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 27-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 28-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 29-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 30-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 32)package "BOOT" 33 34DEFPARAMETER($newCompCompare, false) 35 36--% FUNCTIONS WHICH MUNCH ON == STATEMENTS 37 38compDefine(form,m,e) == 39 result:= compDefine1(form,m,e) 40 result 41 42compDefine1(form,m,e) == 43 --1. decompose after macro-expanding form 44 ['DEF,lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e) 45 $insideWhereIfTrue and isMacro(form,e) and (m=$EmptyMode or m=$NoValueMode) 46 => [lhs,m,put(first lhs,'macro,rhs,e)] 47 null signature.target and not MEMQ(IFCAR rhs, $ConstructorNames) and 48 (sig:= getSignatureFromMode(lhs,e)) => 49 -- here signature of lhs is determined by a previous declaration 50 compDefine1(['DEF,lhs,[first sig,:rest signature],specialCases,rhs],m,e) 51 $insideCapsuleFunctionIfTrue => 52 compInternalFunction(form, m, e) 53 if signature.target=$Category then $insideCategoryIfTrue:= true 54 55-- RDJ (11/83): when argument and return types are all declared, 56-- or arguments have types declared in the environment, 57-- and there is no existing modemap for this signature, add 58-- the modemap by a declaration, then strip off declarations and recurse 59 e := compDefineAddSignature(lhs,signature,e) 60-- 2. if signature list for arguments is not empty, replace ('DEF,..) by 61-- ('where,('DEF,..),..) with an empty signature list; 62-- otherwise, fill in all NILs in the signature 63 not (and/[null x for x in rest signature]) => compDefWhereClause(form,m,e) 64 signature.target=$Category => 65 compDefineCategory(form, m, e, nil, $formalArgList) 66 isDomainForm(rhs,e) and not $insideFunctorIfTrue => 67 if null signature.target then signature:= 68 [getTargetFromRhs(lhs,rhs,giveFormalParametersValues(rest lhs,e)),: 69 rest signature] 70 rhs:= addEmptyCapsuleIfNecessary(signature.target,rhs) 71 new_prefix := getAbbreviation(first(lhs), #(rest(lhs))) 72 compDefineFunctor(['DEF, lhs, signature, specialCases, rhs], m, e, 73 new_prefix, $formalArgList) 74 null($functorForm) => stackAndThrow ['"bad == form ",form] 75 compDefineCapsuleFunction(form, m, e, $prefix, $formalArgList) 76 77compDefineAddSignature([op,:argl],signature,e) == 78 (sig:= hasFullSignature(argl,signature,e)) and 79 not assoc(['$,:sig],LASSOC('modemap,getProplist(op,e))) => 80 declForm:= 81 [":",[op,:[[":",x,m] for x in argl for m in rest sig]],first signature] 82 [.,.,e]:= comp(declForm,$EmptyMode,e) 83 e 84 e 85 86hasFullSignature(argl,[target,:ml],e) == 87 target => 88 u:= [m or get(x,"mode",e) or return 'failed for x in argl for m in ml] 89 u~='failed => [target,:u] 90 91addEmptyCapsuleIfNecessary(target,rhs) == 92 MEMQ(IFCAR rhs, $SpecialDomainNames) => rhs 93 ['add,rhs,['CAPSULE]] 94 95getTargetFromRhs(lhs,rhs,e) == 96 --undeclared target mode obtained from rhs expression 97 rhs is ['CAPSULE,:.] => 98 stackSemanticError(['"target category of ",lhs, 99 '" cannot be determined from definition"],nil) 100 rhs is ['SubDomain,D,:.] => getTargetFromRhs(lhs,D,e) 101 rhs is ['add,D,['CAPSULE,:.]] => getTargetFromRhs(lhs,D,e) 102 rhs is ['Record,:l] => ['RecordCategory,:l] 103 rhs is ['Union,:l] => ['UnionCategory,:l] 104 [.,target,.]:= compOrCroak(rhs,$EmptyMode,e) 105 target is ["Category"] => 106 stackAndThrow(['"Only domains and packages can get mode form target", 107 lhs]) 108 target 109 110giveFormalParametersValues(argl,e) == 111 for x in argl repeat 112 e:= put(x,'value,[genSomeVariable(),get(x,'mode,e),nil],e) 113 e 114 115macroExpandInPlace(x,e) == 116 y:= macroExpand(x,e) 117 atom x or atom y => y 118 RPLACA(x,first y) 119 RPLACD(x,rest y) 120 x 121 122macroExpand(x,e) == --not worked out yet 123 atom x => 124 u := get(x, 'macro, e) => 125 null(rest(u)) => 126 macroExpand(first u, e) 127 SAY(["u =", u]) 128 userError("macro call needs arguments") 129 x 130 x is ['DEF,lhs,sig,spCases,rhs] => 131 ['DEF,macroExpand(lhs,e),macroExpandList(sig,e),macroExpandList(spCases,e), 132 macroExpand(rhs,e)] 133 x is [op, :args] => 134 ATOM(op) => 135 u := get(op, 'macro, e) => 136 margs := rest(u) 137 u := first(u) 138 null(margs) => [macroExpand(u, e), :macroExpandList(args, e)] 139 #args = #margs => 140 macroExpand(SUBLISLIS(args, margs, u), e) 141 userError("invalid macro call, #args ~= #margs") 142 [op, :macroExpandList(args, e)] 143 macroExpandList(x,e) 144 macroExpandList(x,e) 145 146macroExpandList(l,e) == 147 [macroExpand(x,e) for x in l] 148 149compDefineCategory1(df is ['DEF,form,sig,sc,body],m,e,prefix,fal) == 150 categoryCapsule := 151--+ 152 body is ['add,cat,capsule] => 153 body := cat 154 capsule 155 nil 156 [d,m,e]:= compDefineCategory2(form,sig,sc,body,m,e,prefix,fal) 157--+ next two lines 158 if categoryCapsule and not $bootStrapMode then [.,.,e] := 159 $insideCategoryPackageIfTrue: local := true --see NRTmakeSlot1 160--> 161 $categoryPredicateList: local := 162 makeCategoryPredicates(form,$lisplibCategory) 163 compDefine1(mkCategoryPackage(form, cat, categoryCapsule, e), 164 $EmptyMode, e) 165 [d,m,e] 166 167makeCategoryPredicates(form,u) == 168 $tvl := TAKE(#rest form,$TriangleVariableList) 169 $mvl := TAKE(#rest form,rest $FormalMapVariableList) 170 fn(u,nil) where 171 fn(u,pl) == 172 u is ['Join,:.,a] => fn(a,pl) 173 u is ['has,:.] => insert(EQSUBSTLIST($mvl,$tvl,u),pl) 174 u is [op, :.] and MEMQ(op, ["SIGNATURE", "ATTRIBUTE"]) => 175 -- EQ(op, 'ATTRIBUTE) => BREAK() 176 pl 177 atom u => pl 178 fnl(u,pl) 179 fnl(u,pl) == 180 for x in u repeat pl := fn(x,pl) 181 pl 182 183--+ the following function 184mkCategoryPackage(form is [op, :argl], cat, def, e) == 185 packageName:= INTERN(STRCONC(PNAME op,'"&")) 186 packageAbb := INTERN(STRCONC(GETDATABASE(op,'ABBREVIATION),'"-")) 187 $options:local := [] 188 -- This stops the next line from becoming confused 189 abbreviationsSpad2Cmd ['domain,packageAbb,packageName] 190 -- This is a little odd, but the parser insists on calling 191 -- domains, rather than packages 192 nameForDollar := first SETDIFFERENCE('(S A B C D E F G H I),argl) 193 packageArgl := [nameForDollar,:argl] 194 capsuleDefAlist := fn(def,nil) where fn(x,oplist) == 195 atom x => oplist 196 x is ['DEF,y,:.] => [y,:oplist] 197 fn(rest x,fn(first x,oplist)) 198 explicitCatPart := gn cat where gn cat == 199 cat is ['CATEGORY,:.] => rest rest cat 200 cat is ['Join,:u] => gn last u 201 nil 202 catvec := eval mkEvalableCategoryForm(form, e) 203 fullCatOpList := (JoinInner([catvec])).1 204 catOpList := 205 --note: this gets too many modemaps in general 206 -- this is cut down in NRTmakeSlot1 207 [['SIGNATURE,op1,sig] for [[op1,sig],:.] in fullCatOpList 208 --above line calls the category constructor just compiled 209 | assoc(op1,capsuleDefAlist)] 210 null catOpList => nil 211 packageCategory := ['CATEGORY,'domain, 212 :SUBLISLIS(argl,$FormalMapVariableList,catOpList)] 213 nils:= [nil for x in argl] 214 packageSig := [packageCategory,form,:nils] 215 $categoryPredicateList := SUBST(nameForDollar,'$,$categoryPredicateList) 216 SUBST(nameForDollar,'$, 217 ['DEF,[packageName,:packageArgl],packageSig,[nil,:nils],def]) 218 219compDefineCategory2(form,signature,specialCases,body,m,e, 220 $prefix,$formalArgList) == 221 --1. bind global variables 222 $insideCategoryIfTrue: local:= true 223 $definition : local := form 224 --used by DomainSubstitutionFunction 225 $extraParms: local := nil 226 --Set in DomainSubstitutionFunction, used further down 227-- 1.1 augment e to add declaration $: <form> 228 $op: local := nil 229 [$op, :argl] := form 230 e := addBinding("$", [['mode, :form]],e) 231 232-- 2. obtain signature 233 signature':= 234 [first signature, :[getArgumentModeOrMoan(a, form, e) for a in argl]] 235 e:= giveFormalParametersValues(argl,e) 236 237-- 3. replace arguments by $1,..., substitute into body, 238-- and introduce declarations into environment 239 sargl:= TAKE(# argl, $TriangleVariableList) 240 sform := [$op, :sargl] 241 $functorForm : local := sform 242 $formalArgList:= [:sargl,:$formalArgList] 243 aList:= [[a,:sa] for a in argl for sa in sargl] 244 formalBody:= SUBLIS(aList,body) 245 signature' := SUBLIS(aList,signature') 246--Begin lines for category default definitions 247 $functionStats: local:= [0,0] 248 $functorStats: local:= [0,0] 249 $addForm: local:= nil 250 $functor_cosig1 : local := [categoryForm?(t) for t in rest(signature')] 251 for x in sargl for t in rest signature' repeat 252 [.,.,e]:= compMakeDeclaration([":",x,t],m,e) 253 254-- 4. compile body in environment of type declarations for arguments 255 op':= $op 256 -- following line causes cats with no with or Join to be fresh copies 257 if opOf(formalBody)~='Join and opOf(formalBody)~='mkCategory then 258 formalBody := ['Join, formalBody] 259 body:= optFunctorBody (compOrCroak(formalBody,signature'.target,e)).expr 260 if $extraParms then 261 formals:=actuals:=nil 262 for u in $extraParms repeat 263 formals := [first u, :formals] 264 actuals:=[MKQ CDR u,:actuals] 265 body := ['sublisV, ['MAKE_PAIRS, ['QUOTE, formals], 266 ['LIST, :actuals]], body] 267 if argl then body:= -- always subst for args after extraparms 268 ['sublisV, ['MAKE_PAIRS, ['QUOTE, sargl], ['LIST, :sargl]], body] 269 -- FIXME: generate call to 'devaluate' only for domains 270 body:= 271 ['PROG1, ['LET, g:= GENSYM(), body], 272 ['SETELT, g, 0, mkConstructor(sform)]] 273 fun := do_compile([op', ['category_functor, sargl, body]], e) 274 275-- 5. give operator a 'modemap property 276 pairlis:= [[a,:v] for a in argl for v in $FormalMapVariableList] 277 parSignature:= SUBLIS(pairlis,signature') 278 parForm:= SUBLIS(pairlis,form) 279 --Equivalent to the following two lines, we hope 280 if null sargl then 281 evalAndRwriteLispForm('NILADIC, 282 ['MAKEPROP,['QUOTE,op'],'(QUOTE NILADIC),true]) 283 284-- 6. put modemaps into InteractiveModemapFrame 285 $lisplibCategory:= formalBody 286 if $LISPLIB then 287 $lisplibForm:= form 288 $lisplibKind:= 'category 289 modemap:= [[parForm,:parSignature],[true,op']] 290 $lisplibModemap:= modemap 291 $lisplibParents := 292 getParentsFor($op,$FormalMapVariableList,$lisplibCategory) 293 $lisplibAncestors := computeAncestorsOf(sform, nil) 294 $lisplibAbbreviation := constructor? $op 295 domainShell := eval [op', :MAPCAR('MKQ, sargl)] 296 augLisplibModemapsFromCategory(sform, formalBody, signature', 297 domainShell) 298 [fun, '(Category), e] 299 300mkConstructor form == 301 atom form => BREAK() 302 null rest form => ['QUOTE,[first form]] 303 ['LIST, MKQ first form, :rest(form)] 304 305compDefineCategory(df,m,e,prefix,fal) == 306 $lisplibCategory: local := nil 307 not $insideFunctorIfTrue and $LISPLIB => 308 compDefineLisplib(df,m,e,prefix,fal,'compDefineCategory1) 309 compDefineCategory1(df,m,e,prefix,fal) 310 311compDefineFunctor(df,m,e,prefix,fal) == 312 $domainShell: local -- holds the category of the object being compiled 313 $LISPLIB => compDefineLisplib(df,m,e,prefix,fal,'compDefineFunctor1) 314 compDefineFunctor1(df,m,e,prefix,fal) 315 316compDefineFunctor1(df is ['DEF,form,signature,$functorSpecialCases,body], 317 m, e, $prefix, $formalArgList) == 318-- 1. bind global variables 319 $addForm: local := nil 320 321 $functionStats: local:= [0,0] 322 $functorStats: local:= [0,0] 323 $signature: local := nil 324 $Representation: local := nil 325 --Set in doIt, accessed in the compiler - compNoStacking 326 $functorLocalParameters: local := nil 327 $CheckVectorList: local := nil 328 --prevents CheckVector from printing out same message twice 329 $insideFunctorIfTrue: local:= true 330 $genSDVar: local:= 0 331 originale := e 332 $op: local := nil 333 [$op,:argl]:= form 334 $formalArgList:= [:argl,:$formalArgList] 335 $pairlis := [[a,:v] for a in argl for v in $FormalMapVariableList] 336 $mutableDomain: local := 337 -- all defaulting packages should have caching turned off 338 isCategoryPackageName $op or 339 (if BOUNDP '$mutableDomains then MEMQ($op,$mutableDomains) 340 else false ) --true if domain has mutable state 341 signature':= 342 [first signature, :[getArgumentModeOrMoan(a, form, e) for a in argl]] 343 $functorForm : local := form 344 if null first signature' then BREAK() 345 target:= first signature' 346 e := giveFormalParametersValues(argl, e) 347 [ds, ., e] := compMakeCategoryObject(target, e) or 348 sayBrightly '" cannot produce category object:" 349 pp target 350 userError '"cannot produce category object" 351--+ copy needed since slot1 is reset; compMake.. can return a cached vector 352 base_shell := COPY_-SEQ ds 353 $domainShell := base_shell 354--+ 7 lines for $NRT follow 355-->--these globals used by NRTmakeCategoryAlist, set by NRTsetVector4Part1 356 $condAlist: local := nil 357 $uncondAlist: local := nil 358-->>-- next global initialized here, reset by NRTbuildFunctor 359 $NRTslot1PredicateList: local := nil 360 --this is used below to set $lisplibSlot1 global 361 $NRTbase: local := 6 -- equals length of $domainShell 362 $NRTaddForm: local := nil -- see compAdd; NRTmakeSlot1 363 $NRTdeltaLength: local := 0 -- length of $NRTdeltaList 364 $NRTdeltaList: local := nil --list of misc. elts used in compiled fncts 365 -- parallel to $NRTdeltaList, list of COMP-ed forms for $NRTdeltaList 366 $NRTdeltaListComp: local := nil 367 -- the above optimizes the calls to local domains 368 $template: local:= nil --stored in the lisplib (if $NRTvec = true) 369 $functionLocations: local := nil --locations of defined functions in source 370 $functor_cosig1 : local := [categoryForm?(t) for t in rest(signature')] 371 -- generate slots for arguments first, then for $NRTaddForm in compAdd 372 for x in argl repeat NRTgetLocalIndex(x, e) 373 [., ., e] := compMakeDeclaration([":", '_$, target], m, e) 374 375 376 if $insideCategoryPackageIfTrue~= true then 377 e := augModemapsFromCategory('_$, '_$, '_$, target, e) 378 $signature:= signature' 379 parSignature:= SUBLIS($pairlis,signature') 380 parForm:= SUBLIS($pairlis,form) 381 382-- (3.1) now make a list of the functor's local parameters; for 383-- domain D in argl,check its signature: if domain, its type is Join(A1,..,An); 384-- in this case, D is replaced by D1,..,Dn (gensyms) which are set 385-- to the A1,..,An view of D 386--+ 387 $functorLocalParameters := argl 388 e := makeFunctorArgumentParameters(argl, rest signature', 389 first signature', e) 390 -- must do above to bring categories into scope --see line 5 of genDomainView 391-- 4. compile body in environment of type declarations for arguments 392 op':= $op 393 rettype:= signature'.target 394 T := compFunctorBody(body, rettype, e, parForm, base_shell) 395 396 body':= T.expr 397 lamOrSlam := 398 $mutableDomain => 'mutable_domain_functor 399 'domain_functor 400 fun := do_compile(SUBLIS($pairlis, [op', [lamOrSlam, argl, body']]), e) 401 --The above statement stops substitutions getting in one another's way 402--+ 403 operationAlist := SUBLIS($pairlis,$lisplibOperationAlist) 404 if $LISPLIB then 405 augmentLisplibModemapsFromFunctor(parForm,operationAlist,parSignature) 406 $functorStats := addStats($functorStats, $functionStats) 407 reportOnFunctorCompilation($functorStats) 408 409-- 5. give operator a 'modemap property 410 if $LISPLIB then 411 modemap:= [[parForm,:parSignature],[true,op']] 412 $lisplibModemap:= modemap 413 $lisplibCategory := modemap.mmTarget 414 $lisplibParents := 415 getParentsFor($op,$FormalMapVariableList,$lisplibCategory) 416 $lisplibAncestors := computeAncestorsOf(form, nil) 417 $lisplibAbbreviation := constructor? $op 418 $insideFunctorIfTrue:= false 419 if $LISPLIB then 420 $lisplibKind:= 421------->This next line prohibits changing the KIND once given 422--------kk:=GETDATABASE($op,'CONSTRUCTORKIND) => kk 423 target is ["CATEGORY",key,:.] and key~="domain" => 'package 424 'domain 425 $lisplibForm:= form 426 if null $bootStrapMode then 427 NRTslot1Info := NRTmakeSlot1Info(form, base_shell) 428 libFn := GETDATABASE(op','ABBREVIATION) 429 $lookupFunction: local := 430 NRTgetLookupFunction(form, CADAR $lisplibModemap, $NRTaddForm) 431 --either lookupComplete (for forgetful guys) or lookupIncomplete 432 $byteAddress :local := 0 433 $byteVec :local := nil 434 $NRTslot1PredicateList := 435 [simpBool x for x in $NRTslot1PredicateList] 436 output_lisp_form(['MAKEPROP, MKQ $op, ''infovec, 437 getInfovecCode(NRTslot1Info, e)]) 438 $lisplibOperationAlist:= operationAlist 439 $lisplibMissingFunctions:= $CheckVectorList 440 if null argl then 441 evalAndRwriteLispForm('NILADIC, 442 ['MAKEPROP, ['QUOTE,op'], ['QUOTE,'NILADIC], true]) 443 [fun, ['Mapping, :signature'], originale] 444 445compFunctorBody(body, m, e, parForm, base_shell) == 446 $bootStrapMode = true => 447 genOperationAlist(base_shell) 448 [bootStrapError($functorForm, $edit_file), m, e] 449 T:= compOrCroak(body,m,e) 450 body is [op,:.] and MEMQ(op,'(add CAPSULE)) => T 451 $NRTaddForm := 452 body is ["SubDomain",domainForm,predicate] => domainForm 453 body 454 T 455 456reportOnFunctorCompilation(functorStats) == 457 displayMissingFunctions() 458 if $semanticErrorStack then sayBrightly '" " 459 displaySemanticErrors() 460 if $warningStack then sayBrightly '" " 461 displayWarnings() 462 [byteCount, elapsedSeconds] := functorStats 463 sayBrightly ['%l,:bright '" Cumulative Statistics for Constructor", 464 $op] 465 timeString := normalizeStatAndStringify elapsedSeconds 466 sayBrightly ['" Time:",:bright timeString,'"seconds"] 467 sayBrightly '" " 468 'done 469 470displayMissingFunctions() == 471 null $CheckVectorList => nil 472 loc := nil 473 exp := nil 474 for [[op,sig,:.],:pred] in $CheckVectorList | null pred repeat 475 null member(op,$formalArgList) and 476 getmode(op,$env) is ['Mapping,:.] => 477 loc := [[op,sig],:loc] 478 exp := [[op,sig],:exp] 479 if loc then 480 sayBrightly ['%l,:bright '" Missing Local Functions:"] 481 for [op,sig] in loc for i in 1.. repeat 482 sayBrightly ['" [",i,'"]",:bright op, 483 ": ",:formatUnabbreviatedSig sig] 484 if exp then 485 sayBrightly ['%l,:bright '" Missing Exported Functions:"] 486 for [op,sig] in exp for i in 1.. repeat 487 sayBrightly ['" [",i,'"]",:bright op, 488 ": ",:formatUnabbreviatedSig sig] 489 490--% domain view code 491 492makeFunctorArgumentParameters(argl, sigl, target, e) == 493 $forceAdd: local:= true 494 $ConditionalOperators: local := nil 495 $tmp_e := e 496 for a in argl for s in sigl repeat fn(a,augmentSig(s,findExtras(a,target))) 497 where 498 findExtras(a,target) == 499 -- see if conditional information implies anything else 500 -- in the signature of a 501 target is ['Join,:l] => "union"/[findExtras(a,x) for x in l] 502 target is ['CATEGORY,.,:l] => "union"/[findExtras1(a,x) for x in l] where 503 findExtras1(a,x) == 504 x is ['AND,:l] => "union"/[findExtras1(a,y) for y in l] 505 x is ['OR,:l] => "union"/[findExtras1(a,y) for y in l] 506 x is ['IF,c,p,q] => 507 union(findExtrasP(a,c), 508 union(findExtras1(a,p),findExtras1(a,q))) where 509 findExtrasP(a,x) == 510 x is ['AND,:l] => "union"/[findExtrasP(a,y) for y in l] 511 x is ['OR,:l] => "union"/[findExtrasP(a,y) for y in l] 512 x is ['has,=a,y] and y is ['SIGNATURE,:.] => [y] 513 nil 514 nil 515 augmentSig(s,ss) == 516 -- if we find something extra, add it to the signature 517 null ss => s 518 for u in ss repeat 519 $ConditionalOperators:=[CDR u,:$ConditionalOperators] 520 s is ['Join,:sl] => 521 u := ASSQ('CATEGORY, ss) => BREAK() 522 ['Join,:sl,['CATEGORY,'package,:ss]] 523 ['Join,s,['CATEGORY,'package,:ss]] 524 fn(a,s) == 525 not(ATOM(a)) => BREAK() 526 if isCategoryForm(s) then 527 s is ["Join", :catlist] => genDomainViewList(a, rest s) 528 genDomainView(a, s, "getDomainView") 529 $tmp_e 530 531genDomainViewList(id, catlist) == 532 null catlist => nil 533 catlist is [y] and not isCategoryForm(y) => nil 534 for c in catlist repeat 535 genDomainView(id, c, "getDomainView") 536 537genDomainView(viewName, c, viewSelector) == 538 c is ['CATEGORY, ., :l] => genDomainOps(viewName, viewName, c) 539 $tmp_e := augModemapsFromCategory(viewName, viewName, nil, c, $tmp_e) 540 541genDomainOps(viewName,dom,cat) == 542 oplist := getOperationAlist(dom, dom, cat) 543 siglist:= [sig for [sig,:.] in oplist] 544 oplist:= substNames(dom,viewName,dom,oplist) 545 for [opsig,cond,:.] in oplist for i in 0.. repeat 546 if opsig in $ConditionalOperators then cond:=nil 547 [op,sig]:=opsig 548 $tmp_e:= addModemap(op,dom,sig,cond,['ELT,viewName,i],$tmp_e) 549 550compDefWhereClause(['DEF,form,signature,specialCases,body],m,e) == 551-- form is lhs (f a1 ... an) of definition; body is rhs; 552-- signature is (t0 t1 ... tn) where t0= target type, ti=type of ai, i > 0; 553-- specialCases is (NIL l1 ... ln) where li is list of special cases 554-- which can be given for each ti 555 556-- removes declarative and assignment information from form and 557-- signature, placing it in list L, replacing form by ("where",form',:L), 558-- signature by a list of NILs (signifying declarations are in e) 559 $sigAlist: local := nil 560 $predAlist: local := nil 561 562-- 1. create sigList= list of all signatures which have embedded 563-- declarations moved into global variable $sigAlist 564 sigList:= 565 [transformType(x) for a in rest form for x in rest signature] 566 where 567 transformType x == 568 atom x => x 569 x is [":",R,Rtype] => 570 ($sigAlist:= [[R,:transformType Rtype],:$sigAlist]; x) 571 x is ['Record,:.] => x --RDJ 8/83 572 [first x,:[transformType y for y in rest x]] 573 574-- 2. replace each argument of the form (|| x p) by x, recording 575-- the given predicate in global variable $predAlist 576 argList:= 577 [removeSuchthat a for a in rest form] where 578 removeSuchthat x == 579 x is ["|",y,p] => 580 BREAK() 581 ($predAlist:= [[y,:p],:$predAlist]; y) 582 x 583 584 argList2 := [a for a in argList for t in sigList | not(NULL(t))] 585 sigList2 := [t for t in sigList | not(NULL(t))] 586 587-- 3. obtain a list of parameter identifiers (x1 .. xn) ordered so that 588-- the type of xi is independent of xj if i < j 589 varList:= 590 orderByDependency(ASSOCLEFT argDepAlist,ASSOCRIGHT argDepAlist) where 591 argDepAlist:= 592 [[x,:dependencies] for [x,:y] in argSigAlist] where 593 dependencies() == 594 union(listOfIdentifiersIn y, 595 delete(x,listOfIdentifiersIn LASSOC(x,$predAlist))) 596 argSigAlist:= [:$sigAlist,:pairList(argList2, sigList2)] 597 598-- 4. construct a WhereList which declares and/or defines the xi's in 599-- the order constructed in step 3 600 (whereList:= [addSuchthat(x,[":",x,LASSOC(x,argSigAlist)]) for x in varList]) 601 where addSuchthat(x,y) == (p:= LASSOC(x,$predAlist) => ["|",y,p]; y) 602 603-- 5. compile new ('DEF,("where",form',:WhereList),:.) where 604-- all argument parameters of form' are bound/declared in WhereList 605 comp(form',m,e) where 606 form':= 607 ["where",defform,:whereList] where 608 defform:= 609 ['DEF,form'',signature',specialCases,body] where 610 form'':= [first form,:argList] 611 signature':= [first signature,:[nil for x in rest signature]] 612 613orderByDependency(vl,dl) == 614 -- vl is list of variables, dl is list of dependency-lists 615 selfDependents:= [v for v in vl for d in dl | MEMQ(v,d)] 616 for v in vl for d in dl | MEMQ(v,d) repeat 617 (SAY(v," depends on itself"); fatalError:= true) 618 fatalError => userError '"Parameter specification error" 619 until (null vl) repeat 620 newl:= 621 [v for v in vl for d in dl | null intersection(d,vl)] or return nil 622 orderedVarList:= [:newl,:orderedVarList] 623 vl':= setDifference(vl,newl) 624 dl':= [setDifference(d,newl) for x in vl for d in dl | member(x,vl')] 625 vl:= vl' 626 dl:= dl' 627 REMDUP NREVERSE orderedVarList --ordered so ith is indep. of jth if i < j 628 629compInternalFunction(df is ['DEF,form,signature,specialCases,body], m, e) == 630 [op, :argl] := form 631 not(IDENTP(op)) => 632 stackAndThrow ['"Bad name for internal function:", op] 633 nbody := ["+->", argl, body] 634 fmode := ["Mapping", :signature] 635 [., ., e'] := compMakeDeclaration([":", op, fmode], $EmptyMode, e) 636 T := compWithMappingMode(nbody, fmode, e') 637 T or return nil 638 currentProplist := getProplist(op, e) 639 finish_setq_single(T, fmode, op, nbody, currentProplist) 640 641compDefineCapsuleFunction(df is ['DEF,form,signature,specialCases,body], 642 m,oldE,$prefix,$formalArgList) == 643 [lineNumber,:specialCases] := specialCases 644 e := oldE 645 --1. bind global variables 646 $functionStats: local:= [0,0] 647 $finalEnv: local := nil 648 --used by ReplaceExitEtc to get a common environment 649 $locVarsTypes: local := [] 650 $initCapsuleErrorCount: local:= #$semanticErrorStack 651 $insideCapsuleFunctionIfTrue: local:= true 652 $CapsuleModemapFrame: local:= e 653 $CapsuleDomainsInScope: local:= get("$DomainsInScope","special",e) 654 $returnMode:= m 655 $op: local := nil 656 [$op,:argl]:= form 657 $formalArgList:= [:argl,:$formalArgList] 658 659 --let target and local signatures help determine modes of arguments 660 argModeList:= 661 identSig:= hasSigInTargetCategory(argl,form,first signature,e) => 662 (e:= checkAndDeclare(argl,form,identSig,e); rest identSig) 663 [getArgumentModeOrMoan(a,form,e) for a in argl] 664 signature':= [first signature,:argModeList] 665 if null identSig then --make $op a local function 666 oldE := put($op,'mode,['Mapping,:signature'],oldE) 667 668 --obtain target type if not given 669 if null first signature' then signature':= 670 identSig => identSig 671 getSignature($op,rest signature',e) or return nil 672 673 --replace ##1,.. in signature by arguments 674-- pp signature' 675-- pp '"------after----" 676-- pp signature' 677 e:= giveFormalParametersValues(argl,e) 678 679 $signatureOfForm:= signature' --this global is bound in compCapsuleItems 680 $functionLocations := [[[$op, signature'], :lineNumber], 681 :$functionLocations] 682 e:= addDomain(first signature',e) 683 684 --4. introduce needed domains into extendedEnv 685 for domain in signature' repeat e:= addDomain(domain,e) 686 687 --6. compile body in environment with extended environment 688 rettype := resolve(signature'.target, $returnMode) 689 690 localOrExported := 691 null member($op,$formalArgList) and 692 getmode($op,e) is ['Mapping,:.] => 'local 693 'exported 694 695 --6a skip if compiling only certain items but not this one 696 -- could be moved closer to the top 697 formattedSig := formatUnabbreviated ['Mapping,:signature'] 698 sayBrightly ['" compiling ",localOrExported, 699 :bright $op,'": ",:formattedSig] 700 701 T := CATCH('compCapsuleBody, compOrCroak(body,rettype,e)) 702 or ["",rettype,e] 703--+ 704 NRTassignCapsuleFunctionSlot($op, signature', $domainShell, e) 705 if $newCompCompare=true then 706 SAY '"The old compiler generates:" 707 prTriple T 708-- A THROW to the above CATCH occurs if too many semantic errors occur 709-- see stackSemanticError 710 catchTag:= MKQ GENSYM() 711 fun:= 712 body':= replaceExitEtc(T.expr,catchTag,"TAGGEDreturn",$returnMode) 713 finalBody:= ["CATCH",catchTag,body'] 714 do_compile([$op, ["LAMBDA", [:argl, '_$], finalBody]], oldE) 715 $functorStats:= addStats($functorStats,$functionStats) 716 717 718-- 7. give operator a 'value property 719 val:= [fun,signature',e] 720 [fun,['Mapping,:signature'],oldE] -- oldE:= put($op,'value,removeEnv val,e) 721 722getSignatureFromMode(form,e) == 723 getmode(opOf form,e) is ['Mapping,:signature] => 724 #form~=#signature => stackAndThrow ["Wrong number of arguments: ",form] 725 EQSUBSTLIST(rest form,take(#rest form,$FormalMapVariableList),signature) 726 727hasSigInTargetCategory(argl,form,opsig,e) == 728 mList:= [getArgumentMode(x,e) for x in argl] 729 --each element is a declared mode for the variable or nil if none exists 730 potentialSigList:= 731 REMDUP 732 [sig 733 for [[opName,sig,:.],:.] in $domainShell.(1) | 734 fn(opName,sig,opsig,mList,form)] where 735 fn(opName,sig,opsig,mList,form) == 736 opName=$op and #sig=#form and (null opsig or opsig=first sig) and 737 (and/[compareMode2Arg(x,m) for x in mList for m in rest sig]) 738 c:= #potentialSigList 739 1=c => first potentialSigList 740 --accept only those signatures op right length which match declared modes 741 0=c => (#(sig:= getSignatureFromMode(form,e))=#form => sig; nil) 742 1<c => 743 sig:= first potentialSigList 744 stackWarning ["signature of lhs not unique:",:bright sig,"chosen"] 745 sig 746 nil --this branch will force all arguments to be declared 747 748compareMode2Arg(x,m) == null x or modeEqual(x,m) 749 750getArgumentModeOrMoan(x,form,e) == 751 getArgumentMode(x,e) or 752 stackSemanticError(["argument ",x," of ",form," is not declared"],nil) 753 754getArgumentMode(x,e) == 755 STRINGP x => x 756 m:= get(x,'mode,e) => m 757 758checkAndDeclare(argl,form,sig,e) == 759 760-- arguments with declared types must agree with those in sig; 761-- those that don't get declarations put into e 762 for a in argl for m in rest sig repeat 763 m1:= getArgumentMode(a,e) => 764 not modeEqual(m1,m) => 765 stack:= [" ",:bright a,'"must have type ",m, 766 '" not ",m1,'%l,:stack] 767 e:= put(a,'mode,m,e) 768 if stack then 769 sayBrightly ['" Parameters of ",:bright first form, 770 '" are of wrong type:",'%l,:stack] 771 e 772 773getSignature(op, argModeList, e) == 774 1=# 775 (sigl:= 776 REMDUP 777 [sig for [[dc, :sig], [pred, :.]] 778 in (mmList := get(op, 'modemap, e)) | dc='_$ and 779 rest sig=argModeList and known_in_env(pred, e)]) => first sigl 780 null sigl => 781 (u := getmode(op, e)) is ['Mapping, :sig] => sig 782 SAY '"************* USER ERROR **********" 783 SAY("available signatures for ",op,": ") 784 if null mmList 785 then SAY " NONE" 786 else for [[dc,:sig],:.] in mmList repeat printSignature(" ",op,sig) 787 printSignature("NEED ",op,["?",:argModeList]) 788 nil 789 for u in sigl repeat 790 for v in sigl | not (u=v) repeat 791 if SourceLevelSubsume(u,v) then sigl:= delete(v,sigl) 792 --before we complain about duplicate signatures, we should 793 --check that we do not have for example, a partial - as 794 --well as a total one. SourceLevelSubsume (from CATEGORY BOOT) 795 --should do this 796 1=#sigl => first sigl 797 stackSemanticError(["duplicate signatures for ",op,": ",argModeList],nil) 798 799 800putInLocalDomainReferences (def := [opName,[lam,varl,body]]) == 801 $elt: local := ($QuickCode => 'QREFELT; 'ELT) 802--+ 803 NRTputInTail CDDADR def 804 def 805 806 807isLocalFunction(op, e) == 808 null member(op, $formalArgList) and 809 getmode(op, e) is ['Mapping, :.] 810 811do_compile(u, e) == 812 [op,lamExpr] := u 813 if $suffix then 814 $suffix:= $suffix+1 815 op':= 816 opexport:=nil 817 opmodes:= 818 [sel 819 for [[DC, :sig], [., sel]] in get(op, 'modemap, e) | 820 DC='_$ and (opexport:=true) and 821 (and/[modeEqual(x,y) for x in sig for y in $signatureOfForm])] 822 isLocalFunction(op, e) => 823 if opexport then userError ['%b,op,'%d,'" is local and exported"] 824 INTERN STRCONC(encodeItem $prefix, '";", encodeItem op) 825 encodeFunctionName(op,$functorForm,$signatureOfForm,";",$suffix) 826 u:= [op',lamExpr] 827 optimizedBody:= optimizeFunctionDef u 828 stuffToCompile:= 829 if null $insideCapsuleFunctionIfTrue 830 then optimizedBody 831 else putInLocalDomainReferences optimizedBody 832 $doNotCompileJustPrint=true => (PRETTYPRINT stuffToCompile; op') 833 result:= spadCompileOrSetq stuffToCompile 834 functionStats:=[0,elapsedTime()] 835 $functionStats:= addStats($functionStats,functionStats) 836 printStats functionStats 837 result 838 839spadCompileOrSetq (form is [nam,[lam,vl,body]]) == 840 --bizarre hack to take account of the existence of "known" functions 841 --good for performance (LISPLLIB size, BPI size, NILSEC) 842 CONTAINED("",body) => sayBrightly ['" ",:bright nam,'" not compiled"] 843 if vl is [:vl',E] and body is [nam',: =vl'] then 844 output_lisp_form(['PUT,MKQ nam,MKQ 'SPADreplace,MKQ nam']) 845 sayBrightly ['" ",:bright nam,'"is replaced by",:bright nam'] 846 else if (ATOM body or and/[ATOM x for x in body]) 847 and vl is [:vl',E] and not CONTAINED(E,body) then 848 macform := ['XLAM,vl',body] 849 output_lisp_form(['PUT,MKQ nam,MKQ 'SPADreplace,MKQ macform]) 850 sayBrightly ['" ",:bright nam,'"is replaced by",:bright body] 851 $insideCapsuleFunctionIfTrue => first COMP form 852 compileConstructor form 853 854compileConstructor form == 855 u:= compileConstructor1 form 856 clearClams() --clear all CLAMmed functions 857 u 858 859compileConstructor1 (form:=[fn,[key,vl,:bodyl]]) == 860-- fn is the name of some category/domain/package constructor; 861-- we will cache all of its values on $ConstructorCache with reference 862-- counts 863 auxfn := INTERNL1(fn, '";") 864 output_lisp_form(["DECLAIM", ["NOTINLINE", auxfn]]) 865 if key = 'category_functor 866 then u := compAndDefine form 867 else u := COMP form 868 clearConstructorCache fn --clear cache for constructor 869 first u 870 871constructMacro (form is [nam,[lam,vl,body]]) == 872 not (and/[atom x for x in vl]) => 873 stackSemanticError(["illegal parameters for macro: ",vl],nil) 874 ["XLAM",vl':= [x for x in vl | IDENTP x],body] 875 876uncons x == 877 atom x => x 878 x is ["CONS",a,b] => [a,:uncons b] 879 880--% CAPSULE 881 882bootStrapError(functorForm,sourceFile) == 883 ['COND, _ 884 ['$bootStrapMode, _ 885 ['VECTOR,mkDomainConstructor functorForm,nil,nil,nil,nil,nil]], 886 [''T, ['systemError, ['LIST, ''%b, MKQ first functorForm, ''%d, '"from", _ 887 ''%b,MKQ namestring sourceFile,''%d,'"needs to be compiled"]]]] 888 889compAdd(['add,$addForm,capsule],m,e) == 890 $bootStrapMode = true => 891 if $addForm is ["@Tuple", :.] then code := nil 892 else [code,m,e]:= comp($addForm,m,e) 893 [['COND, _ 894 ['$bootStrapMode, _ 895 code],_ 896 [''T, ['systemError, ['LIST, ''%b, MKQ first $functorForm, ''%d, 897 '"from", ''%b, MKQ namestring($edit_file), ''%d, _ 898 '"needs to be compiled"]]]], 899 m, e] 900 $addFormLhs: local:= $addForm 901 addForm := $addForm 902 if $addForm is ["SubDomain",domainForm,predicate] then 903--+ 904 $NRTaddForm := domainForm 905 NRTgetLocalIndex(domainForm, e) 906 --need to generate slot for add form since all $ go-get 907 -- slots will need to access it 908 [$addForm, m1, e] := compSubDomain1(domainForm, predicate, m, e) 909 else 910--+ 911 $NRTaddForm := $addForm 912 [$addForm, m1, e]:= 913 $addForm is ["@Tuple", :.] => BREAK() 914 compOrCroak($addForm,$EmptyMode,e) 915 not(isCategoryForm(m1)) or m1 = '(Category) => 916 userError(concat('"need domain before 'add', got", addForm, 917 '"of type", m1)) 918 compCapsule(capsule,m,e) 919 920compTuple2Record u == ['Record,:[[":",i,x] for i in 1.. for x in rest u]] 921 922compCapsule(['CAPSULE,:itemList],m,e) == 923 $bootStrapMode = true => 924 [bootStrapError($functorForm, $edit_file), m, e] 925 compCapsuleInner(itemList,m,addDomain('_$,e)) 926 927compSubDomain(["SubDomain",domainForm,predicate],m,e) == 928 $addFormLhs: local:= domainForm 929 $addForm: local := nil 930 $NRTaddForm := domainForm 931 [$addForm,.,e]:= compSubDomain1(domainForm,predicate,m,e) 932--+ 933 compCapsule(['CAPSULE],m,e) 934 935compSubDomain1(domainForm,predicate,m,e) == 936 [.,.,e]:= 937 compMakeDeclaration([":","#1",domainForm],$EmptyMode,addDomain(domainForm,e)) 938 u:= 939 compOrCroak(predicate,$Boolean,e) or 940 stackSemanticError(["predicate: ",predicate, 941 " cannot be interpreted with #1: ",domainForm],nil) 942 prefixPredicate:= lispize u.expr 943 $lisplibSuperDomain:= 944 [domainForm,predicate] 945 evalAndRwriteLispForm('evalOnLoad2, 946 ['SETQ,'$CategoryFrame,['put,op':= ['QUOTE,$op],' 947 (QUOTE SuperDomain),dF':= ['QUOTE,domainForm],['put,dF','(QUOTE SubDomain),[ 948 'CONS,['QUOTE,[$op,:prefixPredicate]],['DELASC,op',['get,dF',' 949 (QUOTE SubDomain),'$CategoryFrame]]],'$CategoryFrame]]]) 950 [domainForm,m,e] 951 952compCapsuleInner(itemList,m,e) == 953 e:= addInformation(m,e) 954 --puts a new 'special' property of $Information 955 data:= ["PROGN",:itemList] 956 --RPLACd by compCapsuleItems and Friends 957 e:= compCapsuleItems(itemList,nil,e) 958 localParList:= $functorLocalParameters 959 code:= 960 $insideCategoryIfTrue and not $insideCategoryPackageIfTrue => BREAK() 961 processFunctor($functorForm, $signature, data, localParList, e) 962 [MKPF([code],"PROGN"),m,e] 963 964--% PROCESS FUNCTOR CODE 965 966processFunctor(form,signature,data,localParList,e) == 967 buildFunctor(form, signature, data, localParList, $domainShell, e) 968 969compCapsuleItems(itemlist, $predl, e) == 970 $signatureOfForm: local := nil 971 $suffix: local:= 0 972 for item in itemlist repeat e := compSingleCapsuleItem(item, $predl, e) 973 e 974 975compSingleCapsuleItem(item, $predl, e) == 976 doIt(macroExpandInPlace(item, e), $predl, e) 977 978doIt(item, $predl, e) == 979 $GENNO: local:= 0 980 item is ['SEQ,:l,['exit,1,x]] => 981 RPLACA(item,"PROGN") 982 RPLACA(LASTNODE item,x) 983 for it1 in rest item repeat e := compSingleCapsuleItem(it1, $predl, e) 984 --This will RPLAC as appropriate 985 e 986 isDomainForm(item, e) => 987 -- convert naked top level domains to import 988 u:= ['import, [first item,:rest item]] 989 userError ["Use: import ", [first item,:rest item]] 990 RPLACA(item,first u) 991 RPLACD(item,rest u) 992 doIt(item, $predl, e) 993 item is [":=", lhs, rhs, :.] => 994 not (compOrCroak(item, $EmptyMode, e) is [code, ., e]) => 995 stackSemanticError(["cannot compile assigned value to",:bright lhs],nil) 996 e 997 not (code is ['LET,lhs',rhs',:.] and atom lhs') => 998 code is ["PROGN",:.] => 999 stackSemanticError(["multiple assignment ",item," not allowed"],nil) 1000 e 1001 RPLACA(item,first code) 1002 RPLACD(item,rest code) 1003 e 1004 lhs:= lhs' 1005 if not member(IFCAR rhs, $NonMentionableDomainNames) and 1006 not MEMQ(lhs, $functorLocalParameters) then 1007 $functorLocalParameters:= [:$functorLocalParameters,lhs] 1008 if code is ['LET, ., rhs', :.] and isDomainForm(rhs', e) then 1009 if lhs="Rep" then 1010 -- FIXME: $Representation is set unconditionally, but 1011 -- assignment to Rep may be conditional ... 1012 $Representation := (get("Rep", 'value, e)).(0) 1013 --$Representation bound by compDefineFunctor, used in compNoStacking 1014--+ 1015--+ 1016--+ 1017 code is ['LET, :.] => 1018 RPLACA(item,($QuickCode => 'QSETREFV;'SETELT)) 1019 rhsCode:= 1020 rhs' 1021 RPLACD(item, ['$, NRTgetLocalIndex(lhs, e), rhsCode]) 1022 e 1023 RPLACA(item,first code) 1024 RPLACD(item,rest code) 1025 e 1026 item is [":", a, t] => 1027 [., ., e] := compOrCroak(item, $EmptyMode, e) 1028 e 1029 item is ['import,:doms] => 1030 for dom in doms repeat 1031 sayBrightly ['" importing ",:formatUnabbreviated dom] 1032 [., ., e] := compOrCroak(item, $EmptyMode, e) 1033 RPLACA(item,'PROGN) 1034 RPLACD(item,NIL) -- creates a no-op 1035 e 1036 item is ["IF", :.] => doItIf(item, $predl, e) 1037 item is ["where", b, :l] => doItWhere(item, $predl, e) 1038 item is ["MDEF", :.] => 1039 [., ., e] := compOrCroak(item, $EmptyMode, e) 1040 e 1041 item is ['DEF,[op,:.],:.] => 1042 [., ., e] := t := compOrCroak(item, $EmptyMode, e) 1043 RPLACA(item,"CodeDefine") 1044 --Note that DescendCode, in CodeDefine, is looking for this 1045 RPLACD(CADR item,[$signatureOfForm]) 1046 --This is how the signature is updated for buildFunctor to recognise 1047--+ 1048 functionPart:= ['dispatchFunction,t.expr] 1049 RPLACA(CDDR item,functionPart) 1050 RPLACD(CDDR item,nil) 1051 e 1052 u := compOrCroak(item, $EmptyMode, e) => 1053 ([code, ., e] := u; RPLACA(item, first code); RPLACD(item, rest code)) 1054 e 1055 true => cannotDo() 1056 1057isMacro(x,e) == 1058 x is ['DEF,[op,:args],signature,specialCases,body] and 1059 null get(op,'modemap,e) and null args and null get(op,'mode,e) 1060 and signature is [nil] => body 1061 1062-- FIXME: we ignore effects of computation of condition and 1063-- do not merge branches 1064doItIf(item is [., p, x, y], $predl, e) == 1065 olde := e 1066 [p', ., e] := comp(p, $Boolean, e) or userError ['"not a Boolean:", p] 1067 if x ~= "noBranch" then 1068 compSingleCapsuleItem(x, $predl, getSuccessEnvironment(p, e)) 1069 if y ~= "noBranch" then 1070 compSingleCapsuleItem(y, $predl, getInverseEnvironment(p, olde)) 1071 RPLACA(item, "COND") 1072 RPLACD(item, [[p', x], ['(QUOTE T), y]]) 1073 olde 1074 1075doItWhere(item is [.,form,:exprList], $predl, eInit) == 1076 $insideWhereIfTrue: local:= true 1077 e:= eInit 1078 u:= 1079 for it1 in exprList repeat 1080 e := compSingleCapsuleItem(it1, $predl, e) 1081 $insideWhereIfTrue:= false 1082 form1 := macroExpand(form, eBefore := e) 1083 eAfter := compSingleCapsuleItem(form1, $predl, e) 1084 eFinal:= 1085 del:= deltaContour(eAfter, eBefore) => addContour(del, eInit) 1086 eInit 1087 RPLACA(item, "PROGN") 1088 RPLACD(item, [["PROGN", :exprList], form1]) 1089 eFinal 1090 1091 1092--% CATEGORY AND DOMAIN FUNCTIONS 1093 1094compJoin(["Join",:argl],m,e) == 1095 catList:= [(compForMode(x,$Category,e) or return 'failed).expr for x in argl] 1096 catList='failed => stackSemanticError(["cannot form Join of: ",argl],nil) 1097 catList':= 1098 [extract for x in catList] where 1099 extract() == 1100 x is ["Join", ["mkCategory",:y]] => ["mkCategory",:y] 1101 isCategoryForm(x) => 1102 parameters:= 1103 union("append"/[getParms(y,e) for y in rest x],parameters) 1104 where getParms(y,e) == 1105 atom y => 1106 isDomainForm(y,e) => LIST y 1107 nil 1108 y is ['LENGTH,y'] => 1109 BREAK() 1110 [y,y'] 1111 LIST y 1112 x 1113 x is ["DomainSubstitutionMacro",pl,body] => 1114 parameters := union(pl, parameters) 1115 body is ["Join", ["mkCategory",:y]] => ["mkCategory",:y] 1116 body 1117 x is ["mkCategory",:.] => x 1118 atom x and getmode(x,e)=$Category => x 1119 stackSemanticError(["invalid argument to Join: ",x],nil) 1120 x 1121 T:= [wrapDomainSub(parameters,["Join",:catList']),$Category,e] 1122 convert(T,m) 1123 1124compForMode(x,m,e) == 1125 $compForModeIfTrue: local:= true 1126 comp(x,m,e) 1127 1128compMakeCategoryObject(c, e) == 1129 not isCategoryForm(c) => nil 1130 u := mkEvalableCategoryForm(c, e) => [c_eval u, $Category, e] 1131 nil 1132 1133quotifyCategoryArgument x == MKQ x 1134 1135makeCategoryForm(c,e) == 1136 not isCategoryForm(c) => nil 1137 [x,m,e]:= compOrCroak(c,$EmptyMode,e) 1138 [x,e] 1139 1140mk_acc() == [[], []] 1141 1142push_at_list(ati, acc) == acc.1 := [ati, :acc.1] 1143 1144get_at_list(acc) == acc.1 1145 1146push_sig_list(sig, acc) == acc.0 := [sig, :acc.0] 1147 1148get_sigs_list(acc) == acc.0 1149 1150compCategory(x,m,e) == 1151 (m:= resolve(m,["Category"]))=["Category"] and x is ['CATEGORY, 1152 domainOrPackage,:l] => 1153 acc := mk_acc() 1154 for x in l repeat compCategoryItem(x, nil, acc) 1155 rep := mkExplicitCategoryFunction(get_sigs_list(acc), get_at_list(acc)) 1156 --if inside compDefineCategory, provide for category argument substitution 1157 [rep,m,e] 1158 systemErrorHere '"compCategory" 1159 1160mkExplicitCategoryFunction(sigList, atList) == 1161 ["Join", 1162 ["mkCategory", ['LIST, :REVERSE sigList], ['LIST, 1163 :REVERSE atList], nil, nil]] 1164 1165wrapDomainSub(parameters,x) == 1166 ["DomainSubstitutionMacro",parameters,x] 1167 1168DomainSubstitutionFunction(definition, parameters,body) == 1169 --see optFunctorBody 1170 if parameters then 1171 (body:= Subst(definition, parameters,body)) where 1172 Subst(definition, parameters,body) == 1173 ATOM body => 1174 MEMQ(body,parameters) => MKQ body 1175 body 1176 member(body,parameters) => 1177 g:=GENSYM() 1178 $extraParms:=PUSH([g,:body],$extraParms) 1179 --Used in SetVector12 to generate a substitution list 1180 --bound in buildFunctor 1181 --For categories, bound and used in compDefineCategory 1182 MKQ g 1183 first body="QUOTE" => body 1184 PAIRP definition and 1185 isFunctor first body and 1186 first body ~= first definition 1187 => ['QUOTE,optimize body] 1188 [Subst(definition, parameters,u) for u in body] 1189 not (body is ["Join",:.]) => body 1190 body is ["Join", ["mkCategory", :.]] => body 1191 atom definition => body 1192 null rest definition => body 1193 --should not bother if it will only be called once 1194 name := INTERN STRCONC(IFCAR definition, ";CAT") 1195 output_lisp_defparameter(name, nil) 1196 body:= ["COND",[name],['(QUOTE T),['SETQ,name,body]]] 1197 body 1198 1199compCategoryItem(x, predl, acc) == 1200 x is nil => nil 1201 --1. if x is a conditional expression, recurse; otherwise, form the predicate 1202 x is ["COND",[p,e]] => 1203 predl':= [p,:predl] 1204 compCategoryItem(e, predl', acc) 1205 x is ["IF",a,b,c] => 1206 predl':= [a,:predl] 1207 if b ~= "noBranch" then compCategoryItem(b, predl', acc) 1208 c="noBranch" => nil 1209 predl':= [["not",a],:predl] 1210 compCategoryItem(c, predl', acc) 1211 pred:= (predl => MKPF(predl,"AND"); true) 1212 1213 --2. if attribute, push it and return 1214 x is ["ATTRIBUTE", 'nil] => BREAK() 1215 x is ["ATTRIBUTE", y] => 1216 -- should generate something else for conditional categories 1217 -- BREAK() 1218 push_at_list(MKQ [y, pred], acc) 1219 1220 --3. it may be a list, with PROGN as the CAR, and some information as the CDR 1221 x is ["PROGN", :l] => for u in l repeat compCategoryItem(u, predl, acc) 1222 1223-- 4. otherwise, x gives a signature for a 1224-- single operator name or a list of names; if a list of names, 1225-- recurse 1226 ["SIGNATURE",op,:sig]:= x 1227 null atom op => 1228 for y in op repeat compCategoryItem(["SIGNATURE", y, :sig], predl, acc) 1229 1230 --4. branch on a single type or a signature with source and target 1231 push_sig_list(MKQ [rest x, pred], acc) 1232