diff options
Diffstat (limited to 'src/interp')
| -rw-r--r-- | src/interp/ChangeLog | 18 | ||||
| -rw-r--r-- | src/interp/Makefile.in | 10 | ||||
| -rw-r--r-- | src/interp/Makefile.pamphlet | 16 | ||||
| -rw-r--r-- | src/interp/category.boot.pamphlet | 49 | ||||
| -rw-r--r-- | src/interp/g-util.boot | 22 | ||||
| -rw-r--r-- | src/interp/i-coerce.boot.pamphlet | 13 | ||||
| -rw-r--r-- | src/interp/i-object.boot | 30 | ||||
| -rw-r--r-- | src/interp/i-util.boot.pamphlet | 39 |
8 files changed, 107 insertions, 90 deletions
diff --git a/src/interp/ChangeLog b/src/interp/ChangeLog index 784c6364..874ff605 100644 --- a/src/interp/ChangeLog +++ b/src/interp/ChangeLog @@ -1,3 +1,21 @@ +2007-10-28 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * Makefile.pamphlet (category.$(FASLEXT)): New rule. + (<<category.clisp>>): Remove. + * category.boot.pamphlet: Push into package "BOOT". + Replace ASSOC with assoc throughout. + (mkCategory): Fix syntax. + * i-coerce.boot.pamphlet (stripUnionTags): Move to g-util.boot. + (isTaggeUnion): Likewise. + (getUnionOrRecordTags): Likewise. + * i-util.boot.pamphlet (wrap): Move to i-object.boot. + (isWrapped): Likewise. + (unwrap): Likewise. + (wrapped2Quote): Likewise. + (quote2Wrapped): Likewise. + (removeQuote): Likewise. + (TruthP): Move to g-util.boot. + 2007-10-22 Gabriel Dos Reis <gdr@cs.tamu.edu> * g-util.boot (formatUnabbreviatedSig): Translate '$' to '%' diff --git a/src/interp/Makefile.in b/src/interp/Makefile.in index 9ab363f5..33ed789e 100644 --- a/src/interp/Makefile.in +++ b/src/interp/Makefile.in @@ -451,6 +451,12 @@ format.$(FASLEXT): format.boot macros.$(FASLEXT) match.$(FASLEXT): match.boot sys-macros.$(FASLEXT) $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< +## OpenAxiom's compiler + +category.$(FASLEXT): category.boot g-util.$(FASLEXT) + $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< + + ## Interface with the Aldor compiler. ax.$(FASLEXT): ax.boot as.$(FASLEXT) $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< @@ -652,10 +658,6 @@ br-util.clisp: br-util.boot @ echo 487 making $@ from $< @ echo '(old-boot::boot "br-util.boot")' | ${DEPSYS} -category.clisp: category.boot - @ echo 212 making $@ from $< - @ echo '(old-boot::boot "category.boot")' | ${DEPSYS} - cattable.clisp: cattable.boot @ echo 215 making $@ from $< @ echo '(old-boot::boot "cattable.boot")' | ${DEPSYS} diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index b3bdb548..f6d14df4 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -1083,14 +1083,6 @@ $(axiom_build_texdir)/diagrams.tex: $(axiom_src_docdir)/diagrams.tex $(INSTALL_DATA) $< $@ @ -\subsection{category.boot \cite{58}} - -<<category.clisp>>= -category.clisp: category.boot - @ echo 212 making $@ from $< - @ echo '(old-boot::boot "category.boot")' | ${DEPSYS} -@ - \subsection{cattable.boot \cite{59}} <<cattable.clisp>>= @@ -1609,6 +1601,12 @@ format.$(FASLEXT): format.boot macros.$(FASLEXT) match.$(FASLEXT): match.boot sys-macros.$(FASLEXT) $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< +## OpenAxiom's compiler + +category.$(FASLEXT): category.boot g-util.$(FASLEXT) + $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< + + ## Interface with the Aldor compiler. ax.$(FASLEXT): ax.boot as.$(FASLEXT) $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< @@ -1796,8 +1794,6 @@ boot-pkg.$(FASLEXT): boot-pkg.lisp <<br-util.clisp>> -<<category.clisp>> - <<cattable.clisp>> <<c-doc.clisp>> diff --git a/src/interp/category.boot.pamphlet b/src/interp/category.boot.pamphlet index 0dfa2b45..5da2cc25 100644 --- a/src/interp/category.boot.pamphlet +++ b/src/interp/category.boot.pamphlet @@ -32,21 +32,21 @@ mkCategory(domainOrPackage,sigList,attList,domList,PrincipalAncestor) == 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:= union(NewLocals,Prepare CADAR s) where + Prepare u == "union"/[Prepare2 v for v in u] + 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] OldLocals:= nil if PrincipalAncestor then for u in (OldLocals:= CADDR PrincipalAncestor.4) repeat NewLocals:= delete(first u,NewLocals) @@ -163,6 +163,9 @@ copy. @ <<*>>= <<license>> + +import '"g-util" +)package "BOOT" -- Functions for building categories @@ -225,7 +228,7 @@ SigListUnion(extra,original) == not MachineLevelSubsume(QCAR e,QCAR x) => --systemError '"Source level subsumption not implemented" original:= [e,:original] - return() -- this exits from the innermost for loop + return nil -- this exits from the innermost for loop original:= delete(x,original) [xsig,xpred,:ximplem]:= x -- if xsig ^= esig then -- not quite strong enough @@ -359,8 +362,8 @@ SourceLevelSubset(a,b) == $noSubsumption=true => false b is ["Union",:blist] and member(a,blist) => true BOUNDP '$noSubsets and $noSubsets => false - atom b and ASSOC(a,GETL(b,"Subsets")) => true - a is [a1] and b is [b1] and ASSOC(a1,GETL(b1,"Subsets")) => true + atom b and assoc(a,GETL(b,"Subsets")) => true + a is [a1] and b is [b1] and assoc(a1,GETL(b1,"Subsets")) => true nil MachineLevelSubsume([name1,[out1,:in1],:flag1],[name2,[out2,:in2],:flag2]) == @@ -377,8 +380,8 @@ MachineLevelSubset(a,b) == b is ["Union",:blist] and member(a,blist) and (and/[STRINGP x for x in blist | x^=a]) => true --all other branches must be distinct objects - atom b and ASSOC(a,GETL(b,"Subsets")) => true - a is [a1] and b is [b1] and ASSOC(a1,GETL(b1,"Subsets")) => true + atom b and assoc(a,GETL(b,"Subsets")) => true + a is [a1] and b is [b1] and assoc(a1,GETL(b1,"Subsets")) => true --we assume all subsets are true at the machine level nil @@ -444,7 +447,7 @@ DescendantP(a,b) == a is ["SIGNATURE",:.] => nil a:= CatEval a b is ["ATTRIBUTE",b'] => - (l:=ASSOC(b',a.2)) => TruthP CADR l + (l:=assoc(b',a.2)) => TruthP CADR l member(b,first a.4) => true AncestorP(b,[first u for u in CADR a.4]) => true nil @@ -501,7 +504,7 @@ JoinInner(l,$e) == bname:= b.(0) CondAncestorP(bname,FundamentalAncestors,condition) => nil (f:=AncestorP(bname,[first u for u in FundamentalAncestors])) => - [.,.,index]:=ASSOC(f,FundamentalAncestors) + [.,.,index]:=assoc(f,FundamentalAncestors) FundamentalAncestors:=[[bname,condition,index],:FundamentalAncestors] PrinAncb:= first (CatEval bname).(4) --Principal Ancestors of b @@ -577,7 +580,7 @@ JoinInner(l,$e) == for b in CondList repeat newpred:= first rest b for u in (first b).2 repeat - v:= ASSOC(first u,attl) + v:= assoc(first u,attl) null v => attl:= CADR u=true => [[first u,newpred],:attl] diff --git a/src/interp/g-util.boot b/src/interp/g-util.boot index 5908287c..128e683b 100644 --- a/src/interp/g-util.boot +++ b/src/interp/g-util.boot @@ -51,6 +51,28 @@ PPtoFile(x, fname) == -- Convert an arbitrary lisp object to canonical boolean. bool x == NULL NULL x + +TruthP x == + --True if x is a predicate that's always true + x is nil => nil + x=true => true + x is ['QUOTE,:.] => true + nil + +--% Record and Union utils. + +stripUnionTags doms == + [if dom is [":",.,dom'] then dom' else dom for dom in doms] + +isTaggedUnion u == + u is ['Union,:tl] and tl and first tl is [":",.,.] and true + +getUnionOrRecordTags u == + tags := nil + if u is ['Union, :tl] or u is ['Record, :tl] then + for t in tl repeat + if t is [":",tag,.] then tags := cons(tag, tags) + tags --% Various lispy things diff --git a/src/interp/i-coerce.boot.pamphlet b/src/interp/i-coerce.boot.pamphlet index a3bc0760..ff43961f 100644 --- a/src/interp/i-coerce.boot.pamphlet +++ b/src/interp/i-coerce.boot.pamphlet @@ -1034,19 +1034,6 @@ coerceIntAlgebraicConstant(object,t2) == objNewWrap(getConstantFromDomain('(Zero),t2),t2) NIL -stripUnionTags doms == - [if dom is [":",.,dom'] then dom' else dom for dom in doms] - -isTaggedUnion u == - u is ['Union,:tl] and tl and first tl is [":",.,.] and true - -getUnionOrRecordTags u == - tags := nil - if u is ['Union, :tl] or u is ['Record, :tl] then - for t in tl repeat - if t is [":",tag,.] then tags := cons(tag, tags) - tags - coerceUnion2Branch(object) == [.,:unionDoms] := objMode object doms := orderUnionEntries unionDoms diff --git a/src/interp/i-object.boot b/src/interp/i-object.boot index 2c6515c1..0543e466 100644 --- a/src/interp/i-object.boot +++ b/src/interp/i-object.boot @@ -65,7 +65,35 @@ objEnv obj == $NE objCodeVal obj == CADDR obj objCodeMode obj == CADR obj - +--% Utility Functions Used Only by the Intepreter + +wrap x == + isWrapped x => x + ['WRAPPED,:x] + +isWrapped x == x is ['WRAPPED,:.] or NUMBERP x or FLOATP x or CVECP x + +unwrap x == + NUMBERP x or FLOATP x or CVECP x => x + x is ["WRAPPED",:y] => y + x + +wrapped2Quote x == + x is ["WRAPPED",:y] => MKQ y + x + +quote2Wrapped x == + x is ['QUOTE,y] => wrap y + x + +removeQuote x == + x is ["QUOTE",y] => y + x + +-- addQuote x == +-- NUMBERP x => x +-- ['QUOTE,x] + --% Library compiler structures needed by the interpreter -- Tuples and Crosses diff --git a/src/interp/i-util.boot.pamphlet b/src/interp/i-util.boot.pamphlet index 54cf2874..c0d785da 100644 --- a/src/interp/i-util.boot.pamphlet +++ b/src/interp/i-util.boot.pamphlet @@ -58,35 +58,6 @@ lisp code is unwrapped. <<*>>= <<license>> ---% Utility Functions Used Only by the Intepreter - -wrap x == - isWrapped x => x - ['WRAPPED,:x] - -isWrapped x == x is ['WRAPPED,:.] or NUMBERP x or FLOATP x or CVECP x - -unwrap x == - NUMBERP x or FLOATP x or CVECP x => x - x is ["WRAPPED",:y] => y - x - -wrapped2Quote x == - x is ["WRAPPED",:y] => MKQ y - x - -quote2Wrapped x == - x is ['QUOTE,y] => wrap y - x - -removeQuote x == - x is ["QUOTE",y] => y - x - --- addQuote x == --- NUMBERP x => x --- ['QUOTE,x] - --% The function for making prompts spadPrompt() == @@ -287,16 +258,6 @@ mkPredList listOfEntries == [u,:tagPredList]:= tagPredList u predList - -TruthP x == - --True if x is a predicate that's always true - x is nil => nil - x=true => true - x is ['QUOTE,:.] => true - nil - - - |