diff options
Diffstat (limited to 'src/interp/apply.boot.pamphlet')
| -rw-r--r-- | src/interp/apply.boot.pamphlet | 276 |
1 files changed, 276 insertions, 0 deletions
diff --git a/src/interp/apply.boot.pamphlet b/src/interp/apply.boot.pamphlet new file mode 100644 index 00000000..a859aa3d --- /dev/null +++ b/src/interp/apply.boot.pamphlet @@ -0,0 +1,276 @@ +\documentclass{article} +\usepackage{axiom} + +\title{\File{src/interp/apply.boot} Papmhlet} +\author{The Axiom Team} + +\begin{document} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject + +\section{License} + +<<license>>= +-- 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. + +@ +<<*>>= +<<license>> + +)package "BOOT" + +oldCompilerAutoloadOnceTrigger() == nil + +compAtomWithModemap(x,m,e,v) == + Tl := + [[transImplementation(x,map,fn),target,e] + for map in v | map is [[.,target],[.,fn]]] => + --accept only monadic operators + T:= or/[t for (t:= [.,target,.]) in Tl | modeEqual(m,target)] => T + 1=#(Tl:= [y for t in Tl | (y:= convert(t,m))]) => first Tl + 0<#Tl and m=$NoValueMode => first Tl + nil + +transImplementation(op,map,fn) == +--+ + fn := genDeltaEntry [op,:map] + fn is ["XLAM",:.] => [fn] + ["call",fn] + +compApply(sig,varl,body,argl,m,e) == + argTl:= [[.,.,e]:= comp(x,$EmptyMode,e) for x in argl] + contour:= + [Pair(x,[["mode",m'],["value",removeEnv comp(a,m',e)]]) + for x in varl for m' in sig.source for a in argl] + code:= [["LAMBDA",varl,body'],:[T.expr for T in argTl]] + m':= resolve(m,sig.target) + body':= (comp(body,m',addContour(contour,e))).expr + [code,m',e] + +compToApply(op,argl,m,e) == + T:= compNoStacking(op,$EmptyMode,e) or return nil + m1:= T.mode + T.expr is ["QUOTE", =m1] => nil + compApplication(op,argl,m,T.env,T) + +compApplication(op,argl,m,e,T) == + T.mode is ['Mapping, retm, :argml] => + #argl ^= #argml => nil + retm := resolve(m, retm) + retm = $Category or isCategoryForm(retm,e) => nil -- not handled + argTl := [[.,.,e] := comp(x,m,e) or return "failed" + for x in argl for m in argml] + argTl = "failed" => nil + form:= + not (member(op,$formalArgList) or member(T.expr,$formalArgList)) and ATOM T.expr => + nprefix := $prefix or + -- following needed for referencing local funs at capsule level + getAbbreviation($op,#rest $form) + [op',:[a.expr for a in argTl],"$"] where + op':= INTERN STRCONC(encodeItem nprefix,";",encodeItem T.expr) + ['call, ['applyFun, T.expr], :[a.expr for a in argTl]] + coerce([form, retm, e],resolve(retm,m)) + op = 'elt => nil + eltForm := ['elt, op, :argl] + comp(eltForm, m, e) + +compFormWithModemap(form is [op,:argl],m,e,modemap) == + [map:= [.,target,:.],[pred,impl]]:= modemap + -- this fails if the subsuming modemap is conditional + --impl is ['Subsumed,:.] => nil + if isCategoryForm(target,e) and isFunctor op then + [modemap,e]:= substituteIntoFunctorModemap(argl,modemap,e) or return nil + [map:= [.,target,:.],:cexpr]:= modemap + sv:=listOfSharpVars map + if sv then + -- SAY [ "compiling ", op, " in compFormWithModemap, + -- mode= ",map," sharp vars=",sv] + for x in argl for ss in $FormalMapVariableList repeat + if ss in sv then + [map:= [.,target,:.],:cexpr]:= modemap :=SUBST(x,ss,modemap) + -- SAY ["new map is",map] + not (target':= coerceable(target,m,e)) => nil + map:= [target',:rest map] + [f,Tl,sl]:= compApplyModemap(form,modemap,e,nil) or return nil + + --generate code; return + T:= + [x',m',e'] where + m':= SUBLIS(sl,map.(1)) + x':= + form':= [f,:[t.expr for t in Tl]] + m'=$Category or isCategoryForm(m',e) => form' + -- try to deal with new-style Unions where we know the conditions + op = "elt" and f is ['XLAM,:.] and IDENTP(z:=CAR argl) and + (c:=get(z,'condition,e)) and + c is [['case,=z,c1]] and + (c1 is ['_:,=(CADR argl),=m] or EQ(c1,CADR argl) ) => +-- first is a full tag, as placed by getInverseEnvironment +-- second is what getSuccessEnvironment will place there + ["CDR",z] + ["call",:form'] + e':= + Tl => (LAST Tl).env + e + convert(T,m) + +-- This version tends to give problems with #1 and categories +-- applyMapping([op,:argl],m,e,ml) == +-- #argl^=#ml-1 => nil +-- mappingHasCategoryTarget := +-- isCategoryForm(first ml,e) => --is op a functor? +-- form:= [op,:argl'] +-- pairlis:= [[v,:a] for a in argl for v in $FormalMapVariableList] +-- ml:= SUBLIS(pairlis,ml) +-- true +-- false +-- argl':= +-- [T.expr for x in argl for m' in rest ml] where +-- T() == [.,.,e]:= comp(x,m',e) or return "failed" +-- if argl'="failed" then return nil +-- mappingHasCategoryTarget => convert([form,first ml,e],m) +-- form:= +-- not member(op,$formalArgList) and ATOM op => +-- [op',:argl',"$"] where +-- op':= INTERN STRCONC(STRINGIMAGE $prefix,";",STRINGIMAGE op) +-- ["call",["applyFun",op],:argl'] +-- pairlis:= [[v,:a] for a in argl' for v in $FormalMapVariableList] +-- convert([form,SUBLIS(pairlis,first ml),e],m) + +applyMapping([op,:argl],m,e,ml) == + #argl^=#ml-1 => nil + isCategoryForm(first ml,e) => + --is op a functor? + pairlis:= [[v,:a] for a in argl for v in $FormalMapVariableList] + ml' := SUBLIS(pairlis, ml) + argl':= + [T.expr for x in argl for m' in rest ml'] where + T() == [.,.,e]:= comp(x,m',e) or return "failed" + if argl'="failed" then return nil + form:= [op,:argl'] + convert([form,first ml',e],m) + argl':= + [T.expr for x in argl for m' in rest ml] where + T() == [.,.,e]:= comp(x,m',e) or return "failed" + if argl'="failed" then return nil + form:= + not member(op,$formalArgList) and ATOM op and not get(op,'value,e) => + nprefix := $prefix or + -- following needed for referencing local funs at capsule level + getAbbreviation($op,#rest $form) + [op',:argl',"$"] where + op':= INTERN STRCONC(encodeItem nprefix,";",encodeItem op) + ['call,['applyFun,op],:argl'] + pairlis:= [[v,:a] for a in argl' for v in $FormalMapVariableList] + convert([form,SUBLIS(pairlis,first ml),e],m) + +--% APPLY MODEMAPS + +compApplyModemap(form,modemap,$e,sl) == + [op,:argl] := form --form to be compiled + [[mc,mr,:margl],:fnsel] := modemap --modemap we are testing + + -- $e is the current environment + -- sl substitution list, nil means bottom-up, otherwise top-down + + -- 0. fail immediately if #argl=#margl + + if #argl^=#margl then return nil + + -- 1. use modemap to evaluate arguments, returning failed if + -- not possible + + lt:= + [[.,m',$e]:= + comp(y,g,$e) or return "failed" where + g:= SUBLIS(sl,m) where + sl:= pmatchWithSl(m',m,sl) for y in argl for m in margl] + lt="failed" => return nil + + -- 2. coerce each argument to final domain, returning failed + -- if not possible + + lt':= [coerce(y,d) or return "failed" + for y in lt for d in SUBLIS(sl,margl)] + lt'="failed" => return nil + + -- 3. obtain domain-specific function, if possible, and return + + --$bindings is bound by compMapCond + [f,$bindings]:= compMapCond(op,mc,sl,fnsel) or return nil + +--+ can no longer trust what the modemap says for a reference into +--+ an exterior domain (it is calculating the displacement based on view +--+ information which is no longer valid; thus ignore this index and +--+ store the signature instead. + +--$NRTflag=true and f is [op1,d,.] and NE(d,'$) and member(op1,'(ELT CONST)) => + f is [op1,d,.] and member(op1,'(ELT CONST Subsumed)) => + [genDeltaEntry [op,:modemap],lt',$bindings] + [f,lt',$bindings] + +compMapCond(op,mc,$bindings,fnsel) == + or/[compMapCond'(u,op,mc,$bindings) for u in fnsel] + +compMapCond'([cexpr,fnexpr],op,dc,bindings) == + compMapCond''(cexpr,dc) => compMapCondFun(fnexpr,op,dc,bindings) + stackMessage ["not known that",'%b,dc,'%d,"has",'%b,cexpr,'%d] + +compMapCond''(cexpr,dc) == + cexpr=true => true + --cexpr = "true" => true + cexpr is ["AND",:l] => and/[compMapCond''(u,dc) for u in l] + cexpr is ["OR",:l] => or/[compMapCond''(u,dc) for u in l] + cexpr is ["not",u] => not compMapCond''(u,dc) + cexpr is ["has",name,cat] => (knownInfo cexpr => true; false) + --for the time being we'll stop here - shouldn't happen so far + --$disregardConditionIfTrue => true + --stackSemanticError(("not known that",'%b,name, + -- '%d,"has",'%b,cat,'%d),nil) + --now it must be an attribute + member(["ATTRIBUTE",dc,cexpr],get("$Information","special",$e)) => true + --for the time being we'll stop here - shouldn't happen so far + stackMessage ["not known that",'%b,dc,'%d,"has",'%b,cexpr,'%d] + false + +compMapCondFun(fnexpr,op,dc,bindings) == [fnexpr,bindings] + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} |