aboutsummaryrefslogtreecommitdiff
path: root/src/interp/modemap.boot.pamphlet
diff options
context:
space:
mode:
Diffstat (limited to 'src/interp/modemap.boot.pamphlet')
-rw-r--r--src/interp/modemap.boot.pamphlet379
1 files changed, 379 insertions, 0 deletions
diff --git a/src/interp/modemap.boot.pamphlet b/src/interp/modemap.boot.pamphlet
new file mode 100644
index 00000000..e5af0fac
--- /dev/null
+++ b/src/interp/modemap.boot.pamphlet
@@ -0,0 +1,379 @@
+\documentclass{article}
+\usepackage{axiom}
+
+\title{\$SPAD/src/interp modemap.boot}
+\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>>
+
+--% 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) ==
+ atom domain =>
+ EQ(domain,"$EmptyMode") => e
+ EQ(domain,"$NoValueMode") => e
+ not IDENTP domain or 2<#(s:= STRINGIMAGE domain) and
+ EQ(char "#",s.(0)) and EQ(char "#",s.(1)) => e
+ MEMQ(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)
+ if not isCategoryForm(domain,e) and
+ not member(name,'(Mapping CATEGORY)) then
+ unknownTypeError name
+ e --is not a functor
+
+domainMember(dom,domList) == or/[modeEqual(dom,d) for d in domList]
+
+--% MODEMAP FUNCTIONS
+
+--getTargetMode(x is [op,:argl],e) ==
+-- CASES(#(mml:= getModemapList(op,#argl,e)),
+-- (1 =>
+-- ([[.,target,:.],:.]:= first mml; substituteForFormalArguments(argl,target))
+-- ; 0 => MOAN(x," has no modemap"); systemError [x," has duplicate modemaps"]))
+
+getModemap(x is [op,:.],e) ==
+ for modemap in get(op,'modemap,e) repeat
+ if u:= compApplyModemap(x,modemap,e,nil) then return
+ ([.,.,sl]:= u; SUBLIS(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 [numOfArgs,'" argument form of: ",op,
+ '" has more than one modemap"]
+ 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]
+
+addModemapKnown(op,mc,sig,pred,fn,$e) ==
+-- if knownInfo pred then pred:=true
+-- that line is handled elsewhere
+ $insideCapsuleFunctionIfTrue=true =>
+ $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"
+ $functorForm is ['CategoryDefaults,:.] and mc="$" => e
+ --don't put CD modemaps into environment
+ --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] =>
+ STRINGP sel =>
+ id:= INTERN sel
+ if $insideCapsuleFunctionIfTrue=true
+ then $e:= makeLiteral(id,$e)
+ else e:= makeLiteral(id,e)
+ addModemap1(op,mc,[:lt,id],pred,fn,e)
+ -- atom sel => systemErrorHere '"addEltModemap"
+ addModemap1(op,mc,sig,pred,fn,e)
+ op='setelt and sig is [:lt,sel,v] =>
+ STRINGP sel =>
+ id:= INTERN sel
+ if $insideCapsuleFunctionIfTrue=true
+ then $e:= makeLiteral(id,$e)
+ else e:= makeLiteral(id,e)
+ addModemap1(op,mc,[:lt,id,v],pred,fn,e)
+ -- atom sel => systemError '"addEltModemap"
+ addModemap1(op,mc,sig,pred,fn,e)
+ systemErrorHere '"addEltModemap"
+
+--------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet)
+addModemap1(op,mc,sig,pred,fn,e) ==
+ --mc is the "mode of computation"; fn the "implementation"
+ if mc='Rep then
+ if fn is [kind,'Rep,.] and
+ -- save old sig for NRUNTIME
+ (kind = 'ELT or kind = 'CONST) then fn:=[kind,'Rep,sig]
+ sig:= substitute("$",'Rep,sig)
+ currentProplist:= getProplist(op,e) or nil
+ newModemapList:=
+ mkNewModemapList(mc,sig,pred,fn,LASSOC('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]
+ member(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 isSuperDomain(mc',mc,e) =>
+ newmm:= nil
+ mm:= modemapList
+ while (not EQ(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:= NCONC(NREVERSE newmm,[entry,:mmtail])
+ entry:= nil
+ return modemapList
+ if entry then [:modemapList,entry] else modemapList
+
+-- next definition RPLACs, and hence causes problems.
+-- In ptic., SubResGcd in SparseUnivariatePolynomial is miscompiled
+--mergeModemap(entry:=((mc,:sig),:.),modemapList,e) ==
+-- for (mmtail:= (((mc',:sig'),:.),:.)) in tails modemapList do
+-- mc=mc' or isSuperDomain(mc',mc,e) =>
+-- RPLACD(mmtail,(first mmtail,: rest mmtail))
+-- RPLACA(mmtail,entry)
+-- entry := nil
+-- return modemapList
+-- if entry then (:modemapList,entry) else modemapList
+
+isSuperDomain(domainForm,domainForm',e) ==
+ isSubset(domainForm',domainForm,e) => true
+ domainForm='Rep and domainForm'="$" => true --regard $ as a subdomain of Rep
+ LASSOC(opOf domainForm',get(domainForm,"SubDomain",e))
+
+--substituteForRep(entry is [[mc,:sig],:.],curModemapList) ==
+-- --change 'Rep to "$" unless the resulting signature is already in $
+-- member(entry':= substitute("$",'Rep,entry),curModemapList) =>
+-- [entry,:curModemapList]
+-- [entry,entry',:curModemapList]
+
+addNewDomain(domain,e) ==
+ augModemapsFromDomain(domain,domain,e)
+
+augModemapsFromDomain(name,functorForm,e) ==
+ member(KAR name or name,$DummyFunctorNames) => e
+ name=$Category or isCategoryForm(name,e) => e
+ member(name,curDomainsInScope:= getDomainsInScope e) => e
+ if u:= GETDATABASE(opOf functorForm,'SUPERDOMAIN) then
+ e:= addNewDomain(first u,e)
+ --need code to handle parameterized SuperDomains
+ if innerDom:= listOrVectorElementMode name then e:= addDomain(innerDom,e)
+ if name is ["Union",:dl] then for d in stripUnionTags dl
+ repeat e:= addDomain(d,e)
+ augModemapsFromDomain1(name,functorForm,e)
+ --see LISPLIB BOOT
+
+substituteCategoryArguments(argl,catform) ==
+ argl:= substitute("$$","$",argl)
+ arglAssoc:= [[INTERNL("#",STRINGIMAGE i),:a] for i in 1.. for a in argl]
+ SUBLIS(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:= (isCategory categoryForm => categoryForm.(0); categoryForm)
+ compilerMessage ["Adding ",domainName," modemaps"]
+ e:= putDomainsInScope(domainName,e)
+ $base:= 4
+ for [lhs:=[op,sig,:.],cond,fnsel] in fnAlist repeat
+ u:=ASSOC(SUBST('Rep,domainName,lhs),repFnAlist)
+ u and not AMFCR_,redefinedList(op,functorBody) =>
+ fnsel':=CADDR 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
+ MEMQ(op,'(PROGN SEQ)) => AMFCR_,redefinedList(opname,l)
+ op = 'COND => "OR"/[AMFCR_,redefinedList(opname,CDR u) for u in l]
+
+augModemapsFromCategory(domainName,domainView,functorForm,categoryForm,e) ==
+ [fnAlist,e]:= evalAndSub(domainName,domainView,functorForm,categoryForm,e)
+ -- catform:= (isCategory categoryForm => categoryForm.(0); categoryForm)
+ -- catform appears not to be used, so why set it?
+ --if ^$InteractiveMode then
+ compilerMessage ["Adding ",domainName," modemaps"]
+ e:= putDomainsInScope(domainName,e)
+ $base:= 4
+ condlist:=[]
+ for [[op,sig,:.],cond,fnsel] in fnAlist repeat
+-- e:= addModemap(op,domainName,sig,cond,fnsel,e)
+---------next 5 lines commented out to avoid wasting time checking knownInfo on
+---------conditions attached to each modemap being added, takes a very long time
+---------instead conditions will be checked when maps are actually used
+ --v:=ASSOC(cond,condlist) =>
+ -- e:= addModemapKnown(op,domainName,sig,CDR v,fnsel,e)
+ --$e:local := e -- $e is used by knownInfo
+ --if knownInfo cond then cond1:=true else cond1:=cond
+ --condlist:=[[cond,:cond1],:condlist]
+ e:= addModemapKnown(op,domainName,sig,cond,fnsel,e) -- cond was cond1
+-- for u in sig | (not member(u,$DomainsInScope)) and
+-- (not atom u) and
+-- (not isCategoryForm(u,e)) do
+-- e:= addNewDomain(u,e)
+ e
+
+--subCatParametersInto(domainForm,catForm,e) ==
+-- -- JHD 08/08/84 perhaps we are fortunate that it is not used
+-- --this is particularly dirty and should be cleaned up, say, by wrapping
+-- -- an appropriate lambda expression around mapping forms
+-- domainForm is [op,:l] and l =>
+-- get(op,'modemap,e) is [[[mc,:.],:.]] => SUBLIS(PAIR(rest mc,l),catForm)
+-- catForm
+
+--------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet)
+evalAndSub(domainName,viewName,functorForm,form,$e) ==
+ $lhsOfColon: local:= domainName
+ isCategory form => [substNames(domainName,viewName,functorForm,form.(1)),$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)
+ [substitute("$","$$",substAlist),$e]
+
+getOperationAlist(name,functorForm,form) ==
+ if atom name and GETDATABASE(name,'NILADIC) then functorForm:= [functorForm]
+-- (null isConstructorForm functorForm) and (u:= isFunctor functorForm)
+ (u:= isFunctor functorForm) and not
+ ($insideFunctorIfTrue and first functorForm=first $functorForm) => u
+ $insideFunctorIfTrue and name="$" =>
+ ($domainShell => $domainShell.(1); systemError '"$ has no shell now")
+ T:= compMakeCategoryObject(form,$e) => ([.,.,$e]:= T; T.expr.(1))
+ stackMessage ["not a category form: ",form]
+
+--------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet)
+substNames(domainName,viewName,functorForm,catForm) ==
+ EQSUBSTLIST(KDR functorForm,$FormalMapVariableList,
+ -- [[[op,if KAR fnsel="PAC" then sig else SUBSTQ(domainName,"$",sig),:x],pred,
+ -- SUBSTQ(viewName,"$",fnsel)] for [[op,sig,:x],pred,fnsel] in catForm])
+ -- following calls to SUBSTQ must copy to save RPLAC's in
+ -- putInLocalDomainReferences
+ [[:SUBSTQ(domainName,"$",modemapform),SUBSTQ(viewName,"$",fnsel)]
+ for [:modemapform,fnsel] in catForm])
+
+compCat(form is [functorName,:argl],m,e) ==
+ fn:= GETL(functorName,"makeFunctionList") or return nil
+ [funList,e]:= FUNCALL(fn,form,form,e)
+ catForm:=
+ ["Join",'(SetCategory),["CATEGORY","domain",:
+ [["SIGNATURE",op,sig] for [op,sig,.] in funList | op^="="]]]
+ --RDJ: for coercion purposes, it necessary to know it's a Set; I'm not
+ --sure if it uses any of the other signatures(see extendsCategoryForm)
+ [form,catForm,e]
+
+--------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet)
+addConstructorModemaps(name,form is [functorName,:.],e) ==
+ $InteractiveMode: local:= nil
+ e:= putDomainsInScope(name,e) --frame
+ fn := GETL(functorName,"makeFunctionList")
+ [funList,e]:= FUNCALL(fn,name,form,e)
+ for [op,sig,opcode] in funList repeat
+ e:= addModemap(op,name,sig,true,opcode,e)
+ e
+
+
+--The way XLAMs work:
+-- ((XLAM ($1 $2 $3) (SETELT $1 0 $3)) X "c" V) ==> (SETELT X 0 V)
+
+getDomainsInScope e ==
+ $insideCapsuleFunctionIfTrue=true => $CapsuleDomainsInScope
+ get("$DomainsInScope","special",e)
+
+putDomainsInScope(x,e) ==
+ l:= getDomainsInScope e
+ if member(x,l) then SAY("****** Domain: ",x," already in scope")
+ newValue:= [x,:delete(x,l)]
+ $insideCapsuleFunctionIfTrue => ($CapsuleDomainsInScope:= newValue; e)
+ put("$DomainsInScope","special",newValue,e)
+
+@
+\eject
+\begin{thebibliography}{99}
+\bibitem{1} nothing
+\end{thebibliography}
+\end{document}