-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. -- All rights reserved. -- Copyright (C) 2007-2011, Gabriel Dos Reis. -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are -- met: -- -- - Redistributions of source code must retain the above copyright -- notice, this list of conditions and the following disclaimer. -- -- - Redistributions in binary form must reproduce the above copyright -- notice, this list of conditions and the following disclaimer in -- the documentation and/or other materials provided with the -- distribution. -- -- - Neither the name of The Numerical Algorithms Group Ltd. nor the -- names of its contributors may be used to endorse or promote products -- derived from this software without specific prior written permission. -- -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. import nruncomp import g_-error import database import modemap namespace BOOT module define where compDefine: (%Form,%Mode,%Env) -> %Maybe %Triple compSubDomain: (%Form,%Mode,%Env) -> %Maybe %Triple compCapsule: (%Form, %Mode, %Env) -> %Maybe %Triple compJoin: (%Form,%Mode,%Env) -> %Maybe %Triple compAdd: (%Form, %Mode, %Env) -> %Maybe %Triple compCategory: (%Form,%Mode,%Env) -> %Maybe %Triple --% $newCompCompare := false ++ List of mutable domains. $mutableDomains := nil ++ True if the current constructor being compiled instantiates ++ mutable domains or packages. Default is `false'. $mutableDomain := false ++ when non nil, holds the declaration number of a function in a capsule. $suffix := nil $doNotCompileJustPrint := false ++ stack of pending capsule function definitions. $capsuleFunctionStack := [] $functionStats := nil $functorStats := nil $lisplibCategory := nil $lisplibAncestors := nil $lisplibAbbreviation := nil $CheckVectorList := [] $pairlis := [] $functorTarget := nil $condAlist := [] $uncondAlist := [] $NRTslot1PredicateList := [] $NRTattributeAlist := [] $NRTslot1Info := nil $NRTdeltaListComp := [] $template := nil $signature := nil $isOpPackageName := false $lookupFunction := nil $byteAddress := nil $byteVec := nil $lisplibSlot1 := nil $sigAlist := [] $predAlist := [] $argumentConditionList := [] $finalEnv := nil $initCapsuleErrorCount := nil $CapsuleModemapFrame := nil $CapsuleDomainsInScope := nil $signatureOfForm := nil $addFormLhs := nil $lisplibSuperDomain := nil $sigList := [] $atList := [] ++ List of declarations appearing as side conditions of a where-expression. $whereDecls := nil ++ True if the current functor definition refines a domain. $subdomain := false --% compDefineAddSignature: (%Form,%Sig,%Env) -> %Env --% --======================================================================= -- Generate Code to Create Infovec --======================================================================= getInfovecCode() == --Function called by compDefineFunctor1 to create infovec at compile time ['LIST, MKQ makeDomainTemplate $template, MKQ makeCompactDirect $NRTslot1Info, MKQ NRTgenFinalAttributeAlist(), NRTmakeCategoryAlist(), MKQ $lookupFunction] --======================================================================= -- Generation of Domain Vector Template (Compile Time) --======================================================================= makeDomainTemplate vec == --NOTES: This function is called at compile time to create the template -- (slot 0 of the infovec); called by getInfovecCode from compDefineFunctor1 newVec := newShell # vec for index in 0..maxIndex vec repeat item := vectorRef(vec,index) null item => nil vectorRef(newVec,index) := atom item => item cons? first item => makeGoGetSlot(item,index) item $byteVec := "append"/reverse! $byteVec newVec makeGoGetSlot(item,index) == --NOTES: creates byte vec strings for LATCH slots --these parts of the $byteVec are created first; see also makeCompactDirect [sig,whereToGo,op,:flag] := item n := #sig - 1 newcode := [n,whereToGo,:makeCompactSigCode sig,index] $byteVec := [newcode,:$byteVec] curAddress := $byteAddress $byteAddress := $byteAddress + n + 4 [curAddress,:op] --======================================================================= -- Generate OpTable at Compile Time --======================================================================= --> called by getInfovecCode (see top of this file) from compDefineFunctor1 makeCompactDirect u == $predListLength :local := # $NRTslot1PredicateList $byteVecAcc: local := nil [nam,[addForm,:opList]] := u --pp opList d := [[op,y] for [op,:items] in opList | y := makeCompactDirect1(op,items)] $byteVec := [:$byteVec,:"append"/reverse! $byteVecAcc] LIST2VEC ("append"/d) makeCompactDirect1(op,items) == --NOTES: creates byte codes for ops implemented by the domain curAddress := $byteAddress $op: local := op --temp hack by RDJ 8/90 (see orderBySubsumption) newcodes := "append"/[u for y in orderBySubsumption items | u := fn y] or return nil $byteVecAcc := [newcodes,:$byteVecAcc] curAddress where fn y == [sig,:r] := y r = ['Subsumed] => n := #sig - 1 $byteAddress := $byteAddress + n + 4 [n,0,:makeCompactSigCode sig,0] --always followed by subsuming signature --identified by a 0 in slot position if r is [n,:s] then slot := n is [p,:.] => p --the rest is linenumber of function definition n predCode := s is [pred,:.] => predicateBitIndex pred 0 --> drop items which are not present (predCode = -1) predCode = -1 => return nil --> drop items with nil slots if lookup function is incomplete if null slot then $lookupFunction is 'lookupIncomplete => return nil slot := 1 --signals that operation is not present n := #sig - 1 $byteAddress := $byteAddress + n + 4 res := [n,predCode,:makeCompactSigCode sig,slot] res orderBySubsumption items == acc := subacc := nil for x in items repeat not ($op in '(Zero One)) and x is [.,.,.,'Subsumed] => subacc := [x,:subacc] acc := [x,:acc] y := z := nil for [a,b,:.] in subacc | b repeat --NOTE: b = nil means that the signature a will appear in acc, that this -- entry is be ignored (e.g. init: -> $ in ULS) while (u := assoc(b,subacc)) repeat b := second u u := assoc(b,acc) or systemError nil if null second u then u := [first u,1] --mark as missing operation y := [[a,'Subsumed],u,:y] --makes subsuming signature follow one subsumed z := insert(b,z) --mark a signature as already present [:y,:[w for (w := [c,:.]) in acc | not listMember?(c,z)]] --add those not subsuming makeCompactSigCode sig == [fn for x in sig] where fn() == x is "$$" => 2 x is "$" => 0 not integer? x => systemError ['"code vector slot is ",x,'"; must be number"] x --======================================================================= -- Generate Slot 4 Constructor Vectors --======================================================================= NRTmakeCategoryAlist() == $depthAssocCache: local := hashTable 'EQ $catAncestorAlist: local := nil pcAlist := [:[[x,:"T"] for x in $uncondAlist],:$condAlist] $levelAlist: local := depthAssocList [CAAR x for x in pcAlist] opcAlist := reverse! SORTBY(function NRTcatCompare,pcAlist) newPairlis := [[5 + i,:b] for [.,:b] in $pairlis for i in 1..] slot1 := [[a,:k] for [a,:b] in applySubst($pairlis,opcAlist) | (k := predicateBitIndex b) ~= -1] slot0 := [hasDefaultPackage opOf a for [a,:b] in slot1] sixEtc := [5 + i for i in 1..#$pairlis] formals := ASSOCRIGHT $pairlis for x in slot1 repeat x.first := applySubst(pairList(['$,:formals],["$$",:sixEtc]),first x) -----------code to make a new style slot4 ----------------- predList := ASSOCRIGHT slot1 --is list of predicate indices maxPredList := "MAX"/predList catformvec := ASSOCLEFT slot1 maxElement := "MAX"/$byteVec ['CONS, ['makeByteWordVec2,MAX(maxPredList,1),MKQ predList], ['CONS, MKQ LIST2VEC slot0, ['CONS, MKQ LIST2VEC [encodeCatform x for x in catformvec], ['makeByteWordVec2,maxElement,MKQ $byteVec]]]] --NOTE: this is new form: old form satisfies vector? CDDR form encodeCatform x == k := NRTassocIndex x => k atom x or atom rest x => x [first x,:[encodeCatform y for y in rest x]] NRTcatCompare [catform,:pred] == LASSOC(first catform,$levelAlist) hasDefaultPackage catname == defname := makeDefaultPackageName symbolName catname constructor? defname => defname nil --======================================================================= -- Compute the lookup function (complete or incomplete) --======================================================================= NRTgetLookupFunction(domform,exCategory,addForm) == domform := applySubst($pairlis,domform) addForm := applySubst($pairlis,addForm) $why: local := nil atom addForm => 'lookupComplete extends := NRTextendsCategory1(domform,exCategory,getExportCategory addForm) if null extends then [u,msg,:v] := $why SAY '"--------------non extending category----------------------" sayPatternMsg('"%1p of category %2p", [domform,u]) if v ~= nil then sayPatternMsg('"%1b %2p",[msg,first v]) else sayPatternMsg('"%1b",[msg]) SAY '"----------------------------------------------------------" extends => 'lookupIncomplete 'lookupComplete getExportCategory form == [op,:argl] := form op is 'Record => ['RecordCategory,:argl] op is 'Union => ['UnionCategory,:argl] op is 'Enumeration => ['EnumerationCategory,:argl] functorModemap := getConstructorModemapFromDB op [[.,target,:tl],:.] := functorModemap applySubst(pairList($FormalMapVariableList,argl),target) NRTextendsCategory1(domform,exCategory,addForm) == addForm is ["%Comma",:r] => and/[extendsCategory(domform,exCategory,x) for x in r] extendsCategory(domform,exCategory,addForm) --======================================================================= -- Compute if a domain constructor is forgetful functor --======================================================================= extendsCategory(dom,u,v) == --does category u extend category v (yes iff u contains everything in v) --is dom of category u also of category v? u=v => true v is ["Join",:l] => and/[extendsCategory(dom,u,x) for x in l] v is ["CATEGORY",.,:l] => and/[extendsCategory(dom,u,x) for x in l] v is ["SubsetCategory",cat,d] => extendsCategory(dom,u,cat) and isSubset(dom,d,$e) v := substSlotNumbers(v,$template,$functorForm) extendsCategoryBasic(dom,u,v) => true $why := v is ['SIGNATURE,op,sig] => [u,['" has no ",:formatOpSignature(op,sig)]] [u,'" has no",v] nil extendsCategoryBasic(dom,u,v) == v is ['IF,p,['ATTRIBUTE,c],.] => uVec := (compMakeCategoryObject(u,$EmptyEnvironment)).expr cons? c and isCategoryForm(c,nil) => slot4 := vectorRef(uVec,4) LASSOC(c,second slot4) is [=p,:.] slot2 := vectorRef(uVec,2) LASSOC(c,slot2) is [=p,:.] u is ["Join",:l] => or/[extendsCategoryBasic(dom,x,v) for x in l] u = v => true uVec := (compMakeCategoryObject(u,$EmptyEnvironment)).expr isCategoryForm(v,nil) => catExtendsCat?(u,v,uVec) v is ['SIGNATURE,op,sig] => or/[vectorRef(uVec,i) is [[=op,=sig],:.] for i in 6..maxIndex uVec] u is ['CATEGORY,.,:l] => v is ['IF,:.] => listMember?(v,l) false false catExtendsCat?(u,v,uvec) == u = v => true uvec := uvec or (compMakeCategoryObject(u,$EmptyEnvironment)).expr slot4 := vectorRef(uvec,4) prinAncestorList := first slot4 listMember?(v,prinAncestorList) => true vOp := KAR v if similarForm := assoc(vOp,prinAncestorList) then PRINT u sayBrightlyNT '" extends " PRINT similarForm sayBrightlyNT '" but not " PRINT v or/[catExtendsCat?(x,v,nil) for x in ASSOCLEFT second slot4] substSlotNumbers(form,template,domain) == form is [op,:.] and symbolMember?(op,allConstructors()) => expandType(form,template,domain) form is ['SIGNATURE,op,sig] => ['SIGNATURE,op,[substSlotNumbers(x,template,domain) for x in sig]] form is ['CATEGORY,k,:u] => ['CATEGORY,k,:[substSlotNumbers(x,template,domain) for x in u]] expandType(form,template,domain) expandType(lazyt,template,domform) == atom lazyt => expandTypeArgs(lazyt,template,domform) [functorName,:argl] := lazyt functorName is ":" => [functorName,first argl,expandTypeArgs(second argl,template,domform)] lazyt is ['local,x] => n := POSN1(x,$FormalMapVariableList) domform.(1 + n) [functorName,:[expandTypeArgs(a,template,domform) for a in argl]] expandTypeArgs(u,template,domform) == u is '$ => u --template.0 -------eliminate this as $ is rep by 0 integer? u => expandType(templateVal(template, domform, u), template,domform) u is ['NRTEVAL,y] => y --eval y u is ['QUOTE,y] => y atom u => u expandType(u,template,domform) templateVal(template,domform,index) == --returns a domform or a lazy slot index = 0 => BREAK() --template vectorRef(template,index) --% Subdomains ++ We are defining a functor with head given by `form', as a subdomain ++ of the domain designated by the domain form `super', and predicate ++ `pred' (a VM instruction form). Emit appropriate info into the ++ databases. emitSubdomainInfo(form,super,pred) == pred := applySubst!(pairList(form.args,$AtVariables),pred) super := applySubst!(pairList(form.args,$AtVariables),super) evalAndRwriteLispForm("evalOnLoad2",["noteSubDomainInfo", quoteForm form.op,quoteForm super, quoteForm pred]) ++ List of operations defined in a given capsule ++ Each item on this list is of the form ++ (op sig pred) ++ where ++ op: name of the operation ++ sig: signature of the operation ++ pred: scope predicate of the operation. $capsuleFunctions := nil ++ record that the operation `op' with signature `sig' and predicate ++ `pred' is defined in the current capsule of the current domain ++ being compiled. noteCapsuleFunctionDefinition(op,sig,pred) == listMember?([op,sig,pred],$capsuleFunctions) => stackAndThrow('"redefinition of %1b: %2 %3", [op,formatUnabbreviated ["Mapping",:sig],formatIf pred]) $capsuleFunctions := [[op,sig,pred],:$capsuleFunctions] ++ Clear the list of functions defined in the last domain capsule. clearCapsuleFunctionTable() == $capsuleFunctions := nil ++ List of exports (paireed with scope predicate) declared in ++ the category of the currend domain or package. ++ Note: for category packages, this list is nil. $exports := nil noteExport(form,pred) == -- don't recheck category package exports; we just check -- them when defining the category. Plus, we might actually -- get indirect duplicates, which is OK. $insideCategoryPackageIfTrue => nil listMember?([form,pred],$exports) => stackAndThrow('"redeclaration of %1 %2", [form,formatIf pred]) $exports := [[form,pred],:$exports] clearExportsTable() == $exports := nil makePredicate l == null l => true MKPF(l,"and") --% FUNCTIONS WHICH MUNCH ON == STATEMENTS ++ List of reserved identifiers for which the compiler has special ++ meanings and that shall not be redefined. $reservedNames == '(per rep _$) ++ Check that `var' (a variable of parameter name) is not a reversed name. checkVariableName var == symbolMember?(var,$reservedNames) => stackAndThrow('"You cannot use reserved name %1b as variable",[var]) var checkParameterNames parms == for p in parms repeat checkVariableName p compDefine(form,m,e) == $macroIfTrue: local := false compDefine1(form,m,e) ++ We are about to process the body of a capsule. Check the form of ++ `Rep' definition, and whether it is appropriate to activate the ++ implicitly generated morphisms ++ per: Rep -> % ++ rep: % -> Rep ++ as local inline functions. checkRepresentation: (%Form,%List %Form,%Env) -> %Env checkRepresentation(addForm,body,env) == domainRep := nil hasAssignRep := false -- assume code does not assign to Rep. viewFuns := nil null body => env -- Don't be too hard on nothing. -- Locate possible Rep definition for [stmt,:.] in tails body repeat stmt is ["%LET","Rep",val] => domainRep ~= nil => stackAndThrow('"You cannot assign to constant domain %1b",["Rep"]) if addForm = val then stackWarning('"OpenAxiom suggests removing assignment to %1b",["Rep"]) else if addForm ~= nil then stackWarning('"%1b differs from the base domain",["Rep"]) return hasAssignRep := true stmt is ["MDEF",["Rep",:.],:.] => stackWarning('"Consider using == definition for %1b",["Rep"]) return hasAssignRep := true stmt is ["IF",.,:l] or stmt is ["SEQ",:l] or stmt is ["exit",:l] => checkRepresentation(nil,l,env) stmt isnt ["DEF",[op,:args],sig,.,val] => nil -- skip for now. op in '(rep per) => domainRep ~= nil => stackAndThrow('"You cannot define implicitly generated %1b",[op]) viewFuns := [op,:viewFuns] op ~= "Rep" => nil -- we are only interested in Rep definition domainRep := val viewFuns ~= nil => stackAndThrow('"You cannot define both %1b and %2b",["Rep",:viewFuns]) -- A package has no "%". $functorKind = "package" => stackAndThrow('"You cannot define %1b in a package",["Rep"]) -- It is a mistake to define Rep in category defaults $insideCategoryPackageIfTrue => stackAndThrow('"You cannot define %1b in category defaults",["Rep"]) if args ~= nil then stackAndThrow('"%1b does take arguments",["Rep"]) if sig.target ~= nil then stackAndThrow('"You cannot specify type for %1b",["Rep"]) -- Now, trick the rest of the compiler into believing that -- `Rep' was defined the Old Way, for lookup purpose. stmt.op := "%LET" stmt.rest := ["Rep",domainRep] $useRepresentationHack := false -- Don't confuse `Rep' and `%'. -- Shall we perform the dirty tricks? if hasAssignRep then $useRepresentationHack := true -- Domain extensions with no explicit Rep definition have the -- the base domain as representation (at least operationally). else if null domainRep and addForm ~= nil then if $functorKind = "domain" and addForm isnt ["%Comma",:.] then domainRep := addForm is ["SubDomain",dom,.] => $subdomain := true dom addForm $useRepresentationHack := false env := putMacro('Rep,domainRep,env) env compDefine1: (%Form,%Mode,%Env) -> %Maybe %Triple compDefine1(form,m,e) == $insideExpressionIfTrue: local:= false --1. decompose after macro-expanding form ['DEF,lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e) $insideWhereIfTrue and isMacro(form,e) and (m=$EmptyMode or m=$NoValueMode) => [lhs,m,putMacro(lhs.op,rhs,e)] checkParameterNames lhs.args null signature.target and symbol? KAR rhs and not builtinConstructor? KAR rhs and (sig:= getSignatureFromMode(lhs,e)) => -- here signature of lhs is determined by a previous declaration compDefine1(['DEF,lhs,[sig.target,:signature.source],specialCases,rhs],m,e) if signature.target=$Category then $insideCategoryIfTrue:= true -- RDJ (11/83): when argument and return types are all declared, -- or arguments have types declared in the environment, -- and there is no existing modemap for this signature, add -- the modemap by a declaration, then strip off declarations and recurse e := compDefineAddSignature(lhs,signature,e) -- 2. if signature list for arguments is not empty, replace ('DEF,..) by -- ('where,('DEF,..),..) with an empty signature list; -- otherwise, fill in all NILs in the signature or/[x ~= nil for x in signature.source] => compDefWhereClause(form,m,e) signature.target=$Category => compDefineCategory(form,m,e,nil,$formalArgList) isDomainForm(rhs,e) and not $insideFunctorIfTrue => if null signature.target then signature:= [getTargetFromRhs(lhs,rhs,giveFormalParametersValues(lhs.args,e)),: signature.source] rhs:= addEmptyCapsuleIfNecessary(signature.target,rhs) compDefineFunctor(['DEF,lhs,signature,specialCases,rhs],m,e,nil, $formalArgList) null $form => stackAndThrow ['"bad == form ",form] newPrefix:= $prefix => makeSymbol strconc(encodeItem $prefix,'",",encodeItem $op) getConstructorAbbreviationFromDB $op compDefineCapsuleFunction(form,m,e,newPrefix,$formalArgList) compDefineAddSignature([op,:argl],signature,e) == (sig:= hasFullSignature(argl,signature,e)) and null assoc(['$,:sig],symbolLassoc('modemap,getProplist(op,e))) => declForm:= [":",[op,:[[":",x,m] for x in argl for m in sig.source]],signature.target] [.,.,e]:= comp(declForm,$EmptyMode,e) e e hasFullSignature(argl,[target,:ml],e) == target => u := [m or get(x,"mode",e) or return 'failed for x in argl for m in ml] u is 'failed => nil [target,:u] nil addEmptyCapsuleIfNecessary: (%Form,%Form) -> %Form addEmptyCapsuleIfNecessary(target,rhs) == symbolMember?(KAR rhs,$SpecialDomainNames) => rhs ['add,rhs,['CAPSULE]] getTargetFromRhs: (%Form, %Form, %Env) -> %Form getTargetFromRhs(lhs,rhs,e) == --undeclared target mode obtained from rhs expression rhs is ['CAPSULE,:.] => stackSemanticError(['"target category of ",lhs, '" cannot be determined from definition"],nil) rhs is ['SubDomain,D,:.] => getTargetFromRhs(lhs,D,e) rhs is ['add,D,['CAPSULE,:.]] => getTargetFromRhs(lhs,D,e) rhs is ['Record,:l] => ['RecordCategory,:l] rhs is ['Union,:l] => ['UnionCategory,:l] (compOrCroak(rhs,$EmptyMode,e)).mode giveFormalParametersValues(argl,e) == for x in argl | ident? x repeat e := giveVariableSomeValue(x,get(x,'mode,e),e) e macroExpandInPlace: (%Form,%Env) -> %Form macroExpandInPlace(x,e) == y:= macroExpand(x,e) atom x or atom y => y x.first := first y x.rest := rest y x macroExpand: (%Form,%Env) -> %Form macroExpand(x,e) == --not worked out yet atom x => not ident? x or (u := get(x,"macro",e)) = nil => x -- Don't expand a functional macro name by itself. u is ['%mlambda,:.] => x macroExpand(u,e) x is ['DEF,lhs,sig,spCases,rhs] => ['DEF,macroExpand(lhs,e),macroExpandList(sig,e),macroExpandList(spCases,e), macroExpand(rhs,e)] -- macros should override niladic props [op,:args] := x ident? op and args = nil and niladicConstructorFromDB op and (u := get(op,"macro", e)) => macroExpand(u,e) ident? op and (get(op,"macro",e) is ['%mlambda,parms,body]) => nargs := #args nparms := #parms msg := nargs < nparms => '"Too few arguments" nargs > nparms => '"Too many arguments" nil msg => (stackMessage(strconc(msg,'" to macro %1bp"),[op]); x) args' := macroExpandList(args,e) applySubst(pairList(parms,args'),body) macroExpandList(x,e) macroExpandList(l,e) == [macroExpand(x,e) for x in l] --% constructor evaluation mkEvalableCategoryForm c == c is [op,:argl] => op="Join" => ["Join",:[mkEvalableCategoryForm x for x in argl]] op is "DomainSubstitutionMacro" => mkEvalableCategoryForm second argl op is "mkCategory" => c builtinCategoryName? op => ([x,m,$e]:= compOrCroak(c,$EmptyMode,$e); m=$Category => x) --loadIfNecessary op getConstructorKindFromDB op = 'category or get(op,"isCategory",$CategoryFrame) => [op,:[MKQ x for x in argl]] [x,m,$e]:= compOrCroak(c,$EmptyMode,$e) m=$Category => x MKQ c ++ Return true if we should skip compilation of category package. ++ This situation happens either when there is no default, of we are in ++ bootstrap mode, or we are compiling only for exports. skipCategoryPackage? capsule == null capsule or $bootStrapMode or $compileExportsOnly compDefineCategory1(df is ['DEF,form,sig,sc,body],m,e,prefix,fal) == categoryCapsule := body is ['add,cat,capsule] => body := cat capsule nil [d,m,e]:= compDefineCategory2(form,sig,sc,body,m,e,prefix,fal) if not skipCategoryPackage? categoryCapsule then [.,.,e] := $insideCategoryPackageIfTrue: local := true $categoryPredicateList: local := makeCategoryPredicates(form,$lisplibCategory) T := compDefine1(mkCategoryPackage(form,cat,categoryCapsule),$EmptyMode,e) or return stackSemanticError( ['"cannot compile defaults of",:bright opOf form],nil) if $compileDefaultsOnly then [d,m,e] := T [d,m,e] makeCategoryPredicates(form,u) == $tvl: local := TAKE(#rest form,$TriangleVariableList) $mvl: local := TAKE(#rest form,rest $FormalMapVariableList) fn(u,nil) where fn(u,pl) == u is ['Join,:.,a] => fn(a,pl) u is ["IF",p,:x] => fnl(x,insert(applySubst(pairList($tvl,$mvl),p),pl)) u is ["has",:.] => insert(applySubst(pairList($tvl,$mvl),u),pl) u is [op,:.] and op in '(SIGNATURE ATTRIBUTE) => pl atom u => pl fnl(u,pl) fnl(u,pl) == for x in u repeat pl := fn(x,pl) pl mkCategoryPackage(form is [op,:argl],cat,def) == packageName:= makeDefaultPackageName symbolName op packageAbb := makeSymbol(strconc(getConstructorAbbreviationFromDB op,'"-")) $options:local := [] -- This stops the next line from becoming confused abbreviationsSpad2Cmd ['domain,packageAbb,packageName] -- This is a little odd, but the parser insists on calling -- domains, rather than packages nameForDollar := first SETDIFFERENCE('(S A B C D E F G H I),argl) packageArgl := [nameForDollar,:argl] capsuleDefAlist := fn(def,nil) where fn(x,oplist) == atom x => oplist x is ['DEF,y,:.] => [y,:oplist] fn(x.args,fn(x.op,oplist)) catvec := eval mkEvalableCategoryForm form fullCatOpList := categoryExports JoinInner([catvec],$e) catOpList := [['SIGNATURE,op1,sig] for [[op1,sig],:.] in fullCatOpList | assoc(op1,capsuleDefAlist)] null catOpList => nil packageCategory := ['CATEGORY,'domain, :applySubst(pairList($FormalMapVariableList,argl),catOpList)] nils:= [nil for x in argl] packageSig := [packageCategory,form,:nils] $categoryPredicateList := substitute(nameForDollar,'$,$categoryPredicateList) substitute(nameForDollar,'$, ['DEF,[packageName,:packageArgl],packageSig,[nil,:nils],def]) compDefineCategory2(form,signature,specialCases,body,m,e, $prefix,$formalArgList) == --1. bind global variables $insideCategoryIfTrue: local := true $definition: local := form --used by DomainSubstitutionFunction $form: local := nil $op: local := nil $extraParms: local := nil -- Remember the body for checking the current instantiation. $currentCategoryBody : local := body --Set in DomainSubstitutionFunction, used further down -- 1.1 augment e to add declaration $: