From ed18f7d37b24789fc07ba00ac2399344dbb20be9 Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Wed, 4 Jun 2008 00:56:06 -0400
Subject: [PATCH] Fixing implementation of nil
---
extra/lisp/parser/parser-tests.factor | 9 +++----
extra/lists/lists-docs.factor | 2 +-
extra/lists/lists-tests.factor | 16 +++++++-----
extra/lists/lists.factor | 36 ++++++++++++++++-----------
4 files changed, 36 insertions(+), 27 deletions(-)
diff --git a/extra/lisp/parser/parser-tests.factor b/extra/lisp/parser/parser-tests.factor
index 41254db5b3..4aa8154690 100644
--- a/extra/lisp/parser/parser-tests.factor
+++ b/extra/lisp/parser/parser-tests.factor
@@ -40,8 +40,7 @@ IN: lisp.parser.tests
"+" "atom" \ lisp-expr rule parse parse-result-ast
] unit-test
-{ T{ cons f f f }
-} [
+{ +nil+ } [
"()" lisp-expr parse-result-ast
] unit-test
@@ -53,7 +52,7 @@ IN: lisp.parser.tests
cons
f
1
- T{ cons f 2 T{ cons f "aoeu" T{ cons f f f } } }
+ T{ cons f 2 T{ cons f "aoeu" +nil+ } }
} } } [
"(foo 1 2 \"aoeu\")" lisp-expr parse-result-ast
] unit-test
@@ -61,8 +60,8 @@ IN: lisp.parser.tests
{ T{ cons f
1
T{ cons f
- T{ cons f 3 T{ cons f 4 T{ cons f f f } } }
- T{ cons f 2 T{ cons f f } } }
+ T{ cons f 3 T{ cons f 4 +nil+ } }
+ T{ cons f 2 +nil+ } }
}
} [
"(1 (3 4) 2)" lisp-expr parse-result-ast
diff --git a/extra/lists/lists-docs.factor b/extra/lists/lists-docs.factor
index 4fae52f5b4..51b068d979 100644
--- a/extra/lists/lists-docs.factor
+++ b/extra/lists/lists-docs.factor
@@ -58,7 +58,7 @@ HELP: uncons
{ $values { "cons" "a cons object" } { "car" "the head of the list" } { "cdr" "the tail of the list" } }
{ $description "Put the head and tail of the list on the stack." } ;
-{ leach lreduce lmap } related-words
+{ leach lreduce lmap>array } related-words
HELP: leach
{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- )" } }
diff --git a/extra/lists/lists-tests.factor b/extra/lists/lists-tests.factor
index 16bc65ebb3..534c20245b 100644
--- a/extra/lists/lists-tests.factor
+++ b/extra/lists/lists-tests.factor
@@ -9,7 +9,7 @@ IN: lists.tests
T{ cons f 2
T{ cons f 3
T{ cons f 4
- T{ cons f f f } } } } } [ 2 + ] lmap
+ +nil+ } } } } [ 2 + ] lmap>array
] unit-test
{ 10 } [
@@ -17,7 +17,7 @@ IN: lists.tests
T{ cons f 2
T{ cons f 3
T{ cons f 4
- T{ cons f f f } } } } } 0 [ + ] lreduce
+ +nil+ } } } } 0 [ + ] lreduce
] unit-test
{ T{ cons f
@@ -30,13 +30,17 @@ IN: lists.tests
T{ cons f
4
T{ cons f
- T{ cons f 5 T{ cons f f f } }
- T{ cons f f f } } } }
- T{ cons f f f } } } }
+ T{ cons f 5 +nil+ }
+ +nil+ } } }
+ +nil+ } } }
} [
{ 1 2 { 3 4 { 5 } } } seq>cons
] unit-test
{ { 1 2 { 3 4 { 5 } } } } [
{ 1 2 { 3 4 { 5 } } } seq>cons cons>seq
-] unit-test
\ No newline at end of file
+] unit-test
+
+! { { 3 4 { 5 6 { 7 } } } } [
+! { 1 2 { 3 4 { 5 } } } seq>cons [ 2 + ] traverse cons>seq
+! ] unit-test
\ No newline at end of file
diff --git a/extra/lists/lists.factor b/extra/lists/lists.factor
index f9b7b89e5b..388bfb5bd7 100644
--- a/extra/lists/lists.factor
+++ b/extra/lists/lists.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Chris Double & James Cash
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences accessors math arrays vectors classes ;
+USING: kernel sequences accessors math arrays vectors classes words ;
IN: lists
@@ -8,8 +8,8 @@ IN: lists
MIXIN: list
GENERIC: car ( cons -- car )
GENERIC: cdr ( cons -- cdr )
-GENERIC: nil? ( cons -- ? )
-
+GENERIC: nil? ( cons -- ? )
+
TUPLE: cons car cdr ;
C: cons cons
@@ -19,15 +19,15 @@ M: cons car ( cons -- car )
M: cons cdr ( cons -- cdr )
cdr>> ;
+
+SYMBOL: +nil+
+M: word nil? +nil+ eq? ;
+M: object nil? drop f ;
-: nil ( -- cons )
- T{ cons f f f } ;
+: nil ( -- +nil+ ) +nil+ ;
: uncons ( cons -- cdr car )
[ cdr ] [ car ] bi ;
-
-M: cons nil? ( cons -- ? )
- uncons and not ;
: 1list ( obj -- cons )
nil cons ;
@@ -59,15 +59,18 @@ M: cons nil? ( cons -- ? )
: lreduce ( list identity quot -- result )
swapd leach ; inline
-: (lmap) ( acc cons quot -- seq )
- over nil? [ 2drop ]
- [ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (lmap) ] if ; inline
+! : lmap ( cons quot -- newcons )
-: lmap ( cons quot -- seq )
- { } -rot (lmap) ; inline
+
+: (lmap>array) ( acc cons quot -- newcons )
+ over nil? [ 2drop ]
+ [ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (lmap>array) ] if ; inline
+
+: lmap>array ( cons quot -- newcons )
+ { } -rot (lmap>array) ; inline
: lmap-as ( cons quot exemplar -- seq )
- [ lmap ] dip like ;
+ [ lmap>array ] dip like ;
: same? ( obj1 obj2 -- ? )
[ class ] bi@ = ;
@@ -76,6 +79,9 @@ M: cons nil? ( cons -- ? )
[ <reversed> ] keep nil [ tuck same? [ seq>cons ] when f cons swap >>cdr ] with reduce ;
: cons>seq ( cons -- array )
- [ dup cons? [ cons>seq ] when ] lmap ;
+ [ dup cons? [ cons>seq ] when ] lmap>array ;
+
+: traverse ( list quot -- newlist )
+ [ over list? [ traverse ] [ call ] if ] curry ;
INSTANCE: cons list
\ No newline at end of file