fix a couple of dlists bugs

document more words
add more tests

core/dlists/dlists-docs.factor

@@ -1,4 +1,4 @@
-USING: help.markup help.syntax kernel quotations ;
+USING: help.markup help.syntax kernel quotations dlists.private ;
 IN: dlists
 
 ARTICLE: "dlists" "Doubly-linked lists"
@@ -51,38 +51,52 @@ HELP: dlist-empty?
 HELP: push-front
 { $values { "obj" "an object" } { "dlist" dlist } }
 { $description "Push the object onto the front of the " { $link dlist } "." } 
-{ $notes "This operation is O(1)." }
-{ $see-also push-back pop-front pop-front* pop-back pop-back* } ;
+{ $notes "This operation is O(1)." } ;
+
+HELP: push-front*
+{ $values { "obj" "an object" } { "dlist" dlist } { "dlist-node" dlist-node } }
+{ $description "Push the object onto the front of the " { $link dlist } " and return the newly created " { $snippet "dlist-node" } "." } 
+{ $notes "This operation is O(1)." } ;
 
 HELP: push-back
 { $values { "obj" "an object" } { "dlist" dlist } }
 { $description "Push the object onto the back of the " { $link dlist } "." } 
-{ $notes "This operation is O(1)." }
-{ $see-also push-front pop-front pop-front* pop-back pop-back* } ;
+{ $notes "This operation is O(1)." } ;
+
+HELP: push-back*
+{ $values { "obj" "an object" } { "dlist" dlist } { "dlist-node" dlist-node } }
+{ $description "Push the object onto the back of the " { $link dlist } " and return the newly created " { $snippet "dlist-node" } "." } 
+{ $notes "This operation is O(1)." } ;
+
+HELP: peek-front
+{ $values { "dlist" dlist } { "obj" "an object" } }
+{ $description "Returns the object at the front of the " { $link dlist } "." } ;
 
 HELP: pop-front
 { $values { "dlist" dlist } { "obj" "an object" } }
 { $description "Pop the object off the front of the " { $link dlist } " and return the object." }
-{ $notes "This operation is O(1)." }
-{ $see-also push-front push-back pop-front* pop-back pop-back* } ;
+{ $notes "This operation is O(1)." } ;
 
 HELP: pop-front*
 { $values { "dlist" dlist } }
 { $description "Pop the object off the front of the " { $link dlist } "." }
-{ $notes "This operation is O(1)." }
-{ $see-also push-front push-back pop-front pop-back pop-back* } ;
+{ $notes "This operation is O(1)." } ;
+
+HELP: peek-back
+{ $values { "dlist" dlist } { "obj" "an object" } }
+{ $description "Returns the object at the back of the " { $link dlist } "." } ;
 
 HELP: pop-back
 { $values { "dlist" dlist } { "obj" "an object" } }
 { $description "Pop the object off the back of the " { $link dlist } " and return the object." }
-{ $notes "This operation is O(1)." }
-{ $see-also push-front push-back pop-front pop-front* pop-back* } ;
+{ $notes "This operation is O(1)." } ;
 
 HELP: pop-back*
 { $values { "dlist" dlist } }
 { $description "Pop the object off the back of the " { $link dlist } "." }
-{ $notes "This operation is O(1)." }
-{ $see-also push-front push-back pop-front pop-front* pop-back } ;
+{ $notes "This operation is O(1)." } ;
+
+{ push-front push-front* push-back push-back* peek-front pop-front pop-front* peek-back pop-back pop-back* } related-words
 
 HELP: dlist-find
 { $values { "dlist" { $link dlist } } { "quot" quotation } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }

core/dlists/dlists-tests.factor

@@ -1,6 +1,6 @@
 USING: dlists dlists.private kernel tools.test random assocs
 sets sequences namespaces sorting debugger io prettyprint
-math ;
+math accessors classes ;
 IN: dlists.tests
 
 [ t ] [ <dlist> dlist-empty? ] unit-test
@@ -65,20 +65,17 @@ IN: dlists.tests
 : assert-same-elements
     [ prune natural-sort ] bi@ assert= ;
 
