diff options
Diffstat (limited to 'src/interp')
| -rw-r--r-- | src/interp/buildom.boot (renamed from src/interp/buildom.boot.pamphlet) | 162 | ||||
| -rw-r--r-- | src/interp/c-doc.boot (renamed from src/interp/c-doc.boot.pamphlet) | 26 | ||||
| -rw-r--r-- | src/interp/cattable.boot (renamed from src/interp/cattable.boot.pamphlet) | 26 | ||||
| -rw-r--r-- | src/interp/clam.boot (renamed from src/interp/clam.boot.pamphlet) | 27 | ||||
| -rw-r--r-- | src/interp/clammed.boot (renamed from src/interp/clammed.boot.pamphlet) | 22 | ||||
| -rw-r--r-- | src/interp/compress.boot (renamed from src/interp/compress.boot.pamphlet) | 22 | ||||
| -rw-r--r-- | src/interp/cstream.boot (renamed from src/interp/cstream.boot.pamphlet) | 36 | ||||
| -rw-r--r-- | src/interp/database.boot (renamed from src/interp/database.boot.pamphlet) | 152 | ||||
| -rw-r--r-- | src/interp/domain.lisp.pamphlet | 247 | ||||
| -rw-r--r-- | src/interp/fnewmeta.lisp (renamed from src/interp/fnewmeta.lisp.pamphlet) | 272 | ||||
| -rw-r--r-- | src/interp/format.boot (renamed from src/interp/format.boot.pamphlet) | 24 | ||||
| -rw-r--r-- | src/interp/fortcall.boot (renamed from src/interp/fortcall.boot.pamphlet) | 136 | ||||
| -rw-r--r-- | src/interp/functor.boot (renamed from src/interp/functor.boot.pamphlet) | 26 |
13 files changed, 191 insertions, 987 deletions
diff --git a/src/interp/buildom.boot.pamphlet b/src/interp/buildom.boot index cbbc7a43..31fd1336 100644 --- a/src/interp/buildom.boot.pamphlet +++ b/src/interp/buildom.boot @@ -1,16 +1,3 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp buildom.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{License} -<<license>>= -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. -- @@ -42,9 +29,6 @@ -- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -@ -<<*>>= -<<license>> -- This file contains the constructors for the domains that cannot -- be written in ScratchpadII yet. They are not cached because they @@ -74,36 +58,36 @@ Record0 args == -- JHD added an extra slot to cache EQUAL methods dom.0 := ["Record", :[["_:", CAR a, devaluate CDR a] for a in args]] dom.1 := - [function lookupInTable,dom, - [["_=",[[["Boolean"],"_$","_$"],:12]], - ["coerce",[[$Expression,"_$"],:14]]]] + [function lookupInTable,dom, + [["_=",[[["Boolean"],"_$","_$"],:12]], + ["coerce",[[$Expression,"_$"],:14]]]] dom.2 := NIL dom.3 := ["RecordCategory",:QCDR dom.0] dom.4 := - [[ '(SetCategory) ],[ '(SetCategory) ]] + [[ '(SetCategory) ],[ '(SetCategory) ]] dom.5 := [CDR a for a in args] dom.6 := [function RecordEqual, :dom] dom.7 := [function RecordPrint, :dom] dom.8 := [function Undef, :dom] -- following is cache for equality functions dom.9 := if (n:= LENGTH args) <= 2 - then [NIL,:NIL] - else GETREFV n + then [NIL,:NIL] + else GETREFV n dom RecordEqual(x,y,dom) == PAIRP x => b:= SPADCALL(CAR x, CAR y, CAR(dom.9) or - CAR RPLACA(dom.9,findEqualFun(dom.5.0))) + CAR RPLACA(dom.9,findEqualFun(dom.5.0))) NULL rest(dom.5) => b b and SPADCALL(CDR x, CDR y, CDR (dom.9) or - CDR RPLACD(dom.9,findEqualFun(dom.5.1))) + CDR RPLACD(dom.9,findEqualFun(dom.5.1))) VECP x => equalfuns := dom.9 and/[SPADCALL(x.i,y.i,equalfuns.i or (equalfuns.i:=findEqualFun(fdom))) - for i in 0.. for fdom in dom.5] + for i in 0.. for fdom in dom.5] error '"Bug: Silly record representation" RecordPrint(x,dom) == coerceRe2E(x,dom.3) @@ -136,16 +120,16 @@ coerceRe2E(x,source) == Union(:args) == dom := GETREFV 9 dom.0 := ["Union", :[(if a is ["_:",tag,domval] then ["_:",tag,devaluate domval] - else devaluate a) for a in args]] + else devaluate a) for a in args]] dom.1 := - [function lookupInTable,dom, - [["_=",[[["Boolean"],"_$","_$"],:12]], - ["coerce",[[$Expression,"_$"],:14]]]] + [function lookupInTable,dom, + [["_=",[[["Boolean"],"_$","_$"],:12]], + ["coerce",[[$Expression,"_$"],:14]]]] dom.2 := NIL dom.3 := '(SetCategory) dom.4 := - [[ '(SetCategory) ],[ '(SetCategory) ]] + [[ '(SetCategory) ],[ '(SetCategory) ]] dom.5 := args dom.6 := [function UnionEqual, :dom] dom.7 := [function UnionPrint, :dom] @@ -190,14 +174,14 @@ Mapping(:args) == dom := GETREFV 9 dom.0 := ["Mapping", :[devaluate a for a in args]] dom.1 := - [function lookupInTable,dom, - [["_=",[[["Boolean"],"_$","_$"],:12]], - ["coerce",[[$Expression,"_$"],:14]]]] + [function lookupInTable,dom, + [["_=",[[["Boolean"],"_$","_$"],:12]], + ["coerce",[[$Expression,"_$"],:14]]]] dom.2 := NIL dom.3 := '(SetCategory) dom.4 := - [[ '(SetCategory) ],[ '(SetCategory) ]] + [[ '(SetCategory) ],[ '(SetCategory) ]] dom.5 := args dom.6 := [function MappingEqual, :dom] dom.7 := [function MappingPrint, :dom] @@ -221,14 +205,14 @@ Enumeration(:"args") == -- JHD added an extra slot to cache EQUAL methods dom.0 := ["Enumeration", :args] dom.1 := - [function lookupInTable,dom, - [["_=",[[["Boolean"],"_$","_$"],:12]], - ["coerce",[[$Expression,"_$"],:14], [["_$", $Symbol], :16]] + [function lookupInTable,dom, + [["_=",[[["Boolean"],"_$","_$"],:12]], + ["coerce",[[$Expression,"_$"],:14], [["_$", $Symbol], :16]] ]] dom.2 := NIL dom.3 := ["EnumerationCategory",:QCDR dom.0] dom.4 := - [[ '(SetCategory) ],[ '(SetCategory) ]] + [[ '(SetCategory) ],[ '(SetCategory) ]] dom.5 := args dom.6 := [function EnumEqual, :dom] dom.7 := [function EnumPrint, :dom] @@ -256,11 +240,11 @@ UnionCategory(:"x") == constructorCategory ["Union",:x] --ListCategory(:"x") == constructorCategory ("List",:x) --VectorCategory(:"x") == constructorCategory ("Vector",:x) - --above two now defined in SPAD code. + --above two now defined in SPAD code. constructorCategory (title is [op,:.]) == constructorFunction:= GETL(op,"makeFunctionList") or - systemErrorHere '"constructorCategory" + systemErrorHere '"constructorCategory" [funlist,.]:= FUNCALL(constructorFunction,"$",title,$CategoryFrame) oplist:= [[[a,b],true,c] for [a,b,c] in funlist] cat:= @@ -282,23 +266,23 @@ mkRecordFunList(nam,["Record",:Alist],e) == -- for (.,a,.) in Alist do -- if getmode(a,e) then MOAN("Symbol: ",a, --- " must not be both a variable and literal") +-- " must not be both a variable and literal") -- e:= put(a,"isLiteral","true",e) dc := GENSYM() sigFunAlist:= --:((a,(A,nam),("XLAM",("$1","$2"),("RECORDELT","$1",i,len))) - -- for i in 0..,(.,a,A) in Alist), + -- for i in 0..,(.,a,A) in Alist), [["construct",[nam,:[A for [.,a,A] in Alist]],"mkRecord"], ["_=",[["Boolean"],nam ,nam],["ELT",dc,6]], ["coerce",[$Expression,nam],["ELT",dc,7]],: - [["elt",[A,nam,PNAME a],["XLAM",["$1","$2"],["RECORDELT","$1",i,len]]] - for i in 0.. for [.,a,A] in Alist],: - [["setelt",[A,nam,PNAME a,A],["XLAM",["$1","$2","$3"], - ["SETRECORDELT","$1",i, len,"$3"]]] - for i in 0.. for [.,a,A] in Alist],: - [["copy",[nam,nam],["XLAM",["$1"],["RECORDCOPY", - "$1",len]]]]] + [["elt",[A,nam,PNAME a],["XLAM",["$1","$2"],["RECORDELT","$1",i,len]]] + for i in 0.. for [.,a,A] in Alist],: + [["setelt",[A,nam,PNAME a,A],["XLAM",["$1","$2","$3"], + ["SETRECORDELT","$1",i, len,"$3"]]] + for i in 0.. for [.,a,A] in Alist],: + [["copy",[nam,nam],["XLAM",["$1"],["RECORDCOPY", + "$1",len]]]]] [substitute(nam,dc,substitute("$","Rep",sigFunAlist)),e] mkNewUnionFunList(name,form is ["Union",:listOfEntries],e) == @@ -309,18 +293,18 @@ mkNewUnionFunList(name,form is ["Union",:listOfEntries],e) == [["_=",[["Boolean"],name ,name],["ELT",dc,6]], ["coerce",[$Expression,name],["ELT",dc,7]],: ("append"/ - [[["construct",[name,type],["XLAM",["#1"],["CONS",i,"#1"]]], - ["elt",[type,name,tag],cdownFun], - ["case",['(Boolean),name,tag], - ["XLAM",["#1"],["QEQCAR","#1",i]]]] - for [.,tag,type] in listOfEntries for i in 0..])] where - cdownFun() == - gg:=GENSYM() - $InteractiveMode => - ["XLAM",["#1"],["PROG1",["QCDR","#1"], - ["check_-union",["QEQCAR","#1",i],type,"#1"]]] - ["XLAM",["#1"],["PROG2",["LET",gg,"#1"],["QCDR",gg], - ["check_-union",["QEQCAR",gg,i],type,gg]]] + [[["construct",[name,type],["XLAM",["#1"],["CONS",i,"#1"]]], + ["elt",[type,name,tag],cdownFun], + ["case",['(Boolean),name,tag], + ["XLAM",["#1"],["QEQCAR","#1",i]]]] + for [.,tag,type] in listOfEntries for i in 0..])] where + cdownFun() == + gg:=GENSYM() + $InteractiveMode => + ["XLAM",["#1"],["PROG1",["QCDR","#1"], + ["check_-union",["QEQCAR","#1",i],type,"#1"]]] + ["XLAM",["#1"],["PROG2",["LET",gg,"#1"],["QCDR",gg], + ["check_-union",["QEQCAR",gg,i],type,gg]]] [cList,e] mkEnumerationFunList(nam,["Enumeration",:SL],e) == @@ -347,40 +331,34 @@ mkUnionFunList(op,form is ["Union",:listOfEntries],e) == ["coerce",[$Expression,g],["ELT",op,7]],: ("append"/ [[["autoCoerce",[g,t],upFun], - ["coerce",[t,g],cdownFun], - ["autoCoerce",[t,g],downFun], --this should be removed eventually - ["case",['(Boolean),g,t],typeFun]] - for p in predList for t in listOfEntries])] where - upFun() == - p is ["EQCAR",x,n] => ["XLAM",["#1"],["CONS",n,"#1"]] - ["XLAM",["#1"],"#1"] - cdownFun() == - gg:=GENSYM() - if p is ["EQCAR",x,n] then - ref:=["QCDR",gg] - q:= ["QEQCAR", gg, n] - else - ref:=gg - q:= substitute(gg,"#1",p) - ["XLAM",["#1"],["PROG2",["LET",gg,"#1"],ref, - ["check_-union",q,t,gg]]] - downFun() == - p is ["EQCAR",x,.] => - ["XLAM",["#1"],["QCDR","#1"]] - ["XLAM",["#1"],"#1"] - typeFun() == - p is ["EQCAR",x,n] => - ["XLAM",["#1"],["QEQCAR",x,n]] - ["XLAM",["#1"],p] + ["coerce",[t,g],cdownFun], + ["autoCoerce",[t,g],downFun], --this should be removed eventually + ["case",['(Boolean),g,t],typeFun]] + for p in predList for t in listOfEntries])] where + upFun() == + p is ["EQCAR",x,n] => ["XLAM",["#1"],["CONS",n,"#1"]] + ["XLAM",["#1"],"#1"] + cdownFun() == + gg:=GENSYM() + if p is ["EQCAR",x,n] then + ref:=["QCDR",gg] + q:= ["QEQCAR", gg, n] + else + ref:=gg + q:= substitute(gg,"#1",p) + ["XLAM",["#1"],["PROG2",["LET",gg,"#1"],ref, + ["check_-union",q,t,gg]]] + downFun() == + p is ["EQCAR",x,.] => + ["XLAM",["#1"],["QCDR","#1"]] + ["XLAM",["#1"],"#1"] + typeFun() == + p is ["EQCAR",x,n] => + ["XLAM",["#1"],["QEQCAR",x,n]] + ["XLAM",["#1"],p] op:= op="Rep" => "$" op cList:= substitute(op,g,cList) [cList,e] -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/c-doc.boot.pamphlet b/src/interp/c-doc.boot index d1d0949c..ffbb4617 100644 --- a/src/interp/c-doc.boot.pamphlet +++ b/src/interp/c-doc.boot @@ -1,20 +1,3 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/c-doc.boot} Pamphlet} -\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. -- @@ -46,9 +29,6 @@ -- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -@ -<<*>>= -<<license>> batchExecute() == _/RF_-1 '(GENCON INPUT) @@ -1290,9 +1270,3 @@ checkDecorateForHt u == -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/cattable.boot.pamphlet b/src/interp/cattable.boot index d25eaf80..2d5e74ca 100644 --- a/src/interp/cattable.boot.pamphlet +++ b/src/interp/cattable.boot @@ -1,20 +1,3 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp cattable.boot} Pamphlet} -\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. -- @@ -46,9 +29,6 @@ -- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -@ -<<*>>= -<<license>> hasCat(domainOrCatName,catName) == catName='Object or catName='Type -- every domain is a Type (Object) @@ -519,9 +499,3 @@ clearTempCategoryTable(catNames) == -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/clam.boot.pamphlet b/src/interp/clam.boot index d811c00a..3095753f 100644 --- a/src/interp/clam.boot.pamphlet +++ b/src/interp/clam.boot @@ -1,19 +1,3 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{/src/interp/clam.boot} Pamphlet} -\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. -- @@ -45,9 +29,6 @@ -- 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" @@ -719,11 +700,3 @@ removeAllClams() == for [fun,:.] in $clamList repeat sayBrightly ['"Un-clamming function",'%b,fun,'%d] SET(fun,eval INTERN STRCONC(STRINGIMAGE fun,'";")) -@ - - -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/clammed.boot.pamphlet b/src/interp/clammed.boot index d0689739..82cbffe9 100644 --- a/src/interp/clammed.boot.pamphlet +++ b/src/interp/clammed.boot @@ -1,16 +1,3 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp clammed.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{License} -<<license>>= -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. -- @@ -42,9 +29,6 @@ -- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -@ -<<*>>= -<<license>> --% Functions on $clamList @@ -221,9 +205,3 @@ underDomainOf t == u := getUnderModeOf(t) => u last d -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/compress.boot.pamphlet b/src/interp/compress.boot index ddf74136..a9e41ac5 100644 --- a/src/interp/compress.boot.pamphlet +++ b/src/interp/compress.boot @@ -1,16 +1,3 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp compress.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{License} -<<license>>= -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. -- @@ -42,9 +29,6 @@ -- 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" @@ -81,9 +65,3 @@ minimalise x == x -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/cstream.boot.pamphlet b/src/interp/cstream.boot index 46be9728..01190dac 100644 --- a/src/interp/cstream.boot.pamphlet +++ b/src/interp/cstream.boot @@ -1,30 +1,3 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp cstream.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -The input stream is parsed into a large s-expression by repeated calls -to Delay. Delay takes a function f and an argument x and returns a list -consisting of ("nonnullstream" f x). Eventually multiple calls are made -and a large list structure is created that consists of -("nonnullstream" f x ("nonnullstream" f1 x1 ("nonnullstream" f2 x2... - -This delay structure is given to StreamNull which walks along the -list looking at the head. If the head is "nonnullstream" then the -function is applied to the argument. - -So, in effect, the input is "zipped up" into a Delay data structure -which is then evaluated by calling StreamNull. This "zippered stream" -parser was a research project at IBM and Axiom was the testbed (which -explains the strange parsing technique). -\section{License} -<<license>>= -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. -- @@ -56,9 +29,6 @@ explains the strange parsing technique). -- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -@ -<<*>>= -<<license>> import '"sys-macros" @@ -139,9 +109,3 @@ spadcall1(g)== spadcall2(f,args) == [impl, :env] := f APPLY(impl, [args, env]) -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/database.boot.pamphlet b/src/interp/database.boot index f33d9333..e1c9e069 100644 --- a/src/interp/database.boot.pamphlet +++ b/src/interp/database.boot @@ -1,20 +1,3 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/database.boot} Pamphlet} -\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. -- @@ -46,9 +29,6 @@ -- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -@ -<<*>>= -<<license>> SETANDFILEQ($getUnexposedOperations,true) @@ -72,7 +52,7 @@ augLisplibModemapsFromCategory(form is [op,:argl],body,signature) == pred':= MKPF([pred,:catPredList],'AND) modemap:= [["*1",:sig],[pred',sel]] $lisplibModemapAlist:= - [[op,:interactiveModemapForm modemap],:$lisplibModemapAlist] + [[op,:interactiveModemapForm modemap],:$lisplibModemapAlist] augmentLisplibModemapsFromFunctor(form,opAlist,signature) == form:= [formOp,:argl]:= formal2Pattern form @@ -88,30 +68,30 @@ augmentLisplibModemapsFromFunctor(form,opAlist,signature) == for (entry:= [[op,sig,:.],pred,sel]) in opAlist | or/[(sig in catSig) for catSig in allLASSOCs(op,nonCategorySigAlist)] repeat - skip:= - argl and CONTAINED("$",rest sig) => 'SKIP - nil - sel:= substitute(form,"$",sel) - patternList:= listOfPatternIds sig - --get relevant predicates - predList:= - [[a,m] for a in argl for m in rest signature - | MEMQ(a,$PatternVariableList)] - sig:= substitute(form,"$",sig) - pred':= MKPF([pred,:[mkDatabasePred y for y in predList]],'AND) - l:=listOfPatternIds predList - if "OR"/[null MEMQ(u,l) for u in argl] then - sayMSG ['"cannot handle modemap for",:bright op, - '"by pattern match" ] - skip:= 'SKIP - modemap:= [[form,:sig],[pred',sel,:skip]] - $lisplibModemapAlist:= [[op,:interactiveModemapForm modemap], - :$lisplibModemapAlist] + skip:= + argl and CONTAINED("$",rest sig) => 'SKIP + nil + sel:= substitute(form,"$",sel) + patternList:= listOfPatternIds sig + --get relevant predicates + predList:= + [[a,m] for a in argl for m in rest signature + | MEMQ(a,$PatternVariableList)] + sig:= substitute(form,"$",sig) + pred':= MKPF([pred,:[mkDatabasePred y for y in predList]],'AND) + l:=listOfPatternIds predList + if "OR"/[null MEMQ(u,l) for u in argl] then + sayMSG ['"cannot handle modemap for",:bright op, + '"by pattern match" ] + skip:= 'SKIP + modemap:= [[form,:sig],[pred',sel,:skip]] + $lisplibModemapAlist:= [[op,:interactiveModemapForm modemap], + :$lisplibModemapAlist] rebuildCDT(filemode) == clearConstructorAndLisplibCaches() $databaseQueue:local :=nil - $e: local := [[NIL]] -- We may need to evaluate Categories + $e: local := [[NIL]] -- We may need to evaluate Categories buildDatabase(filemode,false) $IOindex:= 1 $InteractiveFrame:= [[NIL]] @@ -119,7 +99,7 @@ rebuildCDT(filemode) == buildDatabase(filemode,expensive) == $InteractiveMode: local:= true - $constructorList := nil --looked at by buildLibdb + $constructorList := nil --looked at by buildLibdb $ConstructorCache:= MAKE_-HASHTABLE('ID) SAY '"Making constructor autoload" makeConstructorsAutoLoad() @@ -189,14 +169,14 @@ orderPredicateItems(pred1,sig,skip) == orderPredTran(oldList,sig,skip) == lastPreds:=nil --(1) make two kinds of predicates appear last: - ----- (op *target ..) when *target does not appear later in sig - ----- (isDomain *1 ..) + ----- (op *target ..) when *target does not appear later in sig + ----- (isDomain *1 ..) for pred in oldList repeat ((pred is [op,pvar,.] and MEMQ(op,'(isDomain ofCategory)) and pvar=first sig and ^(pvar in rest sig)) or - (^skip and pred is ['isDomain,pvar,.] and pvar="*1")) => - oldList:=delete(pred,oldList) - lastPreds:=[pred,:lastPreds] + (^skip and pred is ['isDomain,pvar,.] and pvar="*1")) => + oldList:=delete(pred,oldList) + lastPreds:=[pred,:lastPreds] --sayBrightlyNT "lastPreds=" --pp lastPreds @@ -221,7 +201,7 @@ orderPredTran(oldList,sig,skip) == indepvl := listOfPatternIds x depvl := nil (INTERSECTIONQ(indepvl,dependList) = nil) - and INTERSECTIONQ(indepvl,lastDependList) => + and INTERSECTIONQ(indepvl,lastDependList) => somethingDone := true lastPreds := [:lastPreds,x] oldList := delete(x,oldList) @@ -235,14 +215,14 @@ orderPredTran(oldList,sig,skip) == while oldList repeat for x in oldList repeat if (x is ['ofCategory,v,body]) or (x is ['isDomain,v,body]) then - indepvl:=listOfPatternIds v - depvl:=listOfPatternIds body + indepvl:=listOfPatternIds v + depvl:=listOfPatternIds body else - indepvl := listOfPatternIds x - depvl := nil + indepvl := listOfPatternIds x + depvl := nil (INTERSECTIONQ(indepvl,dependList) = nil) => - dependList:= setDifference(dependList,depvl) - newList:= [:newList,x] + dependList:= setDifference(dependList,depvl) + newList:= [:newList,x] -- sayBrightlyNT "newList=" -- pp newList @@ -259,7 +239,7 @@ orderPredTran(oldList,sig,skip) == if pred is ['isDomain,x,y] or x is ['ofCategory,x,y] then ids:= listOfPatternIds y if and/[id in fullDependList for id in ids] then - fullDependList:= insertWOC(x,fullDependList) + fullDependList:= insertWOC(x,fullDependList) fullDependList:= UNIONQ(fullDependList,ids) newList:=[:newList,:lastPreds] @@ -274,8 +254,8 @@ isDomainSubst u == main where main == u is [head,:tail] => nhead := - head is ['isDomain,x,y] => ['isDomain,x,fn(y,tail)] - head + head is ['isDomain,x,y] => ['isDomain,x,fn(y,tail)] + head [nhead,:isDomainSubst rest u] u fn(x,alist) == @@ -397,7 +377,7 @@ getDomainFromMm mm == if cond is ['partial, :c] then cond := c condList := cond is ['AND, :cl] => cl - cond is ['OR, ['AND, :cl],:.] => cl --all cl's should give same info + cond is ['OR, ['AND, :cl],:.] => cl --all cl's should give same info [cond] val := for condition in condList repeat @@ -417,7 +397,7 @@ getFirstArgTypeFromMm mm == if cond is ['partial, :c] then cond := c condList := cond is ['AND, :cl] => cl - cond is ['OR, ['AND, :cl],:.] => cl --all cl's should give same info + cond is ['OR, ['AND, :cl],:.] => cl --all cl's should give same info [cond] type := nil for condition in condList while not type repeat @@ -436,7 +416,7 @@ isFreeFunctionFromMmCond cond == if cond is ['partial, :c] then cond := c condList := cond is ['AND, :cl] => cl - cond is ['OR, ['AND, :cl],:.] => cl --all cl's should give same info + cond is ['OR, ['AND, :cl],:.] => cl --all cl's should give same info [cond] iff := false for condition in condList while not iff repeat @@ -463,7 +443,7 @@ getSystemModemaps(op,nargs) == for (x := [[.,:sig],.]) in mml repeat (NUMBERP nargs) and (nargs ^= #QCDR sig) => 'iterate $getUnexposedOperations or isFreeFunctionFromMm(x) or - isExposedConstructor(getDomainFromMm(x)) => mms := [x,:mms] + isExposedConstructor(getDomainFromMm(x)) => mms := [x,:mms] 'iterate mms nil @@ -473,8 +453,8 @@ getInCoreModemaps(modemapList,op,nargs) == mml:= CAR mml [x for (x:= [[dc,:sig],.]) in mml | (NUMBERP nargs => nargs=#rest sig; true) and - (cfn := abbreviate (domName := getDomainFromMm x)) and - ($getUnexposedOperations or isExposedConstructor(domName))] + (cfn := abbreviate (domName := getDomainFromMm x)) and + ($getUnexposedOperations or isExposedConstructor(domName))] nil mkAlistOfExplicitCategoryOps target == @@ -486,16 +466,16 @@ mkAlistOfExplicitCategoryOps target == l:= flattenSignatureList ['PROGN,:l] u:= [[atomizeOp op,:sig] for x in l | x is ['SIGNATURE,op,sig,:.]] - where - atomizeOp op == - atom op => op - op is [a] => a - keyedSystemError("S2GE0016", - ['"mkAlistOfExplicitCategoryOps",'"bad signature"]) + where + atomizeOp op == + atom op => op + op is [a] => a + keyedSystemError("S2GE0016", + ['"mkAlistOfExplicitCategoryOps",'"bad signature"]) opList:= REMDUP ASSOCLEFT u [[x,:fn(x,u)] for x in opList] where fn(op,u) == - u is [[a,:b],:c] => (a=op => [b,:fn(op,c)]; fn(op,c)) + u is [[a,:b],:c] => (a=op => [b,:fn(op,c)]; fn(op,c)) isCategoryForm(target,$e) => nil keyedSystemError("S2GE0016", ['"mkAlistOfExplicitCategoryOps",'"bad signature"]) @@ -508,8 +488,8 @@ flattenSignatureList(x) == x is ['PROGN,:l] => ll:= [] for x in l repeat - x is ['SIGNATURE,:.] => ll:=cons(x,ll) - ll:= append(flattenSignatureList x,ll) + x is ['SIGNATURE,:.] => ll:=cons(x,ll) + ll:= append(flattenSignatureList x,ll) ll nil @@ -569,16 +549,16 @@ loadDependents fn == l:= rread('dependents,stream,nil) RSHUT stream for x in l repeat - x='SubDomain => nil - loadIfNecessary x + x='SubDomain => nil + loadIfNecessary x --% Miscellaneous Stuff getOplistForConstructorForm (form := [op,:argl]) == -- The new form is an op-Alist which has entries (<op> . signature-Alist) - -- where signature-Alist has entries (<signature> . item) - -- where item has form (<slotNumber> <condition> <kind>) - -- where <kind> = ELT | CONST | Subsumed | (XLAM..) .. + -- where signature-Alist has entries (<signature> . item) + -- where item has form (<slotNumber> <condition> <kind>) + -- where <kind> = ELT | CONST | Subsumed | (XLAM..) .. pairlis:= [[fv,:arg] for fv in $FormalMapVariableList for arg in argl] opAlist := getOperationAlistFromLisplib op [:getOplistWithUniqueSignatures(op,pairlis,signatureAlist) @@ -588,8 +568,8 @@ getOplistWithUniqueSignatures(op,pairlis,signatureAlist) == alist:= nil for [sig,:[slotNumber,pred,kind]] in signatureAlist | kind ^= 'Subsumed repeat alist:= insertAlist(SUBLIS(pairlis,[op,sig]), - SUBLIS(pairlis,[pred,[kind,nil,slotNumber]]), - alist) + SUBLIS(pairlis,[pred,[kind,nil,slotNumber]]), + alist) alist --% Code For Modemap Insertion @@ -617,21 +597,21 @@ dropPrefix(fn) == --++ egFiles := NIL --++ while (not PLACEP (x:= READ_-LINE stream)) repeat --++ x := DROPTRAILINGBLANKS x ---++ SIZE(x) = 0 => 'iterate -- blank line +--++ SIZE(x) = 0 => 'iterate -- blank line --++ (x.0 = char "#") or (x.0 = char "*") => 'iterate -- comment --++ x.0 = char " " => --++ -- possible exposure group member name and library name --++ null egName => ---++ throwKeyedMsg("S2IZ0069A",[namestring egFile,x]) +--++ throwKeyedMsg("S2IZ0069A",[namestring egFile,x]) --++ x := dropLeadingBlanks x --++ -- should be two tokens on the line --++ p := STRPOS('" ",x,1,NIL) --++ NULL p => ---++ throwKeyedMsg("S2IZ0069B",[namestring egFile,x]) +--++ throwKeyedMsg("S2IZ0069B",[namestring egFile,x]) --++ n := object2Identifier SUBSTRING(x,0,p) --++ x := dropLeadingBlanks SUBSTRING(x,p+1,NIL) --++ SIZE(x) = 0 => ---++ throwKeyedMsg("S2IZ0069B",[namestring egFile,x]) +--++ throwKeyedMsg("S2IZ0069B",[namestring egFile,x]) --++ egFiles := [[n,:object2Identifier x],:egFiles] --++ -- have a new group name --++ if egName then $globalExposureGroupAlist := @@ -689,9 +669,3 @@ displayHiddenConstructors() == centerAndHighlight c -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/domain.lisp.pamphlet b/src/interp/domain.lisp.pamphlet deleted file mode 100644 index 775f3526..00000000 --- a/src/interp/domain.lisp.pamphlet +++ /dev/null @@ -1,247 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp domain.lisp} -\author{Timothy Daly} -\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>> - -;; lisp support for creating domain stubs - -(in-package "BOOT") -;;(SETQ |$optimizableConstructorNames| nil) - -(defstruct domain constructor args - (dollar (check-dollar-fields constructor args))) - -(defstruct (old-compiler-domain (:include domain) (:conc-name oldom-)) - (devaluate (if dollar (|devaluate| dollar) - (CONS constructor (MAPCAR #'|devaluate| args)))) - (vector nil)) - -(defun check-dollar-fields (constructor arglist) - (if (some #'(lambda (x) (and (domain-p x) (domain-dollar x))) arglist) - (apply constructor (mapcar #'(lambda (x) (if (domain-p x) - (or (domain-dollar x) x) - x)) arglist)) - nil)) - -(defun |domain?| (x) (domain-p x)) - -(defun |Mapping| (&rest args) - (make-old-compiler-domain :constructor '|Mapping| :args args - :vector '|Mapping0|)) - -(defun |Record| (&rest args) - (make-old-compiler-domain :constructor '|Record| :args args - :vector '|Record0|)) - -(defun |Union| (&rest args) - (make-old-compiler-domain :constructor '|Union| :args args - :vector '|Union0|)) - -(defun |devaluate| (x &aux tag dom) - (cond ((REFVECP x) - (if (> (QVSIZE x) 5) - (cond ((equal (qvelt x 3) '(|Category|)) - (qvelt x 0)) -;; next line will become obsolete - ((|isFunctor| (qvelt x 0)) (qvelt x 0)) - ((domain-p (qvelt x 0)) (|devaluate| (qvelt x 0))) - (t x)) - x)) - ((and (pairp x) (eq (car x) '|:|) (dcq (tag dom) (cdr x))) - (list (car x) tag (|devaluate| dom))) -; 20030527 note that domain-p does not exist - ((not (domain-p x)) x) -; 20030527 note that old-compiler-domain-p does not exist - ((old-compiler-domain-p x) (oldom-devaluate x)) - (t (error "devaluate of new compiler domain")))) - -(defun |domainEqual| (x y) - (cond ((old-compiler-domain-p x) - (if (old-compiler-domain-p y) - (equalp (oldom-devaluate x) (oldom-devaluate y)) - nil)) - ((old-compiler-domain-p y) nil) - (t (error "no new compiler domains yet")))) - -(defun |domainSelectDollar| (dom) - (or (domain-dollar dom) dom)) - -(defun |domainSetDollar| (dom dollar) - (setf (domain-dollar dom) dollar) - (if (old-compiler-domain-p dom) - (setf (oldom-devaluate dom) (|devaluate| dollar)))) - -(defun |domainSelectVector| (dom) - (let ((vec (oldom-vector dom))) - (cond ((vectorp vec) vec) - ((null vec) nil) - ((symbolp vec) ;; case for Records and Unions - (setq vec (funcall vec (domain-args dom))) - (setf (elt vec 0) dom) - (setf (oldom-vector dom) vec)) - ((or (fboundp (car vec)) - (|loadLib| (cdr vec)) t) - (instantiate (car vec) dom))))) - -;;(defun instantiate (innername dom) -;; (let ((vec (apply innername (domain-args dom)))) -;; (setelt vec 0 dom) -;; (setf (oldom-vector dom) vec) -;; vec)) - -(defun instantiate (innername dom) - (let* ((infovec (get (domain-constructor dom) '|infovec|)) - (|$dollarVec| (getrefv (size (car infovec ))))) - (declare (special |$dollarVec|)) - (setf (elt |$dollarVec| 0) dom) - (setf (elt |$dollarVec| 1) - (list (symbol-function (|getLookupFun| infovec)) - |$dollarVec| - (elt infovec 1))) - (setf (elt |$dollarVec| 2) (elt infovec 2)) - (setf (oldom-vector dom) |$dollarVec|) - (apply innername (domain-args dom)) - |$dollarVec|)) - -(defun universal-domain-constructor (&rest args-env) - (let* ((args (fix-domain-args (butlast args-env))) - (env (car (last args-env)))) - (check-constructor-cache env args))) - -(defun fix-domain-args (args) - (mapcar #'(lambda (x) (if (and (vectorp x) (domain-p (elt x 0))) - (elt x 0) x)) args)) - -(defun universal-nocache-domain-constructor (&rest args-env) - (let* ((args (butlast args-env)) - (env (car (last args-env)))) - (make-old-compiler-domain :constructor (car env) - :args args - :vector (cdr env)))) - -(defun universal-category-defaults-constructor (&rest args-env) - (let* ((args (butlast args-env)) - (env (car (last args-env)))) - (make-old-compiler-domain :constructor (car env) - :args args - :dollar (car args) - :vector (cdr env)))) - -(defun cached-constructor (cname) - (if (or (|isCategoryPackageName| cname) - (and (boundp '|$mutableDomains|) - (memq cname |$mutableDomains|))) - nil - t)) - -(defun |makeDomainStub| (con) - (|systemDependentMkAutoload| (|constructor?| con) con)) - -(defun |mkAutoLoad| (fn cname) - (cond ((or (memq cname |$CategoryNames|) - (eq (GETDATABSE cname 'CONSTRUCTORKIND) '|category|)) - (function (lambda (&rest args) - (|autoLoad| fn cname) - (apply cname args)))) - (t (|systemDependentMkAutoload| fn cname) - (symbol-function cname)))) - -(defun |systemDependentMkAutoload| (fn cname) - (let* ((cnameInner (intern (strconc cname ";"))) - (env (list* cname cnameInner fn)) - (spadfun - (cond ((|isCategoryPackageName| cname) - (cons #'universal-category-defaults-constructor env)) - ((and (boundp '|$mutableDomains|) - (memq cname |$mutableDomains|)) - (cons #'universal-nocache-domain-constructor env)) - (t (cons #'universal-domain-constructor env))))) - (setf (symbol-function cname) (mkConstructor spadfun)) - (set cname spadfun))) - -(defun mkConstructor (spadfun) - (function (lambda (&rest args) - (apply (car spadfun) (append args (list (cdr spadfun))))))) - -(defun |makeAddDomain| (add-domain dollar) - (cond ((old-compiler-domain-p add-domain) - (make-old-compiler-domain :constructor (domain-constructor add-domain) - :args (domain-args add-domain) - :dollar dollar - :vector (cddr (eval (domain-constructor add-domain))))) - (t (error "no new compiler adds supported yet")))) - -(defun check-constructor-cache (env arglist) - (let ((dollar (check-dollar-fields (car env) arglist))) - (if dollar (make-old-compiler-domain :constructor (car env) - :args arglist - :dollar dollar - :vector (cdr env)) - (let* ((constructor (car env)) - (devargs (mapcar #'|devaluate| arglist)) - (cacheddom - (|lassocShiftWithFunction| devargs - (HGET |$ConstructorCache| constructor) - #'|domainEqualList|))) - (if cacheddom (|CDRwithIncrement| cacheddom) - (cdr (|haddProp| |$ConstructorCache| constructor devargs - (cons 1 (make-old-compiler-domain :constructor constructor - :args arglist - :devaluate - (cons constructor devargs) - :vector (cdr env)))))))))) - - - - - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/fnewmeta.lisp.pamphlet b/src/interp/fnewmeta.lisp index be041a6a..aa0bd478 100644 --- a/src/interp/fnewmeta.lisp.pamphlet +++ b/src/interp/fnewmeta.lisp @@ -1,266 +1,3 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp fnewmeta.lisp} -\author{William Burge} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -<<fnew.meta>>= -% Scratchpad II Boot Language Grammar, Common Lisp Version -% IBM Thomas J. Watson Research Center -% Summer, 1986 -% -% NOTE: Substantially different from VM/LISP version, due to -% different parser and attempt to render more within META proper. - -.META(New NewExpr Process) -.PACKAGE 'BOOT' -.DECLARE(tmptok TOK ParseMode DEFINITION_NAME LABLASOC) -.PREFIX 'PARSE-' - -NewExpr: =')' .(processSynonyms) Command - / .(SETQ DEFINITION_NAME (CURRENT-SYMBOL)) Statement ; - -Command: ')' SpecialKeyWord SpecialCommand +() ; - -SpecialKeyWord: =(MATCH-CURRENT-TOKEN "IDENTIFIER) - .(SETF (TOKEN-SYMBOL (CURRENT-TOKEN)) (unAbbreviateKeyword (CURRENT-SYMBOL))) ; - -SpecialCommand: 'show' <'?' / Expression>! +(show #1) CommandTail - / ?(MEMBER (CURRENT-SYMBOL) \$noParseCommands) - .(FUNCALL (CURRENT-SYMBOL)) - / ?(MEMBER (CURRENT-SYMBOL) \$tokenCommands) TokenList - TokenCommandTail - / PrimaryOrQM* CommandTail ; - -TokenList: (^?(isTokenDelimiter) +=(CURRENT-SYMBOL) .(ADVANCE-TOKEN))* ; - -TokenCommandTail: - <TokenOption*>! ?(atEndOfLine) +(#2 -#1) .(systemCommand #1) ; - -TokenOption: ')' TokenList ; - -CommandTail: <Option*>! ?(atEndOfLine) +(#2 -#1) .(systemCommand #1) ; - -PrimaryOrQM: '?' +\? / Primary ; - -Option: ')' PrimaryOrQM* ; - -Statement: Expr{0} <(',' Expr{0})* +(Series #2 -#1)>; - -InfixWith: With +(Join #2 #1) ; - -With: 'with' Category +(with #1) ; - -Category: 'if' Expression 'then' Category <'else' Category>! +(if #3 #2 #1) - / '(' Category <(';' Category)*>! ')' +(CATEGORY #2 -#1) - / .(SETQ $1 (LINE-NUMBER CURRENT-LINE)) Application - ( ':' Expression +(Signature #2 #1) - .(recordSignatureDocumentation ##1 $1) - / +(Attribute #1) - .(recordAttributeDocumentation ##1 $1)); - -Expression: Expr{(PARSE-rightBindingPowerOf (MAKE-SYMBOL-OF PRIOR-TOKEN) ParseMode)} - +#1 ; - -Import: 'import' Expr{1000} <(',' Expr{1000})*>! +(import #2 -#1) ; - -Infix: =TRUE +=(CURRENT-SYMBOL) .(ADVANCE-TOKEN) <TokTail> - Expression +(#2 #2 #1) ; - -Prefix: =TRUE +=(CURRENT-SYMBOL) .(ADVANCE-TOKEN) <TokTail> - Expression +(#2 #1) ; - -Suffix: +=(CURRENT-SYMBOL) .(ADVANCE-TOKEN) <TokTail> +(#1 #1) ; - -TokTail: ?(AND (NULL \$BOOT) (EQ (CURRENT-SYMBOL) "\$) - (OR (ALPHA-CHAR-P (CURRENT-CHAR)) - (CHAR-EQ (CURRENT-CHAR) '$') - (CHAR-EQ (CURRENT-CHAR) '\%') - (CHAR-EQ (CURRENT-CHAR) '('))) - .(SETQ $1 (COPY-TOKEN PRIOR-TOKEN)) Qualification - .(SETQ PRIOR-TOKEN $1) ; - -Qualification: '$' Primary1 +=(dollarTran #1 #1) ; - -SemiColon: ';' (Expr{82} / + \/throwAway) +(\; #2 #1) ; - -Return: 'return' Expression +(return #1) ; - -Exit: 'exit' (Expression / +\$NoValue) +(exit #1) ; - -Leave: 'leave' ( Expression / +\$NoValue ) - ('from' Label +(leaveFrom #1 #1) / +(leave #1)) ; - -Seg: GliphTok{"\.\.} <Expression>! +(SEGMENT #2 #1) ; - -Conditional: 'if' Expression 'then' Expression <'else' ElseClause>! - +(if #3 #2 #1) ; - -ElseClause: ?(EQ (CURRENT-SYMBOL) "if) Conditional / Expression ; - -Loop: Iterator* 'repeat' Expr{110} +(REPEAT -#2 #1) - / 'repeat' Expr{110} +(REPEAT #1) ; - -Iterator: 'for' Primary 'in' Expression - ( 'by' Expr{200} +(INBY #3 #2 #1) / +(IN #2 #1) ) - < '\|' Expr{111} +(\| #1) > - / 'while' Expr{190} +(WHILE #1) - / 'until' Expr{190} +(UNTIL #1) ; - -Expr{RBP}: NudPart{RBP} <LedPart{RBP}>* +#1; - -LabelExpr: Label Expr{120} +(LABEL #2 #1) ; - -Label: '<<' Name '>>' ; - -LedPart{RBP}: Operation{"Led RBP} +#1; - -NudPart{RBP}: (Operation{"Nud RBP} / Reduction / Form) +#1 ; - -Operation{ParseMode RBP}: - ^?(MATCH-CURRENT-TOKEN "IDENTIFIER) - ?(GETL (SETQ tmptok (CURRENT-SYMBOL)) ParseMode) - ?(LT RBP (PARSE-leftBindingPowerOf tmptok ParseMode)) - .(SETQ RBP (PARSE-rightBindingPowerOf tmptok ParseMode)) - getSemanticForm{tmptok ParseMode (ELEMN (GETL tmptok ParseMode) 5 NIL)} ; - -% Binding powers stored under the Led and Red properties of an operator -% are set up by the file BOTTOMUP.LISP. The format for a Led property -% is <Operator Left-Power Right-Power>, and the same for a Nud, except that -% it may also have a fourth component <Special-Handler>. ELEMN attempts to -% get the Nth indicator, counting from 1. - -leftBindingPowerOf{X IND}: =(LET ((Y (GETL X IND))) (IF Y (ELEMN Y 3 0) 0)) ; - -rightBindingPowerOf{X IND}: =(LET ((Y (GETL X IND))) (IF Y (ELEMN Y 4 105) 105)) ; - -getSemanticForm{X IND Y}: - ?(AND Y (EVAL Y)) / ?(EQ IND "Nud) Prefix / ?(EQ IND "Led) Infix ; - - -Reduction: ReductionOp Expr{1000} +(Reduce #2 #1) ; - -ReductionOp: ?(AND (GETL (CURRENT-SYMBOL) "Led) - (MATCH-NEXT-TOKEN "SPECIAL-CHAR (CODE-CHAR 47))) % Forgive me! - +=(CURRENT-SYMBOL) .(ADVANCE-TOKEN) .(ADVANCE-TOKEN) ; - -Form: 'iterate' < 'from' Label +(#1) >! +(iterate -#1) - / 'yield' Application +(yield #1) - / Application ; - -Application: Primary <Selector>* <Application +(#2 #1)>; - -Selector: ?NONBLANK ?(EQ (CURRENT-SYMBOL) "\.) ?(CHAR-NE (CURRENT-CHAR) "\ ) - '.' PrimaryNoFloat (=\$BOOT +(ELT #2 #1)/ +(#2 #1)) - / (Float /'.' Primary) (=\$BOOT +(ELT #2 #1)/ +(#2 #1)); - -PrimaryNoFloat: Primary1 <TokTail> ; - -Primary: Float /PrimaryNoFloat ; - -Primary1: VarForm <=(AND NONBLANK (EQ (CURRENT-SYMBOL) "\()) Primary1 +(#2 #1)> - /Quad - /String - /IntegerTok - /FormalParameter - /='\'' (?\$BOOT Data / '\'' Expr{999} +(QUOTE #1)) - /Sequence - /Enclosure ; - -Float: FloatBase (?NONBLANK FloatExponent / +0) +=(MAKE-FLOAT #4 #2 #2 #1) ; - -FloatBase: ?(FIXP (CURRENT-SYMBOL)) ?(CHAR-EQ (CURRENT-CHAR) '.') - ?(CHAR-NE (NEXT-CHAR) '.') - IntegerTok FloatBasePart - /?(FIXP (CURRENT-SYMBOL)) ?(CHAR-EQ (CHAR-UPCASE (CURRENT-CHAR)) "E) - IntegerTok +0 +0 - /?(DIGITP (CURRENT-CHAR)) ?(EQ (CURRENT-SYMBOL) "\.) - +0 FloatBasePart ; - -FloatBasePart: '.' - (?(DIGITP (CURRENT-CHAR)) +=(TOKEN-NONBLANK (CURRENT-TOKEN)) IntegerTok - / +0 +0); - - -FloatExponent: =(AND (MEMBER (CURRENT-SYMBOL) "(E e)) - (FIND (CURRENT-CHAR) '+-')) - .(ADVANCE-TOKEN) - (IntegerTok/'+' IntegerTok/'-' IntegerTok +=(MINUS #1)/+0) - /?(IDENTP (CURRENT-SYMBOL)) =(SETQ $1 (FLOATEXPID (CURRENT-SYMBOL))) - .(ADVANCE-TOKEN) +=$1 ; - -Enclosure: '(' ( Expr{6} ')' / ')' +(Tuple) ) - / '{' ( Expr{6} '}' +(brace (construct #1)) / '}' +(brace)) ; - -IntegerTok: NUMBER ; - -FloatTok: NUMBER +=(IF \$BOOT #1 (BFP- #1)) ; - -FormalParameter: FormalParameterTok ; - -FormalParameterTok: ARGUMENT-DESIGNATOR ; - -Quad: '$' +\$ / ?\$BOOT GliphTok{"\.} +\. ; - -String: SPADSTRING ; - -VarForm: Name <Scripts +(Scripts #2 #1) > +#1 ; - -Scripts: ?NONBLANK '[' ScriptItem ']' ; - -ScriptItem: Expr{90} <(';' ScriptItem)* +(\; #2 -#1)> - / ';' ScriptItem +(PrefixSC #1) ; - -Name: IDENTIFIER +#1 ; - -Data: .(SETQ LABLASOC NIL) Sexpr +(QUOTE =(TRANSLABEL #1 LABLASOC)) ; - -Sexpr: .(ADVANCE-TOKEN) Sexpr1 ; - -Sexpr1: AnyId - < NBGliphTok{"\=} Sexpr1 - .(SETQ LABLASOC (CONS (CONS #2 ##1) LABLASOC))> - / '\'' Sexpr1 +(QUOTE #1) - / IntegerTok - / '-' IntegerTok +=(MINUS #1) - / String - / '<' <Sexpr1*>! '>' +=(LIST2VEC #1) - / '(' <Sexpr1* <GliphTok{"\.} Sexpr1 +=(NCONC #2 #1)>>! ')' ; - -NBGliphTok{tok}: ?(AND (MATCH-CURRENT-TOKEN "GLIPH tok) NONBLANK) - .(ADVANCE-TOKEN) ; - -GliphTok{tok}: ?(MATCH-CURRENT-TOKEN "GLIPH tok) .(ADVANCE-TOKEN) ; - -AnyId: IDENTIFIER - / (='$' +=(CURRENT-SYMBOL) .(ADVANCE-TOKEN) / KEYWORD) ; - -Sequence: OpenBracket Sequence1 ']' - / OpenBrace Sequence1 '}' +(brace #1) ; - -Sequence1: (Expression +(#2 #1) / +(#1)) <IteratorTail +(COLLECT -#1 #1)> ; - -OpenBracket: =(EQ (getToken (SETQ $1 (CURRENT-SYMBOL))) "\[ ) - (=(EQCAR $1 "elt) +(elt =(CADR $1) construct) - / +construct) .(ADVANCE-TOKEN) ; - -OpenBrace: =(EQ (getToken (SETQ $1 (CURRENT-SYMBOL))) "\{ ) - (=(EQCAR $1 "elt) +(elt =(CADR $1) brace) - / +construct) .(ADVANCE-TOKEN) ; - -IteratorTail: ('repeat' <Iterator*>! / Iterator*) ; - -.FIN ; - - -@ -\section{License} -<<license>>= ;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. ;; All rights reserved. ;; @@ -292,9 +29,6 @@ IteratorTail: ('repeat' <Iterator*>! / Iterator*) ; ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -@ -<<*>>= -<<license>> (IMPORT-MODULE "parsing") (IN-PACKAGE "BOOT" ) @@ -1004,9 +738,3 @@ IteratorTail: ('repeat' <Iterator*>! / Iterator*) ; (OPTIONAL (STAR REPEATOR (|PARSE-Iterator|))))) (STAR REPEATOR (|PARSE-Iterator|)))) -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/format.boot.pamphlet b/src/interp/format.boot index e4c83a31..fee60054 100644 --- a/src/interp/format.boot.pamphlet +++ b/src/interp/format.boot @@ -1,16 +1,3 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp format.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{License} -<<license>>= -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. -- @@ -42,9 +29,6 @@ -- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -@ -<<*>>= -<<license>> --% Functions for display formatting system objects @@ -646,7 +630,7 @@ application2String(op,argl, linkInfo) == concat(first argl, '"..") concat(first argl, concat('"..", first rest argl)) concat(app2StringWrap(formWrapId op, linkInfo) , - concat("_(",concat(tuple2String argl,"_)"))) + concat("_(",concat(tuple2String argl,"_)"))) app2StringConcat0(x,y) == FORMAT(NIL, '"~a ~a", x, y) @@ -794,9 +778,3 @@ form2FenceQuoteTail x == form2StringList u == atom (r := form2String u) => [r] r -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/fortcall.boot.pamphlet b/src/interp/fortcall.boot index 9513e313..72d79948 100644 --- a/src/interp/fortcall.boot.pamphlet +++ b/src/interp/fortcall.boot @@ -1,16 +1,3 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp fortcall.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{License} -<<license>>= -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. -- @@ -42,9 +29,6 @@ -- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -@ -<<*>>= -<<license>> makeFort(name,args,decls,results,returnType,aspInfo) == -- Create an executable Fortran file to call a given library function, @@ -591,21 +575,21 @@ prepareResults(results,args,dummies,values,decls) == NREVERSE data -- TTT this is dead code now --- transposeVector(u,type) == --- -- Take a vector of vectors and return a single vector which is in column --- -- order (i.e. swap from C to Fortran order). --- els := nil --- rows := CAR ARRAY_-DIMENSIONS(u)-1 --- cols := CAR ARRAY_-DIMENSIONS(ELT(u,0))-1 --- -- Could be a 3D Matrix --- if VECTORP ELT(ELT(u,0),0) then --- planes := CAR ARRAY_-DIMENSIONS(ELT(ELT(u,0),0))-1 --- for k in 0..planes repeat for j in 0..cols repeat for i in 0..rows repeat --- els := [ELT(ELT(ELT(u,i),j),k),:els] --- else --- for j in 0..cols repeat for i in 0..rows repeat --- els := [ELT(ELT(u,i),j),:els] --- makeVector(NREVERSE els,type) +-- transposeVector(u,type) == +-- -- Take a vector of vectors and return a single vector which is in column +-- -- order (i.e. swap from C to Fortran order). +-- els := nil +-- rows := CAR ARRAY_-DIMENSIONS(u)-1 +-- cols := CAR ARRAY_-DIMENSIONS(ELT(u,0))-1 +-- -- Could be a 3D Matrix +-- if VECTORP ELT(ELT(u,0),0) then +-- planes := CAR ARRAY_-DIMENSIONS(ELT(ELT(u,0),0))-1 +-- for k in 0..planes repeat for j in 0..cols repeat for i in 0..rows repeat +-- els := [ELT(ELT(ELT(u,i),j),k),:els] +-- else +-- for j in 0..cols repeat for i in 0..rows repeat +-- els := [ELT(ELT(u,i),j),:els] +-- makeVector(NREVERSE els,type) writeData(tmpFile,indata) == @@ -616,47 +600,47 @@ writeData(tmpFile,indata) == xstr := xdrOpen(str,true) [args,dummies,values,decls] := indata for v in values repeat - -- the two Boolean values - v = "T" => - xdrWrite(xstr,1) - NULL v => - xdrWrite(xstr,0) - -- characters - STRINGP v => - xdrWrite(xstr,v) - -- some array - VECTORP v => - rows := CAR ARRAY_-DIMENSIONS(v) - -- is it 2d or more (most likely) ? - VECTORP ELT(v,0) => - cols := CAR ARRAY_-DIMENSIONS(ELT(v,0)) - -- is it 3d ? - VECTORP ELT(ELT(v,0),0) => - planes := CAR ARRAY_-DIMENSIONS(ELT(ELT(v,0),0)) - -- write 3d array - xdrWrite(xstr,rows*cols*planes) - for k in 0..planes-1 repeat - for j in 0..cols-1 repeat - for i in 0..rows-1 repeat - xdrWrite(xstr,ELT(ELT(ELT(v,i),j),k)) - -- write 2d array - xdrWrite(xstr,rows*cols) - for j in 0..cols-1 repeat - for i in 0..rows-1 repeat xdrWrite(xstr,ELT(ELT(v,i),j)) - -- write 1d array - xdrWrite(xstr,rows) - for i in 0..rows-1 repeat xdrWrite(xstr,ELT(v,i)) - -- this is used for lists of booleans apparently in f01 - LISTP v => - xdrWrite(xstr,LENGTH v) - for el in v repeat - if el then xdrWrite(xstr,1) else xdrWrite(xstr,0) - -- integers - INTEGERP v => - xdrWrite(xstr,v) - -- floats - FLOATP v => - xdrWrite(xstr,v) + -- the two Boolean values + v = "T" => + xdrWrite(xstr,1) + NULL v => + xdrWrite(xstr,0) + -- characters + STRINGP v => + xdrWrite(xstr,v) + -- some array + VECTORP v => + rows := CAR ARRAY_-DIMENSIONS(v) + -- is it 2d or more (most likely) ? + VECTORP ELT(v,0) => + cols := CAR ARRAY_-DIMENSIONS(ELT(v,0)) + -- is it 3d ? + VECTORP ELT(ELT(v,0),0) => + planes := CAR ARRAY_-DIMENSIONS(ELT(ELT(v,0),0)) + -- write 3d array + xdrWrite(xstr,rows*cols*planes) + for k in 0..planes-1 repeat + for j in 0..cols-1 repeat + for i in 0..rows-1 repeat + xdrWrite(xstr,ELT(ELT(ELT(v,i),j),k)) + -- write 2d array + xdrWrite(xstr,rows*cols) + for j in 0..cols-1 repeat + for i in 0..rows-1 repeat xdrWrite(xstr,ELT(ELT(v,i),j)) + -- write 1d array + xdrWrite(xstr,rows) + for i in 0..rows-1 repeat xdrWrite(xstr,ELT(v,i)) + -- this is used for lists of booleans apparently in f01 + LISTP v => + xdrWrite(xstr,LENGTH v) + for el in v repeat + if el then xdrWrite(xstr,1) else xdrWrite(xstr,0) + -- integers + INTEGERP v => + xdrWrite(xstr,v) + -- floats + FLOATP v => + xdrWrite(xstr,v) SHUT(str) tmpFile @@ -721,7 +705,7 @@ protectedNagCall(objFiles,nfile,data,results) == td:=generateDataName() tr:=generateResultsName() UNWIND_-PROTECT( (val:=nagCall(objFiles,nfile,data,results,td,tr) ;errors :=NIL), - errors =>( resetStackLimits(); sendNagmanErrorSignal();cleanUpAfterNagman(td,tr,objFiles))) + errors =>( resetStackLimits(); sendNagmanErrorSignal();cleanUpAfterNagman(td,tr,objFiles))) val @@ -812,9 +796,3 @@ vectorOfFunctions f == -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/functor.boot.pamphlet b/src/interp/functor.boot index 7e952a88..0513d9f0 100644 --- a/src/interp/functor.boot.pamphlet +++ b/src/interp/functor.boot @@ -1,20 +1,3 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\$SPAD/src/interp functor.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. -- @@ -46,9 +29,6 @@ -- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -@ -<<*>>= -<<license>> --% Domain printing keyItem a == @@ -1001,9 +981,3 @@ resolvePatternVars(p,args) == -- [SetFunctionSlots(sig,implem,flag,'adding) -- for u in baseops | u is [sig,[pred,implem]]] -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} |