diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/ChangeLog | 6 | ||||
| -rw-r--r-- | src/interp/Makefile.in | 5 | ||||
| -rw-r--r-- | src/interp/compiler.boot | 11 | ||||
| -rw-r--r-- | src/interp/define.boot | 502 | ||||
| -rw-r--r-- | src/interp/modemap.boot | 574 | ||||
| -rw-r--r-- | src/share/algebra/browse.daase | 2 | ||||
| -rw-r--r-- | src/share/algebra/category.daase | 2 | ||||
| -rw-r--r-- | src/share/algebra/compress.daase | 2 | ||||
| -rw-r--r-- | src/share/algebra/interp.daase | 2 | ||||
| -rw-r--r-- | src/share/algebra/operation.daase | 2 |
10 files changed, 523 insertions, 585 deletions
diff --git a/src/ChangeLog b/src/ChangeLog index 5619b63d..09c94978 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,5 +1,11 @@ 2011-08-18 Gabriel Dos Reis <gdr@cs.tamu.edu> + * interp/momdemap.boot: Fold content into compiler.boot and + define.boot. Remove. + * Makefile.in: Adjust dependencies. + +2011-08-18 Gabriel Dos Reis <gdr@cs.tamu.edu> + * interp/c-util.boot: Use category accessors. * interp/category.boot: Likewise. * interp/modemap.boot: Likewise. diff --git a/src/interp/Makefile.in b/src/interp/Makefile.in index 73b7e13a..548a104f 100644 --- a/src/interp/Makefile.in +++ b/src/interp/Makefile.in @@ -113,7 +113,6 @@ INOBJS= setvart.$(FASLEXT) interop.$(FASLEXT) patches.$(FASLEXT) # Main compiler files. OCOBJS= \ - modemap.$(FASLEXT) \ category.$(FASLEXT) define.$(FASLEXT) \ compiler.$(FASLEXT) \ c-doc.$(FASLEXT) \ @@ -305,8 +304,7 @@ compiler.$(FASLEXT): msgdb.$(FASLEXT) pathname.$(FASLEXT) define.$(FASLEXT) nrunfast.$(FASLEXT): c-util.$(FASLEXT) nruncomp.$(FASLEXT): profile.$(FASLEXT) simpbool.$(FASLEXT) functor.$(FASLEXT) nrungo.$(FASLEXT): c-util.$(FASLEXT) clam.$(FASLEXT) interop.$(FASLEXT) -define.$(FASLEXT): g-error.$(FASLEXT) modemap.$(FASLEXT) \ - nruncomp.$(FASLEXT) database.$(FASLEXT) +define.$(FASLEXT): g-error.$(FASLEXT) nruncomp.$(FASLEXT) database.$(FASLEXT) database.$(FASLEXT): clam.$(FASLEXT) nlib.$(FASLEXT) \ cattable.$(FASLEXT) compat.$(FASLEXT) g-cndata.$(FASLEXT) \ c-util.$(FASLEXT) @@ -378,7 +376,6 @@ trace.$(FASLEXT): debug.$(FASLEXT) termrw.$(FASLEXT): macros.$(FASLEXT) showimp.$(FASLEXT): c-util.$(FASLEXT) sfsfun.$(FASLEXT): macros.$(FASLEXT) -modemap.$(FASLEXT): c-util.$(FASLEXT) slam.$(FASLEXT): g-timer.$(FASLEXT) clammed.$(FASLEXT): g-timer.$(FASLEXT) clam.$(FASLEXT): g-timer.$(FASLEXT) diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot index 6490991d..abf2f685 100644 --- a/src/interp/compiler.boot +++ b/src/interp/compiler.boot @@ -34,7 +34,6 @@ import msgdb import pathname -import modemap import define namespace BOOT @@ -1184,6 +1183,11 @@ compTry(['%Try,x,ys,z],m,e) == --% ELT +getModemapListFromDomain(op,numOfArgs,D,e) == + [mm + for (mm:= [[dc,:sig],:.]) in get(op,'modemap,e) | dc=D and #rest sig= + numOfArgs] + ++ `op' supposedly designate an external entity with language linkage ++ `lang'. Return the mode of its local declaration (import). getExternalSymbolMode(op,lang,e) == @@ -1514,6 +1518,11 @@ compExclusiveOr(x,m,e) == compCase: (%Form,%Mode,%Env) -> %Maybe %Triple compCase1: (%Form,%Mode,%Env) -> %Maybe %Triple +getModemapList(op,numOfArgs,e) == + op is ['elt,D,op'] => getModemapListFromDomain(op',numOfArgs,D,e) + [mm for + (mm:= [[.,.,:sigl],:.]) in get(op,'modemap,e) | numOfArgs=#sigl] + --Will the jerk who commented out these two functions please NOT do so --again. These functions ARE needed, and case can NOT be done by --modemap alone. The reason is that A case B requires to take A diff --git a/src/interp/define.boot b/src/interp/define.boot index 59577423..b1feafef 100644 --- a/src/interp/define.boot +++ b/src/interp/define.boot @@ -33,8 +33,8 @@ import nruncomp import g_-error +import c_-util import database -import modemap namespace BOOT @@ -66,6 +66,10 @@ $doNotCompileJustPrint := false ++ stack of pending capsule function definitions. $capsuleFunctionStack := [] +--% + +$forceAdd := false + $functionStats := nil $functorStats := nil @@ -112,6 +116,250 @@ $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 == + --Assumes that $e is set up to point to an environment + 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 for w in v]] + systemError ['"formatPred",u] + +formatInfo u == + u isnt [.,:.] => u + u is ["SIGNATURE",:v] => ["SIGNATURE","$",:v] + u is ["PROGN",:l] => ["PROGN",:[formatInfo v 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="%noBranch" => ['%when,:liftCond [formatPred a,formatInfo b]] + b="%noBranch" => ['%when,:liftCond [["not",formatPred a],formatInfo c]] + ['%when,:liftCond [formatPred a,formatInfo b],: + liftCond [["not",formatPred a],formatInfo c]] + systemError ['"formatInfo",u] + +addInfo u == + $Information:= [formatInfo u,:$Information] + +addInformation(m,$e) == + $Information: local := nil + info m where + info m == + --Processes information from a mode declaration in compCapsule + m isnt [.,:.] => nil + m is ["CATEGORY",.,:stuff] => for u in stuff repeat addInfo u + m is ["Join",:stuff] => for u in stuff repeat info u + nil + $e:= + put("$Information","special",[:$Information,: + get("$Information","special",$e)],$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 == + pred=true => true + listMember?(pred,get("$Information","special",$e)) => true + pred is ["OR",:l] => or/[knownInfo u for u in l] + pred is ["AND",:l] => and/[knownInfo u for u in l] + pred is ["or",:l] => or/[knownInfo u for u in l] + pred is ["and",:l] => and/[knownInfo u for u in l] + pred is ["ATTRIBUTE",name,attr] => + v := compForMode(name,$EmptyMode,$e) or return + stackAndThrow('"can't find category of %1pb",[name]) + [vv,.,.] := compMakeCategoryObject(v.mode,$e) or return + stackAndThrow('"can't make category of %1pb",[name]) + listMember?(attr,categoryAttributes vv) => true + x := assoc(attr,categoryAttributes vv) => knownInfo second x + --format is a list of two elements: information, predicate + false + pred is ["has",name,cat] => + cat is ["ATTRIBUTE",:a] => knownInfo ["ATTRIBUTE",name,:a] + cat is ["SIGNATURE",:a] => knownInfo ["SIGNATURE",name,:a] + -- unnamed category expressions imply structural checks. + cat is ["Join",:.] => and/[knownInfo ["has",name,c] for c in cat.args] + cat is ["CATEGORY",.,:atts] => + and/[knownInfo hasToInfo ["has",name,att] for att in atts] + name is ['Union,:.] => false + -- we have a named category expression + v:= compForMode(name,$EmptyMode,$e) 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,$e) 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 => true + -- previous line checks fundamental anscestors, we should check their + -- principal anscestors but this requires instantiating categories + + or/[AncestorP(cat,[first u]) + for u in categoryAncestors vv | knownInfo second u] => true + false + pred is ["SIGNATURE",name,op,sig,:.] => + v:= get(op,"modemap",$e) + 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,name,cat,$e) + else + genDomainView(name,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 => 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 + --% --======================================================================= @@ -859,6 +1107,219 @@ predicatesFromAttributes: %List %Form -> %List %Form predicatesFromAttributes attrList == removeDuplicates [second x for x in attrList] +getModemap(x is [op,:.],e) == + for modemap in get(op,'modemap,e) repeat + if u:= compApplyModemap(x,modemap,e) then return + ([.,.,sl]:= u; applySubst(sl,modemap)) + +addModemap(op,mc,sig,pred,fn,$e) == + $InteractiveMode => $e + if knownInfo pred then pred:=true + $insideCapsuleFunctionIfTrue => + $CapsuleModemapFrame := + addModemap0(op,mc,sig,pred,fn,$CapsuleModemapFrame) + $e + addModemap0(op,mc,sig,pred,fn,$e) + +addModemapKnown(op,mc,sig,pred,fn,$e) == + $insideCapsuleFunctionIfTrue => + $CapsuleModemapFrame := + addModemap0(op,mc,sig,pred,fn,$CapsuleModemapFrame) + $e + addModemap0(op,mc,sig,pred,fn,$e) + +addModemap0(op,mc,sig,pred,fn,e) == + --mc is the "mode of computation"; fn the "implementation" + --fn is ['Subsumed,:.] => e -- don't skip subsumed modemaps + -- breaks -:($,$)->U($,failed) in DP + op='elt or op='setelt => addEltModemap(op,mc,sig,pred,fn,e) + addModemap1(op,mc,sig,pred,fn,e) + +addEltModemap(op,mc,sig,pred,fn,e) == + --hack to change selectors from strings to identifiers; and to + --add flag identifiers as literals in the envir + op='elt and sig is [:lt,sel] => + string? sel => + id:= makeSymbol sel + if $insideCapsuleFunctionIfTrue + then $e:= makeLiteral(id,$e) + else e:= makeLiteral(id,e) + addModemap1(op,mc,[:lt,id],pred,fn,e) + -- sel isnt [.,:.] => systemErrorHere '"addEltModemap" + addModemap1(op,mc,sig,pred,fn,e) + op='setelt and sig is [:lt,sel,v] => + string? sel => + id:= makeSymbol sel + if $insideCapsuleFunctionIfTrue + then $e:= makeLiteral(id,$e) + else e:= makeLiteral(id,e) + addModemap1(op,mc,[:lt,id,v],pred,fn,e) + -- sel isnt [.,:.] => systemError '"addEltModemap" + addModemap1(op,mc,sig,pred,fn,e) + systemErrorHere '"addEltModemap" + +mergeModemap(entry is [[mc,:sig],[pred,:.],:.],modemapList,e) == + for (mmtail:= [[[mc',:sig'],[pred',:.],:.],:.]) in tails modemapList repeat + mc=mc' or isSubset(mc,mc',e) => + newmm:= nil + mm:= modemapList + while (not sameObject?(mm,mmtail)) repeat (newmm:= [first mm,:newmm]; mm:= rest mm) + if (mc=mc') and (sig=sig') then + --We only need one of these, unless the conditions are hairy + not $forceAdd and TruthP pred' => + entry:=nil + --the new predicate buys us nothing + return modemapList + TruthP pred => mmtail:=rest mmtail + --the thing we matched against is useless, by comparison + modemapList:= append!(reverse! newmm,[entry,:mmtail]) + entry:= nil + return modemapList + if entry then [:modemapList,entry] else modemapList + +insertModemap(new,mmList) == + null mmList => [new] +--isMoreSpecific(new,old:= first mmList) => [new,:mmList] +--[old,:insertModemap(new,rest mmList)] + [new,:mmList] + +mkNewModemapList(mc,sig,pred,fn,curModemapList,e,filenameOrNil) == + entry:= [map:= [mc,:sig],[pred,fn],:filenameOrNil] + listMember?(entry,curModemapList) => curModemapList + (oldMap:= assoc(map,curModemapList)) and oldMap is [.,[opred, =fn],:.] => + $forceAdd => mergeModemap(entry,curModemapList,e) + opred=true => curModemapList + if pred ~= true and pred ~= opred then pred:= ["OR",pred,opred] + [if x=oldMap then [map,[pred,fn],:filenameOrNil] else x + + --if new modemap less general, put at end; otherwise, at front + for x in curModemapList] + $InteractiveMode => insertModemap(entry,curModemapList) + mergeModemap(entry,curModemapList,e) + +addModemap1(op,mc,sig,pred,fn,e) == + --mc is the "mode of computation"; fn the "implementation" + if mc="Rep" then sig := substituteDollarIfRepHack sig + currentProplist:= getProplist(op,e) or nil + newModemapList:= + mkNewModemapList(mc,sig,pred,fn,symbolLassoc('modemap,currentProplist),e,nil) + newProplist:= augProplist(currentProplist,'modemap,newModemapList) + newProplist':= augProplist(newProplist,"FLUID",true) + unErrorRef op + --There may have been a warning about op having no value + addBinding(op,newProplist',e) + +getDomainsInScope e == + $insideCapsuleFunctionIfTrue => $CapsuleDomainsInScope + get("$DomainsInScope","special",e) + +putDomainsInScope(x,e) == + l:= getDomainsInScope e + if $verbose and listMember?(x,l) then + sayBrightly ['" Note: Domain ",x," already in scope"] + newValue := [x,:remove(l,x)] + $insideCapsuleFunctionIfTrue => ($CapsuleDomainsInScope:= newValue; e) + put("$DomainsInScope","special",newValue,e) + +getOperationAlist(name,functorForm,form) == + if name isnt [.,:.] and niladicConstructorFromDB name then + functorForm:= [functorForm] + (u:= isFunctor functorForm) and not + ($insideFunctorIfTrue and first functorForm=first $functorForm) => u + $insideFunctorIfTrue and name="$" => + $domainShell => categoryExports $domainShell + systemError '"$ has no shell now" + T:= compMakeCategoryObject(form,$e) => ([.,.,$e]:= T; categoryExports T.expr) + stackMessage('"not a category form: %1bp",[form]) + +substNames(domainName,viewName,functorForm,opalist) == + functorForm := substitute("$$","$", functorForm) + nameForDollar := + isCategoryPackageName functorForm => second functorForm + domainName + [[:substitute("$","$$",substitute(nameForDollar,"$",modemapform)), + [sel, viewName,if domainName = "$" then pos else + modemapform.mmTarget]] + for [:modemapform,[sel,"$",pos]] in + applySubst(pairList($FormalMapVariableList,KDR functorForm),opalist)] + +evalAndSub(domainName,viewName,functorForm,form,$e) == + $lhsOfColon: local:= domainName + categoryObject? form => + [substNames(domainName,viewName,functorForm,categoryExports form),$e] + --next lines necessary-- see MPOLY for which $ is actual arg. --- RDJ 3/83 + if CONTAINED("$$",form) then $e:= put("$$","mode",get("$","mode",$e),$e) + opAlist:= getOperationAlist(domainName,functorForm,form) + substAlist:= substNames(domainName,viewName,functorForm,opAlist) + [substAlist,$e] + +augModemapsFromCategory(domainName,domainView,functorForm,categoryForm,e) == + [fnAlist,e]:= evalAndSub(domainName,domainView,functorForm,categoryForm,e) + -- catform:= (categoryObject? categoryForm => categoryForm.0; categoryForm) + -- catform appears not to be used, so why set it? + --if not $InteractiveMode then + compilerMessage('"Adding %1p modemaps",[domainName]) + e:= putDomainsInScope(domainName,e) + condlist:=[] + for [[op,sig,:.],cond,fnsel] in fnAlist repeat + e:= addModemapKnown(op,domainName,sig,cond,fnsel,e) -- cond was cond1 + e + +addConstructorModemaps(name,form is [functorName,:.],e) == + $InteractiveMode: local:= nil + e:= putDomainsInScope(name,e) --frame + fn := property(functorName,"makeFunctionList") + [funList,e]:= FUNCALL(fn,name,form,e) + for [op,sig,opcode] in funList repeat + if opcode is [sel,dc,n] and sel='ELT then + nsig := substitute("$$$",name,sig) + nsig := substitute('$,"$$$",substitute("$$",'$,nsig)) + opcode := [sel,dc,nsig] + e:= addModemap(op,name,sig,true,opcode,e) + e + +augModemapsFromDomain1(name,functorForm,e) == + property(KAR functorForm,"makeFunctionList") => + addConstructorModemaps(name,functorForm,e) + functorForm isnt [.,:.] and (catform := getmode(functorForm,e)) => + augModemapsFromCategory(name,name,functorForm,catform,e) + mappingForm := getmodeOrMapping(KAR functorForm,e) => + ["Mapping",categoryForm,:functArgTypes] := mappingForm + catform := substituteCategoryArguments(rest functorForm,categoryForm) + augModemapsFromCategory(name,name,functorForm,catform,e) + stackMessage('"%1pb is an unknown mode",[functorForm]) + e + +AMFCR_,redefinedList(op,l) == "OR"/[AMFCR_,redefined(op,u) for u in l] + +AMFCR_,redefined(opname,u) == + not(u is [op,:l]) => nil + op = 'DEF => opname = CAAR l + op in '(PROGN SEQ) => AMFCR_,redefinedList(opname,l) + op = '%when => "OR"/[AMFCR_,redefinedList(opname,rest u) for u in l] + +substituteCategoryArguments(argl,catform) == + argl := substitute("$$","$",argl) + arglAssoc := [[INTERNL("#",STRINGIMAGE i),:a] for i in 1.. for a in argl] + applySubst(arglAssoc,catform) + + --Called, by compDefineFunctor, to add modemaps for $ that may + --be equivalent to those of Rep. We must check that these + --operations are not being redefined. +augModemapsFromCategoryRep(domainName,repDefn,functorBody,categoryForm,e) == + [fnAlist,e]:= evalAndSub(domainName,domainName,domainName,categoryForm,e) + [repFnAlist,e]:= evalAndSub("Rep","Rep",repDefn,getmode(repDefn,e),e) + catform:= (categoryObject? categoryForm => categoryForm.0; categoryForm) + compilerMessage('"Adding %1p modemaps",[domainName]) + e:= putDomainsInScope(domainName,e) + for [lhs:=[op,sig,:.],cond,fnsel] in fnAlist repeat + u:=assoc(substitute("Rep",domainName,lhs),repFnAlist) + u and not AMFCR_,redefinedList(op,functorBody) => + fnsel' := third u + e:= addModemap(op,domainName,sig,cond,fnsel',e) + e:= addModemap(op,domainName,sig,cond,fnsel,e) + e + ++ Subroutine of inferConstructorImplicitParameters. typeDependencyPath(m,path,e) == ident? m and assoc(m,$whereDecls) => @@ -1360,6 +1821,45 @@ getSignatureFromMode(form,e) == candidateSignatures(op,nmodes,slot1) == [sig for [[=op,sig,:.],:.] in slot1 | #sig = nmodes] +domainMember(dom,domList) == + or/[modeEqual(dom,d) for d in domList] + +augModemapsFromDomain(name,functorForm,e) == + symbolMember?(KAR name or name,$DummyFunctorNames) => e + name = $Category or isCategoryForm(name,e) => e + listMember?(name,getDomainsInScope e) => e + if super := superType functorForm then + e := addNewDomain(super,e) + if name is ["Union",:dl] then for d in stripUnionTags dl + repeat e:= addDomain(d,e) + augModemapsFromDomain1(name,functorForm,e) + +addNewDomain(domain,e) == + augModemapsFromDomain(domain,domain,e) + +addDomain(domain,e) == + domain isnt [.,:.] => + domain="$EmptyMode" => e + domain="$NoValueMode" => e + not ident? domain or 2 < #(s:= STRINGIMAGE domain) and + char "#" = stringChar(s,0) and char "#" = stringChar(s,1) => e + symbolMember?(domain,getDomainsInScope e) => e + isLiteral(domain,e) => e + addNewDomain(domain,e) + (name:= first domain)='Category => e + domainMember(domain,getDomainsInScope e) => e + getmode(name,e) is ["Mapping",target,:.] and isCategoryForm(target,e)=> + addNewDomain(domain,e) + -- constructor? test needed for domains compiled with $bootStrapMode=true + isFunctor name or constructor? name => addNewDomain(domain,e) + -- ??? we should probably augment $DummyFunctorNames with CATEGORY + -- ??? so that we don't have to do this special check here. Investigate. + isQuasiquote domain => e + if not isCategoryForm(domain,e) and name ~= "Mapping" then + unknownTypeError name + e --is not a functor + + ++ We are compiling a capsule function definition with head given by `form'. ++ Determine whether the function with possibly partial signature `opsig' ++ is exported. Return the complete signature if yes; otherwise diff --git a/src/interp/modemap.boot b/src/interp/modemap.boot deleted file mode 100644 index 4b7b2c13..00000000 --- a/src/interp/modemap.boot +++ /dev/null @@ -1,574 +0,0 @@ --- 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 c_-util -namespace BOOT - ---% - -$forceAdd := false - ---% EXTERNAL ROUTINES - ---These functions are called from outside this file to add a domain --- or to get the current domains in scope; - -addDomain(domain,e) == - domain isnt [.,:.] => - domain="$EmptyMode" => e - domain="$NoValueMode" => e - not ident? domain or 2 < #(s:= STRINGIMAGE domain) and - char "#" = stringChar(s,0) and char "#" = stringChar(s,1) => e - symbolMember?(domain,getDomainsInScope e) => e - isLiteral(domain,e) => e - addNewDomain(domain,e) - (name:= first domain)='Category => e - domainMember(domain,getDomainsInScope e) => e - getmode(name,e) is ["Mapping",target,:.] and isCategoryForm(target,e)=> - addNewDomain(domain,e) - -- constructor? test needed for domains compiled with $bootStrapMode=true - isFunctor name or constructor? name => addNewDomain(domain,e) - -- ??? we should probably augment $DummyFunctorNames with CATEGORY - -- ??? so that we don't have to do this special check here. Investigate. - isQuasiquote domain => e - if not isCategoryForm(domain,e) and name ~= "Mapping" then - unknownTypeError name - e --is not a functor - -domainMember(dom,domList) == or/[modeEqual(dom,d) for d in domList] - ---% MODEMAP FUNCTIONS - -getModemap(x is [op,:.],e) == - for modemap in get(op,'modemap,e) repeat - if u:= compApplyModemap(x,modemap,e) then return - ([.,.,sl]:= u; applySubst(sl,modemap)) - -getUniqueSignature(form,e) == - [[.,:sig],:.]:= getUniqueModemap(first form,#rest form,e) or return nil - sig - -getUniqueModemap(op,numOfArgs,e) == - 1=#(mml:= getModemapList(op,numOfArgs,e)) => first mml - 1<#mml => - stackWarning('"%1 argument form of %2b has more than one modemap", - [numOfArgs,op]) - first mml - nil - -getModemapList(op,numOfArgs,e) == - op is ['elt,D,op'] => getModemapListFromDomain(op',numOfArgs,D,e) - [mm for - (mm:= [[.,.,:sigl],:.]) in get(op,'modemap,e) | numOfArgs=#sigl] - -getModemapListFromDomain(op,numOfArgs,D,e) == - [mm - for (mm:= [[dc,:sig],:.]) in get(op,'modemap,e) | dc=D and #rest sig= - numOfArgs] - - -insertModemap(new,mmList) == - null mmList => [new] ---isMoreSpecific(new,old:= first mmList) => [new,:mmList] ---[old,:insertModemap(new,rest mmList)] - [new,:mmList] - -addModemap(op,mc,sig,pred,fn,$e) == - $InteractiveMode => $e - if knownInfo pred then pred:=true - $insideCapsuleFunctionIfTrue => - $CapsuleModemapFrame := - addModemap0(op,mc,sig,pred,fn,$CapsuleModemapFrame) - $e - addModemap0(op,mc,sig,pred,fn,$e) - -addModemapKnown(op,mc,sig,pred,fn,$e) == - $insideCapsuleFunctionIfTrue => - $CapsuleModemapFrame := - addModemap0(op,mc,sig,pred,fn,$CapsuleModemapFrame) - $e - addModemap0(op,mc,sig,pred,fn,$e) - -addModemap0(op,mc,sig,pred,fn,e) == - --mc is the "mode of computation"; fn the "implementation" - --fn is ['Subsumed,:.] => e -- don't skip subsumed modemaps - -- breaks -:($,$)->U($,failed) in DP - op='elt or op='setelt => addEltModemap(op,mc,sig,pred,fn,e) - addModemap1(op,mc,sig,pred,fn,e) - -addEltModemap(op,mc,sig,pred,fn,e) == - --hack to change selectors from strings to identifiers; and to - --add flag identifiers as literals in the envir - op='elt and sig is [:lt,sel] => - string? sel => - id:= makeSymbol sel - if $insideCapsuleFunctionIfTrue - then $e:= makeLiteral(id,$e) - else e:= makeLiteral(id,e) - addModemap1(op,mc,[:lt,id],pred,fn,e) - -- sel isnt [.,:.] => systemErrorHere '"addEltModemap" - addModemap1(op,mc,sig,pred,fn,e) - op='setelt and sig is [:lt,sel,v] => - string? sel => - id:= makeSymbol sel - if $insideCapsuleFunctionIfTrue - then $e:= makeLiteral(id,$e) - else e:= makeLiteral(id,e) - addModemap1(op,mc,[:lt,id,v],pred,fn,e) - -- sel isnt [.,:.] => systemError '"addEltModemap" - addModemap1(op,mc,sig,pred,fn,e) - systemErrorHere '"addEltModemap" - -addModemap1(op,mc,sig,pred,fn,e) == - --mc is the "mode of computation"; fn the "implementation" - if mc="Rep" then sig := substituteDollarIfRepHack sig - currentProplist:= getProplist(op,e) or nil - newModemapList:= - mkNewModemapList(mc,sig,pred,fn,symbolLassoc('modemap,currentProplist),e,nil) - newProplist:= augProplist(currentProplist,'modemap,newModemapList) - newProplist':= augProplist(newProplist,"FLUID",true) - unErrorRef op - --There may have been a warning about op having no value - addBinding(op,newProplist',e) - -mkNewModemapList(mc,sig,pred,fn,curModemapList,e,filenameOrNil) == - entry:= [map:= [mc,:sig],[pred,fn],:filenameOrNil] - listMember?(entry,curModemapList) => curModemapList - (oldMap:= assoc(map,curModemapList)) and oldMap is [.,[opred, =fn],:.] => - $forceAdd => mergeModemap(entry,curModemapList,e) - opred=true => curModemapList - if pred ~= true and pred ~= opred then pred:= ["OR",pred,opred] - [if x=oldMap then [map,[pred,fn],:filenameOrNil] else x - - --if new modemap less general, put at end; otherwise, at front - for x in curModemapList] - $InteractiveMode => insertModemap(entry,curModemapList) - mergeModemap(entry,curModemapList,e) - -mergeModemap(entry is [[mc,:sig],[pred,:.],:.],modemapList,e) == - for (mmtail:= [[[mc',:sig'],[pred',:.],:.],:.]) in tails modemapList repeat - mc=mc' or isSubset(mc,mc',e) => - newmm:= nil - mm:= modemapList - while (not sameObject?(mm,mmtail)) repeat (newmm:= [first mm,:newmm]; mm:= rest mm) - if (mc=mc') and (sig=sig') then - --We only need one of these, unless the conditions are hairy - not $forceAdd and TruthP pred' => - entry:=nil - --the new predicate buys us nothing - return modemapList - TruthP pred => mmtail:=rest mmtail - --the thing we matched against is useless, by comparison - modemapList:= append!(reverse! newmm,[entry,:mmtail]) - entry:= nil - return modemapList - if entry then [:modemapList,entry] else modemapList - -addNewDomain(domain,e) == - augModemapsFromDomain(domain,domain,e) - -augModemapsFromDomain(name,functorForm,e) == - symbolMember?(KAR name or name,$DummyFunctorNames) => e - name = $Category or isCategoryForm(name,e) => e - listMember?(name,getDomainsInScope e) => e - if super := superType functorForm then - e := addNewDomain(super,e) - if name is ["Union",:dl] then for d in stripUnionTags dl - repeat e:= addDomain(d,e) - augModemapsFromDomain1(name,functorForm,e) - -augModemapsFromDomain1(name,functorForm,e) == - property(KAR functorForm,"makeFunctionList") => - addConstructorModemaps(name,functorForm,e) - functorForm isnt [.,:.] and (catform := getmode(functorForm,e)) => - augModemapsFromCategory(name,name,functorForm,catform,e) - mappingForm := getmodeOrMapping(KAR functorForm,e) => - ["Mapping",categoryForm,:functArgTypes] := mappingForm - catform := substituteCategoryArguments(rest functorForm,categoryForm) - augModemapsFromCategory(name,name,functorForm,catform,e) - stackMessage('"%1pb is an unknown mode",[functorForm]) - e - -substituteCategoryArguments(argl,catform) == - argl := substitute("$$","$",argl) - arglAssoc := [[INTERNL("#",STRINGIMAGE i),:a] for i in 1.. for a in argl] - applySubst(arglAssoc,catform) - - --Called, by compDefineFunctor, to add modemaps for $ that may - --be equivalent to those of Rep. We must check that these - --operations are not being redefined. -augModemapsFromCategoryRep(domainName,repDefn,functorBody,categoryForm,e) == - [fnAlist,e]:= evalAndSub(domainName,domainName,domainName,categoryForm,e) - [repFnAlist,e]:= evalAndSub("Rep","Rep",repDefn,getmode(repDefn,e),e) - catform:= (categoryObject? categoryForm => categoryForm.0; categoryForm) - compilerMessage('"Adding %1p modemaps",[domainName]) - e:= putDomainsInScope(domainName,e) - for [lhs:=[op,sig,:.],cond,fnsel] in fnAlist repeat - u:=assoc(substitute("Rep",domainName,lhs),repFnAlist) - u and not AMFCR_,redefinedList(op,functorBody) => - fnsel' := third u - e:= addModemap(op,domainName,sig,cond,fnsel',e) - e:= addModemap(op,domainName,sig,cond,fnsel,e) - e - -AMFCR_,redefinedList(op,l) == "OR"/[AMFCR_,redefined(op,u) for u in l] - -AMFCR_,redefined(opname,u) == - not(u is [op,:l]) => nil - op = 'DEF => opname = CAAR l - op in '(PROGN SEQ) => AMFCR_,redefinedList(opname,l) - op = '%when => "OR"/[AMFCR_,redefinedList(opname,rest u) for u in l] - -augModemapsFromCategory(domainName,domainView,functorForm,categoryForm,e) == - [fnAlist,e]:= evalAndSub(domainName,domainView,functorForm,categoryForm,e) - -- catform:= (categoryObject? categoryForm => categoryForm.0; categoryForm) - -- catform appears not to be used, so why set it? - --if not $InteractiveMode then - compilerMessage('"Adding %1p modemaps",[domainName]) - e:= putDomainsInScope(domainName,e) - condlist:=[] - for [[op,sig,:.],cond,fnsel] in fnAlist repeat - e:= addModemapKnown(op,domainName,sig,cond,fnsel,e) -- cond was cond1 - e - -evalAndSub(domainName,viewName,functorForm,form,$e) == - $lhsOfColon: local:= domainName - categoryObject? form => - [substNames(domainName,viewName,functorForm,categoryExports form),$e] - --next lines necessary-- see MPOLY for which $ is actual arg. --- RDJ 3/83 - if CONTAINED("$$",form) then $e:= put("$$","mode",get("$","mode",$e),$e) - opAlist:= getOperationAlist(domainName,functorForm,form) - substAlist:= substNames(domainName,viewName,functorForm,opAlist) - [substAlist,$e] - -getOperationAlist(name,functorForm,form) == - if name isnt [.,:.] and niladicConstructorFromDB name then - functorForm:= [functorForm] - (u:= isFunctor functorForm) and not - ($insideFunctorIfTrue and first functorForm=first $functorForm) => u - $insideFunctorIfTrue and name="$" => - $domainShell => categoryExports $domainShell - systemError '"$ has no shell now" - T:= compMakeCategoryObject(form,$e) => ([.,.,$e]:= T; categoryExports T.expr) - stackMessage('"not a category form: %1bp",[form]) - -substNames(domainName,viewName,functorForm,opalist) == - functorForm := substitute("$$","$", functorForm) - nameForDollar := - isCategoryPackageName functorForm => second functorForm - domainName - [[:substitute("$","$$",substitute(nameForDollar,"$",modemapform)), - [sel, viewName,if domainName = "$" then pos else - modemapform.mmTarget]] - for [:modemapform,[sel,"$",pos]] in - applySubst(pairList($FormalMapVariableList,KDR functorForm),opalist)] - -addConstructorModemaps(name,form is [functorName,:.],e) == - $InteractiveMode: local:= nil - e:= putDomainsInScope(name,e) --frame - fn := property(functorName,"makeFunctionList") - [funList,e]:= FUNCALL(fn,name,form,e) - for [op,sig,opcode] in funList repeat - if opcode is [sel,dc,n] and sel='ELT then - nsig := substitute("$$$",name,sig) - nsig := substitute('$,"$$$",substitute("$$",'$,nsig)) - opcode := [sel,dc,nsig] - e:= addModemap(op,name,sig,true,opcode,e) - e - - -getDomainsInScope e == - $insideCapsuleFunctionIfTrue => $CapsuleDomainsInScope - get("$DomainsInScope","special",e) - -putDomainsInScope(x,e) == - l:= getDomainsInScope e - if $verbose and listMember?(x,l) then - sayBrightly ['" Note: Domain ",x," already in scope"] - newValue := [x,:remove(l,x)] - $insideCapsuleFunctionIfTrue => ($CapsuleDomainsInScope:= newValue; e) - put("$DomainsInScope","special",newValue,e) - - - ---% 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 - - -import g_-util -namespace BOOT - -printInfo $e == - for u in get("$Information","special",$e) repeat PRETTYPRINT u - nil - -addInformation(m,$e) == - $Information: local := nil - info m where - info m == - --Processes information from a mode declaration in compCapsule - m isnt [.,:.] => nil - m is ["CATEGORY",.,:stuff] => for u in stuff repeat addInfo u - m is ["Join",:stuff] => for u in stuff repeat info u - nil - $e:= - put("$Information","special",[:$Information,: - get("$Information","special",$e)],$e) - $e - -addInfo u == - $Information:= [formatInfo u,:$Information] - -formatInfo u == - u isnt [.,:.] => u - u is ["SIGNATURE",:v] => ["SIGNATURE","$",:v] - u is ["PROGN",:l] => ["PROGN",:[formatInfo v 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="%noBranch" => ['%when,:liftCond [formatPred a,formatInfo b]] - b="%noBranch" => ['%when,:liftCond [["not",formatPred a],formatInfo c]] - ['%when,:liftCond [formatPred a,formatInfo b],: - liftCond [["not",formatPred a],formatInfo c]] - systemError ['"formatInfo",u] - -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 == - --Assumes that $e is set up to point to an environment - 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 for w in v]] - systemError ['"formatPred",u] - -chaseInferences(pred,$e) == - foo hasToInfo pred where - foo pred == - knownInfo pred => 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 - -hasToInfo (pred is ["has",a,b]) == - b is ["SIGNATURE",:data] => ["SIGNATURE",a,:data] - b is ["ATTRIBUTE",c] => ["ATTRIBUTE",a,c] - pred - -infoToHas a == - a is ["SIGNATURE",b,:data] => ["has",b,["SIGNATURE",:data]] - a is ["ATTRIBUTE",b,c] => ["has",b,["ATTRIBUTE",c]] - a - -++ Return true if we are certain that the information -++ denotated by `pred' is derivable from the current environment. -knownInfo pred == - pred=true => true - listMember?(pred,get("$Information","special",$e)) => true - pred is ["OR",:l] => or/[knownInfo u for u in l] - pred is ["AND",:l] => and/[knownInfo u for u in l] - pred is ["or",:l] => or/[knownInfo u for u in l] - pred is ["and",:l] => and/[knownInfo u for u in l] - pred is ["ATTRIBUTE",name,attr] => - v := compForMode(name,$EmptyMode,$e) or return - stackAndThrow('"can't find category of %1pb",[name]) - [vv,.,.] := compMakeCategoryObject(v.mode,$e) or return - stackAndThrow('"can't make category of %1pb",[name]) - listMember?(attr,categoryAttributes vv) => true - x := assoc(attr,categoryAttributes vv) => knownInfo second x - --format is a list of two elements: information, predicate - false - pred is ["has",name,cat] => - cat is ["ATTRIBUTE",:a] => knownInfo ["ATTRIBUTE",name,:a] - cat is ["SIGNATURE",:a] => knownInfo ["SIGNATURE",name,:a] - -- unnamed category expressions imply structural checks. - cat is ["Join",:.] => and/[knownInfo ["has",name,c] for c in cat.args] - cat is ["CATEGORY",.,:atts] => - and/[knownInfo hasToInfo ["has",name,att] for att in atts] - name is ['Union,:.] => false - -- we have a named category expression - v:= compForMode(name,$EmptyMode,$e) 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,$e) 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 => true - -- previous line checks fundamental anscestors, we should check their - -- principal anscestors but this requires instantiating categories - - or/[AncestorP(cat,[first u]) - for u in categoryAncestors vv | knownInfo second u] => true - false - pred is ["SIGNATURE",name,op,sig,:.] => - v:= get(op,"modemap",$e) - for w in v repeat - ww := w.mmSignature --the actual signature part - ww = sig => - w.mmCondition = true => return true - false - --error '"knownInfo" - false - -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,name,cat,$e) - else - genDomainView(name,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] - -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"] - diff --git a/src/share/algebra/browse.daase b/src/share/algebra/browse.daase index 9caed1a4..df370548 100644 --- a/src/share/algebra/browse.daase +++ b/src/share/algebra/browse.daase @@ -1,5 +1,5 @@ -(2276906 . 3522279582) +(2276906 . 3522680061) (-18 A S) ((|constructor| (NIL "One-dimensional-array aggregates serves as models for one-dimensional arrays. Categorically,{} these aggregates are finite linear aggregates with the \\spadatt{shallowlyMutable} property,{} that is,{} any component of the array may be changed without affecting the identity of the overall array. Array data structures are typically represented by a fixed area in storage and therefore cannot efficiently grow or shrink on demand as can list structures (see however \\spadtype{FlexibleArray} for a data structure which is a cross between a list and an array). Iteration over,{} and access to,{} elements of arrays is extremely fast (and often can be optimized to open-code). Insertion and deletion however is generally slow since an entirely new data structure must be created for the result."))) NIL diff --git a/src/share/algebra/category.daase b/src/share/algebra/category.daase index 06f5a069..84a6fa93 100644 --- a/src/share/algebra/category.daase +++ b/src/share/algebra/category.daase @@ -1,5 +1,5 @@ -(205500 . 3522279586) +(205500 . 3522680065) ((((-877)) . T)) ((((-877)) . T)) ((((-877)) . T)) diff --git a/src/share/algebra/compress.daase b/src/share/algebra/compress.daase index 0f2e7368..a15ed8f1 100644 --- a/src/share/algebra/compress.daase +++ b/src/share/algebra/compress.daase @@ -1,5 +1,5 @@ -(30 . 3522279580) +(30 . 3522680059) (4428 |Enumeration| |Mapping| |Record| |Union| |ofCategory| |isDomain| ATTRIBUTE |package| |domain| |category| CATEGORY |nobranch| AND |Join| |ofType| SIGNATURE "failed" "algebra" |OneDimensionalArrayAggregate&| diff --git a/src/share/algebra/interp.daase b/src/share/algebra/interp.daase index 03d9885f..d1c344d0 100644 --- a/src/share/algebra/interp.daase +++ b/src/share/algebra/interp.daase @@ -1,5 +1,5 @@ -(3432426 . 3522279595) +(3432426 . 3522680074) ((-1935 (((-114) (-1 (-114) |#2| |#2|) $) 86 T ELT) (((-114) $) NIL T ELT)) (-1933 (($ (-1 (-114) |#2| |#2|) $) 18 T ELT) (($ $) NIL T ELT)) (-4218 ((|#2| $ (-558) |#2|) NIL T ELT) ((|#2| $ (-1255 (-558)) |#2|) 44 T ELT)) (-2510 (($ $) 80 T ELT)) (-4272 ((|#2| (-1 |#2| |#2| |#2|) $ |#2| |#2|) 52 T ELT) ((|#2| (-1 |#2| |#2| |#2|) $ |#2|) 50 T ELT) ((|#2| (-1 |#2| |#2| |#2|) $) 49 T ELT)) (-3839 (((-558) (-1 (-114) |#2|) $) 27 T ELT) (((-558) |#2| $) NIL T ELT) (((-558) |#2| $ (-558)) 96 T ELT)) (-3290 (((-661 |#2|) $) 13 T ELT)) (-3938 (($ (-1 (-114) |#2| |#2|) $ $) 64 T ELT) (($ $ $) NIL T ELT)) (-2160 (($ (-1 |#2| |#2|) $) 37 T ELT)) (-4388 (($ (-1 |#2| |#2|) $) NIL T ELT) (($ (-1 |#2| |#2| |#2|) $ $) 60 T ELT)) (-2517 (($ |#2| $ (-558)) NIL T ELT) (($ $ $ (-558)) 67 T ELT)) (-1468 (((-3 |#2| "failed") (-1 (-114) |#2|) $) 29 T ELT)) (-2158 (((-114) (-1 (-114) |#2|) $) 23 T ELT)) (-4230 ((|#2| $ (-558) |#2|) NIL T ELT) ((|#2| $ (-558)) NIL T ELT) (($ $ (-1255 (-558))) 66 T ELT)) (-2518 (($ $ (-558)) 76 T ELT) (($ $ (-1255 (-558))) 75 T ELT)) (-2157 (((-791) (-1 (-114) |#2|) $) 34 T ELT) (((-791) |#2| $) NIL T ELT)) (-1934 (($ $ $ (-558)) 69 T ELT)) (-3820 (($ $) 68 T ELT)) (-3950 (($ (-661 |#2|)) 73 T ELT)) (-4232 (($ $ |#2|) NIL T ELT) (($ |#2| $) NIL T ELT) (($ $ $) 87 T ELT) (($ (-661 $)) 85 T ELT)) (-4376 (((-877) $) 92 T ELT)) (-2159 (((-114) (-1 (-114) |#2|) $) 22 T ELT)) (-3454 (((-114) $ $) 95 T ELT)) (-3086 (((-114) $ $) 99 T ELT))) (((-18 |#1| |#2|) (-10 -8 (-15 -3454 ((-114) |#1| |#1|)) (-15 -4376 ((-877) |#1|)) (-15 -3086 ((-114) |#1| |#1|)) (-15 -1933 (|#1| |#1|)) (-15 -1933 (|#1| (-1 (-114) |#2| |#2|) |#1|)) (-15 -2510 (|#1| |#1|)) (-15 -1934 (|#1| |#1| |#1| (-558))) (-15 -1935 ((-114) |#1|)) (-15 -3938 (|#1| |#1| |#1|)) (-15 -3839 ((-558) |#2| |#1| (-558))) (-15 -3839 ((-558) |#2| |#1|)) (-15 -3839 ((-558) (-1 (-114) |#2|) |#1|)) (-15 -1935 ((-114) (-1 (-114) |#2| |#2|) |#1|)) (-15 -3938 (|#1| (-1 (-114) |#2| |#2|) |#1| |#1|)) (-15 -4218 (|#2| |#1| (-1255 (-558)) |#2|)) (-15 -2517 (|#1| |#1| |#1| (-558))) (-15 -2517 (|#1| |#2| |#1| (-558))) (-15 -2518 (|#1| |#1| (-1255 (-558)))) (-15 -2518 (|#1| |#1| (-558))) (-15 -4388 (|#1| (-1 |#2| |#2| |#2|) |#1| |#1|)) (-15 -4232 (|#1| (-661 |#1|))) (-15 -4232 (|#1| |#1| |#1|)) (-15 -4232 (|#1| |#2| |#1|)) (-15 -4232 (|#1| |#1| |#2|)) (-15 -4230 (|#1| |#1| (-1255 (-558)))) (-15 -3950 (|#1| (-661 |#2|))) (-15 -1468 ((-3 |#2| "failed") (-1 (-114) |#2|) |#1|)) (-15 -4272 (|#2| (-1 |#2| |#2| |#2|) |#1|)) (-15 -4272 (|#2| (-1 |#2| |#2| |#2|) |#1| |#2|)) (-15 -4272 (|#2| (-1 |#2| |#2| |#2|) |#1| |#2| |#2|)) (-15 -4230 (|#2| |#1| (-558))) (-15 -4230 (|#2| |#1| (-558) |#2|)) (-15 -4218 (|#2| |#1| (-558) |#2|)) (-15 -2157 ((-791) |#2| |#1|)) (-15 -3290 ((-661 |#2|) |#1|)) (-15 -2157 ((-791) (-1 (-114) |#2|) |#1|)) (-15 -2158 ((-114) (-1 (-114) |#2|) |#1|)) (-15 -2159 ((-114) (-1 (-114) |#2|) |#1|)) (-15 -2160 (|#1| (-1 |#2| |#2|) |#1|)) (-15 -4388 (|#1| (-1 |#2| |#2|) |#1|)) (-15 -3820 (|#1| |#1|))) (-19 |#2|) (-1238)) (T -18)) NIL diff --git a/src/share/algebra/operation.daase b/src/share/algebra/operation.daase index 322538b7..16430dd8 100644 --- a/src/share/algebra/operation.daase +++ b/src/share/algebra/operation.daase @@ -1,5 +1,5 @@ -(719417 . 3522279583) +(719417 . 3522680062) (((*1 *2 *3 *4) (|partial| -12 (-5 *3 (-1288 *4)) (-4 *4 (-13 (-1070) (-658 (-558)))) (-5 *2 (-1288 (-419 (-558)))) (-5 *1 (-1317 *4))))) |