-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. -- All rights reserved. -- Copyright (C) 2007-2015, 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 lisplib import nruncomp import category namespace BOOT --% Functions for building categories CategoryPrint(D,$e) == SAY "--------------------------------------" SAY "Name (and arguments) of category:" PRETTYPRINT canonicalForm D SAY "operations:" PRETTYPRINT categoryExports D SAY "attributes:" PRETTYPRINT categoryAttributes D SAY "This is a sub-category of" PRETTYPRINT first categoryRef(D,4) for u in second categoryRef(D,4) repeat SAY("This has an alternate view: slot ",rest u," corresponds to ",first u) for u in third categoryRef(D,4) repeat SAY("This has a local domain: slot ",rest u," corresponds to ",first u) for j in $NRTbase..maxIndex D repeat u := categoryRef(D,j) null u => SAY "another domain" first u isnt [.,:.] => SAY("Alternate View corresponding to: ",u) PRETTYPRINT u --% Domain printing --Global strategy here is to maintain a list of substitutions -- ( in $Sublis), of vectors and the names that they have, -- which may be either local names ('View1') or global names ('Where1') -- The global names are remembered on $Sublis from one -- invocation of DomainPrint1 to the next DomainPrint(D,brief) == -- If brief is non-nil, %then only a summary is printed $WhereList: local := nil $Sublis: local := nil $WhereCounter: local := 1 env:= $e or $EmptyEnvironment --in case we are called from top level categoryObject? D => CategoryPrint(D,env) $Sublis:= [[D,:'original]] SAY '"-----------------------------------------------------------------------" DomainPrint1(D,nil,env) while ($WhereList) repeat s:= $WhereList $WhereList:= nil for u in s repeat finishLine $OutputStream SAY ['"Where ",first u,'" is:"] DomainPrint1(rest u,brief,env) SAY '"-----------------------------------------------------------------------" DomainPrint1(D,brief,$e) == if vector? D then D := D.4 --if we were passed a vector, go to the domain Sublis:= [: [[rest u,:makeSymbol strconc('"View",toString i)] for u in D for i in 1..],:$Sublis] for u in D for i in 1.. repeat brief and i>1 => nil uu := copyVector rest u uu.4 := '"This domain" if not brief then SAY ['"View number ",i,'" corresponding to categories:"] PRETTYPRINT first u if i=1 and vector? uu.5 then vv := copyVector uu.5 uu.5 := vv for j in 0..maxIndex vv repeat if vector? vv.j then l := objectAssoc(vv.j,Sublis) if l then name:= rest l else name := DPname() Sublis := [[vv.j,:name],:Sublis] $Sublis := [first Sublis,:$Sublis] $WhereList := [[name,:vv.j],:$WhereList] vv.j := name if i>1 then uu.1 := uu.2 := uu.5 := '"As in first view" for i in $NRTbase..maxIndex uu repeat uu.i := DomainPrintSubst(uu.i,Sublis) if vector? uu.i then name := DPname() Sublis := [[uu.i,:name],:Sublis] $Sublis := [first Sublis,:$Sublis] $WhereList := [[name,:uu.i],:$WhereList] uu.i := name if uu.i is [.,:v] and vector? v then name := DPname() Sublis := [[v,:name],:Sublis] $Sublis := [first Sublis,:$Sublis] $WhereList := [[name,:v],:$WhereList] uu.i := [first uu.i,:name] brief => PRETTYPRINT uu.0 PRETTYPRINT uu DPname() == name := makeSymbol strconc('"Where",toString $WhereCounter) $WhereCounter := $WhereCounter+1 name PacPrint v == vv := copyVector v for j in 0..maxIndex vv repeat if vector? vv.j then l := objectAssoc(vv.j,Sublis) if l then name := rest l else name := DPname() Sublis := [[vv.j,:name],:Sublis] $Sublis := [first Sublis,:$Sublis] $WhereList := [[name,:vv.j],:$WhereList] vv.j := name if cons? vv.j and vector?(u:=rest vv.j) then l := objectAssoc(u,Sublis) if l then name := rest l else name := DPname() Sublis := [[u,:name],:Sublis] $Sublis := [first Sublis,:$Sublis] $WhereList := [[name,:u],:$WhereList] vv.j.rest := name PRETTYPRINT vv DomainPrintSubst(item,Sublis) == item is [a,:b] => c1 := DomainPrintSubst(a,Sublis) c2 := DomainPrintSubst(b,Sublis) sameObject?(c1,a) and sameObject?(c2,b) => item [c1,:c2] l := objectAssoc(item,Sublis) l => rest l l := objectAssoc(item,Sublis) l => rest l item --% Utilities mkDevaluate a == a = nil => nil a is ['QUOTE,a'] => a' = nil => nil a a is '$ => MKQ '$ a is ['%list,:.] => a.args = nil => nil a ['devaluate,a] getDomainView(domain,catform) == u := HasCategory(domain,catform) => u c := eval catform u := HasCategory(domain,c.0) => u -- note: this is necessary because of domain == another domain, e.g. -- Ps are defined to be SUPs with specific arguments so that if one -- asks if a P is a Module over itself, here one has catform= (Module -- (P I)) yet domain is a SUP. By oding this evaluation, c.0=SUP as -- well and test works --- RDJ 10/31/83 throwKeyedMsg("S2IF0009",[devaluate domain, catform]) getPrincipalView domain == pview := domain for [.,:view] in domain.4 repeat if #view > #pview then pview := view pview CategoriesFromGDC x == x isnt [.,:.] => nil x is ['%list,a,:b] and a is ['QUOTE,a'] => union([[a']],"union"/[CategoriesFromGDC u for u in b]) x is ['QUOTE,a] and a is [b] => [a] compCategories(db,u,e) == u isnt [.,:.] => u u.op is [.,:.] => error ['"compCategories: need an atom in operator position", u.op] u.op in '(Record Union Mapping) => -- There is no modemap property for these guys so do it by hand. [u.op, :[compCategories1(db,a,$SetCategory,e) for a in u.args]] u is ['SubDomain,D,.] => compCategories(db,D,e) v := symbolEq?(u.op,dbConstructor db) => [dbConstructorModemap db] get(u.op,'modemap,e) v isnt [.,:.] => error ['"compCategories: could not get proper modemap for operator",u.op] if rest v then sayBrightly ['"compCategories: ", '"%b", '"Warning", '"%d", '"ignoring unexpected stuff at end of modemap"] pp rest v -- the next line "fixes" a bad modemap which sometimes appears .... -- if rest v and null CAAAR v then v := rest v v := resolvePatternVars(first(v).mmSource, u.args) -- replaces #n forms -- select the modemap part of the first entry, and skip result etc. [u.op,:[compCategories1(db,a,b,e) for a in u.args for b in v]] compCategories1(db,u,v,e) == -- v is the mode of u u isnt [.,:.] => u u is [":",x,t] => [u.op,x,compCategories1(db,t,v,e)] isCategoryForm(v,e) => compCategories(db,u,e) [c,:.] := comp(macroExpand(u,e),v,e) => c error 'compCategories1 optFunctorBody(db,x) == atomic? x => x x is ['DomainSubstitutionMacro,parms,body] => optFunctorBody(db,DomainSubstitutionFunction(parms,body)) x is ['%list,:l] => null l => nil l:= [optFunctorBody(db,u) for u in l] every?(function optFunctorBodyQuotable,l) => quote [optFunctorBodyRequote u for u in l] ['%list,:l] x is ['PROGN,:l] => ['%seq,:optFunctorPROGN(db,l)] x is ['%when,:l] => l := [v for u in l | v := relevantClause(db,u)] where relevantClause(db,u) == u is [pred,:conseq] => u := [optFunctorBody(db,pred),:optFunctorPROGN(db,conseq)] u is ['%otherwise] => nil u nil l = nil => nil CAAR l='%otherwise => (null CDAR l => nil; null CDDAR l => CADAR l; ['%seq,:CDAR l]) null rest l and null CDAR l => --there is no meat to this conditional form pred:= CAAR l pred isnt [.,:.] => nil first pred="HasCategory" => nil ['%when,:l] ['%when,:l] [optFunctorBody(db,first x),:optFunctorBody(db,rest x)] optFunctorBodyQuotable u == u = nil or integer? u or string? u => true u isnt [.,:.] => false u is ['QUOTE,:.] => true false optFunctorBodyRequote u == u isnt [.,:.] => u u is ['QUOTE,v] => v systemErrorHere ["optFunctorBodyRequote",u] optFunctorPROGN(db,l) == l is [x,:l'] => worthlessCode(db,x) => optFunctorPROGN(db,l') l':= optFunctorBody(db,l') l' is [nil] => [optFunctorBody(db,x)] [optFunctorBody(db,x),:l'] l worthlessCode(db,x) == x is ['%when,:l] => and/[x is [.,y] and worthlessCode(db,y) for x in l] x is ['PROGN,:l] => optFunctorPROGN(db,l) = nil x is ['%list] => true x = nil => true false cons5(p,l) == l and (CAAR l = first p) => [p,: rest l] # l < 5 => [p,:l] l.rest.rest.rest.rest.rest := nil [p,:l] SetDomainSlots124(dom,names,vals) == l := pairList(names,vals) domainDirectory(dom) := sublisProp(l,domainDirectory dom) domainAttributes(dom) := sublisProp(l,domainAttributes dom) l := [[a,:devaluate b] for a in names for b in vals] domainData(dom) := applySubst(l,domainData dom) domainDirectory(dom) := sublisProp(l,domainDirectory dom) sublisProp(subst,props) == null props => nil [cp,:props']:= props (a' := inspect(cp,subst)) where inspect(cp is [a,cond,:l],subst) == cond=true => cp --keep original CONS cond is ['or,:x] => (or/[inspect(u,subst) for u in x] => [a,true,:l]; nil) cond is ["has",nam,b] and (val := objectAssoc(nam,subst)) => ev := b is ['ATTRIBUTE,c] => HasAttribute(rest val,c) b is ['SIGNATURE,c] => HasSignature(rest val,c) isDomainForm(b,$CategoryFrame) => b=rest val HasCategory(rest val,b) ev => [a,true,:l] nil cp not a' => sublisProp(subst,props') props' := sublisProp(subst,props') sameObject?(a',cp) and sameObject?(props',rest props) => props [a',:props'] mkTypeForm x == x isnt [.,:.] => mkDevaluate x x.op in '(CATEGORY mkCategory) => MKQ x x is [":",selector,dom] => ['%list,MKQ ":",MKQ selector,mkTypeForm dom] x.op is '%call => ['MKQ, optCall x] --The previous line added JHD/BMT 20/3/84 --Necessary for proper compilation of DPOLY SPAD x is [op] => op in '(Join %list) => nil MKQ x ['%list,MKQ x.op,:[mkTypeForm a for a in x.args]] DescendCodeAdd(db,base,flag) == base isnt [.,:.] => DescendCodeVarAdd(db,base,flag) modemap := get(base.op,'modemap,$CategoryFrame) modemap = nil => if getmode(base.op,$e) is ["Mapping",target,:formalArgModes] then formalArgs := take(#formalArgModes,$FormalMapVariableList) --argument substitution if parameterized? else keyedSystemError("S2OR0001",[base.op]) DescendCodeAdd1(db,base,flag,target,formalArgs,formalArgModes) for [[[.,:formalArgs],target,:formalArgModes],.] in modemap repeat (ans:= DescendCodeAdd1(db,base,flag,target,formalArgs,formalArgModes)) => return ans ans DescendCodeAdd1(db,base,flag,target,formalArgs,formalArgModes) == slist := pairList(formalArgs,rest $addFormLhs) --base = comp $addFormLhs-- bound in compAdd e:= $e newModes := applySubst(slist,formalArgModes) or/[not comp(u,m,e) for u in rest $addFormLhs for m in newModes] => return nil --I should check that the actual arguments are of the right type for u in formalArgs for m in newModes repeat [.,.,e]:= compMakeDeclaration(u,m,e) --we can not substitute in the formal arguments before we comp --for that may change the shape of the object, but we must before --we match signatures cat:= (compMakeCategoryObject(target,e)).expr instantiatedBase:= genvar() n:=maxIndex cat code:= [u for i in $NRTbase..n | cons? cat.i and cons? (sig:= first cat.i) and (u:= SetFunctionSlots(db,applySubst(slist,sig),['ELT,instantiatedBase,i],flag, 'adding))~=nil] --The code from here to the end is designed to replace repeated LOAD/STORE --combinations (SETELT ...(ELT ..)) by MVCs where this is practicable copyvec := newShell (1+n) (for u in code repeat if update(u,copyvec,[]) then code := remove(code,u)) where update(code,copyvec,sofar) == code isnt [.,:.] => nil code.op in '(%tref ELT) => copyvec.(third code):=union(copyvec.(third code), sofar) true code is ['%store,['%tref,name,number],u'] => update(u',copyvec,[[name,:number],:sofar]) for i in $NRTbase..n repeat for u in copyvec.i repeat [name,:count]:=u j:=i+1 while j<= MIN(n,i+63) and LASSOC(name,copyvec.j) = count+j-i repeat j:=j+1 --Maximum length of an MVC is 64 words j:=j-1 j > i+2 => for k in i..j repeat copyvec.k := remove(copyvec.k,[name,:count+k-i]) code:=[["REPLACE", name, instantiatedBase, KEYWORD::START1, count, KEYWORD::START2, i, KEYWORD::END2, j+1],:code] copyvec.i => v:=['%tref,instantiatedBase,i] for u in copyvec.i repeat [name,:count]:=u v:=['%store,['%tref,name,count],v] code:=[v,:code] [["%LET",instantiatedBase,base],:code] ++ In a conditional branch, 'cond' is the new condition guarding ++ a branch; return an updated predicate taking into account the ++ logical combination of preceding guards and an updated ++ 'continuation predicate reflecting the new condition. addConditionToGuard(cond,existing) == TruthP cond => [existing,:existing] TruthP existing => [cond,:['NOT,cond]] [['AND,existing,cond],:['AND,existing,['NOT,cond]]] viewsUnderCondition(views,cond) == cond is ['HasCategory,dom,cat] => [[dom,:cat],:views] views DescendCode(db,code,flag,viewAssoc,e) == -- flag = true if we are walking down code always executed; -- otherwise set to conditions in which code = nil => nil code is '%noBranch => nil isMacro(code,e) => nil --RDJ: added 3/16/83 code is ['add,base,:codelist] => codelist:= [v for u in codelist | v := DescendCode(db,u,flag,viewAssoc,e)] -- must do this first, to get this overriding Add code ['PROGN,:DescendCodeAdd(db,base,flag),:codelist] code is ['PROGN,:codelist] => ['PROGN,: --Two REVERSEs leave original order, but ensure last guy wins reverse! [v for u in reverse codelist | v := DescendCode(db,u,flag,viewAssoc,e)]] code is ['%when,:condlist] => c:= [[u2:= ProcessCond(db,first u,e),:q] for u in condlist] where q() == null u2 => nil [f,:flag] := addConditionToGuard(u2,flag) [DescendCode(db,v,f,viewsUnderCondition(viewAssoc,first u),e) for v in rest u] TruthP CAAR c => ['%seq,:CDAR c] while (c and (last c is [c1] or last c is [c1,[]]) and (c1 = '%true or c1 is ['HasAttribute,:.])) repeat --strip out some worthless junk at the end c:=reverse! rest reverse! c c = nil => ['%list] ['%when,:c] code is ["%LET",name,body,:.] => --only keep the names that are useful u := member(name,$locals) => CONTAINED('$,body) and isDomainForm(body,e) => --instantiate domains which depend on $ after constants are set code:=['%store,['%tref,['%tref,'$,$AddChainIndex],#$locals-#u],code] $epilogue:= TruthP flag => [code,:$epilogue] [['%when,[ProcessCond(db,flag,e),code]],:$epilogue] nil code code -- doItIf deletes entries from $locals so can't optimize this code is ['CodeDefine,sig,implem] => --Generated by doIt in COMPILER BOOT dom := u := symbolTarget('$,viewAssoc) => ['getDomainView,'$,u] '$ body:= ['%closure,implem,dom] SetFunctionSlots(db,sig,body,flag,'original) code is ['_:,:.] => (code.first := '%list; code.rest := nil) --Yes, I know that's a hack, but how else do you kill a line? code is ['%list,:.] => nil code is ['devaluate,:.] => nil code is ['MDEF,:.] => nil code is ['%call,:.] => code code is ['%store,:.] => code -- can be generated by doItIf stackWarning('"unknown Functor code: %1 ",[code]) code ProcessCond(db,cond,e) == ncond := dbSubstituteFormals(db,cond) valuePosition(ncond,$NRTslot1PredicateList) => predicateBitRef(db,ncond,e) cond TryGDC cond == --sees if a condition can be optimised by the use of --information in $getDomainCode cond isnt [.,:.] => cond cond is ['HasCategory,:l] => solved := nil for u in $getDomainCode while solved = nil repeat if u is ["%LET",name, =cond] then solved := name solved ~= nil => solved cond cond findOperatorImplementations(db,opsig) == if $insideCategoryPackageIfTrue then opsig := substitute('$,second dbConstructorForm db,opsig) removeDuplicates [u.mapImpl for u in $lisplibOperationAlist | opsig = u.mapOpsig and u.mapImpl isnt [.,.,nil]] SetFunctionSlots(db,sig,body,flag,mode) == --mode is either "original" or "adding" null body => return nil for catImplem in findOperatorImplementations(db,sig) repeat catImplem is [q,.,index] and q in '(ELT CONST) => if q = 'CONST and body is ['%closure,a,b] then body := ['%closure,'%constant,[second a,b]] body:= ['%store,['%tref,'$,index],body] not vector? $SetFunctions => nil --packages don't set it TruthP vectorRef($SetFunctions,index) => -- the function was already assigned return body := nil vectorRef($SetFunctions,index) := TruthP flag => true not vectorRef($SetFunctions,index) => flag ['_or,vectorRef($SetFunctions,index),flag] catImplem is ['Subsumed,:truename] => mode='original => truename is [fn,:.] and fn in '(Zero One) => nil --hack by RDJ 8/90 body := SetFunctionSlots(db,truename,body,nil,mode) keyedSystemError("S2OR0002",[catImplem]) body is ['%store,:.] => body nil --% Under what conditions may views exist? InvestigateConditions(db,catvecListMaker,tbl,env) == -- given a principal view and a list of secondary views, -- discover under what conditions the secondary view are -- always present. $Conditions: local:= nil $principal: local := nil [$principal,:secondaries]:= catvecListMaker --We are not interested in the principal view --The next block allows for the possibility that $principal may --have conditional secondary views null secondaries => '(T) --return for packages which generally have no secondary views if $principal is [op,:.] then principal' := getCategoryObject(tbl,$principal,$e) for u in categoryAncestors principal' repeat if not TruthP(cond:=second u) then new:=['CATEGORY,'domain,['IF,cond,['ATTRIBUTE,first u], '%noBranch]] $principal is ['Join,:l] => not listMember?(new,l) => $principal:=['Join,:l,new] $principal:=['Join,$principal,new] principal' := pessimise $principal where pessimise a == a isnt [.,:.] => a a is ['SIGNATURE,:.] => a a is ['IF,cond,:.] => if not listMember?(cond,$Conditions) then $Conditions:= [cond,:$Conditions] nil [pessimise first a,:pessimise rest a] null $Conditions => [true,:[true for u in secondaries]] PrincipalSecondaries:= getViewsConditions(principal',tbl) MinimalPrimary:= first first PrincipalSecondaries MaximalPrimary := first categoryPrincipals dbDomainShell db necessarySecondaries:= [first u for u in PrincipalSecondaries | rest u=true] and/[listMember?(u,necessarySecondaries) for u in secondaries] => [true,:[true for u in secondaries]] $HackSlot4:= MinimalPrimary=MaximalPrimary => nil MaximalPrimaries := [MaximalPrimary,:categoryPrincipals CatEval(MaximalPrimary,tbl,env)] MinimalPrimaries := [MinimalPrimary,:categoryPrincipals CatEval(MinimalPrimary,tbl,env)] MaximalPrimaries:=S_-(MaximalPrimaries,MinimalPrimaries) [[x] for x in MaximalPrimaries] ($Conditions:= Conds($principal,nil)) where Conds(code,previous) == --each call takes a list of conditions, and returns a list --of refinements of that list code isnt [.,:.] => [previous] code is ['DomainSubstitutionMacro,.,b] => Conds(b,previous) code is ['IF,a,b,c] => union(Conds(b,[a,:previous]),Conds(c,previous)) code is ['PROGN,:l] => "union"/[Conds(u,previous) for u in l] code is ['CATEGORY,:l] => "union"/[Conds(u,previous) for u in l] code is ['Join,:l] => "union"/[Conds(u,previous) for u in l] [previous] $Conditions := remove!([remove!(u,nil) for u in $Conditions],nil) partList:= [getViewsConditions(partPessimise($principal,cond),tbl) for cond in $Conditions] masterSecondaries:= secondaries for u in partList repeat for [v,:.] in u repeat if not listMember?(v,secondaries) then secondaries:= [v,:secondaries] list:= [listMember?(u,necessarySecondaries) for u in secondaries] for u in $Conditions for newS in partList repeat --newS is a list of secondaries and conditions (over and above --u) for which they apply u:= # u=1 => first u ['AND,:u] for [v,:.] in newS repeat for v' in [v,:categoryPrincipals CatEval(v,tbl,env)] repeat if (w:=assoc(v',$HackSlot4)) then w.rest := if rest w then mkOr(u,rest w,tbl,env) else u (list:= update(list,u,secondaries,newS,tbl,env)) where update(list,cond,secondaries,newS,tbl,env) == (list2:= [flist(sec,newS,old,cond,tbl,env) for sec in secondaries for old in list]) where flist(sec,newS,old,cond,tbl,env) == old=true => old for [newS2,:morecond] in newS repeat old:= not ancestor?(sec,[newS2],tbl,env) => old cond2 := mkAnd(cond,morecond,tbl,env) null old => cond2 mkOr(cond2,old,tbl,env) old list2 list:= [[sec,:ICformat(db,u,tbl,env)] for u in list for sec in secondaries] pv:= getPossibleViews($principal,tbl) -- $HackSlot4 is used in SetVector4 to ensure that conditional -- extensions of the principal view are handles correctly -- here we build the code necessary to remove spurious extensions ($HackSlot4:= [reshape(db,u,tbl,env) for u in $HackSlot4]) where reshape(db,u,tbl,env) == ['%when,[TryGDC ICformat(db,rest u,tbl,env)], ['%otherwise,['RPLACA,'(CAR TrueDomain), ['delete, quote first u,'(CAAR TrueDomain)]]]] $supplementaries:= [u for u in list | not listMember?(first u,masterSecondaries) and not (true=rest u) and not listMember?(first u,pv)] [true,:[LASSOC(ms,list) for ms in masterSecondaries]] ICformat(db,u,tbl,env) == u isnt [.,:.] => u u is ["has",:.] => compHasFormat(db,u,env) u is ['AND,:l] or u is ['and,:l] => l:= removeDuplicates [ICformat(db,v,tbl,env) for [v,:l'] in tails l | not listMember?(v,l')] -- we could have duplicates after, even if not before # l=1 => first l l1:= first l for u in rest l repeat l1 := mkAnd(u,l1,tbl,env) l1 u is ['OR,:l] => (l:= ORreduce l) # l=1 => ICformat(db,first l,tbl,env) l:= ORreduce removeDuplicates [ICformat(db,u,tbl,env) for u in l] --causes multiple ANDs to be squashed, etc. -- and duplicates that have been built up by tidying (l:= Hasreduce(l,tbl,env)) where Hasreduce(l,tbl,env) == for u in l | u is ['HasCategory,name,cond] and cond is ['QUOTE, cond] repeat --check that v causes descendants to go for v in l | not (v=u) and v is ['HasCategory, =name,['QUOTE, cond2]] repeat if descendant?(cond,cond2,tbl,env) then l:= remove(l,u) --v subsumes u for u in l | u is ['AND,:l'] or u is ['and,:l'] repeat for u' in l' | u' is ['HasCategory,name,cond] and cond is ['QUOTE, cond] repeat --check that v causes descendants to go for v in l | v is ['HasCategory, =name,['QUOTE, cond2]] repeat if descendant?(cond,cond2,tbl,env) then l:= remove(l,u) --v subsumes u l # l=1 => first l ['OR,:l] systemErrorHere ["ICformat",u] where ORreduce l == for u in l | u is ['AND,:.] or u is ['and,:.] repeat --check that B causes (and A B) to go for v in l | not (v=u) repeat if listMember?(v,u) or (and/[member(w,u) for w in v]) then l:= remove(l,u) --v subsumes u --Note that we are ignoring AND as a component. --Convince yourself that this code still works l partPessimise(a,trueconds) == a isnt [.,:.] => a a is ['SIGNATURE,:.] => a a is ['IF,cond,:.] => (listMember?(cond,trueconds) => a; nil) [partPessimise(first a,trueconds),:partPessimise(rest a,trueconds)] getPossibleViews(u,tbl) == --returns a list of all the categories that can be views of this one vec := getCategoryObject(tbl,u,$e) views:= [first u for u in categoryAncestors vec] null vec.0 => [first categoryPrincipals vec,:views] --* [vec.0,:views] --* --the two lines marked ensure that the principal view comes first --if you don't want it, rest it off getViewsConditions(u,tbl) == --returns a list of all the categories that can be views of this one --paired with the condition under which they are such views vec := getCategoryObject(tbl,u,$e) views:= [[first u,:second u] for u in categoryAncestors vec] null vec.0 => null categoryPrincipals vec => views [[first categoryPrincipals vec,:true],:views] --* [[vec.0,:true],:views] --* --the two lines marked ensure that the principal view comes first --if you don't want it, rest it off DescendCodeVarAdd(db,base,flag) == [SetFunctionSlots(db,sig,implem,flag,'adding) repeat for i in $NRTbase..maxIndex dbDomainShell db | categoryRef(dbDomainShell db,i) is [sig:=[op,types],:.] and LASSOC([base,:substitute(base,'$,types)],get(op,'modemap,$e)) is [[pred,implem]]] resolvePatternVars(p,args) == p := applySubst(pairList($TriangleVariableList,args),p) applySubst(pairList($FormalMapVariableList,args),p) --% Code Processing Packages isCategoryPackageName nam == isDefaultPackageName opOf nam mkOperatorEntry(opSig is [op,sig,:flag],pred,count) == null flag => [opSig,pred,["ELT","$",count]] first flag="constant" => [[op,sig],pred,["CONST","$",count]] systemError ["unknown variable mode: ",flag] --% Code for encoding function names inside package or domain ++ Return the linkage name of the local operation named `op'. encodeLocalFunctionName op == prefix := $prefix => $prefix $functorForm => symbolName dbAbbreviation constructorDB $functorForm.op stackAndThrow('"There is no context for local function %1b",[op]) makeSymbol strconc(prefix,'";",symbolName op) splitEncodedFunctionName(encodedName, sep) == -- [encodedPackage, encodedItem, encodedSig, sequenceNo] or nil -- sep0 is the separator used in "encodeFunctionName". sep0 := '";" if not string? encodedName then encodedName := STRINGIMAGE encodedName null (p1 := STRPOS(sep0, encodedName, 0, '"*")) => nil null (p2 := STRPOS(sep0, encodedName, p1+1, '"*")) => 'inner -- This is picked up in compile for inner functions in partial compilation null (p3 := STRPOS(sep, encodedName, p2+1, '"*")) => nil s1 := subString(encodedName, 0, p1) s2 := subString(encodedName, p1+1, p2-p1-1) s3 := subString(encodedName, p2+1, p3-p2-1) s4 := subString(encodedName, p3+1) [s1, s2, s3, s4]