diff options
Diffstat (limited to 'src/interp/functor.boot')
| -rw-r--r-- | src/interp/functor.boot | 251 |
1 files changed, 240 insertions, 11 deletions
diff --git a/src/interp/functor.boot b/src/interp/functor.boot index c5a55ae3..0d9db0d8 100644 --- a/src/interp/functor.boot +++ b/src/interp/functor.boot @@ -33,6 +33,7 @@ import c_-util +import clam import category namespace BOOT @@ -248,7 +249,6 @@ optFunctorBody x == ['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] == @@ -420,9 +420,7 @@ setVector4(catNames,catsig,conditions) == if $HackSlot4 then for ["%LET",name,cond,:.] in $getDomainCode repeat $HackSlot4:=MSUSBT(name,cond,$HackSlot4) - code:= ---+ - ['SETELT,'$,4,'TrueDomain] + code := ['SETELT,'$,4,'TrueDomain] code:=['(%LET TrueDomain (NREVERSE TrueDomain)),:$HackSlot4,code] code:= [: @@ -669,7 +667,7 @@ 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 @@ -683,7 +681,6 @@ TryGDC 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 @@ -787,7 +784,6 @@ InvestigateConditions 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 @@ -840,9 +836,6 @@ InvestigateConditions catvecListMaker == 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 @@ -959,7 +952,6 @@ getViewsConditions u == 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] --* @@ -994,3 +986,240 @@ resolvePatternVars(p,args) == -- [SetFunctionSlots(sig,implem,flag,'adding) -- for u in baseops | u is [sig,[pred,implem]]] + +--% Code Processing Packages + +isPackageFunction() == + -- called by compile/putInLocalDomainReferences + nil + +isCategoryPackageName nam == + p := PNAME opOf nam + p.(MAXINDEX p) = char '_& + +processFunctorOrPackage(form,signature,data,localParList,m,e) == + processFunctor(form,signature,data,localParList,e) + +processPackage($definition is [name,:args],[$catsig,:argssig],code,locals,$e) == + $GENNO: local:= 0 --for GENVAR() + $catsig: local := nil + --used in ProcessCond + $ResetItems: local := nil + --stores those items that get SETQed, and may need re-processing + $catvecList: local:= [$domainShell] + $catNames: local:= ["$"] + catvec:= $domainShell --from compDefineFunctor + $getDomainCode:= optFunctorBody $getDomainCode + --the purpose of this is so ProcessCond recognises such items + code:= PackageDescendCode(code,true,nil) + if delete(nil,locals) then code:=[:code,:(setPackageCode locals)] where + setPackageCode locals == + locals':=[[u,:i] for u in locals for i in 0.. | u] + locals'' :=[] + while locals' repeat + for v in locals' repeat + [u,:i]:=v + if and/[EQ(v,v') or not subTree(u,CAR v') for v' in locals'] + then + locals'':=[v,:locals''] + locals':=delete(v,locals') + precomp:=code:=[] + for elem in locals'' repeat + [u,:i]:=elem + if ATOM u then u':=u + else + u':=opt(u,precomp) where + opt(u,alist) == + ATOM u => u + for v in u repeat + if (a:=assoc(v,alist)) then + [.,:i]:=a + u:=replace(v,["getShellEntry","$",i],u) where + replace(old,new,l) == + l isnt [h,:t] => l + h = old => [new,:t] + [h,:replace(old,new,t)] + v':=opt(v,alist) + EQ(v,v') => nil + u:=replace(v,v',u) + u + precomp:=[elem,:precomp] + code:=[["setShellEntry","$",i,u'],:code] + nreverse code + code:= + ["PROGN",:$getDomainCode,["%LET","$",["newShell",#locals]], + --It is important to place this code here, + --after $ is set up + --slam functor with shell + --the order of steps in this PROGN are critical + addToSlam($definition,"$"),code,[ + "SETELT","$",0, mkDomainConstructor $definition],: +-- If we call addMutableArg this early, then recurise calls to this domain +-- (e.g. while testing predicates) will generate new domains => trouble +-- "SETELT","$",0,addMutableArg mkDomainConstructor $definition],: + [["SETELT","$",position(name,locals),name] + for name in $ResetItems | MEMQ(name,locals)], + :[($mutableDomain => '(RPLACD (LASTNODE (ELT $ 0)) + (LIST (GENSYM)));[]) ], + "$"] + for u in $getDomainCode repeat + u is ["%LET",.,u'] and u' is ['getDomainView,.,u''] => + $packagesUsed:=union(CategoriesFromGDC u'',$packagesUsed) + $packagesUsed:=union($functorLocalParameters,$packagesUsed) + $getDomainCode:= nil + --if we didn't kill this, DEFINE would insert it in the wrong place + optFunctorBody code + +subTree(u,v) == + v=u => true + ATOM v => nil + or/[subTree(u,v') for v' in v] + +setPackageLocals(pac,locs) == + for var in locs for i in 0.. | var^=nil repeat pac.i:= var + +PackageDescendCode(code,flag,viewAssoc) == + --flag is true if we are walking down code always executed + --nil if we are in conditional code + code=nil => nil + code="%noBranch" => nil + code is ["add",base,:codelist] => + systemError '"packages may not have add clauses" + code is ["PROGN",:codelist] => + ["PROGN",: + [v for u in codelist | (v:= PackageDescendCode(u,flag,viewAssoc))^=nil]] + code is ["COND",:condlist] => + c:= + ["COND",: + [[u2:= ProcessCond(first u,viewAssoc),: + (if null u2 + then nil + else + [PackageDescendCode(v,flag and TruthP u2, + if first u is ["HasCategory",dom,cat] + then [[dom,:cat],:viewAssoc] + else viewAssoc) for v in rest u])] for u in condlist]] + TruthP CAADR c => ["PROGN",:CDADR c] + c + code is ["%LET",name,body,:.] => + if not MEMQ(name,$ResetItems) then $ResetItems:= [name,:$ResetItems] + if body is [a,:.] and isFunctor a + then $packagesUsed:=[body,:$packagesUsed] + code + code is ["CodeDefine",sig,implem] => + --Generated by doIt in COMPILER BOOT + dom:= "$" + dom:= + u:= LASSOC(dom,viewAssoc) => ["getDomainView",dom,u] + dom + body:= ["CONS",implem,dom] + SetFunctionSlots(sig,body,flag,"original") + 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 ["MDEF",:.] => nil + code is ["devaluate",:.] => nil + code is ["call",:.] => code + code is ["SETELT",:.] => code + code is ["QSETREFV",:.] => code + code is ["setShellEntry",:.] => code + stackWarning('"unknown Package code: %1 ",[code]) + code + +mkOperatorEntry(domainOrPackage,opSig is [op,sig,:flag],pred,count) == + domainOrPackage^="domain" => + [opSig,pred,["PAC","$",name]] where + name() == encodeFunctionName(op,domainOrPackage,sig,":",count) + null flag => [opSig,pred,["ELT","$",count]] + first flag="constant" => [[op,sig],pred,["CONST","$",count]] + systemError ["unknown variable mode: ",flag] + +optPackageCall(x,["PAC",packageVariableOrForm,functionName],arglist) == + RPLACA(x,functionName) + RPLACD(x,[:arglist,packageVariableOrForm]) + x + +--% Code for encoding function names inside package or domain + +encodeFunctionName(fun,package is [packageName,:arglist],signature,sep,count) + == + signature':= MSUBST("$",package,signature) + reducedSig:= mkRepititionAssoc [:rest signature',first signature'] + encodedSig:= + ("STRCONC"/[encodedPair for [n,:x] in reducedSig]) where + encodedPair() == + n=1 => encodeItem x + STRCONC(STRINGIMAGE n,encodeItem x) + encodedName:= INTERNL(getAbbreviation(packageName,#arglist),";", + encodeItem fun,";",encodedSig, sep,STRINGIMAGE count) + if $LISPLIB then + $lisplibSignatureAlist:= + [[encodedName,:signature'],:$lisplibSignatureAlist] + encodedName + +splitEncodedFunctionName(encodedName, sep) == + -- [encodedPackage, encodedItem, encodedSig, sequenceNo] or NIL + -- sep0 is the separator used in "encodeFunctionName". + sep0 := '";" + if not STRINGP 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, nil) + [s1, s2, s3, s4] + +mkRepititionAssoc l == + mkRepfun(l,1) where + mkRepfun(l,n) == + null l => nil + l is [x] => [[n,:x]] + l is [x, =x,:l'] => mkRepfun(rest l,n+1) + [[n,:first l],:mkRepfun(rest l,1)] + +encodeItem x == + x is [op,:argl] => getCaps op + IDENTP x => PNAME x + STRINGIMAGE x + +getCaps x == + s:= STRINGIMAGE x + clist:= [c for i in 0..MAXINDEX s | UPPER_-CASE_-P (c:= s.i)] + null clist => '"__" + "STRCONC"/[first clist,:[L_-CASE u for u in rest clist]] + +--% abbreviation code + +getAbbreviation(name,c) == + --returns abbreviation of name with c arguments + x := constructor? name + X := ASSQ(x,$abbreviationTable) => + N:= ASSQ(name,rest X) => + C:= ASSQ(c,rest N) => rest C --already there + newAbbreviation:= mkAbbrev(X,x) + RPLAC(rest N,[[c,:newAbbreviation],:rest N]) + newAbbreviation + newAbbreviation:= mkAbbrev(X,x) + RPLAC(rest X,[[name,[c,:newAbbreviation]],:rest X]) + newAbbreviation + $abbreviationTable:= [[x,[name,[c,:x]]],:$abbreviationTable] + x + +mkAbbrev(X,x) == addSuffix(alistSize rest X,x) + +alistSize c == + count(c,1) where + count(x,level) == + level=2 => #x + null x => 0 + count(CDAR x,level+1)+count(rest x,level) + +addSuffix(n,u) == + ALPHA_-CHAR_-P (s:= STRINGIMAGE u).(MAXINDEX s) => + INTERN STRCONC(s,STRINGIMAGE n) + INTERNL STRCONC(s,STRINGIMAGE ";",STRINGIMAGE n) + |