dlists no longer have a length slot; tweak dlist code so that types infer better

basis/compiler/compiler.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel namespaces arrays sequences io debugger
-words fry continuations vocabs assocs dlists definitions math
-threads graphs generic combinators deques search-deques
+words fry continuations vocabs assocs dlists definitions
+math threads graphs generic combinators deques search-deques
 prettyprint io stack-checker stack-checker.state
 stack-checker.inlining compiler.errors compiler.units
 compiler.tree.builder compiler.tree.optimizer

basis/compiler/tree/dead-code/liveness/liveness.factor

@@ -1,8 +1,9 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry accessors namespaces assocs deques search-deques
-kernel sequences sequences.deep words sets stack-checker.branches
-compiler.tree compiler.tree.def-use compiler.tree.combinators ;
+dlists kernel sequences sequences.deep words sets
+stack-checker.branches compiler.tree compiler.tree.def-use
+compiler.tree.combinators ;
 IN: compiler.tree.dead-code.liveness
 
 SYMBOL: work-list

basis/compiler/tree/def-use/def-use.factor

@@ -18,12 +18,16 @@ TUPLE: definition value node uses ;
         swap >>node
         V{ } clone >>uses ;
 
+ERROR: no-def-error value ;
+
 : def-of ( value -- definition )
-    def-use get at* [ "No def" throw ] unless ;
+    dup def-use get at* [ nip ] [ no-def-error ] if ;
+
+ERROR: multiple-defs-error ;
 
 : def-value ( node value -- )
     def-use get 2dup key? [
-        "Multiple defs" throw
+        multiple-defs-error
     ] [
         [ [ <definition> ] keep ] dip set-at
     ] if ;

basis/compiler/tree/recursive/recursive.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel assocs arrays namespaces accessors sequences deques
-search-deques compiler.tree compiler.tree.combinators ;
+search-deques dlists compiler.tree compiler.tree.combinators ;
 IN: compiler.tree.recursive
 
 ! Collect label info

basis/deques/deques-docs.factor

@@ -4,7 +4,7 @@ IN: deques
 
 HELP: deque-empty?
 { $values { "deque" deque } { "?" "a boolean" } }
-{ $description "Returns true if a deque is empty." }
+{ $contract "Returns true if a deque is empty." }
 { $notes "This operation is O(1)." } ;
 
 HELP: clear-deque
@@ -12,12 +12,6 @@ HELP: clear-deque
      { "deque" deque } }
 { $description "Removes all elements from a deque." } ;
 
