-- 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 c_-util import database 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 --% $doNotCompileJustPrint := false ++ stack of pending capsule function definitions. $capsuleFunctionStack := [] --% $forceAdd := false $functionStats := nil $functorStats := nil $functorTarget := nil $condAlist := [] $uncondAlist := [] $NRTslot1PredicateList := [] $NRTattributeAlist := [] $NRTdeltaListComp := [] $signature := nil $byteAddress := nil $sigAlist := [] $predAlist := [] $argumentConditionList := [] $finalEnv := nil $initCapsuleErrorCount := nil $CapsuleModemapFrame := nil $CapsuleDomainsInScope := nil $signatureOfForm := nil $addFormLhs := nil ++ True if the current functor definition refines a domain. $subdomain := false --% compDefineAddSignature: (%Form,%Sig,%Env) -> %Env --% ADDINFORMATION CODE --% This code adds various items to the special value of $Information, --% in order to keep track of all the compiler's information about --% various categories and similar objects --% An actual piece of (unconditional) information can have one of 3 forms: --% (ATTRIBUTE domainname attribute) --% --These are only stored here --% (SIGNATURE domainname operator signature) --% --These are also stored as 'modemap' properties --% (has domainname categoryexpression) --% --These are also stored as 'value' properties --% Conditional attributes are of the form --% (%when --% (condition info info ...) --% ... ) --% where the condition looks like a 'has' clause, or the 'and' of several --% 'has' clauses: --% (has name categoryexpression) --% (has name (ATTRIBUTE attribute)) --% (has name (SIGNATURE operator signature)) --% The use of two representations is admitted to be clumsy liftCond (clause is [ante,conseq]) == conseq is ['%when,:l] => [[lcAnd(ante,a),:b] for [a,:b] in l] where lcAnd(pred,conj) == conj is ["and",:ll] => ["and",pred,:ll] ["and",pred,conj] [clause] formatPred(u,e) == u is ["has",a,b] => b isnt [.,:.] and isCategoryForm([b],e) => ["has",a,[b]] b isnt [.,:.] => ["has",a,["ATTRIBUTE",b]] isCategoryForm(b,e) => u b is ["ATTRIBUTE",.] => u b is ["SIGNATURE",:.] => u ["has",a,["ATTRIBUTE",b]] u isnt [.,:.] => u u is ["and",:v] => ["and",:[formatPred(w,e) for w in v]] systemError ['"formatPred",u] formatInfo(u,e) == u isnt [.,:.] => u u is ["SIGNATURE",:v] => ["SIGNATURE","$",:v] u is ["PROGN",:l] => ["PROGN",:[formatInfo(v,e) for v in l]] u is ["ATTRIBUTE",v] => -- The parser can't tell between those attributes that really -- are attributes, and those that are category names v isnt [.,:.] and isCategoryForm([v],e) => ["has","$",[v]] v isnt [.,:.] => ["ATTRIBUTE","$",v] isCategoryForm(v,e) => ["has","$",v] ["ATTRIBUTE","$",v] u is ["IF",a,b,c] => c is "%noBranch" => ['%when,:liftCond [formatPred(a,e),formatInfo(b,e)]] b is "%noBranch" => ['%when,:liftCond [["not",formatPred(a,e)],formatInfo(c,e)]] ['%when,:liftCond [formatPred(a,e),formatInfo(b,e)],: liftCond [["not",formatPred(a,e)],formatInfo(c,e)]] systemError ['"formatInfo",u] addInfo(u,e) == $Information:= [formatInfo(u,e),:$Information] addInformation(m,e) == $Information: local := nil info(m,e) where info(m,e) == --Processes information from a mode declaration in compCapsule m isnt [.,:.] => nil m is ["CATEGORY",.,:stuff] => for u in stuff repeat addInfo(u,e) m is ["Join",:stuff] => for u in stuff repeat info(u,e) nil put("$Information","special", [:$Information,:get("$Information","special",e)],e) hasToInfo (pred is ["has",a,b]) == b is ["SIGNATURE",:data] => ["SIGNATURE",a,:data] b is ["ATTRIBUTE",c] => ["ATTRIBUTE",a,c] pred ++ Return true if we are certain that the information ++ denotated by `pred' is derivable from the current environment. knownInfo(pred,env) == pred=true => true listMember?(pred,get("$Information","special",env)) => true pred is ["OR",:l] => or/[knownInfo(u,env) for u in l] pred is ["AND",:l] => and/[knownInfo(u,env) for u in l] pred is ["or",:l] => or/[knownInfo(u,env) for u in l] pred is ["and",:l] => and/[knownInfo(u,env) for u in l] pred is ["ATTRIBUTE",name,attr] => v := compForMode(name,$EmptyMode,env) or return stackAndThrow('"can't find category of %1pb",[name]) [vv,.,.] := compMakeCategoryObject(v.mode,env) or return stackAndThrow('"can't make category of %1pb",[name]) listMember?(attr,categoryAttributes vv) => true x := assoc(attr,categoryAttributes vv) => knownInfo(second x,env) --format is a list of two elements: information, predicate false pred is ["has",name,cat] => cat is ["ATTRIBUTE",:a] => knownInfo(["ATTRIBUTE",name,:a],env) cat is ["SIGNATURE",:a] => knownInfo(["SIGNATURE",name,:a],env) -- unnamed category expressions imply structural checks. cat is ["Join",:.] => and/[knownInfo(["has",name,c],env) for c in cat.args] cat is ["CATEGORY",.,:atts] => and/[knownInfo(hasToInfo ["has",name,att],env) for att in atts] name is ['Union,:.] => false -- we have a named category expression v:= compForMode(name,$EmptyMode,env) or return stackAndThrow('"can't find category of %1pb",[name]) vmode := v.mode cat = vmode => true vmode is ["Join",:l] and listMember?(cat,l) => true [vv,.,.]:= compMakeCategoryObject(vmode,env) or return stackAndThrow('"cannot find category %1pb",[vmode]) listMember?(cat,categoryPrincipals vv) => true --checks princ. ancestors (u:=assoc(cat,categoryAncestors vv)) and knownInfo(second u,env) => true -- previous line checks fundamental anscestors, we should check their -- principal anscestors but this requires instantiating categories or/[AncestorP(cat,[first u],env) for u in categoryAncestors vv | knownInfo(second u,env)] => true false pred is ["SIGNATURE",name,op,sig,:.] => v:= get(op,"modemap",env) for w in v repeat ww := w.mmSignature --the actual signature part ww = sig => w.mmCondition = true => return true false --error '"knownInfo" false mkJoin(cat,mode) == mode is ['Join,:cats] => ['Join,cat,:cats] ['Join,cat,mode] GetValue name == u:= get(name,"value",$e) => u u:= comp(name,$EmptyMode,$e) => u --name may be a form systemError [name,'" is not bound in the current environment"] actOnInfo(u,$e) == null u => $e u is ["PROGN",:l] => (for v in l repeat $e:= actOnInfo(v,$e); $e) $e:= put("$Information","special",Info:= [u,:get("$Information","special",$e)],$e ) u is ['%when,:l] => --there is nowhere %else that this sort of thing exists for [ante,:conseq] in l repeat if listMember?(hasToInfo ante,Info) then for v in conseq repeat $e:= actOnInfo(v,$e) $e u is ["ATTRIBUTE",name,att] => [vval,vmode,.]:= GetValue name compilerMessage('"augmenting %1: %2p", [name,["ATTRIBUTE",att]]) key := -- FIXME: there should be a better to tell whether name -- designates a domain, as opposed to a package CONTAINED("$",vmode) => 'domain 'package cat := ["CATEGORY",key,["ATTRIBUTE",att]] $e:= put(name,"value",[vval,mkJoin(cat,vmode),nil],$e) --there is nowhere %else that this sort of thing exists u is ["SIGNATURE",name,operator,modemap,:q] => kind := q is ["constant"] => "CONST" "ELT" implem:= (implem:=ASSOC([name,:modemap],get(operator,'modemap,$e))) => CADADR implem name = "$" => [kind,name,-1] [kind,name,substitute('$,name,modemap)] $e:= addModemap(operator,name,modemap,true,implem,$e) [vval,vmode,.]:= GetValue name compilerMessage('"augmenting %1: %2p", [name,["SIGNATURE",operator,modemap,:q]]) key := -- FIXME: there should be a better to tell whether name -- designates a domain, as opposed to a package CONTAINED("$",vmode) => 'domain 'package cat:= ["CATEGORY",key,["SIGNATURE",operator,modemap,:q]] $e:= put(name,"value",[vval,mkJoin(cat,vmode),nil],$e) u is ["has",name,cat] => [vval,vmode,.]:= GetValue name cat=vmode => $e --stating the already known u:= compMakeCategoryObject(cat,$e) => --we are adding information about a category [catvec,.,$e]:= u [ocatvec,.,$e]:= compMakeCategoryObject(vmode,$e) --we are adding a principal descendant of what was already known listMember?(cat,categoryPrincipals ocatvec) or assoc(cat,categoryAncestors ocatvec) is [.,"T",.] => $e --what was being asserted is an ancestor of what was known if name="$" then $e:= augModemapsFromCategory(name,name,cat,$e) else genDomainView(name,cat,"HasCategory") -- a domain upgrade at function level is local to that function. if not $insideCapsuleFunctionIfTrue and not symbolMember?(name,$functorLocalParameters) then $functorLocalParameters:=[:$functorLocalParameters,name] compilerMessage('"augmenting %1: %2p", [name,cat]) $e:= put(name,"value",[vval,mkJoin(cat,vmode),nil],$e) SAY("extension of ",vval," to ",cat," ignored") $e systemError ['"actOnInfo",u] infoToHas a == a is ["SIGNATURE",b,:data] => ["has",b,["SIGNATURE",:data]] a is ["ATTRIBUTE",b,c] => ["has",b,["ATTRIBUTE",c]] a chaseInferences(pred,$e) == foo hasToInfo pred where foo pred == knownInfo(pred,$e) => nil $e:= actOnInfo(pred,$e) pred:= infoToHas pred for u in get("$Information","special",$e) repeat u is ['%when,:l] => for [ante,:conseq] in l repeat ante=pred => [foo w for w in conseq] ante is ["and",:ante'] and listMember?(pred,ante') => ante':= remove(ante',pred) v':= # ante'=1 => first ante' ["and",:ante'] v':= ['%when,[v',:conseq]] listMember?(v',get("$Information","special",$e)) => nil $e:= put("$Information","special",[v',: get("$Information","special",$e)],$e) nil $e --% --======================================================================= -- Generate Code to Create Infovec --======================================================================= ++ Called by compDefineFunctor1 to create infovec at compile time getInfovecCode(db,e) == $byteAddress: local := 0 ['LIST, MKQ makeDomainTemplate db, MKQ makeCompactDirect(db,NRTmakeSlot1Info db), MKQ NRTgenFinalAttributeAlist(db,e), NRTmakeCategoryAlist(db,e), MKQ dbLookupFunction db] --======================================================================= -- Generation of Domain Vector Template (Compile Time) --======================================================================= makeDomainTemplate db == --NOTES: This function is called at compile time to create the template -- (slot 0 of the infovec); called by getInfovecCode from compDefineFunctor1 vec := dbTemplate db for index in 0..maxIndex vec repeat item := domainRef(vec,index) item = nil => nil domainRef(vec,index) := item isnt [.,:.] => item cons? first item => makeGoGetSlot(db,item,index) item dbByteList(db) := "append"/reverse! dbByteList db vec makeGoGetSlot(db,item,index) == --NOTES: creates byte vec strings for LATCH slots --these parts of the dbByteList are created first; see also makeCompactDirect [sig,whereToGo,op,:flag] := item n := #sig - 1 newcode := [n,whereToGo,:makeCompactSigCode sig,index] dbByteList(db) := [newcode,:dbByteList db] curAddress := $byteAddress $byteAddress := $byteAddress + n + 4 [curAddress,:op] --======================================================================= -- Generate OpTable at Compile Time --======================================================================= --> called by getInfovecCode (see top of this file) from compDefineFunctor1 makeCompactDirect(db,u) == $predListLength :local := # $NRTslot1PredicateList $byteVecAcc: local := nil [nam,[addForm,:opList]] := u --pp opList d := [[op,y] for [op,:items] in opList | y := makeCompactDirect1(db,op,items)] dbByteList(db) := [:dbByteList db,:"append"/reverse! $byteVecAcc] vector("append"/d) makeCompactDirect1(db,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(db,y)] or return nil $byteVecAcc := [newcodes,:$byteVecAcc] curAddress where fn(db,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,$e) 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 dbLookupFunction db 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 --======================================================================= depthAssocList u == u := removeSymbol(u,'DomainSubstitutionMacro) --hack by RDJ 8/90 removeDuplicates ("append"/[depthAssoc(y) for y in u]) depthAssoc x == y := tableValue($depthAssocCache,x) => y x is ['Join,:u] or (u := getCatAncestors x) => v := depthAssocList u tableValue($depthAssocCache,x) := [[x,:n],:v] where n() == 1 + "MAX"/[rest y for y in v] tableValue($depthAssocCache,x) := [[x,:0]] getCatAncestors x == [CAAR y for y in parentsOf opOf x] NRTmakeCategoryAlist(db,e) == $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 dbFormalSubst db for i in 1..] slot1 := [[a,:k] for [a,:b] in dbSubstituteAllQuantified(db,opcAlist) | (k := predicateBitIndex(b,e)) ~= -1] slot0 := [hasDefaultPackage opOf a for [a,:b] in slot1] sixEtc := [5 + i for i in 1..dbArity db] formals := ASSOCRIGHT dbFormalSubst db 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"/dbByteList db ['CONS, ['makeByteWordVec2,MAX(maxPredList,1),MKQ predList], ['CONS, MKQ vector slot0, ['CONS, MKQ vector [encodeCatform x for x in catformvec], ['makeByteWordVec2,maxElement,MKQ dbByteList db]]]] --NOTE: this is new form: old form satisfies vector? CDDR form encodeCatform x == k := NRTassocIndex x => k x isnt [.,:.] or rest x isnt [.,:.] => 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 ++ Like getmode, except that if the mode is local variable with ++ defined value, we want that value instead. getXmode(x,e) == m := getmode(x,e) or return nil ident? m and get(m,'%macro,e) or m --======================================================================= -- Compute the lookup function (complete or incomplete) --======================================================================= NRTgetLookupFunction(db,addForm,env) == $why: local := nil domform := dbSubstituteFormals(db,dbConstructorForm db) cat := dbCategory db addForm isnt [.,:.] => ident? addForm and (m := getmode(addForm,env)) ~= nil and isCategoryForm(m,env) and extendsCategory(db,domform,cat,dbSubstituteFormals(db,m),env) => 'lookupIncomplete 'lookupComplete addForm := dbSubstituteFormals(db,addForm) NRTextendsCategory1(db,domform,cat,getBaseExports(db,addForm),env) => 'lookupIncomplete [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 '"----------------------------------------------------------" 'lookupComplete getBaseExports(db,form) == [op,:argl] := form op is 'Record => ['RecordCategory,:argl] op is 'Union => ['UnionCategory,:argl] op is 'Enumeration => ['EnumerationCategory,:argl] op is 'Mapping => ['MappingCategory,:argl] op is '%Comma => ['Join, :[getBaseExports(db,substSlotNumbers(x,dbTemplate db,dbConstructorForm db)) for x in argl]] [[.,target,:tl],:.] := getConstructorModemap op applySubst(pairList($FormalMapVariableList,argl),target) NRTextendsCategory1(db,domform,exCategory,addForm,env) == addForm is ["%Comma",:r] => and/[extendsCategory(db,domform,exCategory,x,env) for x in r] extendsCategory(db,domform,exCategory,addForm,env) --======================================================================= -- Compute if a domain constructor is forgetful functor --======================================================================= extendsCategory(db,dom,u,v,env) == --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(db,dom,u,x,env) for x in l] v is ["CATEGORY",.,:l] => and/[extendsCategory(db,dom,u,x,env) for x in l] v is ["SubsetCategory",cat,d] => extendsCategory(db,dom,u,cat,env) and isSubset(dom,d,env) v := substSlotNumbers(v,dbTemplate db,dbConstructorForm db) extendsCategoryBasic(dom,u,v,env) => true $why := v is ['SIGNATURE,op,sig,:.] => [u,['" has no ",:formatOpSignature(op,sig)]] [u,'" has no",v] nil extendsCategoryBasic(dom,u,v,env) == v is ['IF,p,['ATTRIBUTE,c],.] => uVec := compMakeCategoryObject(u,env).expr or return false cons? c and isCategoryForm(c,env) => LASSOC(c,categoryAncestors uVec) is [=p,:.] LASSOC(c,categoryAttributes uVec) is [=p,:.] u is ["Join",:l] => or/[extendsCategoryBasic(dom,x,v,env) for x in l] u = v => true v is ['ATTRIBUTE,c] => cons? c and isCategoryForm(c,env) => extendsCategoryBasic(dom,u,c,env) u is ['CATEGORY,.,:l] => or/[extendsCategoryBasic(dom,x,v,env) for x in l] uVec := compMakeCategoryObject(u,env).expr or return false LASSOC(c,categoryAttributes uVec) is [=true] isCategoryForm(v,env) => catExtendsCat?(u,v,env) v is ['SIGNATURE,op,sig,:.] => uVec := compMakeCategoryObject(u,env).expr or return false or/[categoryRef(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,env) == u = v => true uvec := compMakeCategoryObject(u,env).expr prinAncestorList := categoryPrincipals uvec 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,env) for x in ASSOCLEFT categoryAncestors uvec] substSlotNumbers(form,template,domain) == form is [op,:.] and symbolMember?(op,allConstructors()) => expandType(form,template,domain) form is ['SIGNATURE,op,sig,:q] => ['SIGNATURE,op,[substSlotNumbers(x,template,domain) for x in sig],:q] form is ['CATEGORY,k,:u] => ['CATEGORY,k,:[substSlotNumbers(x,template,domain) for x in u]] expandType(form,template,domain) expandType(lazyt,template,domform) == lazyt isnt [.,:.] => expandTypeArgs(lazyt,template,domform) [functorName,:argl] := lazyt functorName is ":" => [functorName,first argl,expandTypeArgs(second argl,template,domform)] lazyt is ['local,x] => n := symbolPosition(x,$FormalMapVariableList) domform.(1 + n) [functorName,:[expandTypeArgs(a,template,domform) for a in argl]] expandTypeArgs(u,template,domform) == u is '$ => u integer? u => expandType(vectorRef(template,u),template,domform) u is [.,y] and u.op in '(%eval QUOTE) => y u isnt [.,:.] => u expandType(u,template,domform) --% 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) dbSuperDomain(constructorDB form.op) := [super,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: (%Thing, %Form,%List %Form,%Env) -> %Env checkRepresentation(db,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 [":=","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(db,nil,l,env) stmt isnt ["DEF",lhs,sig,val] => nil -- skip for now. op := opOf lhs 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 "%". dbConstructorKind db = "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 lhs is [.,.,:.] then --FIXME: ideally should be 'lhs is [.,:.]' 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 := ":=" stmt.args := ["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 dbConstructorKind db = "domain" and addForm isnt ["%Comma",:.] then domainRep := addForm is ["SubDomain",dom,.] => $subdomain := true dom addForm $useRepresentationHack := false env := putMacro('Rep,domainRep,env) env getSignatureFromMode(form,e) == getXmode(opOf form,e) is ['Mapping,:signature] => #form~=#signature => stackAndThrow ["Wrong number of arguments: ",form] applySubst(pairList($FormalMapVariableList,form.args),signature) compDefine1: (%Form,%Mode,%Env) -> %Maybe %Triple compDefine1(form,m,e) == $insideExpressionIfTrue: local:= false --1. decompose after macro-expanding form ['DEF,lhs,signature,rhs] := form := macroExpand(form,e) $insideWhereIfTrue and isMacro(form,e) and (m=$EmptyMode or m=$NoValueMode) => [lhs,m,putMacro(lhs.op,rhs,e)] if lhs is [.,:.] then 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],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 if lhs is [.,:.] then 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 lhs is [.,:.] and (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 lhs is [.,:.] then e := giveFormalParametersValues(lhs.args,e) if signature.target = nil then signature := [getTargetFromRhs(lhs,rhs,e),:signature.source] rhs := addEmptyCapsuleIfNecessary(signature.target,rhs) compDefineFunctor(['DEF,lhs,signature,rhs],m,e,nil,$formalArgList) $form = nil => stackAndThrow ['"bad == form ",form] db := constructorDB $op newPrefix := $prefix => makeSymbol strconc(encodeItem $prefix,'",",encodeItem $op) dbAbbreviation db compDefineCapsuleFunction(db,form,m,e,newPrefix,$formalArgList) compDefineAddSignature([op,:argl],signature,e) == (sig:= hasFullSignature(argl,signature,e)) and null assoc(['$,:sig],symbolTarget('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]] ++ We are about to elaborate a functor definition, but there ++ is no source-level user-supplied target mode on the result. ++ Attempt to infer the target type by compiling the body. 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] mode(rhs,e) where mode(x,e) == $killOptimizeIfTrue: local := true -- not yet in codegen phase. compOrCroak(x,$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) x isnt [.,:.] or y isnt [.,:.] => y x.first := first y x.rest := rest y x macroExpand: (%Form,%Env) -> %Form macroExpand(x,e) == --not worked out yet x isnt [.,:.] => 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,rhs] => ['DEF,macroExpand(lhs,e),macroExpandList(sig,e),macroExpand(rhs,e)] -- macros should override niladic props [op,:args] := x ident? op and args = nil and niladicConstructor? 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. skipCategoryPackage? capsule == null capsule or $bootStrapMode compDefineCategory1(df is ['DEF,form,sig,body],m,e,prefix,fal) == categoryCapsule := body is ['add,cat,capsule] => body := cat capsule nil if form isnt [.,:.] then form := [form] [d,m,e]:= compDefineCategory2(form,sig,body,m,e,prefix,fal) if not skipCategoryPackage? categoryCapsule then [.,.,e] := $insideCategoryPackageIfTrue: local := true $categoryPredicateList: local := makeCategoryPredicates(form,dbCategory constructorDB form.op) T := compDefine1(mkCategoryPackage(form,cat,categoryCapsule),$EmptyMode,e) or return stackSemanticError( ['"cannot compile defaults of",:bright opOf form],nil) [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 u isnt [.,:.] => pl fnl(u,pl) fnl(u,pl) == for x in u repeat pl := fn(x,pl) pl ++ Subroutine of mkCategoryPackage. ++ Return a category-level declaration of an operation described by `desc'. mkExportFromDescription desc == t := desc.mapKind = 'CONST => ['constant] nil ['SIGNATURE,desc.mapOperation,desc.mapSignature,:t] mkCategoryPackage(form is [op,:argl],cat,def) == catdb := constructorDB op packageName:= makeDefaultPackageName symbolName op packageAbb := makeSymbol strconc(symbolName dbAbbreviation catdb,'"-") $options:local := [] -- This stops the next line from becoming confused abbreviationsSpad2Cmd ['package,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) == x isnt [.,:.] => oplist x is ['DEF,y,:.] => [opOf y,:oplist] fn(x.args,fn(x.op,oplist)) catvec := eval mkEvalableCategoryForm form fullCatOpList := categoryExports JoinInner([catvec],$e) catOpList := [mkExportFromDescription desc for desc in fullCatOpList | symbolMember?(desc.mapOperation,capsuleDefAlist)] null catOpList => nil packageCategory := ['CATEGORY,'package, :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,def]) ++ Return the typing constraint operator for `t' in the environment `e'. typingKind(t,e) == isCategoryForm(t,e) => 'ofCategory 'ofType ++ Subroutine of compDefineFunctor1 and compDefineCategory2. ++ Given a constructor definition defining `db', compute implicit ++ parameters and store that list in `db'. deduceImplicitParameters(db,e) == parms := dbParameters db nonparms := [x for [x,:.] in get('%compilerData,'%whereDecls,e) | not symbolMember?(x,parms)] nonparms = nil => true -- Collect all first-order dependencies. preds := nil qvars := $QueryVariables subst := nil for p in parms for i in 1.. repeat m := getXmode(p,e) ident? m and symbolMember?(m,nonparms) => stackAndThrow('"Parameter %1b cannot be of type implicit parameter %2pb", [p,m]) m isnt [.,:.] => nil preds := [[typingKind(m,e),dbSubstituteFormals(db,p),m],:preds] st := [qpair for a in m.args for [v,:qvars] in tails qvars | ident? a and symbolMember?(a,nonparms)] where qpair() == t := getXmode(a,e) preds := [[typingKind(t,e),a,t],:preds] [a,:v] subst := [:st,:subst] -- Now, build the predicate for implicit parameters. for s in nonparms repeat x := [rest y for y in subst | symbolEq?(s,first y)] x = nil => stackAndThrow('"Implicit parameter %1b has no visible constraint",[s]) x is [.] => nil -- OK. stackAndThrow('"Too many constraints for implicit parameter %1b",[s]) dbImplicitData(db) := [subst,preds] buildConstructorCondition db == dbImplicitData db is [subst,cond] => ['%exist,ASSOCRIGHT subst,mkpf(applySubst(subst,cond),'AND)] true getArgumentMode: (%Form,%Env) -> %Maybe %Mode getArgumentMode(x,e) == string? x => x m := get(x,'mode,e) => m nil getArgumentModeOrMoan: (%Form, %Form, %Env) -> %Mode getArgumentModeOrMoan(x,form,e) == getArgumentMode(x,e) or stackSemanticError(["argument ",x," of ",form," is not declared"],nil) compDefineCategory2(form,signature,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 $: