From 9b71e0a1f285fc207709cf8e90721160af299127 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Thu, 20 Sep 2007 03:47:46 +0000 Subject: remove pamphlets - part 3 --- src/interp/functor.boot | 983 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 983 insertions(+) create mode 100644 src/interp/functor.boot (limited to 'src/interp/functor.boot') diff --git a/src/interp/functor.boot b/src/interp/functor.boot new file mode 100644 index 00000000..0513d9f0 --- /dev/null +++ b/src/interp/functor.boot @@ -0,0 +1,983 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- 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. + + +--% Domain printing +keyItem a == + isDomain a => CDAR a.4 + a + --The item that domain checks on + +--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 + $Sublis: local + $WhereCounter: local + $WhereCounter:= 1 + env:= + not BOUNDP '$e => $EmptyEnvironment + $e='$e => $EmptyEnvironment + $e --in case we are called from top level + isCategory D => CategoryPrint(D,env) + $Sublis:= [[keyItem D,:'original]] + SAY '"-----------------------------------------------------------------------" + DomainPrint1(D,NIL,env) + while ($WhereList) repeat + s:= $WhereList + $WhereList:= nil + for u in s repeat + TERPRI() + SAY ['"Where ",first u,'" is:"] + DomainPrint1(rest u,brief,env) + SAY '"-----------------------------------------------------------------------" + +DomainPrint1(D,brief,$e) == + REFVECP D and not isDomain D => PacPrint D + if REFVECP D then D:= D.4 + --if we were passed a vector, go to the domain + Sublis:= + [: + [[rest u,:INTERNL STRCONC('"View",STRINGIMAGE 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:= COPY_-SEQ rest u + uu.4:= '"This domain" + if not brief then + SAY ['"View number ",i,'" corresponding to categories:"] + PRETTYPRINT first u + if i=1 and REFVECP uu.5 then + vv:= COPY_-SEQ uu.5 + uu.5:= vv + for j in 0..MAXINDEX vv repeat + if REFVECP vv.j then + l:= ASSQ(keyItem vv.j,Sublis) + if l + then name:= rest l + else + name:=DPname() + Sublis:= [[keyItem 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 6..MAXINDEX uu repeat + uu.i:= DomainPrintSubst(uu.i,Sublis) + if REFVECP uu.i then + name:=DPname() + Sublis:= [[keyItem uu.i,:name],:Sublis] + $Sublis:= [first Sublis,:$Sublis] + $WhereList:= [[name,:uu.i],:$WhereList] + uu.i:= name + if uu.i is [.,:v] and REFVECP v then + name:=DPname() + Sublis:= [[keyItem v,:name],:Sublis] + $Sublis:= [first Sublis,:$Sublis] + $WhereList:= [[name,:v],:$WhereList] + uu.i:= [first uu.i,:name] + if brief then PRETTYPRINT uu.0 else PRETTYPRINT uu + +DPname() == + name:= INTERNL STRCONC('"Where",STRINGIMAGE $WhereCounter) + $WhereCounter:= $WhereCounter+1 + name + +PacPrint v == + vv:= COPY_-SEQ v + for j in 0..MAXINDEX vv repeat + if REFVECP vv.j then + l:= ASSQ(keyItem vv.j,Sublis) + if l + then name:= rest l + else + name:=DPname() + Sublis:= [[keyItem vv.j,:name],:Sublis] + $Sublis:= [first Sublis,:$Sublis] + $WhereList:= [[name,:vv.j],:$WhereList] + vv.j:= name + if PAIRP vv.j and REFVECP(u:=CDR vv.j) then + l:= ASSQ(keyItem u,Sublis) + if l + then name:= rest l + else + name:=DPname() + Sublis:= [[keyItem u,:name],:Sublis] + $Sublis:= [first Sublis,:$Sublis] + $WhereList:= [[name,:u],:$WhereList] + RPLACD(vv.j,name) + PRETTYPRINT vv + +DomainPrintSubst(item,Sublis) == + item is [a,:b] => + c1:= DomainPrintSubst(a,Sublis) + c2:= DomainPrintSubst(b,Sublis) + EQ(c1,a) and EQ(c2,b) => item + [c1,:c2] + l:= ASSQ(item,Sublis) + l => rest l + l:= ASSQ(keyItem item,Sublis) + l => rest l + item + +--% Utilities + +mkDevaluate a == + null a => nil + a is ['QUOTE,a'] => (a' => a; nil) + a='$ => MKQ '$ + a is ['LIST] => nil + a is ['LIST,:.] => 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 == + atom x => nil + x is ['LIST,a,:b] and a is ['QUOTE,a'] => + union(LIST LIST a',"union"/[CategoriesFromGDC u for u in b]) + x is ['QUOTE,a] and a is [b] => [a] + +compCategories u == + ATOM u => u + not ATOM first u => + error ['"compCategories: need an atom in operator position", first u] + first u = "Record" => + -- There is no modemap property for these guys so do it by hand. + [first u, :[[":", a.1, compCategories1(a.2,'(SetCategory))] for a in rest u]] + first u = "Union" or first u = "Mapping" => + -- There is no modemap property for these guys so do it by hand. + [first u, :[compCategories1(a,'(SetCategory)) for a in rest u]] + u is ['SubDomain,D,.] => compCategories D + v:=get(first u,'modemap,$e) + ATOM v => + error ['"compCategories: could not get proper modemap for operator",first u] + 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:=CDR v + v:= CDDAAR v + v:=resolvePatternVars(v, rest u) -- replaces #n forms + -- select the modemap part of the first entry, and skip result etc. + u:=[first u,:[compCategories1(a,b) for a in rest u for b in v]] + u + +compCategories1(u,v) == +-- v is the mode of u + ATOM u => u + isCategoryForm(v,$e) => compCategories u + [c,:.] := comp(macroExpand(u,$e),v,$e) => c + error 'compCategories1 + +NewbFVectorCopy(u,domName) == + v:= GETREFV SIZE u + for i in 0..5 repeat v.i:= u.i + for i in 6..MAXINDEX v | PAIRP u.i repeat v.i:= [Undef,[domName,i],:first u.i] + v + +mkVector u == + u => ['VECTOR,:u] + nil + +optFunctorBody x == + atom x => x + x is ['QUOTE,:l] => x + x is ['DomainSubstitutionMacro,parms,body] => + optFunctorBody DomainSubstitutionFunction(parms,body) + x is ['LIST,:l] => + null l => nil + l:= [optFunctorBody u for u in l] + and/[optFunctorBodyQuotable u for u in l] => + ['QUOTE,[optFunctorBodyRequote u for u in l]] + l=rest x => x --CONS-saving hack + ['LIST,:l] + x is ['PROGN,:l] => ['PROGN,:optFunctorPROGN l] + x is ['COND,:l] => +--+ + l:= + [CondClause u for u in l | u and first u] where + CondClause [pred,:conseq] == + [optFunctorBody pred,:optFunctorPROGN conseq] + l:= EFFACE('((QUOTE T)),l) + --delete any trailing ("T) + null l => nil + CAAR l='(QUOTE T) => + (null CDAR l => nil; null CDDAR l => CADAR l; ["PROGN",:CDAR l]) + null rest l and null CDAR l => + --there is no meat to this COND + pred:= CAAR l + atom pred => nil + first pred="HasCategory" => nil + ['COND,:l] + ['COND,:l] + [optFunctorBody u for u in x] + +optFunctorBodyQuotable u == + null u => true + NUMBERP u => true + atom u => nil + u is ['QUOTE,:.] => true + nil + +optFunctorBodyRequote u == + atom u => u + u is ['QUOTE,v] => v + systemErrorHere '"optFunctorBodyRequote" + +optFunctorPROGN l == + l is [x,:l'] => + worthlessCode x => optFunctorPROGN l' + l':= optFunctorBody l' + l'=[nil] => [optFunctorBody x] + [optFunctorBody x,:l'] + l + +worthlessCode x == + x is ['COND,:l] and (and/[x is [.,y] and worthlessCode y for x in l]) => true + x is ['PROGN,:l] => (null (l':= optFunctorPROGN l) => true; false) + x is ['LIST] => true + null x => true + false + +cons5(p,l) == + l and (CAAR l = CAR p) => [p,: rest l] + LENGTH l < 5 => [p,:l] + RPLACD(QCDDDDR l,nil) + [p,:l] + +-- TrimEnvironment e == +-- [TrimLocalEnvironment u for u in e] where +-- TrimLocalEnvironment e == +-- [TrimContour u for u in e] where +-- TrimContour e == +-- [u for u in e | Interesting u] where Interesting u == nil +-- --clearly a temporary definition + +setVector0(catNames,definition) == + --returns code to set element 0 of the vector + --to the definition of the category + definition:= mkDomainConstructor definition +-- If we call addMutableArg this early, then recurise calls to this domain +-- (e.g. while testing predicates) will generate new domains => trouble +--definition:= addMutableArg mkDomainConstructor definition + for u in catNames repeat + definition:= [($QuickCode => 'QSETREFV; 'SETELT),u,0,definition] + definition + +--presence of GENSYM in arg-list differentiates mutable-domains +-- addMutableArg nameFormer == +-- $mutableDomain => +-- nameFormer is ['LIST,:.] => [:nameFormer, '(GENSYM)] +-- ['APPEND,nameFormer,'(LIST (GENSYM))] +-- nameFormer + +--getname D == +-- isDomain D or isCategory D => D.0 +-- D + +setVector12 args == + --The purpose of this function is to replace place holders + --e.g. argument names or gensyms, by real values + null args => nil + args1:=args2:=args + for u in $extraParms repeat + --A typical element of $extraParms, which is set in + --DomainSubstitutionFunction, would be (gensym) cons + --(category parameter), e.g. DirectProduct(length vl,NNI) + --as in DistributedMultivariatePolynomial + args1:=[CAR u,:args1] + args2:=[CDR u,:args2] + freeof($domainShell.1,args1) and + freeof($domainShell.2,args1) and + freeof($domainShell.4,args1) => nil where freeof(a,b) == + ATOM a => NULL MEMQ(a,b) + freeof(CAR a,b) => freeof(CDR a,b) + false + [['SetDomainSlots124,'$,['QUOTE,args1],['LIST,:args2]]] + +SetDomainSlots124(vec,names,vals) == + l:= PAIR(names,vals) + vec.1:= sublisProp(l,vec.1) + vec.2:= sublisProp(l,vec.2) + l:= [[a,:devaluate b] for a in names for b in vals] + vec.4:= SUBLIS(l,vec.4) + vec.1:= SUBLIS(l,vec.1) + +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:= ASSQ(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') + EQ(a',cp) and EQ(props',rest props) => props + [a',:props'] + +setVector3(name,instantiator) == + --generates code to set element 3 of 'name' from 'instantiator' + --element 3 is data structure representing category + --returns a single LISP statement + instantiator is ['DomainSubstitutionMacro,.,body] => setVector3(name,body) + [($QuickCode => 'QSETREFV; 'SETELT),name,3,mkDomainConstructor instantiator] + +mkDomainFormer x == + if x is ['DomainSubstitutionMacro,parms,body] then + x:=DomainSubstitutionFunction(parms,body) + x:=SUBLIS($extraParms,x) + --The next line ensures that only one copy of this structure will + --appear in the BPI being generated, thus saving (some) space + x is ['Join,:.] => ['eval,['QUOTE,x]] + x + +mkDomainConstructor x == + atom x => mkDevaluate x + x is ['Join] => nil + x is ['LIST] => nil + x is ['CATEGORY,:.] => MKQ x + x is ['mkCategory,:.] => MKQ x + x is ['_:,selector,dom] => + ['LIST,MKQ '_:,MKQ selector,mkDomainConstructor dom] + x is ['Record,:argl] => + ['LIST,MKQ 'Record,:[mkDomainConstructor y for y in argl]] + x is ['Join,:argl] => + ['LIST,MKQ 'Join,:[mkDomainConstructor y for y in argl]] + x is ['call,:argl] => ['MKQ, optCall x] + --The previous line added JHD/BMT 20/3/84 + --Necessary for proper compilation of DPOLY SPAD + x is [op] => MKQ x + x is [op,:argl] => ['LIST,MKQ op,:[mkDomainConstructor a for a in argl]] + +setVector4(catNames,catsig,conditions) == + if $HackSlot4 then + for ['LET,name,cond,:.] in $getDomainCode repeat + $HackSlot4:=SUBST(name,cond,$HackSlot4) + code:= +--+ + ['SETELT,'$,4,'TrueDomain] + code:=['(LET TrueDomain (NREVERSE TrueDomain)),:$HackSlot4,code] + code:= + [: + [setVector4Onecat(u,v,w) + for u in catNames for v in catsig for w in conditions],:code] + ['(LET TrueDomain NIL),:code] + +setVector4Onecat(name,instantiator,info) == + --generates code to create one item in the + --Alist representing a domain + --returns a single LISP expression + instantiator is ['DomainSubstitutionMacro,.,body] => + setVector4Onecat(name,body,info) + data:= + --CAR name.4 contains all the names except itself + --hence we need to add this on, by the above CONS + ['CONS,['CONS,mkDomainConstructor instantiator,['CAR,['ELT,name,4]]], + name] + data:= ['SETQ,'TrueDomain,['CONS,data,'TrueDomain]] + TruthP info => data + ['COND,[TryGDC PrepareConditional info,data],: + Supplementaries(instantiator,name)] where + Supplementaries(instantiator,name) == + slist:= + [u for u in $supplementaries | AncestorP(first u,[instantiator])] + null slist => nil + $supplementaries:= S_-($supplementaries,slist) + PRETTYPRINT [instantiator,'" should solve"] + PRETTYPRINT slist + slist:= + [form(u,name) for u in slist] where + form([cat,:cond],name) == + u:= ['QUOTE,[cat,:first (eval cat).4]] + ['COND,[TryGDC cond,['SETQ,'TrueDomain,['CONS,['CONS,u,name], + 'TrueDomain]]]] + LENGTH slist=1 => [CADAR slist] + --return a list, since it is CONSed + slist:= ['PROGN,:slist] + [['(QUOTE T),slist]] + +setVector4part3(catNames,catvecList) == + --the names are those that will be applied to the various vectors + generated:= nil + for u in catvecList for uname in catNames repeat + for v in CADDR u.4 repeat + if w:= ASSOC(first v,generated) + then RPLACD(w,[[rest v,:uname],:rest w]) + else generated:= [[first v,[rest v,:uname]],:generated] + codeList := nil + for [w,:u] in generated repeat + code := compCategories w + for v in u repeat + code:= [($QuickCode => 'QSETREFV; 'SETELT),rest v,first v,code] + if CONTAINED('$,w) then $epilogue := [code,:$epilogue] + else codeList := [code,:codeList] + codeList + +PrepareConditional u == u + +setVector5(catNames,locals) == + generated:= nil + for u in locals for uname in catNames repeat + if w:= ASSOC(u,generated) + then RPLACD(w,[uname,:rest w]) + else generated:= [[u,uname],:generated] + [(w:= mkVectorWithDeferral(first u,first rest u); + for v in rest u repeat + w:= [($QuickCode => 'QSETREFV; 'SETELT),v,5,w]; + w) + for u in generated] + +mkVectorWithDeferral(objects,tag) == +-- Basically a mkVector, but spots things that aren't safe to instantiate +-- and places them at the end of $ConstantAssignments, so that they get +-- called AFTER the constants of $ have been set up. JHD 26.July.89 + ['VECTOR,: + [if CONTAINED('$,u) then -- It's not safe to instantiate this now + $ConstantAssignments:=[:$ConstantAssignments, + [($QuickCode=>'QSETREFV;'SETELT), + [($QuickCode=>'QREFELT;'ELT), tag, 5], + count, + u]] + [] + else u + for u in objects for count in 0..]] + +DescendCodeAdd(base,flag) == + atom base => DescendCodeVarAdd(base,flag) + not (modemap:=get(opOf base,'modemap,$CategoryFrame)) => + if getmode(opOf base,$e) is ["Mapping",target,:formalArgModes] + then formalArgs:= take(#formalArgModes,$FormalMapVariableList) + --argument substitution if parameterized? + + else keyedSystemError("S2OR0001",[opOf base]) + DescendCodeAdd1(base,flag,target,formalArgs,formalArgModes) + for [[[.,:formalArgs],target,:formalArgModes],.] in modemap repeat + (ans:= DescendCodeAdd1(base,flag,target,formalArgs,formalArgModes))=> + return ans + ans + +DescendCodeAdd1(base,flag,target,formalArgs,formalArgModes) == + slist:= pairList(formalArgs,rest $addFormLhs) + --base = comp $addFormLhs-- bound in compAdd + e:= $e + newModes:= SUBLIS(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],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 6..n | not atom cat.i and not atom (sig:= first cat.i) + and + (u:= + SetFunctionSlots(SUBLIS(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:=GETREFV (1+n) + for u in code repeat + if update(u,copyvec,[]) then code:=delete(u,code) + where update(code,copyvec,sofar) == + ATOM code =>nil + MEMQ(QCAR code,'(ELT QREFELT)) => + copyvec.(CADDR code):=union(copyvec.(CADDR code), sofar) + true + code is [x,name,number,u'] and MEMQ(x,'(SETELT QSETREFV)) => + update(u',copyvec,[[name,:number],:sofar]) + for i in 6..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:=delete([name,:count+k-i],copyvec.k) + code:=[['REPLACE, name, instantiatedBase, + INTERN('"START1",'"KEYWORD"), count, + INTERN('"START2",'"KEYWORD"), i, + INTERN('"END2",'"KEYWORD"), j+1],:code] + copyvec.i => + v:=[($QuickCode => 'QREFELT;'ELT),instantiatedBase,i] + for u in copyvec.i repeat + [name,:count]:=u + v:=[($QuickCode => 'QSETREFV;'SETELT),name,count,v] + code:=[v,:code] + [['LET,instantiatedBase,base],:code] + +DescendCode(code,flag,viewAssoc,EnvToPass) == + -- flag = true if we are walking down code always executed; + -- otherwise set to conditions in which + code=nil => nil + code='noBranch => nil + isMacro(code,$e) => nil --RDJ: added 3/16/83 + code is ['add,base,:codelist] => + codelist:= + [v for u in codelist | (v:= DescendCode(u,flag,viewAssoc,EnvToPass))^=nil] + -- must do this first, to get this overriding Add code + ['PROGN,:DescendCodeAdd(base,flag),:codelist] + code is ['PROGN,:codelist] => + ['PROGN,: + --Two REVERSEs leave original order, but ensure last guy wins + NREVERSE [v for u in REVERSE codelist | + (v:= DescendCode(u,flag,viewAssoc,EnvToPass))^=nil]] + code is ['COND,:condlist] => + c:= [[u2:= ProcessCond(first u,viewAssoc),:q] for u in condlist] where q == + null u2 => nil + f:= + TruthP u2 => flag; + TruthP flag => + flag := ['NOT,u2] + u2 + flag := ['AND,flag,['NOT,u2]]; + ['AND,flag,u2] + [DescendCode(v, f, + if first u is ['HasCategory,dom,cat] + then [[dom,:cat],:viewAssoc] + else viewAssoc,EnvToPass) for v in rest u] + TruthP CAAR c => ['PROGN,:CDAR c] + while (c and (LAST c is [c1] or LAST c is [c1,[]]) and + (c1 = '(QUOTE T) or c1 is ['HasAttribute,:.])) repeat + --strip out some worthless junk at the end + c:=NREVERSE CDR NREVERSE c + null c => '(LIST) + ['COND,:c] + code is ['LET,name,body,:.] => + --only keep the names that are useful + if body is [a,:.] and isFunctor a + then $packagesUsed:=[body,:$packagesUsed] + u:=member(name,$locals) => + CONTAINED('$,body) and isDomainForm(body,$e) => + --instantiate domains which depend on $ after constants are set + code:=[($QuickCode => 'QSETREFV; 'SETELT),[($QuickCode => 'QREFELT; 'ELT),'$,5],#$locals-#u,code] + $epilogue:= + TruthP flag => [code,:$epilogue] + [['COND,[ProcessCond(flag,viewAssoc),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:= EnvToPass + dom:= + u:= LASSOC(dom,viewAssoc) => ['getDomainView,dom,u] + dom + body:= ['CONS,implem,dom] + u:= SetFunctionSlots(sig,body,flag,'original) + ConstantCreator u => + if not (flag=true) then u:= ['COND,[ProcessCond(flag,viewAssoc),u]] + $ConstantAssignments:= [u,:$ConstantAssignments] + nil + u + code is ['_:,:.] => (RPLACA(code,'LIST); RPLACD(code,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 ['SETELT,:.] => code -- can be generated by doItIf + code is ['QSETREFV,:.] => code -- can be generated by doItIf + stackWarning ['"unknown Functor code ",code] + code + +ConstantCreator u == + null u => nil + u is [q,.,.,u'] and (q='SETELT or q='QSETREFV) => ConstantCreator u' + u is ['CONS,:.] => nil + true + +ProcessCond(cond,viewassoc) == + ncond := SUBLIS($pairlis,cond) + INTEGERP POSN1(ncond,$NRTslot1PredicateList) => predicateBitRef ncond + cond +--+ +TryGDC cond == + --sees if a condition can be optimised by the use of + --information in $getDomainCode + atom cond => cond + cond is ['HasCategory,:l] => + solved:= nil + for u in $getDomainCode | not solved repeat + if u is ['LET,name, =cond] then solved:= name + solved => solved + cond + cond + +SetFunctionSlots(sig,body,flag,mode) == --mode is either "original" or "adding" +--+ + catNames := ['$] + for u in $catvecList for v in catNames repeat + null body => return NIL + for catImplem in LookUpSigSlots(sig,u.1) repeat + if catImplem is [q,.,index] and (q='ELT or q='CONST) + then + if q is 'CONST and body is ['CONS,a,b] then + body := ['CONS,'IDENTITY,['FUNCALL,a,b]] + body:= [($QuickCode => 'QSETREFV; 'SETELT),v,index,body] + if REFVECP $SetFunctions and TruthP flag then u.index:= true + --used by CheckVector to determine which ops are missing + if v='$ then -- i.e. we are looking at the principal view + not REFVECP $SetFunctions => nil + --packages don't set it + $MissingFunctionInfo.index:= flag + TruthP $SetFunctions.index => (body:= nil; return nil) + -- the function was already assigned + $SetFunctions.index:= + TruthP flag => true + not $SetFunctions.index=>flag --JHD didn't set $SF on this branch + ["or",$SetFunctions.index,flag] + else + if catImplem is ['Subsumed,:truename] + --a special marker generated by SigListUnion + then + if mode='original + then if truename is [fn,:.] and MEMQ(fn,'(Zero One)) + then nil --hack by RDJ 8/90 + else body:= SetFunctionSlots(truename,body,nil,mode) + else nil + else + if not (catImplem is ['PAC,:.]) then + keyedSystemError("S2OR0002",[catImplem]) + body is ['SETELT,:.] => body + body is ['QSETREFV,:.] => body + nil + +--------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet) +LookUpSigSlots(sig,siglist) == +--+ must kill any implementations below of the form (ELT $ NIL) + siglist := $lisplibOperationAlist + REMDUP [implem for u in siglist | SigSlotsMatch(sig,first u,implem:=CADDR u) + and KADDR implem] + +SigSlotsMatch(sig,pattern,implem) == + sig=pattern => true + not (LENGTH CADR sig=LENGTH CADR pattern) => nil + --CADR sig is the actual signature part + not (first sig=first pattern) => nil + pat' :=SUBSTQ($definition,'$,CADR pattern) + sig' :=SUBSTQ($definition,'$,CADR sig) + sig'=pat' => true + --If we don't have this next test, then we'll recurse in SetFunctionSlots + implem is ['Subsumed,:.] => nil + SourceLevelSubsume(sig',pat') => true + nil + +CheckVector(vec,name,catvecListMaker) == + code:= nil + condAlist := + [[a,:first b] for [.,a,:b] in $getDomainCode] + -- used as substitution alist below + for i in 6..MAXINDEX vec repeat + v:= vec.i + v=true => nil + null v => nil + --a domain, which setVector4part3 will fill in + atom v => systemErrorHere '"CheckVector" + atom first v => + --It's a secondary view of a domain, which we + --must generate code to fill in + for x in $catNames for y in catvecListMaker repeat + if y=v then code:= + [[($QuickCode => 'QSETREFV; 'SETELT),name,i,x],:code] + if name='$ then + ASSOC(first v,$CheckVectorList) => nil + $CheckVectorList:= + [[first v,:makeMissingFunctionEntry(condAlist,i)],:$CheckVectorList] +-- member(first v,$CheckVectorList) => nil +-- $CheckVectorList:= [first v,:$CheckVectorList] + code + +makeMissingFunctionEntry(alist,i) == + tran SUBLIS(alist,$MissingFunctionInfo.i) where + tran x == + x is ["HasCategory",a,["QUOTE",b]] => ['has,a,b] + x is [op,:l] and op in '(AND OR NOT) => [op,:[tran y for y in l]] + x + +--% Under what conditions may views exist? + +InvestigateConditions catvecListMaker == + -- 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 + [$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',:.]:=compMakeCategoryObject($principal,$e) + --Rather like eval, but quotes parameters first + for u in CADR principal'.4 repeat + if not TruthP(cond:=CADR u) then + new:=['CATEGORY,'domain,['IF,cond,['ATTRIBUTE,CAR u], 'noBranch]] + $principal is ['Join,:l] => + not member(new,l) => + $principal:=['Join,:l,new] + $principal:=['Join,$principal,new] + principal' := + pessimise $principal where + pessimise a == + atom a => a + a is ['SIGNATURE,:.] => a + a is ['IF,cond,:.] => + if not member(cond,$Conditions) then $Conditions:= [cond,:$Conditions] + nil + [pessimise first a,:pessimise rest a] + null $Conditions => [true,:[true for u in secondaries]] + PrincipalSecondaries:= getViewsConditions principal' + MinimalPrimary:= CAR first PrincipalSecondaries + MaximalPrimary:= CAAR $domainShell.4 + necessarySecondaries:= [first u for u in PrincipalSecondaries | rest u=true] + and/[member(u,necessarySecondaries) for u in secondaries] => + [true,:[true for u in secondaries]] + $HackSlot4:= + MinimalPrimary=MaximalPrimary => nil + MaximalPrimaries:=[MaximalPrimary,:CAR (CatEval MaximalPrimary).4] + MinimalPrimaries:=[MinimalPrimary,:CAR (CatEval MinimalPrimary).4] + 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 + atom code => [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:= EFFACE(nil,[EFFACE(nil,u) for u in $Conditions]) + partList:= + [getViewsConditions partPessimise($principal,cond) for cond in $Conditions] + masterSecondaries:= secondaries + for u in partList repeat + for [v,:.] in u repeat + if not member(v,secondaries) then secondaries:= [v,:secondaries] + --PRETTYPRINT $Conditions + --PRETTYPRINT masterSecondaries + --PRETTYPRINT secondaries + (list:= [mkNilT member(u,necessarySecondaries) for u in secondaries]) where + mkNilT u == + u => true + nil + 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:= + LENGTH u=1 => first u + ['AND,:u] + for [v,:.] in newS repeat + for v' in [v,:CAR (CatEval v).4] repeat + if (w:=ASSOC(v',$HackSlot4)) then + RPLAC(rest w,if rest w then mkOr(u,rest w) else u) + (list:= update(list,u,secondaries,newS)) where + update(list,cond,secondaries,newS) == + (list2:= + [flist(sec,newS,old,cond) for sec in secondaries for old in list]) where + flist(sec,newS,old,cond) == + old=true => old + for [newS2,:morecond] in newS repeat + old:= + not AncestorP(sec,[newS2]) => old + cond2:= mkAnd(cond,morecond) + null old => cond2 + mkOr(cond2,old) + old + list2 + list:= [[sec,:ICformat u] for u in list for sec in secondaries] + pv:= getPossibleViews $principal +-- $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 u for u in $HackSlot4]) where + reshape u == + ['COND,[TryGDC ICformat rest u], + ['(QUOTE T),['RPLACA,'(CAR TrueDomain), + ['delete,['QUOTE,first u],'(CAAR TrueDomain)]]]] + $supplementaries:= + [u + for u in list | not member(first u,masterSecondaries) + and not (true=rest u) and not member(first u,pv)] + [true,:[LASSOC(ms,list) for ms in masterSecondaries]] + +ICformat u == + atom u => u + u is ['has,:.] => compHasFormat u + u is ['AND,:l] or u is ['and,:l] => + l:= REMDUP [ICformat v for [v,:l'] in tails l | not member(v,l')] + -- we could have duplicates after, even if not before + LENGTH l=1 => first l + l1:= first l + for u in rest l repeat + l1:=mkAnd(u,l1) + l1 + u is ['OR,:l] => + (l:= ORreduce l) 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 member(v,u) or (and/[member(w,u) for w in v]) then l:= + delete(u,l) + --v subsumes u + --Note that we are ignoring AND as a component. + --Convince yourself that this code still works + l + LENGTH l=1 => ICformat first l + l:= ORreduce REMDUP [ICformat u for u in l] + --causes multiple ANDs to be squashed, etc. + -- and duplicates that have been built up by tidying + (l:= Hasreduce l) where + Hasreduce l == + 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 DescendantP(cond,cond2) then l:= delete(u,l) + --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 DescendantP(cond,cond2) then l:= delete(u,l) + --v subsumes u + l + LENGTH l=1 => first l + ['OR,:l] + systemErrorHere '"ICformat" + +partPessimise(a,trueconds) == + atom a => a + a is ['SIGNATURE,:.] => a + a is ['IF,cond,:.] => (member(cond,trueconds) => a; nil) + [partPessimise(first a,trueconds),:partPessimise(rest a,trueconds)] + +getPossibleViews u == + --returns a list of all the categories that can be views of this one + [vec,:.]:= compMakeCategoryObject(u,$e) or + systemErrorHere '"getPossibleViews" + views:= [first u for u in CADR vec.4] + null vec.0 => [CAAR vec.4,:views] --* + [vec.0,:views] --* + --the two lines marked ensure that the principal view comes first + --if you don't want it, CDR it off + +getViewsConditions u == + + --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,:.]:= compMakeCategoryObject(u,$e) or + systemErrorHere '"getViewsConditions" + views:= [[first u,:CADR u] for u in CADR vec.4] + null vec.0 => +--+ + null CAR vec.4 => views + [[CAAR vec.4,:true],:views] --* + [[vec.0,:true],:views] --* + --the two lines marked ensure that the principal view comes first + --if you don't want it, CDR it off + +DescendCodeVarAdd(base,flag) == + princview := CAR $catvecList + [SetFunctionSlots(sig,SUBST('ELT,'CONST,implem),flag,'adding) repeat + for i in 6..MAXINDEX princview | + princview.i is [sig:=[op,types],:.] and + LASSOC([base,:SUBST(base,'$,types)],get(op,'modemap,$e)) is + [[pred,implem]]] + +resolvePatternVars(p,args) == + p := SUBLISLIS(args, $TriangleVariableList, p) + SUBLISLIS(args, $FormalMapVariableList, p) + +--resolvePatternVars(p,args) == +-- atom p => +-- isSharpVarWithNum p => args.(position(p,$FormalMapVariableList)) +-- p +-- [resolvePatternVars(CAR p,args),:resolvePatternVars(CDR p,args)] + +-- Mysterious JENKS definition follows: +--DescendCodeVarAdd(base,flag) == +-- baseops := [(u:=LASSOC([base,:SUBST(base,'$,types)], +-- get(op,'modemap,$e))) and [sig,:u] +-- for (sig := [op,types]) in $CheckVectorList] +-- $CheckVectorList := [sig for sig in $CheckVectorList +-- for op in baseops | null op] +-- [SetFunctionSlots(sig,implem,flag,'adding) +-- for u in baseops | u is [sig,[pred,implem]]] + -- cgit v1.2.3