-HELP: deque-length
-{ $values
-     { "deque" deque }
-     { "n" integer } }
-{ $description "Returns the number of elements in a deque." } ;
-
 HELP: deque-member?
 { $values
      { "value" object } { "deque" deque }
@@ -31,7 +25,7 @@ HELP: push-front
 
 HELP: push-front*
 { $values { "obj" object } { "deque" deque } { "node" "a node" } }
-{ $description "Push the object onto the front of the deque and return the newly created node." } 
+{ $contract "Push the object onto the front of the deque and return the newly created node." } 
 { $notes "This operation is O(1)." } ;
 
 HELP: push-back
@@ -41,7 +35,7 @@ HELP: push-back
 
 HELP: push-back*
 { $values { "obj" object } { "deque" deque } { "node" "a node" } }
-{ $description "Push the object onto the back of the deque and return the newly created node." } 
+{ $contract "Push the object onto the back of the deque and return the newly created node." } 
 { $notes "This operation is O(1)." } ;
 
 HELP: push-all-back
@@ -56,7 +50,7 @@ HELP: push-all-front
 
 HELP: peek-front
 { $values { "deque" deque } { "obj" object } }
-{ $description "Returns the object at the front of the deque." } ;
+{ $contract "Returns the object at the front of the deque." } ;
 
 HELP: pop-front
 { $values { "deque" deque } { "obj" object } }
@@ -65,12 +59,12 @@ HELP: pop-front
 
 HELP: pop-front*
 { $values { "deque" deque } }
-{ $description "Pop the object off the front of the deque." }
+{ $contract "Pop the object off the front of the deque." }
 { $notes "This operation is O(1)." } ;
 
 HELP: peek-back
 { $values { "deque" deque } { "obj" object } }
-{ $description "Returns the object at the back of the deque." } ;
+{ $contract "Returns the object at the back of the deque." } ;
 
 HELP: pop-back
 { $values { "deque" deque } { "obj" object } }
@@ -79,13 +73,13 @@ HELP: pop-back
 
 HELP: pop-back*
 { $values { "deque" deque } }
-{ $description "Pop the object off the back of the deque." }
+{ $contract "Pop the object off the back of the deque." }
 { $notes "This operation is O(1)." } ;
 
 HELP: delete-node
 { $values
      { "node" object } { "deque" deque } }
-{ $description "Deletes the node from the deque." } ;
+{ $contract "Deletes the node from the deque." } ;
 
 HELP: deque
 { $description "A data structure that has constant-time insertion and removal of elements at both ends." } ;
@@ -111,7 +105,7 @@ $nl
 "Querying the deque:"
 { $subsection peek-front }
 { $subsection peek-back }
-{ $subsection deque-length }
+{ $subsection deque-empty? }
 { $subsection deque-member? }
 "Adding and removing elements:"
 { $subsection push-front* }
@@ -123,7 +117,6 @@ $nl
 { $subsection delete-node }
 { $subsection node-value }
 "Utility operations built in terms of the above:"
-{ $subsection deque-empty? }
 { $subsection push-front }
 { $subsection push-all-front }
 { $subsection push-back }

basis/deques/deques.factor

@@ -10,13 +10,10 @@ GENERIC: peek-back ( deque -- obj )
 GENERIC: pop-front* ( deque -- )
 GENERIC: pop-back* ( deque -- )
 GENERIC: delete-node ( node deque -- )
-GENERIC: deque-length ( deque -- n )
 GENERIC: deque-member? ( value deque -- ? )
 GENERIC: clear-deque ( deque -- )
 GENERIC: node-value ( node -- value )
-
-: deque-empty? ( deque -- ? )
-    deque-length zero? ;
+GENERIC: deque-empty? ( deque -- ? )
 
 : push-front ( obj deque -- )
     push-front* drop ;

basis/dlists/dlists-docs.factor

@@ -1,5 +1,5 @@
 USING: help.markup help.syntax kernel quotations
-deques ;
+deques search-deques hashtables ;
 IN: dlists
 
 ARTICLE: "dlists" "Double-linked lists"
@@ -18,10 +18,16 @@ $nl
 { $subsection dlist-contains? }
 "Deleting a node matching a predicate:"
 { $subsection delete-node-if* }
-{ $subsection delete-node-if } ;
+{ $subsection delete-node-if }
+"Search deque implementation:"
+{ $subsection <hashed-dlist> } ;
 
 ABOUT: "dlists"
 
+HELP: <hashed-dlist> ( -- search-deque )
+{ $values { "search-deque" search-deque } }
+{ $description "Creates a new " { $link search-deque } " backed by a " { $link dlist } ", with a " { $link hashtable } " for fast membership tests." } ;
+
 HELP: dlist-find
 { $values { "dlist" { $link dlist } } { "quot" quotation } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
 { $description "Applies the quotation to each element of the " { $link dlist } " in turn, until it outputs a true value or the end of the " { $link dlist } " is reached.  Outputs either the object it found or " { $link f } ", and a boolean which is true if an object is found." }

basis/dlists/dlists-tests.factor

@@ -52,15 +52,6 @@ IN: dlists.tests
 [ 1 ] [ <dlist> 1 over push-back [ 1 = ] delete-node-if ] unit-test
 [ t ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop deque-empty? ] unit-test
 [ t ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop deque-empty? ] unit-test
-[ 0 ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop deque-length ] unit-test
-[ 1 ] [ <dlist> 1 over push-back 2 over push-back dup [ 1 = ] delete-node-if drop deque-length ] unit-test
-[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 1 = ] delete-node-if drop deque-length ] unit-test
-[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 2 = ] delete-node-if drop deque-length ] unit-test
-[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 3 = ] delete-node-if drop deque-length ] unit-test
-
-[ 0 ] [ <dlist> deque-length ] unit-test
-[ 1 ] [ <dlist> 1 over push-front deque-length ] unit-test
-[ 0 ] [ <dlist> 1 over push-front dup pop-front* deque-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

basis/dlists/dlists.factor

@@ -2,51 +2,57 @@
 ! Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: combinators kernel math sequences accessors deques
-summary ;
+search-deques summary hashtables ;
 IN: dlists
 
-TUPLE: dlist front back length ;
-
-: <dlist> ( -- obj )
-    dlist new
-        0 >>length ;
-
-M: dlist deque-length length>> ;
-
 <PRIVATE
 
-TUPLE: dlist-node obj prev next ;
+MIXIN: ?dlist-node
+
+INSTANCE: f ?dlist-node
+
+TUPLE: dlist-node obj { prev ?dlist-node } { next ?dlist-node } ;
+
+INSTANCE: dlist-node ?dlist-node
 
 C: <dlist-node> dlist-node
 
+PRIVATE>
+
+TUPLE: dlist
+{ front ?dlist-node }
+{ back ?dlist-node } ;
+
+: <dlist> ( -- obj )
+    dlist new ; inline
+
+: <hashed-dlist> ( -- search-deque )
+    20 <hashtable> <dlist> <search-deque> ;
+
+M: dlist deque-empty? front>> not ;
+
 M: dlist-node node-value obj>> ;
 
-: inc-length ( dlist -- )
-    [ 1+ ] change-length drop ; inline
-
-: dec-length ( dlist -- )
-    [ 1- ] change-length drop ; inline
-
 : set-prev-when ( dlist-node dlist-node/f -- )
-    [ (>>prev) ] [ drop ] if* ;
+    [ (>>prev) ] [ drop ] if* ; inline
 
 : set-next-when ( dlist-node dlist-node/f -- )
-    [ (>>next) ] [ drop ] if* ;
+    [ (>>next) ] [ drop ] if* ; inline
 
 : set-next-prev ( dlist-node -- )
-    dup next>> set-prev-when ;
+    dup next>> set-prev-when ; inline
 
 : normalize-front ( dlist -- )
-    dup back>> [ f >>front ] unless drop ;
+    dup back>> [ f >>front ] unless drop ; inline
 
 : normalize-back ( dlist -- )
-    dup front>> [ f >>back ] unless drop ;
+    dup front>> [ f >>back ] unless drop ; inline
 
 : set-back-to-front ( dlist -- )
-    dup back>> [ dup front>> >>back ] unless drop ;
+    dup back>> [ dup front>> >>back ] unless drop ; inline
 
 : set-front-to-back ( dlist -- )
-    dup front>> [ dup back>> >>front ] unless drop ;
+    dup front>> [ dup back>> >>front ] unless drop ; inline
 
 : (dlist-find-node) ( dlist-node quot: ( node -- ? ) -- node/f ? )
     over [
@@ -62,22 +68,20 @@ M: dlist-node node-value obj>> ;
 
 : unlink-node ( dlist-node -- )
     dup prev>> over next>> set-prev-when
-    dup next>> swap prev>> set-next-when ;
+    dup next>> swap prev>> set-next-when ; inline
 
 PRIVATE>
 
 M: dlist push-front* ( obj dlist -- dlist-node )
     [ front>> f swap <dlist-node> dup dup set-next-prev ] keep
     [ (>>front) ] keep
-    [ set-back-to-front ] keep
-    inc-length ;
+    set-back-to-front ;
 
 M: dlist push-back* ( obj dlist -- dlist-node )
     [ back>> f <dlist-node> ] keep
     [ back>> set-next-when ] 2keep
     [ (>>back) ] 2keep
-    [ set-front-to-back ] keep
-    inc-length ;
+    set-front-to-back ;
 
 ERROR: empty-dlist ;
 
@@ -88,31 +92,27 @@ M: dlist peek-front ( dlist -- obj )
     front>> [ obj>> ] [ empty-dlist ] if* ;
 
 M: dlist pop-front* ( dlist -- )
-    dup front>> [ empty-dlist ] unless
     [
-        dup front>>
+        dup front>> [ empty-dlist ] unless*
         dup next>>
         f rot (>>next)
         f over set-prev-when
         swap (>>front)
     ] keep
-    [ normalize-back ] keep
-    dec-length ;
+    normalize-back ;
 
 M: dlist peek-back ( dlist -- obj )
     back>> [ obj>> ] [ empty-dlist ] if* ;
 
 M: dlist pop-back* ( dlist -- )
-    dup back>> [ empty-dlist ] unless
     [
-        dup back>>
+        dup back>> [ empty-dlist ] unless*
         dup prev>>
         f rot (>>prev)
         f over set-next-when
         swap (>>back)
     ] keep
-    [ normalize-front ] keep
-    dec-length ;
+    normalize-front ;
 
 : dlist-find ( dlist quot -- obj/f ? )
     [ obj>> ] prepose
@@ -128,7 +128,7 @@ M: dlist delete-node ( dlist-node dlist -- )
     {
         { [ 2dup front>> eq? ] [ nip pop-front* ] }
         { [ 2dup back>> eq? ] [ nip pop-back* ] }
-        [ dec-length unlink-node ]
+        [ drop unlink-node ]
     } cond ;
 
 : delete-node-if* ( dlist quot -- obj/f ? )

basis/search-deques/search-deques-docs.factor

@@ -1,21 +1,15 @@
 IN: search-deques
-USING: help.markup help.syntax kernel dlists hashtables
+USING: help.markup help.syntax kernel hashtables
 deques assocs ;
 
 ARTICLE: "search-deques" "Search deques"
 "A search deque is a data structure with constant-time insertion and removal of elements at both ends, and constant-time membership tests. Inserting an element more than once has no effect. Search deques implement all deque operations in terms of an underlying deque, and membership testing with " { $link deque-member? } " is implemented with an underlying assoc. Search deques are defined in the " { $vocab-link "search-deques" } " vocabulary."
 $nl
 "Creating a search deque:"
-{ $subsection <search-deque> }
-"Default implementation:"
-{ $subsection <hashed-dlist> } ;
+{ $subsection <search-deque> } ;
 
 ABOUT: "search-deques"
 
 HELP: <search-deque> ( assoc deque -- search-deque )
 { $values { "assoc" assoc } { "deque" deque } { "search-deque" search-deque } }
 { $description "Creates a new " { $link search-deque } "." } ;
-
-HELP: <hashed-dlist> ( -- search-deque )
-{ $values { "search-deque" search-deque } }
-{ $description "Creates a new " { $link search-deque } " backed by a " { $link dlist } ", with a " { $link hashtable } " for fast membership tests." } ;

basis/search-deques/search-deques-tests.factor

@@ -1,6 +1,6 @@
 IN: search-deques.tests
 USING: search-deques tools.test namespaces
-kernel sequences words deques vocabs ;
+kernel sequences words deques vocabs dlists ;
 
 <hashed-dlist> "h" set
 
@@ -15,13 +15,11 @@ kernel sequences words deques vocabs ;
 [ t ] [ "1" get "2" get eq? ] unit-test
 [ t ] [ "2" get "3" get eq? ] unit-test
 
-[ 3 ] [ "h" get deque-length ] unit-test
 [ t ] [ 7 "h" get deque-member? ] unit-test
 
 [ 3 ] [ "1" get node-value ] unit-test
 [ ] [ "1" get "h" get delete-node ] unit-test
 
-[ 2 ] [ "h" get deque-length ] unit-test
 [ 1 ] [ "h" get pop-back ] unit-test
 [ 7 ] [ "h" get pop-back ] unit-test
 

basis/search-deques/search-deques.factor

@@ -1,16 +1,13 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel assocs deques dlists hashtables ;
+USING: accessors kernel assocs deques ;
 IN: search-deques
 
 TUPLE: search-deque assoc deque ;
 
 C: <search-deque> search-deque
 
-: <hashed-dlist> ( -- search-deque )
-    0 <hashtable> <dlist> <search-deque> ;
-
-M: search-deque deque-length deque>> deque-length ;
+M: search-deque deque-empty? deque>> deque-empty? ;
 
 M: search-deque peek-front deque>> peek-front ;