[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Axiom-developer] 20080216.01.wxh.patch (hash tables to speed compiles)
|
From: |
daly |
|
Subject: |
[Axiom-developer] 20080216.01.wxh.patch (hash tables to speed compiles) |
|
Date: |
Sat, 16 Feb 2008 14:07:23 -0600 |
This code is a performance improvement by Waldek Hebisch.
(Fricas patches 232 and 233).
The essence of the speedup appears to be caused by two factors.
The original code was non-recursive and used union across lists.
The new code is recursive. It also uses a hashtable to reduce
the amount of redundant list construction.
Additionally, the code in these files was rearranged and commented
by me for documentation purposes.
Tim
======================================================================
diff --git a/changelog b/changelog
index 94eac53..0a7fe92 100644
--- a/changelog
+++ b/changelog
@@ -1,3 +1,7 @@
+20082016 wxh src/interp/i-intern.boot use hashtable to speedup compiles
+20082016 wxh src/interp/g-util.boot use hashtable to speedup compiles
+20082016 wxh src/interp/compiler.boot use hashtable to speedup compiles
+20082016 wxh src/interp/category.boot use hashtable to speedup compiles
20080215 tpd src/interp/format.boot add )d op documentation
20080215 tpd src/algebra/plot add comment documentation
20080210 tpd src/algebra/Makefile add plot help and input files for plot
diff --git a/src/interp/category.boot.pamphlet
b/src/interp/category.boot.pamphlet
index d90e771..097ede9 100644
--- a/src/interp/category.boot.pamphlet
+++ b/src/interp/category.boot.pamphlet
@@ -9,9 +9,93 @@
\eject
\tableofcontents
\eject
-\section{mkCategory}
-This code defines the structure of a category.
-<<mkCategory>>=
+\section{Category}
+Functions for building categories.
+
+Sorry to say, this hack is needed by isCategoryType
+<<*>>=
+Category() == nil
+
+@
+\subsection{CategoryPrint}
+<<*>>=
+CategoryPrint(D,$e) ==
+ SAY "--------------------------------------"
+ SAY "Name (and arguments) of category:"
+ PRETTYPRINT D.(0)
+ SAY "operations:"
+ PRETTYPRINT D.(1)
+ SAY "attributes:"
+ PRETTYPRINT D.2
+ SAY "This is a sub-category of"
+ PRETTYPRINT first D.4
+ for u in CADR D.4 repeat
+ SAY("This has an alternate view: slot ",rest u," corresponds to ",first u)
+ for u in CADDR D.4 repeat
+ SAY("This has a local domain: slot ",rest u," corresponds to ",first u)
+ for j in 6..MAXINDEX D repeat
+ u:= D.j
+ null u => SAY "another domain"
+ atom first u => SAY("Alternate View corresponding to: ",u)
+ PRETTYPRINT u
+
+@
+\subsection{sigParams}
+This code is a performance improvement by Waldek Hebisch.
+The essence of the speedup appears to be caused by two factors.
+The original code was non-recursive and used union across lists.
+The new code is recursive. It also uses a hashtable to reduce
+the amount of redundant list construction.
+
+We compute the list of parameters that occur in signatures on the
+sigList, removing duplicates, and skipping the ``known'' constructors,
+Union, Mapping, List, and Record.
+
+\verb|$PrimitiveDomainNames| is a list of domains that we need not cache.
+It is set in init.lisp.pamphlet.
+<<*>>=
+sigParams(sigList) ==
+ result:=nil
+ myhash:=MAKE_-HASHTABLE 'EQUAL
+ NewLocals:=nil
+ for s in sigList repeat
+ (NewLocals:=Prepare(CADAR s,NewLocals)) where
+ Prepare(u,l)==for v in u repeat l:=Prepare2(v,l)
+ Prepare2(v,l)==
+ v is "$" => l
+ STRINGP v => l
+ atom v => [v,:l]
+ MEMQ(first v,$PrimitiveDomainNames) => l
+ v is ["Union",:w] =>
+ for x in stripUnionTags w repeat l:=Prepare2(x,l)
+ l
+ v is ["Mapping",:w] =>
+ for x in w repeat l:=Prepare2(x,l)
+ l
+ v is ["List",:w] => Prepare2(w,l)
+ v is ["Record",:w] =>
+ for x in w repeat l:=Prepare2(CADDR x,l)
+ l
+ [v,:l]
+ for s in NewLocals repeat
+ if null(HGET(myhash,s)) then
+ HPUT(myhash,s,true)
+ result:=[s,:result]
+ result
+
+@
+\subsection{mkCategory}
+This code defines the structure of a category. It creates a new category
+vector. The arguments are:
+\begin{itemize}
+\item domainOrPackage -- ``domain'' or ``package'' which marks the kind
+of category object.
+\item sigList -- list of all signatures
+\item attList -- list of all attributes
+\item domList
+\item PrincipalAncestor -- principal ancestor (if any)
+\end{itemize}
+<<*>>=
mkCategory(domainOrPackage,sigList,attList,domList,PrincipalAncestor) ==
NSigList:= nil
if PrincipalAncestor=nil then count:= 6 else count:= SIZE PrincipalAncestor
@@ -26,23 +110,7 @@
mkCategory(domainOrPackage,sigList,attList,domList,PrincipalAncestor) ==
count:= count+1
nsig
else s for s in sigList]
- NewLocals:= nil
- for s in sigList repeat
- ((NewLocals:= UNION(NewLocals,Prepare CADAR s)) where
- Prepare u == "UNION"/[Prepare2 v for v in u]) where
- Prepare2 v ==
- v is "$" => nil
- STRINGP v => nil
- atom v => [v]
- MEMQ(first v,$PrimitiveDomainNames) => nil
- --This variable is set in INIT LISP
- --It is a list of all the domains that we need not cache
- v is ["Union",:w] =>
- "UNION"/[Prepare2 x for x in stripUnionTags w]
- v is ["Mapping",:w] => "UNION"/[Prepare2 x for x in w]
- v is ["List",w] => Prepare2 w
- v is ["Record",.,:w] => "UNION"/[Prepare2 CADDR x for x in w]
- [v]
+ NewLocals:= sigParams(sigList)
OldLocals:= nil
if PrincipalAncestor then for u in (OldLocals:= CADDR PrincipalAncestor.4)
repeat NewLocals:= DELETE(first u,NewLocals)
@@ -63,138 +131,23 @@
mkCategory(domainOrPackage,sigList,attList,domList,PrincipalAncestor) ==
v
@
-\section{hasCategoryBug}
-The hasCategoryBug (bug000001)\cite{2} manifests itself by causing a
-value stack overflow when compiling algebra code that uses conditions
-that read ``if R has ...'' when using GCL (but not CCL). Essentially
-the [[|Ring|]] category keeps getting added to the list each time
-[[|Ring|]] is processed. Camm Maguire's mail explains it thus:
-
-The bottom line is that [[(|Ring|)]] is totally correct until
-[[|Algebra|]] is executed, at which point the fourth element returned
-by [[(|Ring|)]] is overwritten by the result returned in the fourth
-element of the vector returned by [[|Algebra|]]. The point of this
-overwrite is at the following form of [[|JoinInner|]] from
-[[(int/interp/category.clisp)]]
-
-\begin{verbatim}
- (SETELT |$NewCatVec| 4 (CONS |c| (CONS |FundamentalAncestors| (CONS
- (CADDR (ELT |$NewCatVec| 4)) NIL))))
-\end{verbatim}
-
-called from [[|Algebra;|]] [[(int/algebra/ALGEBRA.nrlib/code.lsp)]] through
-
-\begin{verbatim}
-(|Join| (|Ring|) (|Module| (QUOTE |t#1|)) (|mkCategory| (QUOTE
-|domain|) (QUOTE (((|coerce| ($ |t#1|)) T))) NIL (QUOTE NIL) NIL))
-\end{verbatim}
-
-I haven't parsed [[|JoinInner|]] yet, but my guess is that there is a
-copy-seq in there which is not getting executed in the assignment of
-[[|$NewCatVec|]] before the setelt.
-
-The original code failed to copy the NewCatVec before updating
-it. This code from macros.lisp\cite{1} checks whether the array is
-adjustable.
-
-\begin{verbatim}
-(defun lengthenvec (v n)
- (if (adjustable-array-p v) (adjust-array v n)
- (replace (make-array n) v)))
-\end{verbatim}
-At least in GCL, the code for lengthenvec need not copy the vec to a
-new location. In this case the FundamentalAncesters array is adjustable
-and in GCL the adjust-array need not, and in this case, does not do a
-copy.
-<<hasCategoryBug>>=
- if reallynew then
- n:= SIZE $NewCatVec
- FundamentalAncestors:= [[b.(0),condition,n],:FundamentalAncestors]
- $NewCatVec:= LENGTHENVEC($NewCatVec,n+1)
--- We need to copy the vector otherwise the FundamentalAncestors
--- list will get stepped on while compiling "If R has ... " code
--- Camm Maguire July 26, 2003
--- copied:= true
- copied:= false
- originalvector:= false
- $NewCatVec.n:= b.(0)
- if not copied then $NewCatVec:= COPY_-SEQ $NewCatVec
- -- It is important to copy the vector now,
- -- in case SigListUnion alters it while
- -- performing Operator Subsumption
-@
-\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.
-
-@
+\subsection{isCategory}
<<*>>=
-<<license>>
-
--- Functions for building categories
-
-Category() == nil --sorry to say, this hack is needed by isCategoryType
-
-CategoryPrint(D,$e) ==
- SAY "--------------------------------------"
- SAY "Name (and arguments) of category:"
- PRETTYPRINT D.(0)
- SAY "operations:"
- PRETTYPRINT D.(1)
- SAY "attributes:"
- PRETTYPRINT D.2
- SAY "This is a sub-category of"
- PRETTYPRINT first D.4
- for u in CADR D.4 repeat
- SAY("This has an alternate view: slot ",rest u," corresponds to ",first u)
- for u in CADDR D.4 repeat
- SAY("This has a local domain: slot ",rest u," corresponds to ",first u)
- for j in 6..MAXINDEX D repeat
- u:= D.j
- null u => SAY "another domain"
- atom first u => SAY("Alternate View corresponding to: ",u)
- PRETTYPRINT u
-
-<<mkCategory>>
isCategory a == REFVECP a and #a>5 and a.3=["Category"]
---% Subsumption code (for operators)
-
+@
+\subsection{DropImplementations}
+Subsumption code (for operators)
+<<*>>=
DropImplementations (a is [sig,pred,:implem]) ==
if implem is [[q,:.]] and (q="ELT" or q="CONST")
then if (q="ELT") then [sig,pred]
else [[:sig,:'(constant)],pred]
else a
+@
+\subsection{SigListUnion}
+<<*>>=
SigListUnion(extra,original) ==
--augments original %with everything in extra that is not in original
for (o:=[[ofn,osig,:.],opred,:.]) in original repeat
@@ -247,6 +200,9 @@ SigListUnion(extra,original) ==
original:= [e,:original]
original
+@
+\subsection{mkOr}
+<<*>>=
mkOr(a,b) ==
a=true => true
b=true => true
@@ -268,6 +224,9 @@ mkOr(a,b) ==
LENGTH l = 1 => CAR l
["OR",:l]
+@
+\subsection{mkOr2}
+<<*>>=
mkOr2(a,b) ==
--a is a condition, "b" a list of them
MEMBER(a,b) => b
@@ -281,6 +240,9 @@ mkOr2(a,b) ==
[a,:b]
[a,:b]
+@
+\subsection{mkAnd}
+<<*>>=
mkAnd(a,b) ==
a=true => b
b=true => a
@@ -298,6 +260,9 @@ mkAnd(a,b) ==
LENGTH l = 1 => CAR l
["AND",:l]
+@
+\subsection{mkAnd2}
+<<*>>=
mkAnd2(a,b) ==
--a is a condition, "b" a list of them
MEMBER(a,b) => b
@@ -311,15 +276,24 @@ mkAnd2(a,b) ==
[a,:b]
[a,:b]
+@
+\subsection{SigListMember}
+<<*>>=
SigListMember(m,list) ==
list=nil => false
SigEqual(m,first list) => true
SigListMember(m,rest list)
+@
+\subsection{SigEqual}
+<<*>>=
SigEqual([sig1,pred1,:.],[sig2,pred2,:.]) ==
-- Notice asymmetry: checks that arg1 is a consequence of arg2
sig1=sig2 and PredImplies(pred2,pred1)
+@
+\subsection{PredImplies}
+<<*>>=
PredImplies(a,b) ==
--true if a => b in the sense of logical implication
--a = "true" => true
@@ -328,6 +302,9 @@ PredImplies(a,b) ==
false -- added by RDJ: 12/21/82
--error() -- for the time being
+@
+\subsection{SigListOpSubsume}
+<<*>>=
SigListOpSubsume([[name1,sig1,:.],:.],list) ==
--does m subsume another operator in the list?
--see "operator subsumption" in SYSTEM SCRIPT
@@ -339,16 +316,25 @@ SigListOpSubsume([[name1,sig1,:.],:.],list) ==
ans:=[n,:ans]
return ans
+@
+\subsection{SigOpsubsume}
+<<*>>=
SigOpsubsume([[name1,sig1,:flag1],pred1,:.],[[name2,sig2,:flag2],pred2,:.]) ==
--flag1 = flag2 and :this really should be checked
name1=name2 and LENGTH sig1=LENGTH sig2 and SourceLevelSubsume(sig1,sig2)
+@
+\subsection{SourceLevelSubsume}
+<<*>>=
SourceLevelSubsume([out1,:in1],[out2,:in2]) ==
-- Checks for source-level subsumption in the sense of SYSTEM SCRIPT
-- true if the first signature subsumes the second
SourceLevelSubset(out1,out2) and
- (and/[SourceLevelSubset(inarg2,inarg1) for inarg1 in in1 for inarg2 in
in2])
+ (and/[SourceLevelSubset(inarg2,inarg1) for inarg1 in in1 for inarg2 in in2])
+@
+\subsection{SourceLevelSubset}
+<<*>>=
SourceLevelSubset(a,b) ==
--true if a is a source-level subset of b
a=b => true
@@ -359,14 +345,20 @@ SourceLevelSubset(a,b) ==
a is [a1] and b is [b1] and ASSOC(a1,GET(b1,"Subsets")) => true
nil
+@
+\subsection{MachineLevelSubsume}
+<<*>>=
MachineLevelSubsume([name1,[out1,:in1],:flag1],[name2,[out2,:in2],:flag2]) ==
-- Checks for machine-level subsumption in the sense of SYSTEM SCRIPT
-- true if the first signature subsumes the second
-- flag1 = flag2 and: this really should be checked, but
name1=name2 and MachineLevelSubset(out1,out2) and
- (and/[MachineLevelSubset(inarg2,inarg1) for inarg1 in in1 for inarg2 in
in2]
+ (and/[MachineLevelSubset(inarg2,inarg1) for inarg1 in in1 for inarg2 in in2]
)
+@
+\subsection{MachineLevelSubset}
+<<*>>=
MachineLevelSubset(a,b) ==
--true if a is a machine-level subset of b
a=b => true
@@ -378,8 +370,10 @@ MachineLevelSubset(a,b) ==
--we assume all subsets are true at the machine level
nil
---% Ancestor chasing code
-
+@
+\subsection{FindFundAncs}
+Ancestor chasing code
+<<*>>=
FindFundAncs l ==
--l is a list of categories and associated conditions (a list of 2-lists
--returns a list of them and all their fundamental ancestors
@@ -406,23 +400,26 @@ FindFundAncs l ==
-- descendant of something previously added which is therefore
-- subsumed
+@
+\subsection{CatEval}
+<<*>>=
CatEval x ==
REFVECP x => x
$InteractiveMode => CAR compMakeCategoryObject(x,$CategoryFrame)
CAR compMakeCategoryObject(x,$e)
---RemovePrinAncs(l,leaves) ==
--- l=nil => nil
--- leaves:= [first y for y in leaves]
--- --remove the slot pointers
--- [x for x in l | not AncestorP(x.(0),leaves)]
-
+@
+\subsection{AncestorP}
+<<*>>=
AncestorP(xname,leaves) ==
-- checks for being a principal ancestor of one of the leaves
MEMBER(xname,leaves) => xname
for y in leaves repeat
MEMBER(xname,first (CatEval y).4) => return y
+@
+\subsection{CondAncestorP}
+<<*>>=
CondAncestorP(xname,leaves,condition) ==
-- checks for being a principal ancestor of one of the leaves
for u in leaves repeat
@@ -433,6 +430,9 @@ CondAncestorP(xname,leaves,condition) ==
xname = u' or MEMBER(xname,first (CatEval u').4) =>
PredImplies(ucond,condition) => return u'
+@
+\subsection{DescendantP}
+<<*>>=
DescendantP(a,b) ==
-- checks to see if a is any kind of Descendant of b
a=b => true
@@ -445,8 +445,53 @@ DescendantP(a,b) ==
AncestorP(b,[first u for u in CADR a.4]) => true
nil
---% The implementation of Join
-
+@
+\subsection{JoinInner}
+The implementation of Join
+\subsubsection{hasCategoryBug}
+The hasCategoryBug (bug000001)\cite{2} manifests itself by causing a
+value stack overflow when compiling algebra code that uses conditions
+that read ``if R has ...'' when using GCL (but not CCL). Essentially
+the [[|Ring|]] category keeps getting added to the list each time
+[[|Ring|]] is processed. Camm Maguire's mail explains it thus:
+
+The bottom line is that [[(|Ring|)]] is totally correct until
+[[|Algebra|]] is executed, at which point the fourth element returned
+by [[(|Ring|)]] is overwritten by the result returned in the fourth
+element of the vector returned by [[|Algebra|]]. The point of this
+overwrite is at the following form of [[|JoinInner|]] from
+[[(int/interp/category.clisp)]]
+
+\begin{verbatim}
+ (SETELT |$NewCatVec| 4 (CONS |c| (CONS |FundamentalAncestors| (CONS
+ (CADDR (ELT |$NewCatVec| 4)) NIL))))
+\end{verbatim}
+
+called from [[|Algebra;|]] [[(int/algebra/ALGEBRA.nrlib/code.lsp)]] through
+
+\begin{verbatim}
+(|Join| (|Ring|) (|Module| (QUOTE |t#1|)) (|mkCategory| (QUOTE
+|domain|) (QUOTE (((|coerce| ($ |t#1|)) T))) NIL (QUOTE NIL) NIL))
+\end{verbatim}
+
+I haven't parsed [[|JoinInner|]] yet, but my guess is that there is a
+copy-seq in there which is not getting executed in the assignment of
+[[|$NewCatVec|]] before the setelt.
+
+The original code failed to copy the NewCatVec before updating
+it. This code from macros.lisp\cite{1} checks whether the array is
+adjustable.
+
+\begin{verbatim}
+(defun lengthenvec (v n)
+ (if (adjustable-array-p v) (adjust-array v n)
+ (replace (make-array n) v)))
+\end{verbatim}
+At least in GCL, the code for lengthenvec need not copy the vec to a
+new location. In this case the FundamentalAncesters array is adjustable
+and in GCL the adjust-array need not, and in this case, does not do a
+copy.
+<<*>>=
JoinInner(l,$e) ==
$NewCatVec: local := nil
CondList:= nil
@@ -561,7 +606,21 @@ JoinInner(l,$e) ==
if c=true
then attl:= [[a,condition],:attl]
else attl:= [[a,["and",condition,c]],:attl]
-<<hasCategoryBug>>
+ if reallynew then
+ n:= SIZE $NewCatVec
+ FundamentalAncestors:= [[b.(0),condition,n],:FundamentalAncestors]
+ $NewCatVec:= LENGTHENVEC($NewCatVec,n+1)
+-- We need to copy the vector otherwise the FundamentalAncestors
+-- list will get stepped on while compiling "If R has ... " code
+-- Camm Maguire July 26, 2003
+-- copied:= true
+ copied:= false
+ originalvector:= false
+ $NewCatVec.n:= b.(0)
+ if not copied then $NewCatVec:= COPY_-SEQ $NewCatVec
+ -- It is important to copy the vector now,
+ -- in case SigListUnion alters it while
+ -- performing Operator Subsumption
for b in l repeat
sigl:= SigListUnion([DropImplementations u for u in b.(1)],sigl)
attl:=
@@ -598,20 +657,48 @@ JoinInner(l,$e) ==
$NewCatVec.4:= [c,FundamentalAncestors,CADDR $NewCatVec.4]
mkCategory("domain",sigl,attl,globalDomains,$NewCatVec)
---ProduceDomainAlist(u,e) ==
--- -- Gives a complete Alist for all the functions in the Domain
--- not (sig:= get(u,"modemap",e)) => nil
--- sig:= CADAAR sig
--- --an incantation
--- [c,.,.]:= compMakeCategoryObject(sig,e)
--- -- We assume that the environment need not be kept
--- c.(1)
-
+@
+\subsection{isCategoryForm}
+<<*>>=
isCategoryForm(x,e) ==
x is [name,:.] => categoryForm? name
atom x => u:= get(x,"macro",e) => isCategoryForm(u,e)
@
+\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.
+
+@
\eject
\begin{thebibliography}{99}
\bibitem{1} [[pamphlet:src/interp/macros.lisp.pamphlet]]
diff --git a/src/interp/compiler.boot.pamphlet
b/src/interp/compiler.boot.pamphlet
index ce51681..4deb2b2 100644
--- a/src/interp/compiler.boot.pamphlet
+++ b/src/interp/compiler.boot.pamphlet
@@ -9,92 +9,9 @@
\eject
\tableofcontents
\eject
-\section{Bug fixes}
-The compMacro function does macro expansion during spad file compiles.
-If a macro occurs twice in the same file the macro expands infinitely
-causing a stack overflow. The reason for the infinite recursion is that
-the left hand side of the macro definition is expanded. Thus defining
-a macro:
-\begin{verbatim}
-name ==> 1
-\end{verbatim}
-will expand properly the first time. The second time it turns into:
-\begin{verbatim}
-1 ==> 1
-\end{verbatim}
-The original code read:
-\begin{verbatim}
-compMacro(form,m,e) ==
- $macroIfTrue: local:= true
- ["MDEF",lhs,signature,specialCases,rhs]:= form
- rhs :=
- rhs is ['CATEGORY,:.] => ['"-- the constructor category"]
- rhs is ['Join,:.] => ['"-- the constructor category"]
- rhs is ['CAPSULE,:.] => ['"-- the constructor capsule"]
- rhs is ['add,:.] => ['"-- the constructor capsule"]
- formatUnabbreviated rhs
- sayBrightly ['" processing macro definition",'%b,
- :formatUnabbreviated lhs,'" ==> ",:rhs,'%d]
- ["MDEF",lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e)
- m=$EmptyMode or m=$NoValueMode =>
- ["/throwAway",$NoValueMode,put(first lhs,"macro",rhs,e)]
-
-\end{verbatim}
-Juergen Weiss proposed the following fixed code. This does not expand
-the left hand side of the macro.
-<<compMacro>>=
-compMacro(form,m,e) ==
- $macroIfTrue: local:= true
- ["MDEF",lhs,signature,specialCases,rhs]:= form
- prhs :=
- rhs is ['CATEGORY,:.] => ['"-- the constructor category"]
- rhs is ['Join,:.] => ['"-- the constructor category"]
- rhs is ['CAPSULE,:.] => ['"-- the constructor capsule"]
- rhs is ['add,:.] => ['"-- the constructor capsule"]
- formatUnabbreviated rhs
- sayBrightly ['" processing macro definition",'%b,
- :formatUnabbreviated lhs,'" ==> ",:prhs,'%d]
- m=$EmptyMode or m=$NoValueMode =>
- ["/throwAway",$NoValueMode,put(first lhs,"macro",macroExpand(rhs,e),e)]
-
-@
-\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.
-
-@
+\section{Compiler Top Level Functions}
+\subsection{compTopLevel}
<<*>>=
-<<license>>
-
compTopLevel(x,m,e) ==
--+ signals that target is derived from lhs-- see NRTmakeSlot1Info
$NRTderivedTargetIfTrue: local := false
@@ -103,6 +20,11 @@ compTopLevel(x,m,e) ==
$compTimeSum: local := 0
$resolveTimeSum: local := 0
$packagesUsed: local := []
+ -- This hashtable is a performance improvement by Waldek Hebisch
+ $envHashTable: local := MAKE_-HASHTABLE 'EQUAL
+ for u in CAR(CAR(e)) repeat
+ for v in CDR(u) repeat
+ HPUT($envHashTable,[CAR u, CAR v],true)
-- The next line allows the new compiler to be tested interactively.
compFun := if $newCompAtTopLevel=true then 'newComp else 'compOrCroak
x is ["DEF",:.] or x is ["where",["DEF",:.],:.] =>
@@ -110,6 +32,9 @@ compTopLevel(x,m,e) ==
--keep old environment after top level function defs
FUNCALL(compFun,x,m,e)
+@
+\subsection{compUniquely}
+<<*>>=
compUniquely(x,m,e) ==
$compUniquelyIfTrue: local:= true
CATCH("compUniquely",comp(x,m,e))
@@ -128,7 +53,7 @@ CohenCategory(): Category == SetCategory with
construct:(CExpr,CExpr)->CExpr
++ construct:(CExpr,CExpr)->CExpr
-@
+\end{verbatim}
the resulting call looks like:
\begin{verbatim}
(|compOrCroak|
@@ -156,6 +81,7 @@ The third argument, {\tt e}, is the environment.
In the call to {\tt compOrCroak1} the fourth argument {\tt comp}
is the function to call.
+\subsection{compOrCroak}
<<*>>=
compOrCroak(x,m,e) == compOrCroak1(x,m,e,'comp)
@@ -211,6 +137,8 @@ The fourth argument {\tt comp} is the function to call.
The inner function augments the environment with information
from the compiler stack {\tt \$compStack} and
{\tt \$compErrorMessageStack}.
+
+\subsection{compOrCroak1}
<<*>>=
compOrCroak1(x,m,e,compFn) ==
fn(x,m,e,nil,nil,compFn) where
@@ -237,16 +165,25 @@ compOrCroak1(x,m,e,compFn) ==
displayComp $level
userError errorMessage
+@
+\subsection{tc}
+<<*>>=
tc() ==
$tripleCache:= nil
comp($x,$m,$f)
+@
+\subsection{comp}
+<<*>>=
comp(x,m,e) ==
T:= compNoStacking(x,m,e) => ($compStack:= nil; T)
$compStack:= [[x,m,e,$exitModeStack],:$compStack]
nil
+@
+\subsection{compNoStacking}
+<<*>>=
compNoStacking(x,m,e) ==
T:= comp2(x,m,e) =>
(m=$EmptyMode and T.mode=$Representation => [T.expr,"$",T.env]; T)
@@ -255,11 +192,17 @@ compNoStacking(x,m,e) ==
--preferred to the underlying representation -- RDJ 9/12/83
compNoStacking1(x,m,e,$compStack)
+@
+\subsection{compNoStacking1}
+<<*>>=
compNoStacking1(x,m,e,$compStack) ==
u:= get(if m="$" then "Rep" else m,"value",e) =>
(T:= comp2(x,u.expr,e) => [T.expr,m,T.env]; nil)
nil
+@
+\subsection{comp2}
+<<*>>=
comp2(x,m,e) ==
[y,m',e]:= comp3(x,m,e) or return nil
if $LISPLIB and isDomainForm(x,e) then
@@ -272,6 +215,9 @@ comp2(x,m,e) ==
--$bootStrapMode-test necessary for compiling Ring in $bootStrapMode
[y,m',e]
+@
+\subsection{comp3}
+<<*>>=
comp3(x,m,$e) ==
--returns a Triple or %else nil to signalcan't do'
$e:= addDomain(m,$e)
@@ -292,18 +238,27 @@ comp3(x,m,$e) ==
[x',m',addDomain(m',e')]
t
+@
+\subsection{compTypeOf}
+<<*>>=
compTypeOf(x:=[op,:argl],m,e) ==
$insideCompTypeOf: local := true
newModemap:= EQSUBSTLIST(argl,$FormalMapVariableList,get(op,'modemap,e))
e:= put(op,'modemap,newModemap,e)
comp3(x,m,e)
+@
+\subsection{hasFormalMapVariable}
+<<*>>=
hasFormalMapVariable(x, vl) ==
$formalMapVariables: local := vl
null vl => false
ScanOrPairVec('hasone?,x) where
hasone? x == MEMQ(x,$formalMapVariables)
+@
+\subsection{compWithMappingMode}
+<<*>>=
compWithMappingMode(x,m is ["Mapping",m',:sl],oldE) ==
$killOptimizeIfTrue: local:= true
e:= oldE
@@ -400,6 +355,9 @@ compWithMappingMode(x,m is ["Mapping",m',:sl],oldE) ==
['LIST,fname]
[uu,m,oldE]
+@
+\subsection{extractCodeAndConstructTriple}
+<<*>>=
extractCodeAndConstructTriple(u, m, oldE) ==
u is ["call",fn,:.] =>
if fn is ["applyFun",a] then fn := a
@@ -407,12 +365,18 @@ extractCodeAndConstructTriple(u, m, oldE) ==
[op,:.,env] := u
[["CONS",["function",op],env],m,oldE]
+@
+\subsection{compExpression}
+<<*>>=
compExpression(x,m,e) ==
$insideExpressionIfTrue: local:= true
atom first x and (fn:= GET(first x,"SPECIAL")) =>
FUNCALL(fn,x,m,e)
compForm(x,m,e)
+@
+\subsection{compAtom}
+<<*>>=
compAtom(x,m,e) ==
T:= compAtomWithModemap(x,m,e,get(x,"modemap",e)) => T
x="nil" =>
@@ -428,6 +392,9 @@ compAtom(x,m,e) ==
[x,primitiveType x or return nil,e]
convert(t,m)
+@
+\subsection{primitiveType}
+<<*>>=
primitiveType x ==
x is nil => $EmptyMode
STRINGP x => $String
@@ -438,6 +405,9 @@ primitiveType x ==
FLOATP x => $DoubleFloat
nil
+@
+\subsection{compSymbol}
+<<*>>=
compSymbol(s,m,e) ==
s="$NoValue" => ["$NoValue",$NoValueMode,e]
isFluid s => [s,getmode(s,e) or return nil,e]
@@ -458,14 +428,23 @@ compSymbol(s,m,e) ==
m = $Expression or m = $Symbol => [['QUOTE,s],m,e]
not isFunction(s,e) => errorRef s
+@
+\subsection{convertOrCroak}
+<<*>>=
convertOrCroak(T,m) ==
u:= convert(T,m) => u
userError ["CANNOT CONVERT: ",T.expr,"%l"," OF MODE: ",T.mode,"%l",
" TO MODE: ",m,"%l"]
+@
+\subsection{convert}
+<<*>>=
convert(T,m) ==
coerce(T,resolve(T.mode,m) or return nil)
+@
+\subsection{mkUnion}
+<<*>>=
mkUnion(a,b) ==
b="$" and $Rep is ["Union",:l] => b
a is ["Union",:l] =>
@@ -474,10 +453,16 @@ mkUnion(a,b) ==
b is ["Union",:l] => ["Union",:setUnion([a],l)]
["Union",a,b]
+@
+\subsection{maxSuperType}
+<<*>>=
maxSuperType(m,e) ==
typ:= get(m,"SuperDomain",e) => maxSuperType(typ,e)
m
+@
+\subsection{hasType}
+<<*>>=
hasType(x,e) ==
fn get(x,"condition",e) where
fn x ==
@@ -485,12 +470,18 @@ hasType(x,e) ==
x is [["case",.,y],:.] => y
fn rest x
+@
+\subsection{compForm}
+<<*>>=
compForm(form,m,e) ==
T:=
compForm1(form,m,e) or compArgumentsAndTryAgain(form,m,e) or return
stackMessageIfNone ["cannot compile","%b",form,"%d"]
T
+@
+\subsection{compArgumentsAndTryAgain}
+<<*>>=
compArgumentsAndTryAgain(form is [.,:argl],m,e) ==
-- used in case: f(g(x)) where f is in domain introduced by
-- comping g, e.g. for (ELT (ELT x a) b), environment can have no
@@ -501,6 +492,9 @@ compArgumentsAndTryAgain(form is [.,:argl],m,e) ==
u="failed" => nil
compForm1(form,m,e)
+@
+\subsection{outputComp}
+<<*>>=
outputComp(x,e) ==
u:=comp(['_:_:,x,$Expression],$Expression,e) => u
x is ['construct,:argl] =>
@@ -509,6 +503,9 @@ outputComp(x,e) ==
[['coerceUn2E,x,v.mode],$Expression,e]
[x,$Expression,e]
+@
+\subsection{compForm1}
+<<*>>=
compForm1(form is [op,:argl],m,e) ==
$NumberOfArgsIfInteger: local:= #argl --see compElt
op="error" =>
@@ -537,11 +534,17 @@ compForm1(form is [op,:argl],m,e) ==
(mmList:= getFormModemaps(form,e)) and (T:= compForm2(form,m,e,mmList)) => T
compToApply(op,argl,m,e)
+@
+\subsection{compExpressionList}
+<<*>>=
compExpressionList(argl,m,e) ==
Tl:= [[.,.,e]:= comp(x,$Expression,e) or return "failed" for x in argl]
Tl="failed" => nil
convert([["LIST",:[y.expr for y in Tl]],$Expression,e],m)
+@
+\subsection{compForm2}
+<<*>>=
compForm2(form is [op,:argl],m,e,modemapList) ==
sargl:= TAKE(# argl, $TriangleVariableList)
aList:= [[sa,:a] for a in argl for sa in sargl]
@@ -569,10 +572,16 @@ compForm2(form is [op,:argl],m,e,modemapList) ==
compForm3(form,m,e,modemapList)
compForm3(form,m,e,modemapList)
+@
+\subsection{compFormPartiallyBottomUp}
+<<*>>=
compFormPartiallyBottomUp(form,m,e,modemapList,partialModeList) ==
mmList:= [mm for mm in modemapList | compFormMatch(mm,partialModeList)] =>
compForm3(form,m,e,mmList)
+@
+\subsection{compFormMatch}
+<<*>>=
compFormMatch(mm,partialModeList) ==
mm is [[.,.,:argModeList],:.] and match(argModeList,partialModeList) where
match(a,b) ==
@@ -580,6 +589,9 @@ compFormMatch(mm,partialModeList) ==
null first b => match(rest a,rest b)
first a=first b and match(rest a,rest b)
+@
+\subsection{compForm3}
+<<*>>=
compForm3(form is [op,:argl],m,e,modemapList) ==
T:=
or/
@@ -591,6 +603,9 @@ compForm3(form is [op,:argl],m,e,modemapList) ==
T
T
+@
+\subsection{getFormModemaps}
+<<*>>=
getFormModemaps(form is [op,:argl],e) ==
op is ["elt",domain,op1] =>
[x for x in getFormModemaps([op1,:argl],e) | x is [[ =domain,:.],:.]]
@@ -609,12 +624,18 @@ getFormModemaps(form is [op,:argl],e) ==
stackMessage ["no modemap for","%b",op,"%d","with ",nargs," arguments"]
finalModemapList
+@
+\subsection{getConstructorFormOfMode}
+<<*>>=
getConstructorFormOfMode(m,e) ==
isConstructorForm m => m
if m="$" then m:= "Rep"
atom m and get(m,"value",e) is [v,:.] =>
isConstructorForm v => v
+@
+\subsection{getConstructorMode}
+<<*>>=
getConstructorMode(x,e) ==
atom x => (u:= getmode(x,e) or return nil; getConstructorFormOfMode(u,e))
x is ["elt",y,a] =>
@@ -624,8 +645,14 @@ getConstructorMode(x,e) ==
u is ["Record",:l] =>
(or/[p is [., =a,R] for p in l]) and isConstructorForm R => R
+@
+\subsection{isConstructorForm}
+<<*>>=
isConstructorForm u == u is [name,:.] and MEMBER(name,'(Record Vector List))
+@
+\subsection{eltModemapFilter}
+<<*>>=
eltModemapFilter(name,mmList,e) ==
isConstantId(name,e) =>
l:= [mm for mm in mmList | mm is [[.,.,.,sel,:.],:.] and sel=name] => l
@@ -634,6 +661,9 @@ eltModemapFilter(name,mmList,e) ==
nil
mmList
+@
+\subsection{seteltModemapFilter}
+<<*>>=
seteltModemapFilter(name,mmList,e) ==
isConstantId(name,e) =>
l:= [mm for (mm:= [[.,.,.,sel,:.],:.]) in mmList | sel=name] => l
@@ -642,6 +672,9 @@ seteltModemapFilter(name,mmList,e) ==
nil
mmList
+@
+\subsection{substituteIntoFunctorModemap}
+<<*>>=
substituteIntoFunctorModemap(argl,modemap is [[dc,:sig],:.],e) ==
#dc^=#sig =>
keyedSystemError("S2GE0016",['"substituteIntoFunctorModemap",
@@ -655,14 +688,22 @@ substituteIntoFunctorModemap(argl,modemap is
[[dc,:sig],:.],e) ==
[SUBLIS(substitutionList,modemap),e]
nil
---% SPECIAL EVALUATION FUNCTIONS
+@
+\section{Special evaluation functions}
+\subsection{compConstructorCategory}
+<<*>>=
compConstructorCategory(x,m,e) == [x,resolve($Category,m),e]
+@
+\subsection{compString}
+<<*>>=
compString(x,m,e) == [x,resolve($StringCategory,m),e]
---% SUBSET CATEGORY
-
+@
+\subsection{compSubsetCategory}
+Compile SubsetCategory
+<<*>>=
compSubsetCategory(["SubsetCategory",cat,R],m,e) ==
--1. put "Subsets" property on R to allow directly coercion to subset;
-- allow automatic coercion from subset to R but not vice versa
@@ -675,10 +716,15 @@ compSubsetCategory(["SubsetCategory",cat,R],m,e) ==
["CATEGORY","domain",["SIGNATURE","coerce",[R,"$"]],["SIGNATURE",
"lift",[R,"$"]],["SIGNATURE","reduce",["$",R]]]
---% CONS
-
+@
+\subsection{compCons}
+Compile cons
+<<*>>=
compCons(form,m,e) == compCons1(form,m,e) or compForm(form,m,e)
+@
+\subsection{compCons1}
+<<*>>=
compCons1(["CONS",x,y],m,e) ==
[x,mx,e]:= comp(x,$EmptyMode,e) or return nil
null y => convert([["LIST",x],["List",mx],e],m)
@@ -693,10 +739,15 @@ compCons1(["CONS",x,y],m,e) ==
[["CONS",x,y],["Pair",mx,my],e]
convert(T,m)
---% SETQ
-
+@
+\subsection{compSetq}
+Compile setq
+<<*>>=
compSetq(["LET",form,val],m,E) == compSetq1(form,val,m,E)
+@
+\subsection{compSetq1}
+<<*>>=
compSetq1(form,val,m,E) ==
IDENTP form => setqSingle(form,val,m,E)
form is [":",x,y] =>
@@ -707,13 +758,23 @@ compSetq1(form,val,m,E) ==
op="Tuple" => setqMultiple(l,val,m,E)
setqSetelt(form,val,m,E)
+@
+\subsection{compMakeDeclaration}
+<<*>>=
compMakeDeclaration(x,m,e) ==
$insideExpressionIfTrue: local
compColon(x,m,e)
+@
+\subsection{setqSetelt}
+Compile setelt
+<<*>>=
setqSetelt([v,:s],val,m,E) ==
comp(["setelt",v,:s,val],m,E)
+@
+\subsection{setqSingle}
+<<*>>=
setqSingle(id,val,m,E) ==
$insideSetqSingleIfTrue: local:= true
--used for comping domain forms within functions
@@ -756,6 +817,9 @@ setqSingle(id,val,m,E) ==
(isDomainForm(x,e') => ['ELT,id,0];CAR outputComp(id,e'))]
[form,m',e']
+@
+\subsection{assignError}
+<<*>>=
assignError(val,m',form,m) ==
message:=
val =>
@@ -764,6 +828,9 @@ assignError(val,m',form,m) ==
["CANNOT ASSIGN: ",val,"%l"," TO: ",form,"%l"," OF MODE: ",m]
stackMessage message
+@
+\subsection{setqMultiple}
+<<*>>=
setqMultiple(nameList,val,m,e) ==
val is ["CONS",:.] and m=$NoValueMode =>
setqMultipleExplicit(nameList,uncons val,m,e)
@@ -796,6 +863,9 @@ setqMultiple(nameList,val,m,e) ==
if assignList="failed" then NIL
else [MKPROGN [x,:assignList,g],m',e]
+@
+\subsection{setqMultipleExplicit}
+<<*>>=
setqMultipleExplicit(nameList,valList,m,e) ==
#nameList^=#valList =>
stackMessage ["Multiple assignment error; # of items in: ",nameList,
@@ -813,7 +883,10 @@ setqMultipleExplicit(nameList,valList,m,e) ==
[["PROGN",:[T.expr for T in assignList],:[T.expr for T in reAssignList]],
$NoValueMode, (LAST reAssignList).env]
---% WHERE
+@
+\subsection{compWhere}
+Compile where
+<<*>>=
compWhere([.,form,:exprList],m,eInit) ==
$insideExpressionIfTrue: local:= false
$insideWhereIfTrue: local:= true
@@ -829,6 +902,10 @@ compWhere([.,form,:exprList],m,eInit) ==
eInit
[x,m,eFinal]
+@
+\subsection{compConstruct}
+Compile construct
+<<*>>=
compConstruct(form is ["construct",:l],m,e) ==
y:= modeIsAggregateOf("List",m,e) =>
T:= compList(l,["List",CADR y],e) => convert(T,m)
@@ -845,26 +922,90 @@ compConstruct(form is ["construct",:l],m,e) ==
(T:= compVector(l,["Vector",CADR y],e)) and (T':= convert(T,m)) =>
return T'
+@
+\subsection{compQuote}
+Compile quote
+<<*>>=
compQuote(expr,m,e) == [expr,m,e]
+@
+\subsection{compList}
+Compile list
+<<*>>=
compList(l,m is ["List",mUnder],e) ==
null l => [NIL,m,e]
Tl:= [[.,mUnder,e]:= comp(x,mUnder,e) or return "failed" for x in l]
Tl="failed" => nil
T:= [["LIST",:[T.expr for T in Tl]],["List",mUnder],e]
+@
+\subsection{compVector}
+Compile vector
+<<*>>=
compVector(l,m is ["Vector",mUnder],e) ==
null l => [$EmptyVector,m,e]
Tl:= [[.,mUnder,e]:= comp(x,mUnder,e) or return "failed" for x in l]
Tl="failed" => nil
[["VECTOR",:[T.expr for T in Tl]],m,e]
---% MACROS
-<<compMacro>>
---% SEQ
+@
+\subsection{compMacro}
+The compMacro function does macro expansion during spad file compiles.
+If a macro occurs twice in the same file the macro expands infinitely
+causing a stack overflow. The reason for the infinite recursion is that
+the left hand side of the macro definition is expanded. Thus defining
+a macro:
+\begin{verbatim}
+name ==> 1
+\end{verbatim}
+will expand properly the first time. The second time it turns into:
+\begin{verbatim}
+1 ==> 1
+\end{verbatim}
+The original code read:
+\begin{verbatim}
+compMacro(form,m,e) ==
+ $macroIfTrue: local:= true
+ ["MDEF",lhs,signature,specialCases,rhs]:= form
+ rhs :=
+ rhs is ['CATEGORY,:.] => ['"-- the constructor category"]
+ rhs is ['Join,:.] => ['"-- the constructor category"]
+ rhs is ['CAPSULE,:.] => ['"-- the constructor capsule"]
+ rhs is ['add,:.] => ['"-- the constructor capsule"]
+ formatUnabbreviated rhs
+ sayBrightly ['" processing macro definition",'%b,
+ :formatUnabbreviated lhs,'" ==> ",:rhs,'%d]
+ ["MDEF",lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e)
+ m=$EmptyMode or m=$NoValueMode =>
+ ["/throwAway",$NoValueMode,put(first lhs,"macro",rhs,e)]
+\end{verbatim}
+Juergen Weiss proposed the following fixed code. This does not expand
+the left hand side of the macro.
+<<*>>=
+compMacro(form,m,e) ==
+ $macroIfTrue: local:= true
+ ["MDEF",lhs,signature,specialCases,rhs]:= form
+ prhs :=
+ rhs is ['CATEGORY,:.] => ['"-- the constructor category"]
+ rhs is ['Join,:.] => ['"-- the constructor category"]
+ rhs is ['CAPSULE,:.] => ['"-- the constructor capsule"]
+ rhs is ['add,:.] => ['"-- the constructor capsule"]
+ formatUnabbreviated rhs
+ sayBrightly ['" processing macro definition",'%b,
+ :formatUnabbreviated lhs,'" ==> ",:prhs,'%d]
+ m=$EmptyMode or m=$NoValueMode =>
+ ["/throwAway",$NoValueMode,put(first lhs,"macro",macroExpand(rhs,e),e)]
+
+@
+\subsection{compSeq}
+Compile seq
+<<*>>=
compSeq(["SEQ",:l],m,e) == compSeq1(l,[m,:$exitModeStack],e)
+@
+\subsection{compSeq1}
+<<*>>=
compSeq1(l,$exitModeStack,e) ==
$insideExpressionIfTrue: local
$finalEnv: local
@@ -882,8 +1023,14 @@ compSeq1(l,$exitModeStack,e) ==
form:= ["SEQ",:replaceExitEtc(c,catchTag,"TAGGEDexit",$exitModeStack.(0))]
[["CATCH",catchTag,form],$exitModeStack.(0),$finalEnv]
+@
+\subsection{compSeqItem}
+<<*>>=
compSeqItem(x,m,e) == comp(macroExpand(x,e),m,e)
+@
+\subsection{replaceExitEtc}
+<<*>>=
replaceExitEtc(x,tag,opFlag,opMode) ==
(fn(x,tag,opFlag,opMode); x) where
fn(x,tag,opFlag,opMode) ==
@@ -905,15 +1052,20 @@ replaceExitEtc(x,tag,opFlag,opMode) ==
replaceExitEtc(first x,tag,opFlag,opMode)
replaceExitEtc(rest x,tag,opFlag,opMode)
---% SUCHTHAT
+@
+\subsection{compSuchthat}
+Compile suchthat
+<<*>>=
compSuchthat([.,x,p],m,e) ==
[x',m',e]:= comp(x,m,e) or return nil
[p',.,e]:= comp(p,$Boolean,e) or return nil
e:= put(x',"condition",p',e)
[x',m',e]
---% exit
-
+@
+\subsection{compExit}
+Compile exit
+<<*>>=
compExit(["exit",level,x],m,e) ==
index:= level-1
$exitModeStack = [] => comp(x,m,e)
@@ -925,20 +1077,29 @@ compExit(["exit",level,x],m,e) ==
modifyModeStack(m',index)
[["TAGGEDexit",index,u],m,e]
+@
+\subsection{modifyModeStack}
+<<*>>=
modifyModeStack(m,index) ==
$reportExitModeStack =>
SAY("exitModeStack: ",COPY $exitModeStack," ====> ",
($exitModeStack.index:= resolve(m,$exitModeStack.index); $exitModeStack))
$exitModeStack.index:= resolve(m,$exitModeStack.index)
+@
+\subsection{compLeave}
+Compile leave
+<<*>>=
compLeave(["leave",level,x],m,e) ==
index:= #$exitModeStack-1-$leaveLevelStack.(level-1)
[x',m',e']:= u:= comp(x,$exitModeStack.index,e) or return nil
modifyModeStack(m',index)
[["TAGGEDexit",index,u],m,e]
---% return
-
+@
+\subsection{compReturn}
+Compile return
+<<*>>=
compReturn(["return",level,x],m,e) ==
null $exitModeStack =>
stackSemanticError(["the return before","%b",x,"%d","is unneccessary"],nil)
@@ -952,8 +1113,10 @@ compReturn(["return",level,x],m,e) ==
modifyModeStack(m',index)
[["TAGGEDreturn",0,u],m,e']
---% ELT
-
+@
+\subsection{compElt}
+Compile Elt
+<<*>>=
compElt(form,m,E) ==
form isnt ["elt",aDomain,anOp] => compForm(form,m,E)
aDomain="Lisp" =>
@@ -979,8 +1142,10 @@ compElt(form,m,E) ==
convert([["call",val],first rest sig,E], m) --implies fn calls used to
access constants
compForm(form,m,E)
---% HAS
-
+@
+\subsection{compHas}
+Compile has
+<<*>>=
compHas(pred is ["has",a,b],m,$e) ==
--b is (":",:.) => (.,.,E):= comp(b,$EmptyMode,E)
$e:= chaseInferences(pred,$e)
@@ -990,6 +1155,9 @@ compHas(pred is ["has",a,b],m,$e) ==
--used in various other places to make the discrimination
+@
+\subsection{compHasFormat}
+<<*>>=
compHasFormat (pred is ["has",olda,b]) ==
argl := rest $form
formals := TAKE(#argl,$FormalMapVariableList)
@@ -1003,8 +1171,10 @@ compHasFormat (pred is ["has",olda,b]) ==
isDomainForm(b,$EmptyEnvironment) => ["EQUAL",a,b]
["HasCategory",a,mkDomainConstructor b]
---% IF
-
+@
+\subsection{compIf}
+Compile if
+<<*>>=
compIf(["IF",a,b,c],m,E) ==
[xa,ma,Ea,Einv]:= compBoolean(a,$Boolean,E) or return nil
[xb,mb,Eb]:= Tb:= compFromIf(b,m,Ea) or return nil
@@ -1019,6 +1189,9 @@ compIf(["IF",a,b,c],m,E) ==
E
[x,mc,returnEnv]
+@
+\subsection{canReturn}
+<<*>>=
canReturn(expr,level,exitCount,ValueFlag) == --SPAD: exit and friends
atom expr => ValueFlag and level=exitCount
(op:= first expr)="QUOTE" => ValueFlag and level=exitCount
@@ -1056,10 +1229,16 @@ canReturn(expr,level,exitCount,ValueFlag) == --SPAD:
exit and friends
and/[canReturn(u,level,exitCount,ValueFlag) for u in expr]
systemErrorHere '"canReturn" --for the time being
+@
+\subsection{compBoolean}
+<<*>>=
compBoolean(p,m,E) ==
[p',m,E]:= comp(p,m,E) or return nil
[p',m,getSuccessEnvironment(p,E),getInverseEnvironment(p,E)]
+@
+\subsection{getSuccessEnvironment}
+<<*>>=
getSuccessEnvironment(a,e) ==
-- the next four lines try to ensure that explicit special-case tests
@@ -1079,6 +1258,9 @@ getSuccessEnvironment(a,e) ==
put(x,"condition",[a,:get(x,"condition",e)],e)
e
+@
+\subsection{getInverseEnvironment}
+<<*>>=
getInverseEnvironment(a,E) ==
atom a => E
[op,:argl]:= a
@@ -1101,12 +1283,18 @@ getInverseEnvironment(a,E) ==
put(x,"condition",[newpred,:get(x,"condition",E)],E)
E
+@
+\subsection{getUnionMode}
+<<*>>=
getUnionMode(x,e) ==
m:=
atom x => getmode(x,e)
return nil
isUnionMode(m,e)
+@
+\subsection{isUnionMode}
+<<*>>=
isUnionMode(m,e) ==
m is ["Union",:.] => m
(m':= getmode(m,e)) is ["Mapping",["UnionCategory",:.]] => CADR m'
@@ -1114,30 +1302,45 @@ isUnionMode(m,e) ==
(v.expr is ["Union",:.] => v.expr; nil)
nil
+@
+\subsection{compFromIf}
+<<*>>=
compFromIf(a,m,E) ==
a="noBranch" => ["noBranch",m,E]
true => comp(a,m,E)
+@
+\subsection{quotify}
+<<*>>=
quotify x == x
+@
+\subsection{compImport}
+<<*>>=
compImport(["import",:doms],m,e) ==
for dom in doms repeat e:=addDomain(dom,e)
["/throwAway",$NoValueMode,e]
---Will the jerk who commented out these two functions please NOT do so
---again. These functions ARE needed, and case can NOT be done by
---modemap alone. The reason is that A case B requires to take A
---evaluated, but B unevaluated. Therefore a special function is
---required. You may have thought that you had tested this on "failed"
---etc., but "failed" evaluates to it's own mode. Try it on x case $
---next time.
--- An angry JHD - August 15th., 1984
-
+@
+\subsection{compCase}
+Will the jerk who commented out these two functions please NOT do so
+again. These functions ARE needed, and case can NOT be done by
+modemap alone. The reason is that A case B requires to take A
+evaluated, but B unevaluated. Therefore a special function is
+required. You may have thought that you had tested this on ``failed''
+etc., but ``failed'' evaluates to it's own mode. Try it on x case \$
+next time.
+
+An angry JHD - August 15th., 1984
+<<*>>=
compCase(["case",x,m'],m,e) ==
e:= addDomain(m',e)
T:= compCase1(x,m',e) => coerce(T,m)
nil
+@
+\subsection{compCase1}
+<<*>>=
compCase1(x,m,e) ==
[x',m',e']:= comp(x,$EmptyMode,e) or return nil
u:=
@@ -1147,6 +1350,9 @@ compCase1(x,m,e) ==
fn:= (or/[selfn for [cond,selfn] in u | cond=true]) or return nil
[["call",fn,x'],$Boolean,e']
+@
+\subsection{compColon}
+<<*>>=
compColon([":",f,t],m,e) ==
$insideExpressionIfTrue=true => compColonInside(f,m,e,t)
--if inside an expression, ":" means to convert to m "on faith"
@@ -1177,12 +1383,18 @@ compColon([":",f,t],m,e) ==
e:= put(f,"value",[genSomeVariable(),t,$noEnv],e)
["/throwAway",getmode(f,e),e]
+@
+\subsection{unknownTypeError}
+<<*>>=
unknownTypeError name ==
name:=
name is [op,:.] => op
name
stackSemanticError(["%b",name,"%d","is not a known type"],nil)
+@
+\subsection{compPretend}
+<<*>>=
compPretend(["pretend",x,t],m,e) ==
e:= addDomain(t,e)
T:= comp(x,t,e) or comp(x,$EmptyMode,e) or return nil
@@ -1192,6 +1404,9 @@ compPretend(["pretend",x,t],m,e) ==
T:= [T.expr,t,T.env]
T':= coerce(T,m) => (if warningMessage then stackWarning warningMessage; T')
+@
+\subsection{compColonInside}
+<<*>>=
compColonInside(x,m,e,m') ==
e:= addDomain(m',e)
T:= comp(x,$EmptyMode,e) or return nil
@@ -1208,19 +1423,23 @@ compColonInside(x,m,e,m') ==
stackWarning [":",m'," -- should replace by pretend"]
T'
+@
+\subsection{compIs}
+<<*>>=
compIs(["is",a,b],m,e) ==
[aval,am,e] := comp(a,$EmptyMode,e) or return nil
[bval,bm,e] := comp(b,$EmptyMode,e) or return nil
T:= [["domainEqual",aval,bval],$Boolean,e]
coerce(T,m)
---% Functions for coercion by the compiler
-
--- The function coerce is used by the old compiler for coercions.
--- The function coerceInteractive is used by the interpreter.
--- One should always call the correct function, since the represent-
--- ation of basic objects may not be the same.
-
+@
+\section{Functions for coercion by the compiler}
+\subsection{coerce}
+The function coerce is used by the old compiler for coercions.
+The function coerceInteractive is used by the interpreter.
+One should always call the correct function, since the representation
+of basic objects may not be the same.
+<<*>>=
coerce(T,m) ==
$InteractiveMode =>
keyedSystemError("S2GE0016",['"coerce",
@@ -1237,6 +1456,9 @@ coerce(T,m) ==
["Cannot coerce","%b",x,"%d","%l"," of mode","%b",m1,"%d","%l",
" to mode","%b",m2,"%d"]
+@
+\subsection{coerceEasy}
+<<*>>=
coerceEasy(T,m) ==
m=$EmptyMode => T
m=$NoValueMode or m=$Void => [T.expr,m,T.env]
@@ -1248,6 +1470,9 @@ coerceEasy(T,m) ==
T.mode=$EmptyMode or modeEqualSubst(T.mode,m,T.env) =>
[T.expr,m,T.env]
+@
+\subsection{coerceSubset}
+<<*>>=
coerceSubset([x,m,e],m') ==
isSubset(m,m',e) or m="Rep" and m'="$" => [x,m',e]
m is ['SubDomain,=m',:.] => [x,m',e]
@@ -1259,6 +1484,9 @@ coerceSubset([x,m,e],m') ==
[x,m',e]
nil
+@
+\subsection{coerceHard}
+<<*>>=
coerceHard(T,m) ==
$e: local:= T.env
m':= T.mode
@@ -1275,6 +1503,9 @@ coerceHard(T,m) ==
coerceExtraHard(T,m)
coerceExtraHard(T,m)
+@
+\subsection{coerceExtraHard}
+<<*>>=
coerceExtraHard(T is [x,m',e],m) ==
T':= autoCoerceByModemap(T,m) => T'
isUnionMode(m',e) is ["Union",:l] and (t:= hasType(x,e)) and
@@ -1284,6 +1515,9 @@ coerceExtraHard(T is [x,m',e],m) ==
[['coerceRe2E,x,['ELT,COPY m',0]],m,e]
nil
+@
+\subsection{coerceable}
+<<*>>=
coerceable(m,m',e) ==
m=m' => m
-- must find any free parameters in m
@@ -1291,16 +1525,25 @@ coerceable(m,m',e) ==
coerce(["$fromCoerceable$",m,e],m') => m'
nil
+@
+\subsection{coerceExit}
+<<*>>=
coerceExit([x,m,e],m') ==
m':= resolve(m,m')
x':= replaceExitEtc(x,catchTag:= MKQ GENSYM(),"TAGGEDexit",$exitMode)
coerce([["CATCH",catchTag,x'],m,e],m')
+@
+\subsection{compAtSign}
+<<*>>=
compAtSign(["@",x,m'],m,e) ==
e:= addDomain(m',e)
T:= comp(x,m',e) or return nil
coerce(T,m)
+@
+\subsection{compCoerce}
+<<*>>=
compCoerce(["::",x,m'],m,e) ==
e:= addDomain(m',e)
T:= compCoerce1(x,m',e) => coerce(T,m)
@@ -1308,6 +1551,9 @@ compCoerce(["::",x,m'],m,e) ==
T:= (or/[compCoerce1(x,m1,e) for m1 in l]) or return nil
coerce([T.expr,m',T.env],m)
+@
+\subsection{compCoerce1}
+<<*>>=
compCoerce1(x,m',e) ==
T:= comp(x,m',e) or comp(x,$EmptyMode,e) or return nil
m1:=
@@ -1323,6 +1569,9 @@ compCoerce1(x,m',e) ==
code:= ['PROG1,['LET,gg,T.expr], ['check_-subtype,pred,MKQ m',gg]]
[code,m',T.env]
+@
+\subsection{coerceByModemap}
+<<*>>=
coerceByModemap([x,m,e],m') ==
--+ modified 6/27 for new runtime system
u:=
@@ -1337,6 +1586,9 @@ coerceByModemap([x,m,e],m') ==
genDeltaEntry ['coerce,:mm]
[["call",fn,x],m',e]
+@
+\subsection{autoCoerceByModemap}
+<<*>>=
autoCoerceByModemap([x,source,e],target) ==
u:=
[cexpr
@@ -1351,9 +1603,12 @@ autoCoerceByModemap([x,source,e],target) ==
" to: ",target," without a case statement"]
[["call",fn,x],target,e]
---% Very old resolve
--- should only be used in the old (preWATT) compiler
+@
+\subsection{resolve}
+Very old resolve
+should only be used in the old (preWATT) compiler
+<<*>>=
resolve(din,dout) ==
din=$NoValueMode or dout=$NoValueMode => $NoValueMode
dout=$EmptyMode => din
@@ -1363,6 +1618,9 @@ resolve(din,dout) ==
mkUnion(din,dout)
dout
+@
+\subsection{modeEqual}
+<<*>>=
modeEqual(x,y) ==
-- this is the late modeEqual
-- orders Unions
@@ -1379,6 +1637,9 @@ modeEqual(x,y) ==
true
(and/[modeEqual(u,v) for u in x for v in y])
+@
+\subsection{modeEqualSubst}
+<<*>>=
modeEqualSubst(m1,m,e) ==
modeEqual(m1, m) => true
atom m1 => get(m1,"value",e) is [m',:.] and modeEqual(m',m)
@@ -1389,10 +1650,9 @@ modeEqualSubst(m1,m,e) ==
and/[modeEqualSubst(xm1,xm2,e) for xm1 in l1 for xm2 in l2]
nil
---% Things to support )compile
-
@
\section{)compile}
+This is the implementation of the )compile command.
You use this command to invoke the new Axiom library compiler or the
old Axiom system compiler. The {\tt )compile} system command is
@@ -1701,8 +1961,8 @@ with a {\tt .lsp} file, the Lisp file is compiled and
{\tt )library}
is called. For Aldor, You must also have present a {\tt .asy}
generated from the same source file.
+\subsection{compileSpad2Cmd}
<<*>>=
-
compileSpad2Cmd args ==
-- This is the old compiler
-- Assume we entered from the "compiler" function, so args ^= nil
@@ -1801,6 +2061,9 @@ compileSpad2Cmd args ==
terminateSystemCommand()
spadPrompt()
+@
+\subsection{convertSpadToAsFile}
+<<*>>=
convertSpadToAsFile path ==
-- can assume path has type = .spad
$globalMacroStack : local := nil -- for spad -> as translator
@@ -1833,6 +2096,9 @@ convertSpadToAsFile path ==
mkCheck()
'done
+@
+\subsection{compilerDoit}
+<<*>>=
compilerDoit(constructor, fun) ==
$byConstructors : local := []
$constructorsSeen : local := []
@@ -1847,6 +2113,9 @@ compilerDoit(constructor, fun) ==
null MEMBER(ii,$constructorsSeen) =>
sayBrightly ['">>> Warning ",'%b,ii,'%d,'" was not found"]
+@
+\subsection{compilerDoitWithScreenedLisplib}
+<<*>>=
compilerDoitWithScreenedLisplib(constructor, fun) ==
EMBED('RWRITE,
'(LAMBDA (KEY VALUE STREAM)
@@ -1860,6 +2129,40 @@ compilerDoitWithScreenedLisplib(constructor, fun) ==
@
+\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.
+
+@
\eject
\begin{thebibliography}{99}
\bibitem{1} nothing
diff --git a/src/interp/g-util.boot.pamphlet b/src/interp/g-util.boot.pamphlet
index 878e547..dd1e8c4 100644
--- a/src/interp/g-util.boot.pamphlet
+++ b/src/interp/g-util.boot.pamphlet
@@ -20,68 +20,52 @@ THIS CODE TO LISP AND STORE THE RESULTING LISP CODE BACK
INTO
THIS FILE.}
See the {\bf g-util.clisp} section below.
-\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.
-@
+\section{Utility Functions of General Use}
+\subsection{PPtoFile}
<<*>>=
-<<license>>
-
---% Utility Functions of General Use
-
PPtoFile(x, fname) ==
stream := DEFIOSTREAM([['MODE, :'OUTPUT], ['FILE, :fname]], 80, 0)
PRETTYPRINT(x, stream)
SHUT stream
x
--- Convert an arbitrary lisp object to canonical boolean.
+@
+\subsection{bool}
+Convert an arbitrary lisp object to canonical boolean.
+<<*>>=
bool x ==
NULL NULL x
---% Various lispy things
-
+@
+\subsection{Identity}
+<<*>>=
Identity x == x
+@
+\section{Property Lists}
+\subsection{length1?}
+<<*>>=
length1? l == PAIRP l and not PAIRP QCDR l
+@
+\subsection{length2?}
+<<*>>=
length2? l == PAIRP l and PAIRP (l := QCDR l) and not PAIRP QCDR l
+@
+\subsection{pairList}
+<<*>>=
pairList(u,v) == [[x,:y] for x in u for y in v]
--- GETALIST(alist,prop) == IFCDR assoc(prop,alist)
+@
+\subsection{GETALIST}
+<<*>>=
GETALIST(alist,prop) == CDR assoc(prop,alist)
+@
+\subsection{PUTALIST}
+<<*>>=
PUTALIST(alist,prop,val) ==
null alist => [[prop,:val]]
pair := assoc(prop,alist) =>
@@ -92,6 +76,9 @@ PUTALIST(alist,prop,val) ==
QRPLACD(LASTPAIR alist,[[prop,:val]])
alist
+@
+\subsection{REMALIST}
+<<*>>=
REMALIST(alist,prop) ==
null alist => alist
alist is [[ =prop,:.],:r] =>
@@ -110,20 +97,28 @@ REMALIST(alist,prop) ==
if null (l := QCDR l) or null rest l then ok := NIL
alist
+@
+\section{Association Lists}
+\subsection{deleteLassoc}
+<<*>>=
deleteLassoc(x,y) ==
y is [[a,:.],:y'] =>
EQ(x,a) => y'
[first y,:deleteLassoc(x,y')]
y
---% association list functions
-
+@
+\subsection{deleteAssoc}
+<<*>>=
deleteAssoc(x,y) ==
y is [[a,:.],:y'] =>
a=x => deleteAssoc(x,y')
[first y,:deleteAssoc(x,y')]
y
+@
+\subsection{deleteAssocWOC}
+<<*>>=
deleteAssocWOC(x,y) ==
null y => y
[[a,:.],:t]:= y
@@ -134,6 +129,9 @@ deleteAssocWOC(x,y) ==
fn(x,t)
nil
+@
+\subsection{insertWOC}
+<<*>>=
insertWOC(x,y) ==
null y => [x]
(fn(x,y); y) where fn(x,y is [h,:t]) ==
@@ -143,14 +141,17 @@ insertWOC(x,y) ==
RPLACA(y,x)
fn(x,t)
-
-
---% Miscellaneous Functions for Working with Strings
-
+@
+\section{String Handling}
+\subsection{fillerSpaces}
+<<*>>=
fillerSpaces(n,:charPart) ==
n <= 0 => '""
MAKE_-FULL_-CVEC(n,IFCAR charPart or '" ")
+@
+\subsection{centerString}
+<<*>>=
centerString(text,width,fillchar) ==
wid := entryWidth text
wid >= width => text
@@ -162,6 +163,9 @@ centerString(text,width,fillchar) ==
if f.1 ^= 0 then fill1 := STRCONC(fillchar,fill1)
[fill1,text,fill2]
+@
+\subsection{stringPrefix?}
+<<*>>=
stringPrefix?(pref,str) ==
-- sees if the first #pref letters of str are pref
-- replaces STRINGPREFIXP
@@ -175,6 +179,9 @@ stringPrefix?(pref,str) ==
i := i + 1
ok
+@
+\subsection{stringChar2Integer}
+<<*>>=
stringChar2Integer(str,pos) ==
-- replaces GETSTRINGDIGIT in UT LISP
-- returns small integer represented by character in position pos
@@ -185,6 +192,9 @@ stringChar2Integer(str,pos) ==
not DIGITP(d := SCHAR(str,pos)) => NIL
DIG2FIX d
+@
+\subsection{dropLeadingBlanks}
+<<*>>=
dropLeadingBlanks str ==
str := object2String str
l := QCSIZE str
@@ -197,13 +207,22 @@ dropLeadingBlanks str ==
nb => SUBSTRING(str,nb,NIL)
'""
+@
+\subsection{concat}
+<<*>>=
concat(:l) == concatList l
+@
+\subsection{concatList}
+<<*>>=
concatList [x,:y] ==
null y => x
null x => concatList y
concat1(x,concatList y)
+@
+\subsection{concat1}
+<<*>>=
concat1(x,y) ==
null x => y
atom x => (null y => x; atom y => [x,y]; [x,:y])
@@ -211,37 +230,58 @@ concat1(x,y) ==
atom y => [:x,y]
[:x,:y]
---% BOOT ravel and reshape
-
+@
+\section{BOOT ravel and reshape}
+\subsection{ravel}
+<<*>>=
ravel a == a
+@
+\subsection{reshape}
+<<*>>=
reshape(a,b) == a
---% Some functions for algebra code
-
+@
+\section{Some functions for algebra code}
+\subsection{boolODDP}
+<<*>>=
boolODDP x == ODDP x
---% Miscellaneous
-
+@
+\section{Miscellaneous}
+\subsection{freeOfSharpVars}
+<<*>>=
freeOfSharpVars x ==
atom x => not isSharpVarWithNum x
freeOfSharpVars first x and freeOfSharpVars rest x
+@
+\subsection{listOfSharpVars}
+<<*>>=
listOfSharpVars x ==
atom x => (isSharpVarWithNum x => LIST x; nil)
setUnion(listOfSharpVars first x,listOfSharpVars rest x)
+@
+\subsection{listOfPatternIds}
+<<*>>=
listOfPatternIds x ==
isPatternVar x => [x]
atom x => nil
x is ['QUOTE,:.] => nil
UNIONQ(listOfPatternIds first x,listOfPatternIds rest x)
+@
+\subsection{isPatternVar}
+<<*>>=
isPatternVar v ==
-- a pattern variable consists of a star followed by a star or digit(s)
IDENTP(v) and MEMQ(v,'(_*_* _*1 _*2 _*3 _*4 _*5 _*6 _*7 _*8 _*9 _*10
_*11 _*12 _*13 _*14 _*15 _*16 _*17 _*18 _*19 _*20)) and true
+@
+\subsection{removeZeroOne}
+<<*>>=
removeZeroOne x ==
-- replace all occurrences of (Zero) and (One) with
-- 0 and 1
@@ -250,6 +290,9 @@ removeZeroOne x ==
atom x => x
[removeZeroOne first x,:removeZeroOne rest x]
+@
+\subsection{removeZeroOneDestructively}
+<<*>>=
removeZeroOneDestructively t ==
-- replace all occurrences of (Zero) and (One) with
-- 0 and 1 destructively
@@ -259,6 +302,9 @@ removeZeroOneDestructively t ==
RPLNODE(t,removeZeroOneDestructively first t,
removeZeroOneDestructively rest t)
+@
+\subsection{flattenSexpr}
+<<*>>=
flattenSexpr s ==
null s => s
ATOM s => s
@@ -266,14 +312,26 @@ flattenSexpr s ==
ATOM f => [f,:flattenSexpr r]
[:flattenSexpr f,:flattenSexpr r]
+@
+\subsection{isLowerCaseLetter}
+<<*>>=
isLowerCaseLetter c == charRangeTest CHAR2NUM c
+@
+\subsection{isUpperCaseLetter}
+<<*>>=
isUpperCaseLetter c == charRangeTest QSDIFFERENCE(CHAR2NUM c,64)
+@
+\subsection{isLetter}
+<<*>>=
isLetter c ==
n:= CHAR2NUM c
charRangeTest n or charRangeTest QSDIFFERENCE(CHAR2NUM c,64)
+@
+\subsection{charRangeTest}
+<<*>>=
charRangeTest n ==
QSLESSP(153,n) =>
QSLESSP(169,n) => false
@@ -285,18 +343,24 @@ charRangeTest n ==
true
false
+@
+\subsection{update}
+<<*>>=
update() ==
OBEY
STRCONC('"SPADEDIT ",STRINGIMAGE _/VERSION,'" ",STRINGIMAGE _/WSNAME,'" A")
_/UPDATE()
---% Inplace Merge Sort for Lists
--- MBM April/88
+@
+\section{Inplace Merge Sort for Lists}
+MBM April/88
--- listSort(pred,list) or listSort(pred,list,key)
--- the pred function is a boolean valued function defining the ordering
--- the key function extracts the key from an item for comparison by pred
+\verb|listSort(pred,list)| or \verb|listSort(pred,list,key)|
+The pred function is a boolean valued function defining the ordering
+the key function extracts the key from an item for comparison by pred
+\subsection{listSort}
+<<*>>=
listSort(pred,list,:optional) ==
NOT functionp pred => error "listSort: first arg must be a function"
NOT LISTP list => error "listSort: second argument must be a list"
@@ -305,20 +369,29 @@ listSort(pred,list,:optional) ==
NOT functionp key => error "listSort: last arg must be a function"
mergeSort(pred,key,list,LENGTH list)
--- non-destructive merge sort using NOT GGREATERP as predicate
+@
+\subsection{MSORT}
+Non-destructive merge sort using NOT GGREATERP as predicate
+<<*>>=
MSORT list == listSort(function GLESSEQP, COPY_-LIST list)
--- destructive merge sort using NOT GGREATERP as predicate
+@
+\subsection{NMSORT}
+Destructive merge sort using NOT GGREATERP as predicate
+<<*>>=
NMSORT list == listSort(function GLESSEQP, list)
--- non-destructive merge sort using ?ORDER as predicate
+@
+\subsection{orderList}
+Non-destructive merge sort using ?ORDER as predicate
+<<*>>=
orderList l == listSort(function _?ORDER, COPY_-LIST l)
--- dummy defn until clean-up
--- order l == orderList l
-
+@
+\subsection{mergeInPlace}
+Merge the two sorted lists p and q
+<<*>>=
mergeInPlace(f,g,p,q) ==
- -- merge the two sorted lists p and q
if NULL p then return p
if NULL q then return q
if FUNCALL(f,FUNCALL(g, QCAR p),FUNCALL(g, QCAR q))
@@ -331,6 +404,9 @@ mergeInPlace(f,g,p,q) ==
if NULL p then QRPLACD(t,q) else QRPLACD(t,p)
r
+@
+\subsection{mergeSort}
+<<*>>=
mergeSort(f,g,p,n) ==
if EQ(n,2) and FUNCALL(f,FUNCALL(g,QCADR p),FUNCALL(g,QCAR p)) then
t := p
@@ -348,19 +424,26 @@ mergeSort(f,g,p,n) ==
q := mergeSort(f,g,q,QSDIFFERENCE(n,l))
mergeInPlace(f,g,p,q)
---% Throwing with glorious highlighting (maybe)
-
+@
+\subsection{spadThrow}
+Throwing with glorious highlighting (maybe)
+<<*>>=
spadThrow() ==
if $interpOnly and $mapName then
putHist($mapName,'localModemap, nil, $e)
THROW("SPAD__READER",nil)
+@
+\subsection{spadThrowBrightly}
+<<*>>=
spadThrowBrightly x ==
sayBrightly x
spadThrow()
---% Type Formatting Without Abbreviation
-
+@
+\subsection{formatUnabbreviatedSig}
+Type Formatting Without Abbreviation
+<<*>>=
formatUnabbreviatedSig sig ==
null sig => ["() -> ()"]
[target,:args] := sig
@@ -370,6 +453,9 @@ formatUnabbreviatedSig sig ==
args := formatUnabbreviatedTuple args
['"(",:args,'") -> ",:target]
+@
+\subsection{formatUnabbreviatedTuple}
+<<*>>=
formatUnabbreviatedTuple t ==
-- t is a list of types
null t => t
@@ -378,6 +464,9 @@ formatUnabbreviatedTuple t ==
null rest t => t0
[:t0,'",",:formatUnabbreviatedTuple QCDR t]
+@
+\subsection{formatUnabbreviated}
+<<*>>=
formatUnabbreviated t ==
atom t =>
[t]
@@ -399,6 +488,9 @@ formatUnabbreviated t ==
[arg,'"(",:formatUnabbreviatedTuple args,'")"]
t
+@
+\subsection{sublisNQ}
+<<*>>=
sublisNQ(al,e) ==
atom al => e
fn(al,e) where fn(al,e) ==
@@ -412,12 +504,17 @@ sublisNQ(al,e) ==
EQ(a,u) and EQ(rest e,v) => e
[u,:v]
--- function for turning strings in tex format
-
+@
+\subsection{str2Outform}
+Function for turning strings in tex format
+<<*>>=
str2Outform s ==
parse := ncParseFromString s or systemError '"String for TeX will not parse"
parse2Outform parse
+@
+\subsection{parse2Outform}
+<<*>>=
parse2Outform x ==
x is [op,:argl] =>
nargl := [parse2Outform y for y in argl]
@@ -426,16 +523,25 @@ parse2Outform x ==
[op,:nargl]
x
+@
+\subsection{str2Tex}
+<<*>>=
str2Tex s ==
outf := str2Outform s
val := coerceInt(mkObj(wrap outf, '(OutputForm)), '(TexFormat))
val := objValUnwrap val
CAR val.1
+@
+\subsection{opOf}
+<<*>>=
opOf x ==
atom x => x
first x
+@
+\subsection{getProplist}
+<<*>>=
getProplist(x,E) ==
not atom x => getProplist(first x,E)
u:= search(x,E) => u
@@ -446,14 +552,23 @@ getProplist(x,E) ==
-- (pl:=PROPLIST x) => pl
-- Above line commented out JHD/BMT 2.Aug.90
+@
+\subsection{search}
+<<*>>=
search(x,e is [curEnv,:tailEnv]) ==
searchCurrentEnv(x,curEnv) or searchTailEnv(x,tailEnv)
+@
+\subsection{searchCurrentEnv}
+<<*>>=
searchCurrentEnv(x,currentEnv) ==
for contour in currentEnv repeat
if u:= ASSQ(x,contour) then return (signal:= u)
KDR signal
+@
+\subsection{searchTailEnv}
+<<*>>=
searchTailEnv(x,e) ==
for env in e repeat
signal:=
@@ -462,6 +577,9 @@ searchTailEnv(x,e) ==
if signal then return signal
KDR signal
+@
+\subsection{augProplist}
+<<*>>=
augProplist(proplist,prop,val) ==
$InteractiveMode => augProplistInteractive(proplist,prop,val)
while (proplist is [[ =prop,:.],:proplist']) repeat proplist:= proplist'
@@ -471,24 +589,42 @@ augProplist(proplist,prop,val) ==
DELLASOS(prop,proplist)
[[prop,:val],:proplist]
+@
+\subsection{augProplistOf}
+<<*>>=
augProplistOf(var,prop,val,e) ==
proplist:= getProplist(var,e)
semchkProplist(var,proplist,prop,val)
augProplist(proplist,prop,val)
+@
+\subsection{semchkProplist}
+<<*>>=
semchkProplist(x,proplist,prop,val) ==
prop="isLiteral" =>
LASSOC("value",proplist) or LASSOC("mode",proplist) => warnLiteral x
MEMQ(prop,'(mode value)) =>
LASSOC("isLiteral",proplist) => warnLiteral x
+@
+\subsection{addBinding}
+The \verb|$envHashTable| is a performance improvement by Waldek Hebisch.
+<<*>>=
+DEFPARAMETER($envHashTable,nil)
+
addBinding(var,proplist,e is [[curContour,:tailContour],:tailEnv]) ==
EQ(proplist,getProplist(var,e)) => e
+ if $envHashTable then
+ for u in proplist repeat
+ HPUT($envHashTable,[var, CAR u],true)
$InteractiveMode => addBindingInteractive(var,proplist,e)
if curContour is [[ =var,:.],:.] then curContour:= rest curContour
--Previous line should save some space
[[[lx,:curContour],:tailContour],:tailEnv] where lx:= [var,:proplist]
+@
+\subsection{position}
+<<*>>=
position(x,l) ==
posn(x,l,0) where
posn(x,l,n) ==
@@ -496,21 +632,35 @@ position(x,l) ==
x=first l => n
posn(x,rest l,n+1)
+@
+\subsection{insert}
+<<*>>=
insert(x,y) ==
MEMBER(x,y) => y
[x,:y]
+@
+\subsection{after}
+<<*>>=
after(u,v) ==
r:= u
for x in u for y in v repeat r:= rest r
r
-
+@
+\section{String trimming}
+<<*>>=
$blank := char ('_ )
+@
+\subsection{trimString}
+<<*>>=
trimString s ==
leftTrim rightTrim s
+@
+\subsection{leftTrim}
+<<*>>=
leftTrim s ==
k := MAXINDEX s
k < 0 => s
@@ -519,6 +669,9 @@ leftTrim s ==
SUBSTRING(s,j + 1,nil)
s
+@
+\subsection{rightTrim}
+<<*>>=
rightTrim s == -- assumed a non-empty string
k := MAXINDEX s
k < 0 => s
@@ -527,38 +680,57 @@ rightTrim s == -- assumed a non-empty string
SUBSTRING(s,0,j)
s
+@
+\subsection{pp}
+<<*>>=
pp x ==
PRETTYPRINT x
x
+@
+\subsection{pr}
+<<*>>=
pr x ==
F_,PRINT_-ONE x
nil
+@
+\subsection{quickAnd}
+<<*>>=
quickAnd(a,b) ==
a = true => b
b = true => a
a = false or b = false => false
simpBool ['AND,a,b]
+@
+\subsection{quickOr}
+<<*>>=
quickOr(a,b) ==
a = true or b = true => true
b = false => a
a = false => b
simpCatPredicate simpBool ['OR,a,b]
+@
+\subsection{intern}
+<<*>>=
intern x ==
STRINGP x =>
DIGITP x.0 => string2Integer x
INTERN x
x
+@
+\subsection{isDomain}
+<<*>>=
isDomain a ==
PAIRP a and VECP(CAR a) and
MEMBER(CAR(a).0, $domainTypeTokens)
--- variables used by browser
-
+@
+\section{Variables used by browser}
+<<*>>=
$htHash := MAKE_-HASH_-TABLE()
$glossHash := MAKE_-HASH_-TABLE()
$lispHash := MAKE_-HASH_-TABLE()
@@ -629,14 +801,18 @@ $beginEndList := '(
"verbatim"
"detail")
+@
+\subsection{isDefaultPackageName}
+<<*>>=
isDefaultPackageName x == (s := PNAME x).(MAXINDEX s) = char '_&
@
\section{g-util.clisp}
<<g-util.clisp>>=
+;;; -*- Mode:Lisp; Package:Boot -*-
+
(IN-PACKAGE "BOOT" )
-;--% Utility Functions of General Use
;PPtoFile(x, fname) ==
; stream := DEFIOSTREAM([['MODE, :'OUTPUT], ['FILE, :fname]], 80, 0)
; PRETTYPRINT(x, stream)
@@ -646,14 +822,12 @@ isDefaultPackageName x == (s := PNAME x).(MAXINDEX s) =
char '_&
;;; *** |PPtoFile| REDEFINED
(DEFUN |PPtoFile| (|x| |fname|) (PROG (|stream|) (RETURN (PROGN (SPADLET
|stream| (DEFIOSTREAM (CONS (CONS (QUOTE MODE) (QUOTE OUTPUT)) (CONS (CONS
(QUOTE FILE) |fname|) NIL)) 80 0)) (PRETTYPRINT |x| |stream|) (SHUT |stream|)
|x|))))
-;-- Convert an arbitrary lisp object to canonical boolean.
;bool x ==
; NULL NULL x
;;; *** |bool| REDEFINED
(DEFUN |bool| (|x|) (NULL (NULL |x|)))
-;--% Various lispy things
;Identity x == x
;;; *** |Identity| REDEFINED
@@ -673,8 +847,7 @@ isDefaultPackageName x == (s := PNAME x).(MAXINDEX s) =
char '_&
;;; *** |pairList| REDEFINED
-(DEFUN |pairList| (|u| |v|) (PROG NIL (RETURN (SEQ (PROG (#0=#:G2415) (SPADLET
#0# NIL) (RETURN (DO ((#1=#:G2421 |u| (CDR #1#)) (|x| NIL) (#2=#:G2422 |v| (CDR
#2#)) (|y| NIL)) ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL) (ATOM #2#)
(PROGN (SETQ |y| (CAR #2#)) NIL)) (NREVERSE0 #0#)) (SEQ (EXIT (SETQ #0# (CONS
(CONS |x| |y|) #0#)))))))))))
-;-- GETALIST(alist,prop) == IFCDR assoc(prop,alist)
+(DEFUN |pairList| (|u| |v|) (PROG NIL (RETURN (SEQ (PROG (#0=#:G1403) (SPADLET
#0# NIL) (RETURN (DO ((#1=#:G1404 |u| (CDR #1#)) (|x| NIL) (#2=#:G1405 |v| (CDR
#2#)) (|y| NIL)) ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL) (ATOM #2#)
(PROGN (SETQ |y| (CAR #2#)) NIL)) (NREVERSE0 #0#)) (SEQ (EXIT (SETQ #0# (CONS
(CONS |x| |y|) #0#)))))))))))
;GETALIST(alist,prop) == CDR assoc(prop,alist)
;;; *** GETALIST REDEFINED
@@ -723,7 +896,6 @@ isDefaultPackageName x == (s := PNAME x).(MAXINDEX s) =
char '_&
;;; *** |deleteLassoc| REDEFINED
(DEFUN |deleteLassoc| (|x| |y|) (PROG (|ISTMP#1| |a| |y'|) (RETURN (COND ((AND
(PAIRP |y|) (PROGN (SPADLET |ISTMP#1| (QCAR |y|)) (AND (PAIRP |ISTMP#1|) (PROGN
(SPADLET |a| (QCAR |ISTMP#1|)) (QUOTE T)))) (PROGN (SPADLET |y'| (QCDR |y|))
(QUOTE T))) (COND ((EQ |x| |a|) |y'|) ((QUOTE T) (CONS (CAR |y|)
(|deleteLassoc| |x| |y'|))))) ((QUOTE T) |y|)))))
-;--% association list functions
;deleteAssoc(x,y) ==
; y is [[a,:.],:y'] =>
; a=x => deleteAssoc(x,y')
@@ -766,14 +938,13 @@ isDefaultPackageName x == (s := PNAME x).(MAXINDEX s) =
char '_&
;;; *** |insertWOC| REDEFINED
(DEFUN |insertWOC| (|x| |y|) (COND ((NULL |y|) (CONS |x| NIL)) ((QUOTE T)
(|insertWOC,fn| |x| |y|) |y|)))
-;--% Miscellaneous Functions for Working with Strings
;fillerSpaces(n,:charPart) ==
; n <= 0 => '""
; MAKE_-FULL_-CVEC(n,IFCAR charPart or '" ")
;;; *** |fillerSpaces| REDEFINED
-(DEFUN |fillerSpaces| (&REST #0=#:G2562 &AUX |charPart| |n|) (DSETQ (|n| .
|charPart|) #0#) (COND ((<= |n| 0) (MAKESTRING "")) ((QUOTE T) (MAKE-FULL-CVEC
|n| (OR (IFCAR |charPart|) (MAKESTRING " "))))))
+(DEFUN |fillerSpaces| (&REST #0=#:G1406 &AUX |charPart| |n|) (DSETQ (|n| .
|charPart|) #0#) (COND ((<= |n| 0) (MAKESTRING "")) ((QUOTE T) (MAKE-FULL-CVEC
|n| (OR (IFCAR |charPart|) (MAKESTRING " "))))))
;centerString(text,width,fillchar) ==
; wid := entryWidth text
; wid >= width => text
@@ -787,7 +958,7 @@ isDefaultPackageName x == (s := PNAME x).(MAXINDEX s) =
char '_&
;;; *** |centerString| REDEFINED
-(DEFUN |centerString| (|text| |width| |fillchar|) (PROG (|wid| |f| |fill2|
|fill1|) (RETURN (SEQ (PROGN (SPADLET |wid| (|entryWidth| |text|)) (COND ((>=
|wid| |width|) |text|) ((QUOTE T) (SPADLET |f| (DIVIDE (SPADDIFFERENCE |width|
|wid|) 2)) (SPADLET |fill1| (QUOTE ||)) (DO ((#0=#:G2567 (ELT |f| 0)) (|i| 1
(QSADD1 |i|))) ((QSGREATERP |i| #0#) NIL) (SEQ (EXIT (SPADLET |fill1| (STRCONC
|fillchar| |fill1|))))) (SPADLET |fill2| |fill1|) (COND ((NEQUAL (ELT |f| 1) 0)
(SPADLET |fill1| (STRCONC |fillchar| |fill1|)))) (CONS |fill1| (CONS |text|
(CONS |fill2| NIL))))))))))
+(DEFUN |centerString| (|text| |width| |fillchar|) (PROG (|wid| |f| |fill2|
|fill1|) (RETURN (SEQ (PROGN (SPADLET |wid| (|entryWidth| |text|)) (COND ((>=
|wid| |width|) |text|) ((QUOTE T) (SPADLET |f| (DIVIDE (SPADDIFFERENCE |width|
|wid|) 2)) (SPADLET |fill1| (QUOTE ||)) (DO ((#0=#:G1407 (ELT |f| 0)) (|i| 1
(QSADD1 |i|))) ((QSGREATERP |i| #0#) NIL) (SEQ (EXIT (SPADLET |fill1| (STRCONC
|fillchar| |fill1|))))) (SPADLET |fill2| |fill1|) (COND ((NEQUAL (ELT |f| 1) 0)
(SPADLET |fill1| (STRCONC |fillchar| |fill1|)))) (CONS |fill1| (CONS |text|
(CONS |fill2| NIL))))))))))
;stringPrefix?(pref,str) ==
; -- sees if the first #pref letters of str are pref
; -- replaces STRINGPREFIXP
@@ -836,7 +1007,7 @@ isDefaultPackageName x == (s := PNAME x).(MAXINDEX s) =
char '_&
;;; *** |concat| REDEFINED
-(DEFUN |concat| (&REST #0=#:G2621 &AUX |l|) (DSETQ |l| #0#) (|concatList|
|l|))
+(DEFUN |concat| (&REST #0=#:G1408 &AUX |l|) (DSETQ |l| #0#) (|concatList|
|l|))
;concatList [x,:y] ==
; null y => x
; null x => concatList y
@@ -844,7 +1015,7 @@ isDefaultPackageName x == (s := PNAME x).(MAXINDEX s) =
char '_&
;;; *** |concatList| REDEFINED
-(DEFUN |concatList| (#0=#:G2623) (PROG (|x| |y|) (RETURN (PROGN (SPADLET |x|
(CAR #0#)) (SPADLET |y| (CDR #0#)) (COND ((NULL |y|) |x|) ((NULL |x|)
(|concatList| |y|)) ((QUOTE T) (|concat1| |x| (|concatList| |y|))))))))
+(DEFUN |concatList| (#0=#:G1409) (PROG (|x| |y|) (RETURN (PROGN (SPADLET |x|
(CAR #0#)) (SPADLET |y| (CDR #0#)) (COND ((NULL |y|) |x|) ((NULL |x|)
(|concatList| |y|)) ((QUOTE T) (|concat1| |x| (|concatList| |y|))))))))
;concat1(x,y) ==
; null x => y
; atom x => (null y => x; atom y => [x,y]; [x,:y])
@@ -855,7 +1026,6 @@ isDefaultPackageName x == (s := PNAME x).(MAXINDEX s) =
char '_&
;;; *** |concat1| REDEFINED
(DEFUN |concat1| (|x| |y|) (COND ((NULL |x|) |y|) ((ATOM |x|) (COND ((NULL
|y|) |x|) ((ATOM |y|) (CONS |x| (CONS |y| NIL))) ((QUOTE T) (CONS |x| |y|))))
((NULL |y|) |x|) ((ATOM |y|) (APPEND |x| (CONS |y| NIL))) ((QUOTE T) (APPEND
|x| |y|))))
-;--% BOOT ravel and reshape
;ravel a == a
;;; *** |ravel| REDEFINED
@@ -866,13 +1036,11 @@ isDefaultPackageName x == (s := PNAME x).(MAXINDEX s) =
char '_&
;;; *** |reshape| REDEFINED
(DEFUN |reshape| (|a| |b|) |a|)
-;--% Some functions for algebra code
;boolODDP x == ODDP x
;;; *** |boolODDP| REDEFINED
(DEFUN |boolODDP| (|x|) (ODDP |x|))
-;--% Miscellaneous
;freeOfSharpVars x ==
; atom x => not isSharpVarWithNum x
; freeOfSharpVars first x and freeOfSharpVars rest x
@@ -976,11 +1144,6 @@ isDefaultPackageName x == (s := PNAME x).(MAXINDEX s) =
char '_&
;;; *** |update| REDEFINED
(DEFUN |update| NIL (PROGN (OBEY (STRCONC (MAKESTRING "SPADEDIT ")
(STRINGIMAGE /VERSION) (MAKESTRING " ") (STRINGIMAGE /WSNAME) (MAKESTRING "
A"))) (/UPDATE)))
-;--% Inplace Merge Sort for Lists
-;-- MBM April/88
-;-- listSort(pred,list) or listSort(pred,list,key)
-;-- the pred function is a boolean valued function defining the ordering
-;-- the key function extracts the key from an item for comparison by pred
;listSort(pred,list,:optional) ==
; NOT functionp pred => error "listSort: first arg must be a function"
; NOT LISTP list => error "listSort: second argument must be a list"
@@ -991,29 +1154,23 @@ isDefaultPackageName x == (s := PNAME x).(MAXINDEX s) =
char '_&
;;; *** |listSort| REDEFINED
-(DEFUN |listSort| (&REST #0=#:G2710 &AUX |optional| LIST |pred|) (DSETQ
(|pred| LIST . |optional|) #0#) (PROG (|key|) (RETURN (COND ((NULL (|functionp|
|pred|)) (|error| (QUOTE |listSort: first arg must be a function|))) ((NULL
(LISTP LIST)) (|error| (QUOTE |listSort: second argument must be a list|)))
((NULL |optional|) (|mergeSort| |pred| (|function| |Identity|) LIST (LENGTH
LIST))) ((QUOTE T) (SPADLET |key| (CAR |optional|)) (COND ((NULL (|functionp|
|key|)) (|error| (QUOTE |listSort: last arg must be a function|))) ((QUOTE T)
(|mergeSort| |pred| |key| LIST (LENGTH LIST)))))))))
-;-- non-destructive merge sort using NOT GGREATERP as predicate
+(DEFUN |listSort| (&REST #0=#:G1410 &AUX |optional| LIST |pred|) (DSETQ
(|pred| LIST . |optional|) #0#) (PROG (|key|) (RETURN (COND ((NULL (|functionp|
|pred|)) (|error| (QUOTE |listSort: first arg must be a function|))) ((NULL
(LISTP LIST)) (|error| (QUOTE |listSort: second argument must be a list|)))
((NULL |optional|) (|mergeSort| |pred| (|function| |Identity|) LIST (LENGTH
LIST))) ((QUOTE T) (SPADLET |key| (CAR |optional|)) (COND ((NULL (|functionp|
|key|)) (|error| (QUOTE |listSort: last arg must be a function|))) ((QUOTE T)
(|mergeSort| |pred| |key| LIST (LENGTH LIST)))))))))
;MSORT list == listSort(function GLESSEQP, COPY_-LIST list)
;;; *** MSORT REDEFINED
(DEFUN MSORT (LIST) (|listSort| (|function| GLESSEQP) (COPY-LIST LIST)))
-;-- destructive merge sort using NOT GGREATERP as predicate
;NMSORT list == listSort(function GLESSEQP, list)
;;; *** NMSORT REDEFINED
(DEFUN NMSORT (LIST) (|listSort| (|function| GLESSEQP) LIST))
-;-- non-destructive merge sort using ?ORDER as predicate
;orderList l == listSort(function _?ORDER, COPY_-LIST l)
;;; *** |orderList| REDEFINED
(DEFUN |orderList| (|l|) (|listSort| (|function| ?ORDER) (COPY-LIST |l|)))
-;-- dummy defn until clean-up
-;-- order l == orderList l
;mergeInPlace(f,g,p,q) ==
-; -- merge the two sorted lists p and q
; if NULL p then return p
; if NULL q then return q
; if FUNCALL(f,FUNCALL(g, QCAR p),FUNCALL(g, QCAR q))
@@ -1048,8 +1205,7 @@ isDefaultPackageName x == (s := PNAME x).(MAXINDEX s) =
char '_&
;;; *** |mergeSort| REDEFINED
-(DEFUN |mergeSort| (|f| |g| |p| |n|) (PROG (|l| |t| |q|) (RETURN (SEQ (PROGN
(COND ((AND (EQ |n| 2) (FUNCALL |f| (FUNCALL |g| (QCADR |p|)) (FUNCALL |g|
(QCAR |p|)))) (SPADLET |t| |p|) (SPADLET |p| (QCDR |p|)) (QRPLACD |p| |t|)
(QRPLACD |t| NIL))) (COND ((QSLESSP |n| 3) (RETURN |p|))) (SPADLET |l|
(QSQUOTIENT |n| 2)) (SPADLET |t| |p|) (DO ((#0=#:G2749 (SPADDIFFERENCE |l| 1))
(|i| 1 (QSADD1 |i|))) ((QSGREATERP |i| #0#) NIL) (SEQ (EXIT (SPADLET |t| (QCDR
|t|))))) (SPADLET |q| (CDR |t|)) (QRPLACD |t| NIL) (SPADLET |p| (|mergeSort|
|f| |g| |p| |l|)) (SPADLET |q| (|mergeSort| |f| |g| |q| (QSDIFFERENCE |n|
|l|))) (|mergeInPlace| |f| |g| |p| |q|))))))
-;--% Throwing with glorious highlighting (maybe)
+(DEFUN |mergeSort| (|f| |g| |p| |n|) (PROG (|l| |t| |q|) (RETURN (SEQ (PROGN
(COND ((AND (EQ |n| 2) (FUNCALL |f| (FUNCALL |g| (QCADR |p|)) (FUNCALL |g|
(QCAR |p|)))) (SPADLET |t| |p|) (SPADLET |p| (QCDR |p|)) (QRPLACD |p| |t|)
(QRPLACD |t| NIL))) (COND ((QSLESSP |n| 3) (RETURN |p|))) (SPADLET |l|
(QSQUOTIENT |n| 2)) (SPADLET |t| |p|) (DO ((#0=#:G1411 (SPADDIFFERENCE |l| 1))
(|i| 1 (QSADD1 |i|))) ((QSGREATERP |i| #0#) NIL) (SEQ (EXIT (SPADLET |t| (QCDR
|t|))))) (SPADLET |q| (CDR |t|)) (QRPLACD |t| NIL) (SPADLET |p| (|mergeSort|
|f| |g| |p| |l|)) (SPADLET |q| (|mergeSort| |f| |g| |q| (QSDIFFERENCE |n|
|l|))) (|mergeInPlace| |f| |g| |p| |q|))))))
;spadThrow() ==
; if $interpOnly and $mapName then
; putHist($mapName,'localModemap, nil, $e)
@@ -1065,7 +1221,6 @@ isDefaultPackageName x == (s := PNAME x).(MAXINDEX s) =
char '_&
;;; *** |spadThrowBrightly| REDEFINED
(DEFUN |spadThrowBrightly| (|x|) (PROGN (|sayBrightly| |x|) (|spadThrow|)))
-;--% Type Formatting Without Abbreviation
;formatUnabbreviatedSig sig ==
; null sig => ["() -> ()"]
; [target,:args] := sig
@@ -1128,12 +1283,11 @@ isDefaultPackageName x == (s := PNAME x).(MAXINDEX s) =
char '_&
;;; *** |sublisNQ,fn| REDEFINED
-(DEFUN |sublisNQ,fn| (|al| |e|) (PROG (|a| |u| |v|) (RETURN (SEQ (IF (ATOM
|e|) (EXIT (SEQ (DO ((#0=#:G2847 |al| (CDR #0#)) (|x| NIL)) ((OR (ATOM #0#)
(PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) (SEQ (EXIT (IF (EQ (CAR |x|) |e|) (EXIT
(RETURN (SPADLET |e| (CDR |x|)))))))) (EXIT |e|)))) (IF (EQ (SPADLET |a| (CAR
|e|)) (QUOTE QUOTE)) (EXIT |e|)) (SPADLET |u| (|sublisNQ,fn| |al| |a|))
(SPADLET |v| (|sublisNQ,fn| |al| (CDR |e|))) (IF (AND (EQ |a| |u|) (EQ (CDR
|e|) |v|)) (EXIT |e|)) (EXIT (CONS |u| |v|))))))
+(DEFUN |sublisNQ,fn| (|al| |e|) (PROG (|a| |u| |v|) (RETURN (SEQ (IF (ATOM
|e|) (EXIT (SEQ (DO ((#0=#:G1412 |al| (CDR #0#)) (|x| NIL)) ((OR (ATOM #0#)
(PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) (SEQ (EXIT (IF (EQ (CAR |x|) |e|) (EXIT
(RETURN (SPADLET |e| (CDR |x|)))))))) (EXIT |e|)))) (IF (EQ (SPADLET |a| (CAR
|e|)) (QUOTE QUOTE)) (EXIT |e|)) (SPADLET |u| (|sublisNQ,fn| |al| |a|))
(SPADLET |v| (|sublisNQ,fn| |al| (CDR |e|))) (IF (AND (EQ |a| |u|) (EQ (CDR
|e|) |v|)) (EXIT |e|)) (EXIT (CONS |u| |v|))))))
;;; *** |sublisNQ| REDEFINED
(DEFUN |sublisNQ| (|al| |e|) (COND ((ATOM |al|) |e|) ((QUOTE T) (|sublisNQ,fn|
|al| |e|))))
-;-- function for turning strings in tex format
;str2Outform s ==
; parse := ncParseFromString s or systemError '"String for TeX will not parse"
; parse2Outform parse
@@ -1151,7 +1305,7 @@ isDefaultPackageName x == (s := PNAME x).(MAXINDEX s) =
char '_&
;;; *** |parse2Outform| REDEFINED
-(DEFUN |parse2Outform| (|x|) (PROG (|op| |argl| |nargl| |ISTMP#1| BRACKET |r|)
(RETURN (SEQ (COND ((AND (PAIRP |x|) (PROGN (SPADLET |op| (QCAR |x|)) (SPADLET
|argl| (QCDR |x|)) (QUOTE T))) (SPADLET |nargl| (PROG (#0=#:G2887) (SPADLET #0#
NIL) (RETURN (DO ((#1=#:G2892 |argl| (CDR #1#)) (|y| NIL)) ((OR (ATOM #1#)
(PROGN (SETQ |y| (CAR #1#)) NIL)) (NREVERSE0 #0#)) (SEQ (EXIT (SETQ #0# (CONS
(|parse2Outform| |y|) #0#)))))))) (COND ((BOOT-EQUAL |op| (QUOTE |construct|))
(CONS (QUOTE BRACKET) (CONS (CONS (QUOTE ARGLST) (PROG (#2=#:G2902) (SPADLET
#2# NIL) (RETURN (DO ((#3=#:G2907 |argl| (CDR #3#)) (|y| NIL)) ((OR (ATOM #3#)
(PROGN (SETQ |y| (CAR #3#)) NIL)) (NREVERSE0 #2#)) (SEQ (EXIT (SETQ #2# (CONS
(|parse2Outform| |y|) #2#)))))))) NIL))) ((AND (BOOT-EQUAL |op| (QUOTE
|brace|)) (PAIRP |nargl|) (EQ (QCDR |nargl|) NIL) (PROGN (SPADLET |ISTMP#1|
(QCAR |nargl|)) (AND (PAIRP |ISTMP#1|) (PROGN (SPADLET BRACKET (QCAR
|ISTMP#1|)) (SPADLET |r| (QCDR |ISTMP#1|)) (QUOTE T))))) (CONS (QUOT!
E BRACE) |r|)) ((QUOTE T) (CONS |op| |nargl|)))) ((QUOTE T) |x|))))))
+(DEFUN |parse2Outform| (|x|) (PROG (|op| |argl| |nargl| |ISTMP#1| BRACKET |r|)
(RETURN (SEQ (COND ((AND (PAIRP |x|) (PROGN (SPADLET |op| (QCAR |x|)) (SPADLET
|argl| (QCDR |x|)) (QUOTE T))) (SPADLET |nargl| (PROG (#0=#:G1413) (SPADLET #0#
NIL) (RETURN (DO ((#1=#:G1414 |argl| (CDR #1#)) (|y| NIL)) ((OR (ATOM #1#)
(PROGN (SETQ |y| (CAR #1#)) NIL)) (NREVERSE0 #0#)) (SEQ (EXIT (SETQ #0# (CONS
(|parse2Outform| |y|) #0#)))))))) (COND ((BOOT-EQUAL |op| (QUOTE |construct|))
(CONS (QUOTE BRACKET) (CONS (CONS (QUOTE ARGLST) (PROG (#2=#:G1415) (SPADLET
#2# NIL) (RETURN (DO ((#3=#:G1416 |argl| (CDR #3#)) (|y| NIL)) ((OR (ATOM #3#)
(PROGN (SETQ |y| (CAR #3#)) NIL)) (NREVERSE0 #2#)) (SEQ (EXIT (SETQ #2# (CONS
(|parse2Outform| |y|) #2#)))))))) NIL))) ((AND (BOOT-EQUAL |op| (QUOTE
|brace|)) (PAIRP |nargl|) (EQ (QCDR |nargl|) NIL) (PROGN (SPADLET |ISTMP#1|
(QCAR |nargl|)) (AND (PAIRP |ISTMP#1|) (PROGN (SPADLET BRACKET (QCAR
|ISTMP#1|)) (SPADLET |r| (QCDR |ISTMP#1|)) (QUOTE T))))) (CONS (QUOT!
E BRACE) |r|)) ((QUOTE T) (CONS |op| |nargl|)))) ((QUOTE T) |x|))))))
;str2Tex s ==
; outf := str2Outform s
; val := coerceInt(mkObj(wrap outf, '(OutputForm)), '(TexFormat))
@@ -1194,7 +1348,7 @@ isDefaultPackageName x == (s := PNAME x).(MAXINDEX s) =
char '_&
;;; *** |searchCurrentEnv| REDEFINED
-(DEFUN |searchCurrentEnv| (|x| |currentEnv|) (PROG (|u| |signal|) (RETURN (SEQ
(PROGN (DO ((#0=#:G2958 |currentEnv| (CDR #0#)) (|contour| NIL)) ((OR (ATOM
#0#) (PROGN (SETQ |contour| (CAR #0#)) NIL)) NIL) (SEQ (EXIT (COND ((SPADLET
|u| (ASSQ |x| |contour|)) (RETURN (SPADLET |signal| |u|))) ((QUOTE T) NIL)))))
(KDR |signal|))))))
+(DEFUN |searchCurrentEnv| (|x| |currentEnv|) (PROG (|u| |signal|) (RETURN (SEQ
(PROGN (DO ((#0=#:G1417 |currentEnv| (CDR #0#)) (|contour| NIL)) ((OR (ATOM
#0#) (PROGN (SETQ |contour| (CAR #0#)) NIL)) NIL) (SEQ (EXIT (COND ((SPADLET
|u| (ASSQ |x| |contour|)) (RETURN (SPADLET |signal| |u|))) ((QUOTE T) NIL)))))
(KDR |signal|))))))
;searchTailEnv(x,e) ==
; for env in e repeat
; signal:=
@@ -1205,7 +1359,7 @@ isDefaultPackageName x == (s := PNAME x).(MAXINDEX s) =
char '_&
;;; *** |searchTailEnv| REDEFINED
-(DEFUN |searchTailEnv| (|x| |e|) (PROG (|u| |signal|) (RETURN (SEQ (PROGN (DO
((#0=#:G2976 |e| (CDR #0#)) (|env| NIL)) ((OR (ATOM #0#) (PROGN (SETQ |env|
(CAR #0#)) NIL)) NIL) (SEQ (EXIT (SPADLET |signal| (PROGN (DO ((#1=#:G2985
|env| (CDR #1#)) (|contour| NIL)) ((OR (ATOM #1#) (PROGN (SETQ |contour| (CAR
#1#)) NIL)) NIL) (SEQ (EXIT (COND ((AND (SPADLET |u| (ASSQ |x| |contour|))
(ASSQ (QUOTE FLUID) |u|)) (RETURN (SPADLET |signal| |u|))) ((QUOTE T) NIL)))))
(COND (|signal| (RETURN |signal|)) ((QUOTE T) NIL))))))) (KDR |signal|))))))
+(DEFUN |searchTailEnv| (|x| |e|) (PROG (|u| |signal|) (RETURN (SEQ (PROGN (DO
((#0=#:G1418 |e| (CDR #0#)) (|env| NIL)) ((OR (ATOM #0#) (PROGN (SETQ |env|
(CAR #0#)) NIL)) NIL) (SEQ (EXIT (SPADLET |signal| (PROGN (DO ((#1=#:G1419
|env| (CDR #1#)) (|contour| NIL)) ((OR (ATOM #1#) (PROGN (SETQ |contour| (CAR
#1#)) NIL)) NIL) (SEQ (EXIT (COND ((AND (SPADLET |u| (ASSQ |x| |contour|))
(ASSQ (QUOTE FLUID) |u|)) (RETURN (SPADLET |signal| |u|))) ((QUOTE T) NIL)))))
(COND (|signal| (RETURN |signal|)) ((QUOTE T) NIL))))))) (KDR |signal|))))))
;augProplist(proplist,prop,val) ==
; $InteractiveMode => augProplistInteractive(proplist,prop,val)
; while (proplist is [[ =prop,:.],:proplist']) repeat proplist:= proplist'
@@ -1235,8 +1389,14 @@ isDefaultPackageName x == (s := PNAME x).(MAXINDEX s) =
char '_&
;;; *** |semchkProplist| REDEFINED
(DEFUN |semchkProplist| (|x| |proplist| |prop| |val|) (SEQ (COND ((BOOT-EQUAL
|prop| (QUOTE |isLiteral|)) (COND ((OR (LASSOC (QUOTE |value|) |proplist|)
(LASSOC (QUOTE |mode|) |proplist|)) (EXIT (|warnLiteral| |x|))))) ((MEMQ |prop|
(QUOTE (|mode| |value|))) (COND ((LASSOC (QUOTE |isLiteral|) |proplist|) (EXIT
(|warnLiteral| |x|))))))))
+;DEFPARAMETER($envHashTable,nil)
+
+(DEFPARAMETER |$envHashTable| NIL)
;addBinding(var,proplist,e is [[curContour,:tailContour],:tailEnv]) ==
; EQ(proplist,getProplist(var,e)) => e
+; if $envHashTable then
+; for u in proplist repeat
+; HPUT($envHashTable,[var, CAR u],true)
; $InteractiveMode => addBindingInteractive(var,proplist,e)
; if curContour is [[ =var,:.],:.] then curContour:= rest curContour
; --Previous line should save some space
@@ -1244,7 +1404,7 @@ isDefaultPackageName x == (s := PNAME x).(MAXINDEX s) =
char '_&
;;; *** |addBinding| REDEFINED
-(DEFUN |addBinding| (|var| |proplist| |e|) (PROG (|tailContour| |tailEnv|
|ISTMP#1| |curContour| |lx|) (RETURN (PROGN (SPADLET |curContour| (CAAR |e|))
(SPADLET |tailContour| (CDAR |e|)) (SPADLET |tailEnv| (CDR |e|)) (COND ((EQ
|proplist| (|getProplist| |var| |e|)) |e|) (|$InteractiveMode|
(|addBindingInteractive| |var| |proplist| |e|)) ((QUOTE T) (COND ((AND (PAIRP
|curContour|) (PROGN (SPADLET |ISTMP#1| (QCAR |curContour|)) (AND (PAIRP
|ISTMP#1|) (EQUAL (QCAR |ISTMP#1|) |var|)))) (SPADLET |curContour| (CDR
|curContour|)))) (SPADLET |lx| (CONS |var| |proplist|)) (CONS (CONS (CONS |lx|
|curContour|) |tailContour|) |tailEnv|)))))))
+(DEFUN |addBinding| (|var| |proplist| |e|) (PROG (|tailContour| |tailEnv|
|ISTMP#1| |curContour| |lx|) (RETURN (SEQ (PROGN (SPADLET |curContour| (CAAR
|e|)) (SPADLET |tailContour| (CDAR |e|)) (SPADLET |tailEnv| (CDR |e|)) (COND
((EQ |proplist| (|getProplist| |var| |e|)) |e|) ((QUOTE T) (COND
(|$envHashTable| (DO ((#0=#:G1420 |proplist| (CDR #0#)) (|u| NIL)) ((OR (ATOM
#0#) (PROGN (SETQ |u| (CAR #0#)) NIL)) NIL) (SEQ (EXIT (HPUT |$envHashTable|
(CONS |var| (CONS (CAR |u|) NIL)) (QUOTE T))))))) (COND (|$InteractiveMode|
(|addBindingInteractive| |var| |proplist| |e|)) ((QUOTE T) (COND ((AND (PAIRP
|curContour|) (PROGN (SPADLET |ISTMP#1| (QCAR |curContour|)) (AND (PAIRP
|ISTMP#1|) (EQUAL (QCAR |ISTMP#1|) |var|)))) (SPADLET |curContour| (CDR
|curContour|)))) (SPADLET |lx| (CONS |var| |proplist|)) (CONS (CONS (CONS |lx|
|curContour|) |tailContour|) |tailEnv|))))))))))
;position(x,l) ==
; posn(x,l,0) where
; posn(x,l,n) ==
@@ -1273,7 +1433,7 @@ isDefaultPackageName x == (s := PNAME x).(MAXINDEX s) =
char '_&
;;; *** |after| REDEFINED
-(DEFUN |after| (|u| |v|) (PROG (|r|) (RETURN (SEQ (PROGN (SPADLET |r| |u|) (DO
((#0=#:G3068 |u| (CDR #0#)) (|x| NIL) (#1=#:G3069 |v| (CDR #1#)) (|y| NIL))
((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL) (ATOM #1#) (PROGN (SETQ |y|
(CAR #1#)) NIL)) NIL) (SEQ (EXIT (SPADLET |r| (CDR |r|))))) |r|)))))
+(DEFUN |after| (|u| |v|) (PROG (|r|) (RETURN (SEQ (PROGN (SPADLET |r| |u|) (DO
((#0=#:G1421 |u| (CDR #0#)) (|x| NIL) (#1=#:G1422 |v| (CDR #1#)) (|y| NIL))
((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL) (ATOM #1#) (PROGN (SETQ |y|
(CAR #1#)) NIL)) NIL) (SEQ (EXIT (SPADLET |r| (CDR |r|))))) |r|)))))
;$blank := char ('_ )
(SPADLET |$blank| (|char| (QUOTE | |)))
@@ -1304,7 +1464,7 @@ isDefaultPackageName x == (s := PNAME x).(MAXINDEX s) =
char '_&
;;; *** |rightTrim| REDEFINED
-(DEFUN |rightTrim| (|s|) (PROG (|k| |j|) (RETURN (SEQ (PROGN (SPADLET |k|
(MAXINDEX |s|)) (COND ((MINUSP |k|) |s|) ((BOOT-EQUAL (ELT |s| |k|) |$blank|)
(DO ((#0=#:G3107 (SPADDIFFERENCE 1)) (|i| |k| (+ |i| #0#))) ((OR (IF (MINUSP
#0#) (< |i| 0) (> |i| 0)) (NULL (BOOT-EQUAL (ELT |s| |i|) |$blank|))) NIL) (SEQ
(EXIT (SPADLET |j| |i|)))) (SUBSTRING |s| 0 |j|)) ((QUOTE T) |s|)))))))
+(DEFUN |rightTrim| (|s|) (PROG (|k| |j|) (RETURN (SEQ (PROGN (SPADLET |k|
(MAXINDEX |s|)) (COND ((MINUSP |k|) |s|) ((BOOT-EQUAL (ELT |s| |k|) |$blank|)
(DO ((#0=#:G1423 (SPADDIFFERENCE 1)) (|i| |k| (+ |i| #0#))) ((OR (IF (MINUSP
#0#) (< |i| 0) (> |i| 0)) (NULL (BOOT-EQUAL (ELT |s| |i|) |$blank|))) NIL) (SEQ
(EXIT (SPADLET |j| |i|)))) (SUBSTRING |s| 0 |j|)) ((QUOTE T) |s|)))))))
;pp x ==
; PRETTYPRINT x
; x
@@ -1347,12 +1507,12 @@ isDefaultPackageName x == (s := PNAME x).(MAXINDEX s) =
char '_&
(DEFUN |intern| (|x|) (COND ((STRINGP |x|) (COND ((DIGITP (ELT |x| 0))
(|string2Integer| |x|)) ((QUOTE T) (INTERN |x|)))) ((QUOTE T) |x|)))
;isDomain a ==
-; REFVECP a and #a>5 and GETDATABASE(a.0,'CONSTRUCTORKIND) = 'domain
+; PAIRP a and VECP(CAR a) and
+; MEMBER(CAR(a).0, $domainTypeTokens)
;;; *** |isDomain| REDEFINED
-(DEFUN |isDomain| (|a|) (AND (REFVECP |a|) (> (|#| |a|) 5) (BOOT-EQUAL
(GETDATABASE (ELT |a| 0) (QUOTE CONSTRUCTORKIND)) (QUOTE |domain|))))
-;-- variables used by browser
+(DEFUN |isDomain| (|a|) (AND (PAIRP |a|) (VECP (CAR |a|)) (|member| (ELT (CAR
|a|) 0) |$domainTypeTokens|)))
;$htHash := MAKE_-HASH_-TABLE()
(SPADLET |$htHash| (MAKE-HASH-TABLE))
@@ -1501,6 +1661,40 @@ isDefaultPackageName x == (s := PNAME x).(MAXINDEX s) =
char '_&
;;;Boot translation finished for g-util.boot
@
+\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.
+
+@
\eject
\begin{thebibliography}{99}
\bibitem{1} nothing
diff --git a/src/interp/i-intern.boot.pamphlet
b/src/interp/i-intern.boot.pamphlet
index 144aa0e..7520954 100644
--- a/src/interp/i-intern.boot.pamphlet
+++ b/src/interp/i-intern.boot.pamphlet
@@ -9,9 +9,7 @@
\eject
\tableofcontents
\eject
-\begin{verbatim}
-Internal Interpreter Facilities
-
+\section{Internal Interpreter Facilities}
Vectorized Attributed Trees
The interpreter translates parse forms into vats for analysis.
@@ -19,82 +17,65 @@ These contain a number of slots in each node for
information.
The leaves are now all vectors, though the leaves for basic types
such as integers and strings used to just be the objects themselves.
The vectors for the leaves with such constants now have the value
-of $immediateDataSymbol as their name. Their are undoubtably still
+of \verb|$immediateDataSymbol| as their name. Their are undoubtably still
some functions that still check whether a leaf is a constant. Note
that if it is not a vector it is a subtree.
attributed tree nodes have the following form:
-slot description
----- -----------------------------------------------------
- 0 operation name or literal
- 1 declared mode of variable
- 2 computed value of subtree from this node
- 3 modeset: list of single computed mode of subtree
- 4 prop list for extra things
-
-\end{verbatim}
-\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.
-@
+\begin{tabular}{cl}
+slot & description\\
+---- & ------------------------- \\
+ 0 & operation name or literal\\
+ 1 & declared mode of variable\\
+ 2 & computed value of subtree from this node\\
+ 3 & modeset: list of single computed mode of subtree\\
+ 4 & prop list for extra things\\
+\end{tabular}
<<*>>=
-<<license>>
SETANDFILEQ($useParserSrcPos, NIL)
SETANDFILEQ($transferParserSrcPos, NIL)
--- Making Trees
-
+@
+\section{Making trees}
+\subsection{mkAtreeNode}
+<<*>>=
mkAtreeNode x ==
-- maker of attrib tree node
v := MAKE_-VEC 5
v.0 := x
v
+@
+\subsection{mkAtree}
+Maker of attrib tree from parser form
+<<*>>=
mkAtree x ==
- -- maker of attrib tree from parser form
mkAtree1 mkAtreeExpandMacros x
+@
+\subsection{mkAtreeWithSrcPos}
+<<*>>=
mkAtreeWithSrcPos(form, posnForm) ==
posnForm and $useParserSrcPos => pf2Atree(posnForm)
transferSrcPosInfo(posnForm, mkAtree form)
+@
+\subsection{mkAtree1WithSrcPos}
+<<*>>=
mkAtree1WithSrcPos(form, posnForm) ==
transferSrcPosInfo(posnForm, mkAtree1 form)
+@
+\subsection{mkAtreeNodeWithSrcPos}
+<<*>>=
mkAtreeNodeWithSrcPos(form, posnForm) ==
transferSrcPosInfo(posnForm, mkAtreeNode form)
+@
+\subsection{transferSrcPosInfo}
+<<*>>=
transferSrcPosInfo(pf, atree) ==
not (pf and $transferParserSrcPos) => atree
pos := pfPosOrNopos(pf)
@@ -108,9 +89,12 @@ transferSrcPosInfo(pf, atree) ==
putSrcPos(atree, fn, pfSourceText(pf), pfLinePosn(pos), pfCharPosn(pos))
atree
+@
+\subsection{mkAtreeExpandMacros}
+Handle macro expansion. if the macros have args we require that
+we match the correct number of args
+<<*>>=
mkAtreeExpandMacros x ==
- -- handle macro expansion. if the macros have args we require that
- -- we match the correct number of args
if x isnt ['MDEF,:.] and x isnt ['DEF,['macro,:.],:.] then
atom x and (m := isInterpMacro x) =>
[args,:body] := m
@@ -134,6 +118,9 @@ mkAtreeExpandMacros x ==
x := [mkAtreeExpandMacros op,:argl]
x
+@
+\subsection{mkAtree1}
+<<*>>=
mkAtree1 x ==
-- first special handler for making attrib tree
null x => throwKeyedMsg("S2IP0005",['"NIL"])
@@ -156,8 +143,10 @@ mkAtree1 x ==
x is [op,:argl] => mkAtree2(x,op,argl)
systemErrorHere '"mkAtree1"
--- mkAtree2 and mkAtree3 were created because mkAtree1 got so big
-
+@
+\subsection{mkAtree2}
+mkAtree2 and mkAtree3 were created because mkAtree1 got so big
+<<*>>=
mkAtree2(x,op,argl) ==
nargl := #argl
(op= '_-) and (nargl = 1) and (INTEGERP CAR argl) =>
@@ -227,6 +216,10 @@ mkAtree2(x,op,argl) ==
'"not qualifying an operator"])
mkAtree3(x,op,argl)
+@
+\subsection{mkAtree3}
+mkAtree2 and mkAtree3 were created because mkAtree1 got so big
+<<*>>=
mkAtree3(x,op,argl) ==
op='REDUCE and argl is [op1,axis,body] =>
[mkAtreeNode op,axis,mkAtree1 op1,mkAtree1 body]
@@ -314,12 +307,17 @@ mkAtree3(x,op,argl) ==
mkAtree1 op
[z,:[mkAtree1 y for y in argl]]
+@
+\subsection{collectDefTypesAndPreds}
+Given an arglist to a DEF-like form, this function returns
+a vector of three things:
+\begin{itemize}
+\item slot 0: just the variables
+\item slot 1: the type declarations on the variables
+\item slot 2: a predicate for all arguments
+\end{itemize}
+<<*>>=
collectDefTypesAndPreds args ==
- -- given an arglist to a DEF-like form, this function returns
- -- a vector of three things:
- -- slot 0: just the variables
- -- slot 1: the type declarations on the variables
- -- slot 2: a predicate for all arguments
pred := types := vars := NIL
junk :=
IDENTP args =>
@@ -357,11 +355,17 @@ collectDefTypesAndPreds args ==
vars := [args]
VECTOR(vars,types,pred)
+@
+\subsection{mkAtreeValueOf}
+<<*>>=
mkAtreeValueOf l ==
-- scans for ['valueOf,atom]
not CONTAINED('valueOf,l) => l
mkAtreeValueOf1 l
+@
+\subsection{mkAtreeValueOf1}
+<<*>>=
mkAtreeValueOf1 l ==
null l or atom l or null rest l => l
l is ['valueOf,u] and IDENTP u =>
@@ -371,10 +375,16 @@ mkAtreeValueOf1 l ==
v
[mkAtreeValueOf1 x for x in l]
+@
+\subsection{mkLessOrEqual}
+<<*>>=
mkLessOrEqual(lhs,rhs) == ['not,['_<,rhs,lhs]]
+@
+\subsection{emptyAtree}
+Remove mode, value, and misc. info from attrib tree
+<<*>>=
emptyAtree expr ==
- -- remove mode, value, and misc. info from attrib tree
VECP expr =>
$immediateDataSymbol = expr.0 => nil
expr.1:= NIL
@@ -384,8 +394,11 @@ emptyAtree expr ==
atom expr => nil
for e in expr repeat emptyAtree e
+@
+\subsection{unVectorize}
+Transforms from an atree back into a tree
+<<*>>=
unVectorize body ==
- -- transforms from an atree back into a tree
VECP body =>
name := getUnname body
name ^= $immediateDataSymbol => name
@@ -399,9 +412,10 @@ unVectorize body ==
[newOp,:unVectorize argl]
systemErrorHere '"unVectorize"
-
--- Stuffing and Getting Info
-
+@
+\section{Stuffing and Getting Info}
+\subsection{putAtree}
+<<*>>=
putAtree(x,prop,val) ==
x is [op,:.] =>
-- only willing to add property if op is a vector
@@ -414,6 +428,9 @@ putAtree(x,prop,val) ==
x.4 := insertShortAlist(prop,val,x.4)
x
+@
+\subsection{getAtree}
+<<*>>=
getAtree(x,prop) ==
x is [op,:.] =>
-- only willing to get property if op is a vector
@@ -425,19 +442,31 @@ getAtree(x,prop) ==
=> x.n
QLASSQ(prop,x.4)
+@
+\subsection{putTarget}
+<<*>>=
putTarget(x, targ) ==
-- want to put nil modes perhaps to clear old target
if targ = $EmptyMode then targ := nil
putAtree(x,'target,targ)
+@
+\subsection{getTarget}
+<<*>>=
getTarget(x) == getAtree(x,'target)
+@
+\subsection{insertShortAlist}
+<<*>>=
insertShortAlist(prop,val,al) ==
pair := QASSQ(prop,al) =>
RPLACD(pair,val)
al
[[prop,:val],:al]
+@
+\subsection{transferPropsToNode}
+<<*>>=
transferPropsToNode(x,t) ==
propList := getProplist(x,$env)
QLASSQ('Led,propList) or QLASSQ('Nud,propList) => nil
@@ -456,19 +485,32 @@ transferPropsToNode(x,t) ==
putMode(t,am)
t
-isLeaf x == atom x --may be a number or a vector
+@
+\subsection{isLeaf}
+May be a number or a vector
+<<*>>=
+isLeaf x == atom x
+@
+\subsection{getMode}
+<<*>>=
getMode x ==
x is [op,:.] => getMode op
VECP x => x.1
m := getBasicMode x => m
keyedSystemError("S2II0001",[x])
+@
+\subsection{putMode}
+<<*>>=
putMode(x,y) ==
x is [op,:.] => putMode(op,y)
null VECP x => keyedSystemError("S2II0001",[x])
x.1 := y
+@
+\subsection{getValue}
+<<*>>=
getValue x ==
VECP x => x.2
atom x =>
@@ -476,40 +518,64 @@ getValue x ==
keyedSystemError("S2II0001",[x])
getValue first x
+@
+\subsection{putValue}
+<<*>>=
putValue(x,y) ==
x is [op,:.] => putValue(op,y)
null VECP x => keyedSystemError("S2II0001",[x])
x.2 := y
+@
+\subsection{putValueValue}
+<<*>>=
putValueValue(vec,val) ==
putValue(vec,val)
vec
+@
+\subsection{getUnnameIfCan}
+<<*>>=
getUnnameIfCan x ==
VECP x => x.0
x is [op,:.] => getUnnameIfCan op
atom x => x
nil
+@
+\subsection{getUnname}
+<<*>>=
getUnname x ==
x is [op,:.] => getUnname op
getUnname1 x
+@
+\subsection{getUnname1}
+<<*>>=
getUnname1 x ==
VECP x => x.0
null atom x => keyedSystemError("S2II0001",[x])
x
+@
+\subsection{computedMode}
+<<*>>=
computedMode t ==
getModeSet t is [m] => m
keyedSystemError("S2GE0016",['"computedMode",'"non-singleton modeset"])
+@
+\subsection{putModeSet}
+<<*>>=
putModeSet(x,y) ==
x is [op,:.] => putModeSet(op,y)
not VECP x => keyedSystemError("S2II0001",[x])
x.3 := y
y
+@
+\subsection{getModeOrFirstModeSetIfThere}
+<<*>>=
getModeOrFirstModeSetIfThere x ==
x is [op,:.] => getModeOrFirstModeSetIfThere op
VECP x =>
@@ -522,6 +588,9 @@ getModeOrFirstModeSetIfThere x ==
m := getBasicMode x => m
NIL
+@
+\subsection{getModeSet}
+<<*>>=
getModeSet x ==
x and PAIRP x => getModeSet first x
VECP x =>
@@ -535,6 +604,9 @@ getModeSet x ==
keyedSystemError("S2GE0016",['"getModeSet",
'"not an attributed tree"])
+@
+\subsection{getModeSetUseSubdomain}
+<<*>>=
getModeSetUseSubdomain x ==
x and PAIRP x => getModeSetUseSubdomain first x
VECP(x) =>
@@ -562,8 +634,14 @@ getModeSetUseSubdomain x ==
keyedSystemError("S2GE0016",
['"getModeSetUseSubomain",'"not an attributed tree"])
+@
+\subsection{atree2EvaluatedTree}
+<<*>>=
atree2EvaluatedTree x == atree2Tree1(x,true)
+@
+\subsection{atree2Tree1}
+<<*>>=
atree2Tree1(x,evalIfTrue) ==
(triple := getValue x) and objMode(triple) ^= $EmptyMode =>
coerceOrCroak(triple,$OutputForm,$mapName)
@@ -572,12 +650,10 @@ atree2Tree1(x,evalIfTrue) ==
x
[atree2Tree1(y,evalIfTrue) for y in x]
---% Environment Utilities
-
--- getValueFromEnvironment(x,mode) ==
--- $failure ^= (v := getValueFromSpecificEnvironment(x,mode,$env)) => v
--- $failure ^= (v := getValueFromSpecificEnvironment(x,mode,$e)) => v
--- throwKeyedMsg("S2IE0001",[x])
+@
+\section{Environment Utilities}
+\subsection{getValueFromEnvironment}
+<<*>>=
getValueFromEnvironment(x,mode) ==
$failure ^= (v := getValueFromSpecificEnvironment(x,mode,$env)) => v
$failure ^= (v := getValueFromSpecificEnvironment(x,mode,$e)) => v
@@ -585,6 +661,9 @@ getValueFromEnvironment(x,mode) ==
throwKeyedMsg("S2IE0001",[x])
objValUnwrap v
+@
+\subsection{getValueFromSpecificEnvironment}
+<<*>>=
getValueFromSpecificEnvironment(id,mode,e) ==
PAIRP e =>
u := get(id,'value,e) =>
@@ -610,6 +689,9 @@ getValueFromSpecificEnvironment(id,mode,e) ==
$failure
$failure
+@
+\subsection{addBindingInteractive}
+<<*>>=
addBindingInteractive(var,proplist,e is [[curContour,:.],:.]) ==
-- change proplist of var in e destructively
u := ASSQ(var,curContour) =>
@@ -618,21 +700,36 @@ addBindingInteractive(var,proplist,e is
[[curContour,:.],:.]) ==
RPLAC(CAAR e,[[var,:proplist],:curContour])
e
+@
+\subsection{augProplistInteractive}
+<<*>>=
augProplistInteractive(proplist,prop,val) ==
u := ASSQ(prop,proplist) =>
RPLACD(u,val)
proplist
[[prop,:val],:proplist]
+@
+\subsection{getFlag}
+<<*>>=
getFlag x == get("--flags--",x,$e)
+@
+\subsection{putFlag}
+<<*>>=
putFlag(flag,value) ==
$e := put ("--flags--", flag, value, $e)
+@
+\subsection{get}
+<<*>>=
get(x,prop,e) ==
$InteractiveMode => get0(x,prop,e)
get1(x,prop,e)
+@
+\subsection{get0}
+<<*>>=
get0(x,prop,e) ==
null atom x => get(QCAR x,prop,e)
u:= QLASSQ(x,CAR QCAR e) => QLASSQ(prop,u)
@@ -640,6 +737,9 @@ get0(x,prop,e) ==
QLASSQ(prop,u)
nil
+@
+\subsection{get1}
+<<*>>=
get1(x,prop,e) ==
--this is the old get
null atom x => get(QCAR x,prop,e)
@@ -648,21 +748,39 @@ get1(x,prop,e) ==
or get2(x,prop,e)
LASSOC(prop,getProplist(x,e)) or get2(x,prop,e)
+@
+\subsection{get2}
+<<*>>=
get2(x,prop,e) ==
prop="modemap" and constructor? x =>
(u := getConstructorModemap(x)) => [u]
nil
nil
+@
+\subsection{getI}
+<<*>>=
getI(x,prop) == get(x,prop,$InteractiveFrame)
+@
+\subsection{putI}
+<<*>>=
putI(x,prop,val) == ($InteractiveFrame := put(x,prop,val,$InteractiveFrame))
+@
+\subsection{getIProplist}
+<<*>>=
getIProplist x == getProplist(x,$InteractiveFrame)
+@
+\subsection{removeBindingI}
+<<*>>=
removeBindingI x ==
RPLAC(CAAR $InteractiveFrame,deleteAssocWOC(x,CAAR $InteractiveFrame))
+@
+\subsection{rempropI}
+<<*>>=
rempropI(x,prop) ==
id:=
atom x => x
@@ -672,17 +790,26 @@ rempropI(x,prop) ==
recordOldValue(id,prop,getI(id,prop))
$InteractiveFrame:= remprop(id,prop,$InteractiveFrame)
+@
+\subsection{remprop}
+<<*>>=
remprop(x,prop,e) ==
u:= ASSOC(prop,pl:= getProplist(x,e)) =>
e:= addBinding(x,DELASC(first u,pl),e)
e
e
+@
+\subsection{fastSearchCurrentEnv}
+<<*>>=
fastSearchCurrentEnv(x,currentEnv) ==
u:= QLASSQ(x,CAR currentEnv) => u
while (currentEnv:= QCDR currentEnv) repeat
u:= QLASSQ(x,CAR currentEnv) => u
+@
+\subsection{put}
+<<*>>=
put(x,prop,val,e) ==
$InteractiveMode and not EQ(e,$CategoryFrame) =>
putIntSymTab(x,prop,val,e)
@@ -697,6 +824,9 @@ put(x,prop,val,e) ==
e
addBinding(x,newProplist,e)
+@
+\subsection{putIntSymTab}
+<<*>>=
putIntSymTab(x,prop,val,e) ==
null atom x => putIntSymTab(first x,prop,val,e)
pl0 := pl := search(x,e)
@@ -712,6 +842,9 @@ putIntSymTab(x,prop,val,e) ==
EQ(pl0,pl) => e
addIntSymTabBinding(x,pl,e)
+@
+\subsection{addIntSymTabBinding}
+<<*>>=
addIntSymTabBinding(var,proplist,e is [[curContour,:.],:.]) ==
-- change proplist of var in e destructively
u := ASSQ(var,curContour) =>
@@ -720,33 +853,55 @@ addIntSymTabBinding(var,proplist,e is
[[curContour,:.],:.]) ==
RPLAC(CAAR e,[[var,:proplist],:curContour])
e
+@
+\section{Source and position information}
+In the following, src is a string containing an original input line,
+line is the line number of the string within the source file,
+and col is the index within src of the start of the form represented
+by x. x is a VAT.
---% Source and position information
-
--- In the following, src is a string containing an original input line,
--- line is the line number of the string within the source file,
--- and col is the index within src of the start of the form represented
--- by x. x is a VAT.
-
+\subsection{putSrcPos}
+<<*>>=
putSrcPos(x, file, src, line, col) ==
putAtree(x, 'srcAndPos, srcPos_New(file, src, line, col))
+@
+\subsection{getSrcPos}
+<<*>>=
getSrcPos(x) == getAtree(x, 'srcAndPos)
+@
+\subsection{srcPosNew}
+<<*>>=
srcPosNew(file, src, line, col) == LIST2VEC [file, src, line, col]
+@
+\subsection{srcPosFile}
+<<*>>=
srcPosFile(sp) ==
if sp then sp.0 else nil
+@
+\subsection{srcPosSource}
+<<*>>=
srcPosSource(sp) ==
if sp then sp.1 else nil
+@
+\subsection{srcPosLine}
+<<*>>=
srcPosLine(sp) ==
if sp then sp.2 else nil
+@
+\subsection{srcPosColumn}
+<<*>>=
srcPosColumn(sp) ==
if sp then sp.3 else nil
+@
+\subsection{srcPosDisplay}
+<<*>>=
srcPosDisplay(sp) ==
null sp => nil
s := STRCONC('"_"", srcPosFile sp, '"_", line ",
@@ -759,58 +914,163 @@ srcPosDisplay(sp) ==
sayBrightly [fillerSpaces(#s, '" "), dots, '"^"]
true
---% Functions on interpreter objects
-
--- Interpreter objects used to be called triples because they had the
--- structure [value, type, environment]. For many years, the environment
--- was not used, so finally in January, 1990, the structure of objects
--- was changed to be (type . value). This was chosen because it was the
--- structure of objects of type Any. Sometimes the values are wrapped
--- (see the function isWrapped to see what this means physically).
--- Wrapped values are not actual values belonging to their types. An
--- unwrapped value must be evaluated to get an actual value. A wrapped
--- value must be unwrapped before being passed to a library function.
--- Typically, an unwrapped value in the interpreter consists of LISP
--- code, e.g., parts of a function that is being constructed.
--- RSS 1/14/90
-
--- These are the new structure functions.
-
+@
+\section{Functions on interpreter objects}
+Interpreter objects used to be called triples because they had the
+structure [value, type, environment]. For many years, the environment
+was not used, so finally in January, 1990, the structure of objects
+was changed to be (type . value). This was chosen because it was the
+structure of objects of type Any. Sometimes the values are wrapped
+(see the function isWrapped to see what this means physically).
+Wrapped values are not actual values belonging to their types. An
+unwrapped value must be evaluated to get an actual value. A wrapped
+value must be unwrapped before being passed to a library function.
+Typically, an unwrapped value in the interpreter consists of LISP
+code, e.g., parts of a function that is being constructed.
+-- RSS 1/14/90
+
+These are the new structure functions.
+
+\subsection{mkObj}
+<<*>>=
mkObj(val, mode) == CONS(mode,val) -- old names
+
+@
+\subsection{mkObjWrap}
+<<*>>=
mkObjWrap(val, mode) == CONS(mode,wrap val)
+
+@
+\subsection{mkObjCode}
+<<*>>=
mkObjCode(val, mode) == ['CONS, MKQ mode,val ]
+@
+\subsection{objNew}
+<<*>>=
objNew(val, mode) == CONS(mode,val) -- new names as of 10/14/93
+
+@
+\subsection{objNewWrap}
+<<*>>=
objNewWrap(val, mode) == CONS(mode,wrap val)
+
+@
+\subsection{objNewCode}
+<<*>>=
objNewCode(val, mode) == ['CONS, MKQ mode,val ]
+
+@
+\subsection{objSetVal}
+<<*>>=
objSetVal(obj,val) == RPLACD(obj,val)
+
+@
+\subsection{objSetMode}
+<<*>>=
objSetMode(obj,mode) == RPLACA(obj,mode)
+@
+\subsection{objVal}
+<<*>>=
objVal obj == CDR obj
+
+@
+\subsection{objValUnwrap}
+<<*>>=
objValUnwrap obj == unwrap CDR obj
+
+@
+\subsection{objMode}
+<<*>>=
objMode obj == CAR obj
+
+@
+\subsection{objEnv}
+<<*>>=
objEnv obj == $NE
+@
+\subsection{objCodeVal}
+<<*>>=
objCodeVal obj == CADDR obj
-objCodeMode obj == CADR obj
-
+@
+\subsection{objCodeMode}
+<<*>>=
+objCodeMode obj == CADR obj
-
---% Library compiler structures needed by the interpreter
-
--- Tuples and Crosses
-
+@
+\section{Library compiler structures needed by the interpreter}
+Tuples and Crosses
+\subsection{asTupleNew}
+<<*>>=
asTupleNew(size, listOfElts) == CONS(size, LIST2VEC listOfElts)
+
+@
+\subsection{asTupleNew0}
+<<*>>=
asTupleNew0(listOfElts) == CONS(#listOfElts, LIST2VEC listOfElts)
+@
+\subsection{asTupleNewCode}
+<<*>>=
asTupleNewCode(size, listOfElts) == ["asTupleNew", size, ['LIST, :listOfElts]]
+
+@
+\subsection{asTupleNewCode0}
+<<*>>=
asTupleNewCode0(listForm) == ["asTupleNew0", listForm]
+@
+\subsection{asTupleSize}
+<<*>>=
asTupleSize(at) == CAR at
+
+@
+\subsection{asTupleAsVector}
+<<*>>=
asTupleAsVector(at) == CDR at
+
+@
+\subsection{asTupleAsList}
+<<*>>=
asTupleAsList(at) == VEC2LIST asTupleAsVector at
@
+\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.
+
+@
\eject
\begin{thebibliography}{99}
\bibitem{1} nothing
- [Axiom-developer] 20080216.01.wxh.patch (hash tables to speed compiles),
daly <=