From 292bd212f1c30a51f0191128d5a9cd2691c5ccf9 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Wed, 28 Dec 2011 06:12:21 +0000 Subject: * boot/tokens.boot: Remove redundant renaming of REM. loopBody and loopExit are not selectors. * interp/i-output.boot: Include sys-utility. * interp/sys-utility.boot (last): New macro. (loopBody): Likewise. * interp/vmlisp.lisp (LASTNODE): Remove. (LASTPAIR): Likewise. (last): Do not define here. --- src/ChangeLog | 11 +++++++++++ src/boot/strap/tokens.clisp | 47 +++++++++++++++++++++++---------------------- src/boot/tokens.boot | 3 ++- src/boot/utility.boot | 36 +++++++++++++++++----------------- src/interp/Makefile.in | 2 +- src/interp/g-opt.boot | 2 ++ src/interp/i-output.boot | 1 + src/interp/slam.boot | 2 +- src/interp/sys-utility.boot | 8 ++++++++ src/interp/vmlisp.lisp | 10 ---------- 10 files changed, 68 insertions(+), 54 deletions(-) diff --git a/src/ChangeLog b/src/ChangeLog index 59992dbb..ebc8a2a5 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,14 @@ +2011-12-28 Gabriel Dos Reis + + * boot/tokens.boot: Remove redundant renaming of REM. + loopBody and loopExit are not selectors. + * interp/i-output.boot: Include sys-utility. + * interp/sys-utility.boot (last): New macro. + (loopBody): Likewise. + * interp/vmlisp.lisp (LASTNODE): Remove. + (LASTPAIR): Likewise. + (last): Do not define here. + 2011-12-27 Gabriel Dos Reis * boot/tokens.boot: Do not rewrite drop and take. diff --git a/src/boot/strap/tokens.clisp b/src/boot/strap/tokens.clisp index 3d170958..e59680a6 100644 --- a/src/boot/strap/tokens.clisp +++ b/src/boot/strap/tokens.clisp @@ -219,9 +219,9 @@ (LIST '|writeLine| 'WRITE-LINE) (LIST '|writeNewline| 'TERPRI) (LIST '|writeString| 'WRITE-STRING) (LIST 'PLUS '+) (LIST 'MINUS '-) (LIST 'TIMES '*) (LIST 'POWER 'EXPT) - (LIST 'REM 'REM) (LIST 'QUO 'TRUNCATE) (LIST 'SLASH '/) - (LIST 'LT '<) (LIST 'GT '>) (LIST 'LE '<=) (LIST 'GE '>=) - (LIST 'SHOEEQ 'EQUAL) (LIST 'SHOENE '/=) (LIST 'T 'T$))) + (LIST 'QUO 'TRUNCATE) (LIST 'SLASH '/) (LIST 'LT '<) (LIST 'GT '>) + (LIST 'LE '<=) (LIST 'GE '>=) (LIST 'SHOEEQ 'EQUAL) + (LIST 'SHOENE '/=) (LIST 'T 'T$))) (|i| NIL)) (LOOP (COND @@ -232,26 +232,27 @@ (LET ((|bfVar#1| (LIST (LIST '|absKind| 'CAR) (LIST '|absParms| 'CADR) - (LIST '|absBody| 'CADDR) (LIST '|setName| 0) (LIST '|setLabel| 1) - (LIST '|setLevel| 2) (LIST '|setType| 3) (LIST '|setVar| 4) - (LIST '|setLeaf| 5) (LIST '|setDef| 6) (LIST '|aGeneral| 4) - (LIST '|aMode| 1) (LIST '|aModeSet| 3) (LIST '|aTree| 0) - (LIST '|aValue| 2) (LIST '|args| 'CDR) (LIST '|attributes| 'CADDR) - (LIST '|cacheCount| 'CADDDDR) (LIST '|cacheName| 'CADR) - (LIST '|cacheReset| 'CADDDR) (LIST '|cacheType| 'CADDR) - (LIST '|env| 'CADDR) (LIST '|expr| 'CAR) (LIST 'CAR 'CAR) - (LIST '|mmCondition| 'CAADR) (LIST '|mmDC| 'CAAR) - (LIST '|mmImplementation| 'CADADR) (LIST '|mmSignature| 'CDAR) - (LIST '|mmTarget| 'CADAR) (LIST '|mmSource| 'CDDAR) - (LIST '|mapOpsig| 'CAR) (LIST '|mapOperation| 'CAAR) - (LIST '|mapSignature| 'CADAR) (LIST '|mapTarget| 'CAADAR) - (LIST '|mapSource| 'CDADAR) (LIST '|mapPredicate| 'CADR) - (LIST '|mapImpl| 'CADDR) (LIST '|mapKind| 'CAADDR) - (LIST '|mode| 'CADR) (LIST '|op| 'CAR) (LIST '|opcode| 'CADR) - (LIST '|opSig| 'CADR) (LIST 'CDR 'CDR) (LIST '|sig| 'CDDR) - (LIST '|source| 'CDR) (LIST '|streamCode| 'CADDDR) - (LIST '|streamDef| 'CADDR) (LIST '|streamName| 'CADR) - (LIST '|target| 'CAR))) + (LIST '|absBody| 'CADDR) (LIST '|loopBody| '|loopBody|) + (LIST '|loopExit| '|last|) (LIST '|setName| 0) + (LIST '|setLabel| 1) (LIST '|setLevel| 2) (LIST '|setType| 3) + (LIST '|setVar| 4) (LIST '|setLeaf| 5) (LIST '|setDef| 6) + (LIST '|aGeneral| 4) (LIST '|aMode| 1) (LIST '|aModeSet| 3) + (LIST '|aTree| 0) (LIST '|aValue| 2) (LIST '|args| 'CDR) + (LIST '|attributes| 'CADDR) (LIST '|cacheCount| 'CADDDDR) + (LIST '|cacheName| 'CADR) (LIST '|cacheReset| 'CADDDR) + (LIST '|cacheType| 'CADDR) (LIST '|env| 'CADDR) + (LIST '|expr| 'CAR) (LIST 'CAR 'CAR) (LIST '|mmCondition| 'CAADR) + (LIST '|mmDC| 'CAAR) (LIST '|mmImplementation| 'CADADR) + (LIST '|mmSignature| 'CDAR) (LIST '|mmTarget| 'CADAR) + (LIST '|mmSource| 'CDDAR) (LIST '|mapOpsig| 'CAR) + (LIST '|mapOperation| 'CAAR) (LIST '|mapSignature| 'CADAR) + (LIST '|mapTarget| 'CAADAR) (LIST '|mapSource| 'CDADAR) + (LIST '|mapPredicate| 'CADR) (LIST '|mapImpl| 'CADDR) + (LIST '|mapKind| 'CAADDR) (LIST '|mode| 'CADR) (LIST '|op| 'CAR) + (LIST '|opcode| 'CADR) (LIST '|opSig| 'CADR) (LIST 'CDR 'CDR) + (LIST '|sig| 'CDDR) (LIST '|source| 'CDR) + (LIST '|streamCode| 'CADDDR) (LIST '|streamDef| 'CADDR) + (LIST '|streamName| 'CADR) (LIST '|target| 'CAR))) (|i| NIL)) (LOOP (COND diff --git a/src/boot/tokens.boot b/src/boot/tokens.boot index 77b29cb2..2adea400 100644 --- a/src/boot/tokens.boot +++ b/src/boot/tokens.boot @@ -323,7 +323,6 @@ for i in [ _ ["MINUS", "-"] , _ ["TIMES", "*"] , _ ["POWER", "EXPT"] , _ - ['REM, 'REM],_ ['QUO, 'TRUNCATE],_ ["SLASH", "/"] , _ ["LT", "<"], _ @@ -341,6 +340,8 @@ for i in [ _ ["absKind", "CAR"] ,_ ["absParms", "CADR"] ,_ ["absBody", "CADDR"] ,_ + ["loopBody", "loopBody"] ,_ + ["loopExit", "last"] ,_ ["setName", 0] , _ ["setLabel", 1] , _ ["setLevel", 2] , _ diff --git a/src/boot/utility.boot b/src/boot/utility.boot index 52593e5d..5ba81a1e 100644 --- a/src/boot/utility.boot +++ b/src/boot/utility.boot @@ -120,7 +120,7 @@ copyTree t == objectMember?(x,l) == repeat l = nil => return false - cons? l => + l is [.,:.] => sameObject?(x,first l) => return true l := rest l return sameObject?(x,l) @@ -128,7 +128,7 @@ objectMember?(x,l) == symbolMember?(s,l) == repeat l = nil => return false - cons? l => + l is [.,:.] => symbolEq?(s,first l) => return true l := rest l return symbolEq?(s,l) @@ -136,7 +136,7 @@ symbolMember?(s,l) == stringMember?(s,l) == repeat l = nil => return false - cons? l => + l is [.,:.] => stringEq?(s,first l) => return true l := rest l return stringEq?(s,l) @@ -144,7 +144,7 @@ stringMember?(s,l) == charMember?(c,l) == repeat l = nil => return false - cons? l => + l is [.,:.] => charEq?(c,first l) => return true l := rest l return charEq?(c,l) @@ -152,7 +152,7 @@ charMember?(c,l) == scalarMember?(s,l) == repeat l = nil => return false - cons? l => + l is [.,:.] => scalarEq?(s,first l) => return true l := rest l return scalarEq?(s,l) @@ -160,7 +160,7 @@ scalarMember?(s,l) == listMember?(x,l) == repeat l = nil => return false - cons? l => + l is [.,:.] => listEq?(x,first l) => return true l := rest l return listEq?(x,l) @@ -170,7 +170,7 @@ listMember?(x,l) == reverse l == r := nil repeat - cons? l => + l is [.,:.] => r := [first l,:r] l := rest l return r @@ -178,7 +178,7 @@ reverse l == reverse! l == l1 := nil repeat - cons? l => + l is [.,:.] => l2 := rest l l.rest := l1 l1 := l @@ -188,17 +188,17 @@ reverse! l == --% return a pointer to the last cons-cell in the list `l'. lastNode l == - while l is [.,:l'] and cons? l' repeat + while l is [.,:l'] and l' is [.,:.] repeat l := l' l --% list copying copyList l == - not cons? l => l + l isnt [.,:.] => l l' := t := [first l] repeat l := rest l - cons? l => + l is [.,:.] => t.rest := [first l] t := rest t t.rest := l @@ -232,7 +232,7 @@ objectAssoc(x,l) == substitute!(y,x,s) == s = nil => nil sameObject?(x,s) => y - if cons? s then + if s is [.,:.] then s.first := substitute!(y,x,first s) s.rest := substitute!(y,x,rest s) s @@ -240,7 +240,7 @@ substitute!(y,x,s) == substitute(y,x,s) == s = nil => nil sameObject?(x,s) => y - cons? s => + s is [.,:.] => h := substitute(y,x,first s) t := substitute(y,x,rest s) sameObject?(h,first s) and sameObject?(t,rest s) => s @@ -249,7 +249,7 @@ substitute(y,x,s) == applySubst(sl,t) == sl = nil => t - cons? t => + t is [.,:.] => hd := applySubst(sl,first t) tl := applySubst(sl,rest t) sameObject?(hd,first t) and sameObject?(tl,rest t) => t @@ -259,7 +259,7 @@ applySubst(sl,t) == applySubst!(sl,t) == sl = nil => t - cons? t => + t is [.,:.] => hd := applySubst!(sl,first t) tl := applySubst!(sl,rest t) t.first := hd @@ -309,7 +309,7 @@ removeSymbol(l,x) == before := nil l' := l repeat - not cons? l' => return l + l' isnt [.,:.] => return l [y,:l'] := l' symbolEq?(x,y) => return append!(reverse! before,l') before := [y,:before] @@ -318,7 +318,7 @@ removeScalar(l,x) == before := nil l' := l repeat - not cons? l' => return l + l' isnt [.,:.] => return l [y,:l'] := l' scalarEq?(x,y) => return append!(reverse! before,l') before := [y,:before] @@ -327,7 +327,7 @@ removeValue(l,x) == before := nil l' := l repeat - not cons? l' => return l + l' isnt [.,:.] => return l [y,:l'] := l' valueEq?(x,y) => return append!(reverse! before,l') before := [y,:before] diff --git a/src/interp/Makefile.in b/src/interp/Makefile.in index 2157553b..5930d44f 100644 --- a/src/interp/Makefile.in +++ b/src/interp/Makefile.in @@ -279,7 +279,7 @@ osyscmd.$(FASLEXT): int-top.$(FASLEXT) int-top.$(FASLEXT): incl.$(FASLEXT) i-toplev.$(FASLEXT) unlisp.$(FASLEXT) i-toplev.$(FASLEXT): i-analy.$(FASLEXT) i-syscmd.$(FASLEXT): i-object.$(FASLEXT) -i-output.$(FASLEXT): sys-macros.$(FASLEXT) +i-output.$(FASLEXT): sys-utility.$(FASLEXT) sys-macros.$(FASLEXT) i-special.$(FASLEXT): i-analy.$(FASLEXT) i-funsel.$(FASLEXT): i-coerfn.$(FASLEXT) i-map.$(FASLEXT): i-object.$(FASLEXT) diff --git a/src/interp/g-opt.boot b/src/interp/g-opt.boot index 880d088b..ef5b6a51 100644 --- a/src/interp/g-opt.boot +++ b/src/interp/g-opt.boot @@ -317,6 +317,8 @@ unnestWhen! x == f x where x is ['%seq,:.] => for stmts in tails x.args repeat stmts.first := f first stmts + x is ['%repeat,:.] => + x.loopBody := unnestWhen! x.loopBody x ++ Transform nested-to-tower. diff --git a/src/interp/i-output.boot b/src/interp/i-output.boot index 20028fc4..421e9386 100644 --- a/src/interp/i-output.boot +++ b/src/interp/i-output.boot @@ -32,6 +32,7 @@ -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +import sys_-utility import sys_-macros namespace BOOT diff --git a/src/interp/slam.boot b/src/interp/slam.boot index 11816e99..13768228 100644 --- a/src/interp/slam.boot +++ b/src/interp/slam.boot @@ -298,7 +298,7 @@ compileRecurrenceRelation(op,nam,argl,junk,[body,sharpArg,n,:initCode]) == newValueCode:= ["%LET",g,substitute(gIndex,sharpArg, applySubst(pairList(rest $TriangleVariableList,gsList),body))] ['%bind,decomposeBindings, - ['%repeat,["WHILE",true],["PROGN",endTest,advanceCode, + ['%repeat,["WHILE",'%true],["PROGN",endTest,advanceCode, newValueCode,:rotateCode],voidValue()]] fromScratchInit:= [["%LET",gIndex,n],:[["%LET",g,x] for g in gsList for x in initCode]] diff --git a/src/interp/sys-utility.boot b/src/interp/sys-utility.boot index f9f7cbf8..96bd829b 100644 --- a/src/interp/sys-utility.boot +++ b/src/interp/sys-utility.boot @@ -405,6 +405,14 @@ displayTextFile f == finally stream ~= nil => closeStream stream +--% +macro last x == + lastNode(x).first + +--% +macro loopBody x == + take(-2,x).first + --% macro constructorDB ctor == property(ctor,'DATABASE) diff --git a/src/interp/vmlisp.lisp b/src/interp/vmlisp.lisp index e922e1de..e571a161 100644 --- a/src/interp/vmlisp.lisp +++ b/src/interp/vmlisp.lisp @@ -174,12 +174,6 @@ (defmacro lam (&rest body) (list 'quote (*lam (copy-tree body)))) -(defmacro lastnode (l) - `(last ,l)) - -(defmacro lastpair (l) - `(last ,l)) - (defmacro lessp (&rest args) `(< ,@args)) @@ -665,10 +659,6 @@ ((and (atom item) (not (arrayp item))) (member item sequence)) (T (member item sequence :test #'equalp)))) -; 14.2 Accessing - -(defun |last| (x) (car (lastpair x))) - ; 14.3 Searching (DEFUN |assoc| (X Y) -- cgit v1.2.3