-: dlist-push-all [ push-front ] curry each ;
-
 : dlist-delete-all [ dlist-delete drop ] curry each ;
 
 : dlist>array [ [ , ] dlist-slurp ] { } make ;
 
 [ ] [
     5 [ drop 30 random >fixnum ] map prune
-    6 [ drop 30 random >fixnum ] map prune 2dup nl . . nl
-    [
+    6 [ drop 30 random >fixnum ] map prune [
         <dlist>
-        [ dlist-push-all ] keep
-        [ dlist-delete-all ] keep
-        dlist>array
+        [ push-all-front ]
+        [ dlist-delete-all ]
+        [ dlist>array ] tri
     ] 2keep swap diff assert-same-elements
 ] unit-test
 
@@ -95,3 +92,11 @@ IN: dlists.tests
 
 [ 1 ] [ "d" get dlist-length ] unit-test
 [ 1 ] [ "d" get dlist>array length ] unit-test
+
+[ t ] [ <dlist> 4 over push-back 5 over push-back [ obj>> 4 = ] dlist-find-node drop class dlist-node = ] unit-test
+[ t ] [ <dlist> 4 over push-back 5 over push-back [ obj>> 5 = ] dlist-find-node drop class dlist-node = ] unit-test
+[ t ] [ <dlist> 4 over push-back 5 over push-back* [ = ] curry dlist-find-node drop class dlist-node = ] unit-test
+[ ] [ <dlist> 4 over push-back 5 over push-back [ drop ] dlist-each ] unit-test
+
+[ f ] [ <dlist> peek-front ] unit-test
+[ f ] [ <dlist> peek-back ] unit-test

core/dlists/dlists.factor

@@ -47,7 +47,7 @@ C: <dlist-node> dlist-node
 
 : (dlist-find-node) ( dlist-node quot -- node/f ? )
     over [
-        [ >r obj>> r> call ] 2keep rot
+        [ call ] 2keep rot
         [ drop t ] [ >r next>> r> (dlist-find-node) ] if
     ] [ 2drop f f ] if ; inline
 
@@ -55,7 +55,7 @@ C: <dlist-node> dlist-node
     >r front>> r> (dlist-find-node) ; inline
 
 : dlist-each-node ( dlist quot -- )
-    [ t ] compose dlist-find-node 2drop ; inline
+    [ f ] compose dlist-find-node 2drop ; inline
 
 PRIVATE>
 
@@ -85,7 +85,7 @@ PRIVATE>
     [ push-back ] curry each ;
 
 : peek-front ( dlist -- obj )
-    front>> obj>> ;
+    front>> dup [ obj>> ] when ;
 
 : pop-front ( dlist -- obj )
     dup front>> [
@@ -96,10 +96,11 @@ PRIVATE>
     ] 2keep obj>>
     swap [ normalize-back ] keep dec-length ;
 
-: pop-front* ( dlist -- ) pop-front drop ;
+: pop-front* ( dlist -- )
+    pop-front drop ;
 
 : peek-back ( dlist -- obj )
-    back>> obj>> ;
+    back>> dup [ obj>> ] when ;
 
 : pop-back ( dlist -- obj )
     dup back>> [
@@ -110,9 +111,11 @@ PRIVATE>
     ] 2keep obj>>
     swap [ normalize-front ] keep dec-length ;
 
-: pop-back* ( dlist -- ) pop-back drop ;
+: pop-back* ( dlist -- )
+    pop-back drop ;
 
 : dlist-find ( dlist quot -- obj/f ? )
+    [ obj>> ] prepose
     dlist-find-node [ obj>> t ] [ drop f f ] if ; inline
 
 : dlist-contains? ( dlist quot -- ? )
@@ -141,6 +144,7 @@ PRIVATE>
     ] if ; inline
 
 : delete-node-if ( dlist quot -- obj/f )
+    [ obj>> ] prepose
     delete-node-if* drop ; inline
 
 : dlist-delete ( obj dlist -- obj/f )