growable hashtables

library/arrays.factor

@@ -30,6 +30,7 @@ USE: generic
 USE: math-internals
 USE: kernel
 USE: lists
+USE: vectors
 
 ! An array is a range of memory storing pointers to other
 ! objects. Arrays are not used directly, and their access words
@@ -44,8 +45,8 @@ USE: lists
 BUILTIN: array 8
 
 : array-capacity   ( array -- n )   1 slot ; inline
-: vector-array     ( vec -- array ) 2 slot ; inline
-: set-vector-array ( array vec -- ) 2 set-slot ; inline
+: vector-array     ( vec -- array ) >vector 2 slot ; inline
+: set-vector-array ( array vec -- ) >vector 2 set-slot ; inline
 
 : array-nth ( n array -- obj )
     swap 2 fixnum+ slot ; inline

library/bootstrap/boot-stage2.factor

@@ -57,11 +57,11 @@ USE: namespaces
     "/library/math/ratio.factor"
     "/library/math/float.factor"
     "/library/math/complex.factor"
-    "/library/words.factor"
     "/library/lists.factor"
     "/library/vectors.factor"
     "/library/strings.factor"
     "/library/hashtables.factor"
+    "/library/words.factor"
     "/library/namespaces.factor"
     "/library/sbuf.factor"
     "/library/errors.factor"

library/bootstrap/boot.factor

@@ -51,11 +51,11 @@ USE: hashtables
     "/library/math/ratio.factor" parse-resource append,
     "/library/math/float.factor" parse-resource append,
     "/library/math/complex.factor" parse-resource append,
-    "/library/words.factor" parse-resource append,
     "/library/lists.factor" parse-resource append,
     "/library/vectors.factor" parse-resource append,
     "/library/strings.factor" parse-resource append,
     "/library/hashtables.factor" parse-resource append,
+    "/library/words.factor" parse-resource append,
     "/library/namespaces.factor" parse-resource append,
     "/library/sbuf.factor" parse-resource append,
     "/library/errors.factor" parse-resource append,

library/bootstrap/image.factor

@@ -192,7 +192,7 @@ M: f ' ( obj -- ptr )
         0 ,
         dup word-primitive ,
         dup word-parameter ' ,
-        dup word-plist ' ,
+        dup word-props ' ,
         0 ,
         0 ,
     ] make-list
@@ -284,16 +284,16 @@ M: string ' ( string -- pointer )
 M: vector ' ( vector -- pointer )
     emit-vector ;
 
-: rehash ( hashtable -- )
-    ! Now make a rehashing boot quotation
-    dup hash>alist [
-        over hash-clear
-        [ unswons rot set-hash ] each-with
-    ] cons cons
-    boot-quot [ append ] change ;
+! : rehash ( hashtable -- )
+!     ! Now make a rehashing boot quotation
+!     dup hash>alist [
+!         over hash-clear
+!         [ unswons rot set-hash ] each-with
+!     ] cons cons
+!     boot-quot [ append ] change ;
 
 : emit-hashtable ( hash -- pointer )
-    dup buckets>list emit-array swap hash-size
+    dup buckets>list emit-array swap hash>alist length
     object-tag here-as >r
     hashtable-type >header emit
     emit-fixnum ( length )
@@ -303,7 +303,7 @@ M: vector ' ( vector -- pointer )
 M: hashtable ' ( hashtable -- pointer )
     #! Only hashtables are pooled, not vectors!
     dup pooled-object [
-        [ dup emit-hashtable [ pool-object ] keep ] keep rehash
+        dup emit-hashtable [ pool-object ] keep
     ] ?unless ;
 
 ( End of the image )

library/cons.factor

@@ -80,6 +80,10 @@ PREDICATE: general-list list ( list -- ? )
     #! cell whose cdr is a proper list.
     dup [ last* cdr ] when not ;
 
+: with ( obj quot elt -- obj quot )
+    #! Utility word for each-with, map-with.
+    pick pick >r >r swap call r> r> ; inline
+
 : all? ( list pred -- ? )
     #! Push if the predicate returns true for each element of
     #! the list.
@@ -93,6 +97,9 @@ PREDICATE: general-list list ( list -- ? )
         2drop t
     ] ifte ; inline
 
+: all-with? ( obj list pred -- ? )
+    swap [ with rot ] all? 2nip ; inline
+
 : (each) ( list quot -- list quot )
     >r uncons r> tuck 2slip ; inline
 
@@ -101,10 +108,6 @@ PREDICATE: general-list list ( list -- ? )
     #! quotation with effect ( elt -- ) to each element.
     over [ (each) each ] [ 2drop ] ifte ; inline
 
-: with ( obj quot elt -- obj quot )
-    #! Utility word for each-with, map-with.
-    pick pick >r >r swap call r> r> ; inline
-
 : each-with ( obj list quot -- )
     #! Push each element of a proper list in turn, and apply a
     #! quotation with effect ( obj elt -- ) to each element.

library/hashtables.factor

@@ -39,9 +39,14 @@ BUILTIN: hashtable 10
 ! buckets are associative lists which are searched
 ! linearly.
 
+! The unsafe words go in kernel internals. Everything else, even
+! if it is somewhat 'implementation detail', is in the
+! public 'hashtables' vocabulary.
+
 IN: kernel-internals
 
 : hash-array 2 slot ; inline
+: set-hash-array 2 set-slot ; inline
 
 : hash-bucket ( n hash -- alist )
     swap >fixnum swap >hashtable hash-array array-nth ; inline
@@ -50,14 +55,19 @@ IN: kernel-internals
     swap >fixnum swap >hashtable hash-array set-array-nth ;
     inline
 
+: change-bucket ( n hash quot -- )
+    -rot hash-array
+    [ array-nth swap call ] 2keep
+    set-array-nth ; inline
+
+IN: hashtables
+
 : hash-size+ ( hash -- )
     >hashtable dup 1 slot 1 + swap 1 set-slot ; inline
 
 : hash-size- ( hash -- )
     >hashtable dup 1 slot 1 - swap 1 set-slot ; inline
 
-IN: hashtables
-
 : hash-size ( hash -- n )
     #! Number of elements in the hashtable.
     >hashtable 1 slot ;
@@ -80,24 +90,53 @@ IN: hashtables
     #! undefined value, or a value set to f.
     hash* dup [ cdr ] when ;
 
-: set-hash* ( key table quot -- )
+: set-hash* ( key hash quot -- )
     #! Apply the quotation to yield a new association list.
     #! If the association list already contains the key,
     #! decrement the hash size, since it will get removed.
-    >r
-        2dup (hashcode)
-    r> pick >r
-        over >r
-            >r swap hash-bucket r> call
-        r>
-    r> set-hash-bucket ; inline
+    -rot 2dup (hashcode) over [
+        ( quot key hash assoc -- )
+        swapd 2dup
+        assoc [ rot hash-size- ] [ rot drop ] ifte
+        rot call
+    ] change-bucket ; inline
+
+: rehash? ( hash -- ? )
+    dup bucket-count 3 * 2 /i swap hash-size < ;
+
+: grow-hash ( hash -- )
+    #! A good way to earn a living.
+    dup hash-size 3 * 2 /i <array> swap set-hash-array ;
+
+: (hash>alist) ( alist n hash -- alist )
+    2dup bucket-count >= [
+        2drop
+    ] [
+        [ hash-bucket [ swons ] each ] 2keep
+        >r 1 + r> (hash>alist)
+    ] ifte ;
+
+: hash>alist ( hash -- alist )
+    #! Push a list of key/value pairs in a hashtable.
+    [ ] 0 rot (hash>alist) ;
+
+: (set-hash) ( value key hash -- )
+    dup hash-size+ [ set-assoc ] set-hash* ;
+
+: rehash ( hash -- )
+    #! Increase the hashtable size if its too small.
+    dup rehash? [
+        dup hash>alist over grow-hash
+        [ unswons rot (set-hash) ] each-with
+    ] [
+        drop
+    ] ifte ;
 
 : set-hash ( value key table -- )
     #! Store the value in the hashtable. Either replaces an
     #! existing value in the appropriate bucket, or adds a new
     #! key/value pair.
-    dup hash-size+
-    [ set-assoc ] set-hash* ;
+    dup rehash (set-hash) ;
 
 : remove-hash ( key table -- )
     #! Remove a value from a hashtable.
@@ -113,20 +152,9 @@ IN: hashtables
     #! Push a list of key/value pairs in a hashtable.
     dup bucket-count swap hash-array array>list ;
 
-: (hash>alist) ( alist n hash -- alist )
-    2dup bucket-count >= [
-        2drop
-    ] [
-        [ hash-bucket [ swons ] each ] 2keep
-        >r 1 + r> (hash>alist)
-    ] ifte ;
-
-: hash>alist ( hash -- alist )
-    #! Push a list of key/value pairs in a hashtable.
-    [ ] 0 rot (hash>alist) ;
-
 : alist>hash ( alist -- hash )
-    dup length <hashtable> swap [ unswons pick set-hash ] each ;
+    dup length 1 max <hashtable> swap
+    [ unswons pick set-hash ] each ;
 
 : hash-keys ( hash -- list )
     #! Push a list of keys in a hashtable.
@@ -139,3 +167,22 @@ IN: hashtables
 : hash-each ( hash code -- )
     #! Apply the code to each key/value pair of the hashtable.
     >r hash>alist r> each ; inline
+
+M: hashtable clone ( hash -- hash )
+    dup bucket-count dup <hashtable> [
+        hash-array rot hash-array rot copy-array
+    ] keep ;
+
+: hash-subset? ( subset of -- ? )
+    hash>alist [ uncons >r swap hash r> = ] all-with? ;
+
+M: hashtable = ( obj hash -- ? )
+    2dup eq? [
+        2drop t
+    ] [
+        over hashtable? [
+            2dup hash-subset? >r swap hash-subset? r> and
+        ] [
+            2drop f
+        ] ifte
+    ] ifte ;

library/inference/branches.factor

@@ -108,11 +108,11 @@ USE: prettyprint
 
 SYMBOL: cloned
 
-: deep-clone ( vector -- vector )
-    #! Clone a vector if it hasn't already been cloned in this
+: deep-clone ( obj -- obj )
+    #! Clone an object if it hasn't already been cloned in this
     #! with-deep-clone scope.
     dup cloned get assoc [
-        vector-clone [ dup cloned [ acons ] change ] keep
+        clone [ dup cloned [ acons ] change ] keep
     ] ?unless ;
 
 : deep-clone-vector ( vector -- vector )

library/kernel.factor

@@ -2,7 +2,7 @@
 
 ! $Id$
 !
-! Copyright (C) 2004 Slava Pestov.
+! Copyright (C) 2004, 2005 Slava Pestov.
 ! 
 ! Redistribution and use in source and binary forms, with or without
 ! modification, are permitted provided that the following conditions are met:
@@ -43,6 +43,9 @@ M: object hashcode drop 0 ;
 GENERIC: = ( obj obj -- ? )
 M: object = eq? ;
 
+GENERIC: clone ( obj -- obj )
+M: object clone ;
+
 : cpu ( -- arch )
     #! Returns one of "x86" or "unknown".
     7 getenv ;

library/test/crashes.factor

@@ -25,7 +25,7 @@ USE: prettyprint
 
 10 <vector> "x" set
 [ -2 "x" get set-vector-length ] [ drop ] catch
-[ "x" get vector-clone drop ] [ drop ] catch
+[ "x" get clone drop ] [ drop ] catch
 
 10 [ [ -1000000 <vector> ] [ drop ] catch ] times
 
@@ -57,7 +57,7 @@ USE: prettyprint
 : callstack-overflow callstack-overflow f ;
 [ callstack-overflow ] unit-test-fails
 
-[ [ cdr cons ] word-plist ] unit-test-fails
+[ [ cdr cons ] word-props ] unit-test-fails
 
 ! Forgot to tag out of bounds index
 [ 1 { } vector-nth ] [ garbage-collection drop ] catch

library/test/hashtables.factor

@@ -45,7 +45,7 @@ f 100000000000000000000000000 "testhash" get set-hash
 
 [ t ] [ #{ 2 3 }# "testhash" get hash ] unit-test
 [ f ] [ 100000000000000000000000000 "testhash" get hash* cdr ] unit-test
-[ { } ] [ { [ { } ] } vector-clone "testhash" get hash* cdr ] unit-test
+[ { } ] [ { [ { } ] } clone "testhash" get hash* cdr ] unit-test
 
 [
     [[ "salmon" "fish" ]]
@@ -68,7 +68,19 @@ f 100000000000000000000000000 "testhash" get set-hash
 ! Testing the hash element counting
 
 <namespace> "counting" set
-"key" "value" "counting" get set-hash
+"value" "key" "counting" get set-hash
 [ 1 ] [ "counting" get hash-size ] unit-test
-"key" "value" "counting" get set-hash
+"value" "key" "counting" get set-hash
 [ 1 ] [ "counting" get hash-size ] unit-test
+"key" "counting" get remove-hash
+[ 0 ] [ "counting" get hash-size ] unit-test
+"key" "counting" get remove-hash
+[ 0 ] [ "counting" get hash-size ] unit-test
+
+[ t ] [ {{ }} dup = ] unit-test
+[ f ] [ "xyz" {{ }} = ] unit-test
+[ t ] [ {{ }} {{ }} = ] unit-test
+[ f ] [ {{ [[ 1 3 ]] }} {{ }} = ] unit-test
+[ f ] [ {{ }} {{ [[ 1 3 ]] }} = ] unit-test
+[ t ] [ {{ [[ 1 3 ]] }} {{ [[ 1 3 ]] }} = ] unit-test
+[ f ] [ {{ [[ 1 3 ]] }} {{ [[ 1 "hey" ]] }} = ] unit-test

library/test/httpd/httpd.factor

@@ -29,7 +29,7 @@ USE: lists
     "X-Spyware-Requested: yes" header-line
 ] unit-test
 
-[ ] [ "404 not found" ] [ httpd-error ] test-word
+[ ] [ "404 not found" httpd-error ] unit-test
 
 [ "arg" ] [
     [

library/test/inference.factor

@@ -218,7 +218,6 @@ SYMBOL: sym-test
 [ [ [ object object ] [ cons ] ] ] [ [ cons ] infer ] unit-test
 [ [ [ cons ] [ cons ] ] ] [ [ uncons cons ] infer ] unit-test
 [ [ [ general-list ] [ object ] ] ] [ [ dup [ car ] when ] infer ] unit-test
-[ [ [ vector ] [ vector ] ] ] [ [ vector-clone ] infer ] unit-test
 ! [ [ [ number ] [ number ] ] ] [ [ dup + ] infer ] unit-test
 ! [ [ [ number number number ] [ number ] ] ] [ [ digit+ ] infer ] unit-test
 [ [ [ number ] [ real real ] ] ] [ [ >rect ] infer ] unit-test

library/test/lists/namespaces.factor

@@ -3,9 +3,9 @@ USE: lists
 USE: namespaces
 USE: test
 
-[ [ 1 ] ] [ 1 f ] [ "x" set "x" cons@ "x" get ] test-word
-[ [[ 1 2 ]] ] [ 1 2 ] [ "x" set "x" cons@ "x" get ] test-word
-[ [ 1 2 ] ] [ 1 [ 2 ] ] [ "x" set "x" cons@ "x" get ] test-word
+[ [ 1 ] ] [ 1 f "x" set "x" cons@ "x" get ] unit-test
+[ [[ 1 2 ]] ] [ 1 2 "x" set "x" cons@ "x" get ] unit-test
+[ [ 1 2 ] ] [ 1 [ 2 ] "x" set "x" cons@ "x" get ] unit-test
 
 [ [ [[ 2 3 ]] [[ 1 2 ]] ] ] [
     "x" off 2 1 "x" [ acons ] change 3 2 "x" [ acons ] change "x" get

library/test/math/complex.factor

@@ -6,45 +6,45 @@ USE: test
 [ 1 #{ 0 1 }# rect> ] unit-test-fails
 [ #{ 0 1 }# 1 rect> ] unit-test-fails
 
-[ f ] [ #{ 5 12.5 }# 5 ] [ = ] test-word
-[ t ] [ #{ 1.0 2.0 }# #{ 1 2 }# ] [ = ] test-word
-[ f ] [ #{ 1.0 2.3 }# #{ 1 2 }# ] [ = ] test-word
+[ f ] [ #{ 5 12.5 }# 5  = ] unit-test
+[ t ] [ #{ 1.0 2.0 }# #{ 1 2 }#  = ] unit-test
+[ f ] [ #{ 1.0 2.3 }# #{ 1 2 }#  = ] unit-test
 
-[ #{ 2 5 }# ] [ 2 5 ] [ rect> ] test-word
-[ 2 5 ] [ #{ 2 5 }# ] [ >rect ] test-word
-[ #{ 1/2 1 }# ] [ 1/2 i ] [ + ] test-word
-[ #{ 1/2 1 }# ] [ i 1/2 ] [ + ] test-word
-[ t ] [ #{ 11 64 }# #{ 11 64 }# ] [ = ] test-word
-[ #{ 2 1 }# ] [ 2 i ] [ + ] test-word
-[ #{ 2 1 }# ] [ i 2 ] [ + ] test-word
-[ #{ 5 4 }# ] [ #{ 2 2 }# #{ 3 2 }# ] [ + ] test-word
-[ 5 ] [ #{ 2 2 }# #{ 3 -2 }# ] [ + ] test-word
-[ #{ 1.0 1 }# ] [ 1.0 i ] [ + ] test-word
+[ #{ 2 5 }# ] [ 2 5  rect> ] unit-test
+[ 2 5 ] [ #{ 2 5 }#  >rect ] unit-test
+[ #{ 1/2 1 }# ] [ 1/2 i  + ] unit-test
+[ #{ 1/2 1 }# ] [ i 1/2  + ] unit-test
+[ t ] [ #{ 11 64 }# #{ 11 64 }#  = ] unit-test
+[ #{ 2 1 }# ] [ 2 i  + ] unit-test
+[ #{ 2 1 }# ] [ i 2  + ] unit-test
+[ #{ 5 4 }# ] [ #{ 2 2 }# #{ 3 2 }#  + ] unit-test
+[ 5 ] [ #{ 2 2 }# #{ 3 -2 }#  + ] unit-test
+[ #{ 1.0 1 }# ] [ 1.0 i  + ] unit-test
 
-[ #{ 1/2 -1 }# ] [ 1/2 i ] [ - ] test-word
-[ #{ -1/2 1 }# ] [ i 1/2 ] [ - ] test-word
-[ #{ 1/3 1/4 }# ] [ 1 3 / 1 2 / i * + 1 4 / i * ] [ - ] test-word
-[ #{ -1/3 -1/4 }# ] [ 1 4 / i * 1 3 / 1 2 / i * + ] [ - ] test-word
-[ #{ 1/5 1/4 }# ] [ #{ 3/5 1/2 }# #{ 2/5 1/4 }# ] [ - ] test-word
-[ 4 ] [ #{ 5 10/3 }# #{ 1 10/3 }# ] [ - ] test-word
-[ #{ 1.0 -1 }# ] [ 1.0 i ] [ - ] test-word
+[ #{ 1/2 -1 }# ] [ 1/2 i  - ] unit-test
+[ #{ -1/2 1 }# ] [ i 1/2  - ] unit-test
+[ #{ 1/3 1/4 }# ] [ 1 3 / 1 2 / i * + 1 4 / i *  - ] unit-test
+[ #{ -1/3 -1/4 }# ] [ 1 4 / i * 1 3 / 1 2 / i * +  - ] unit-test
+[ #{ 1/5 1/4 }# ] [ #{ 3/5 1/2 }# #{ 2/5 1/4 }#  - ] unit-test
+[ 4 ] [ #{ 5 10/3 }# #{ 1 10/3 }#  - ] unit-test
+[ #{ 1.0 -1 }# ] [ 1.0 i  - ] unit-test
 
-[ #{ 0 1 }# ] [ i 1 ] [ * ] test-word
-[ #{ 0 1 }# ] [ 1 i ] [ * ] test-word
-[ #{ 0 1.0 }# ] [ 1.0 i ] [ * ] test-word
-[ -1 ] [ i i ] [ * ] test-word
-[ #{ 0 1 }# ] [ 1 i ] [ * ] test-word
-[ #{ 0 1 }# ] [ i 1 ] [ * ] test-word
-[ #{ 0 1/2 }# ] [ 1/2 i ] [ * ] test-word
-[ #{ 0 1/2 }# ] [ i 1/2 ] [ * ] test-word
-[ 2 ] [ #{ 1 1 }# #{ 1 -1 }# ] [ * ] test-word
-[ 1 ] [ i -i ] [ * ] test-word
+[ #{ 0 1 }# ] [ i 1  * ] unit-test
+[ #{ 0 1 }# ] [ 1 i  * ] unit-test
+[ #{ 0 1.0 }# ] [ 1.0 i  * ] unit-test
+[ -1 ] [ i i  * ] unit-test
+[ #{ 0 1 }# ] [ 1 i  * ] unit-test
+[ #{ 0 1 }# ] [ i 1  * ] unit-test
+[ #{ 0 1/2 }# ] [ 1/2 i  * ] unit-test
+[ #{ 0 1/2 }# ] [ i 1/2  * ] unit-test
+[ 2 ] [ #{ 1 1 }# #{ 1 -1 }#  * ] unit-test
+[ 1 ] [ i -i  * ] unit-test
 
-[ -1 ] [ i -i ] [ / ] test-word
-[ #{ 0 1 }# ] [ 1 -i ] [ / ] test-word
-[ t ] [ #{ 12 13 }# #{ 13 14 }# / #{ 13 14 }# * #{ 12 13 }# ] [ = ] test-word
+[ -1 ] [ i -i  / ] unit-test
+[ #{ 0 1 }# ] [ 1 -i  / ] unit-test
+[ t ] [ #{ 12 13 }# #{ 13 14 }# / #{ 13 14 }# * #{ 12 13 }#  = ] unit-test
 
-[ #{ -3 4 }# ] [ #{ 3 -4 }# ] [ neg ] test-word
+[ #{ -3 4 }# ] [ #{ 3 -4 }#  neg ] unit-test
 
 [ 5 ] [ #{ 3 4 }# abs ] unit-test
 [ 5 ] [ -5.0 abs ] unit-test

library/test/parse-number.factor

@@ -6,134 +6,108 @@ USE: test
 USE: unparser
 
 [ f ]
-[ f ]
-[ parse-number ]
-test-word
+[ f parse-number ]
+unit-test
 
 [ f ]
-[ "12345abcdef" ]
-[ parse-number ]
-test-word
+[ "12345abcdef" parse-number ]
+unit-test
 
 [ t ]
-[ "-12" ]
-[ parse-number 0 < ]
-test-word
+[ "-12" parse-number 0 < ]
+unit-test
 
 [ f ]
-[ "--12" ]
-[ parse-number ]
-test-word
+[ "--12" parse-number ]
+unit-test
 
 [ f ]
-[ "-" ]
-[ parse-number ]
-test-word
+[ "-" parse-number ]
+unit-test
 
 [ f ]
-[ "e" ]
-[ parse-number ]
-test-word
+[ "e" parse-number ]
+unit-test
 
 [ "100.0" ]
-[ "1.0e2" ]
-[ parse-number unparse ]
-test-word
+[ "1.0e2" parse-number unparse ]
+unit-test
 
 [ "-100.0" ]
-[ "-1.0e2" ]
-[ parse-number unparse ]
-test-word
+[ "-1.0e2" parse-number unparse ]
+unit-test
 
 [ "0.01" ]
-[ "1.0e-2" ]
-[ parse-number unparse ]
-test-word
+[ "1.0e-2" parse-number unparse ]
+unit-test
 
 [ "-0.01" ]
-[ "-1.0e-2" ]
-[ parse-number unparse ]
-test-word
+[ "-1.0e-2" parse-number unparse ]
+unit-test
 
 [ f ]
-[ "-1e-2e4" ]
-[ parse-number ]
-test-word
+[ "-1e-2e4" parse-number ]
+unit-test
 
 [ "3.14" ]
-[ "3.14" ]
-[ parse-number unparse ]
-test-word
+[ "3.14" parse-number unparse ]
+unit-test
 
 [ f ]
-[ "." ]
-[ parse-number ]
-test-word
+[ "." parse-number ]
+unit-test
 
 [ f ]
-[ ".e" ]
-[ parse-number ]
-test-word
+[ ".e" parse-number ]
+unit-test
 
 [ "101.0" ]
-[ "1.01e2" ]
-[ parse-number unparse ]
-test-word
+[ "1.01e2" parse-number unparse ]
+unit-test
 
 [ "-101.0" ]
-[ "-1.01e2" ]
-[ parse-number unparse ]
-test-word
+[ "-1.01e2" parse-number unparse ]
+unit-test
 
 [ "1.01" ]
-[ "101.0e-2" ]
-[ parse-number unparse ]
-test-word
+[ "101.0e-2" parse-number unparse ]
+unit-test
 
 [ "-1.01" ]
-[ "-101.0e-2" ]
-[ parse-number unparse ]
-test-word
+[ "-101.0e-2" parse-number unparse ]
+unit-test
 
 [ 5 ]
-[ "10/2" ]
-[ parse-number ]
-test-word
+[ "10/2" parse-number ]
+unit-test
 
 [ -5 ]
-[ "-10/2" ]
-[ parse-number ]
-test-word
+[ "-10/2" parse-number ]
+unit-test
 
 [ -5 ]
-[ "10/-2" ]
-[ parse-number ]
-test-word
+[ "10/-2" parse-number ]
+unit-test
 
 [ 5 ]
-[ "-10/-2" ]
-[ parse-number ]
-test-word
+[ "-10/-2" parse-number ]
+unit-test
 
 [ f ]
-[ "10.0/2" ]
-[ parse-number ]
-test-word
+[ "10.0/2" parse-number ]
+unit-test
 
 [ f ]
-[ "1e1/2" ]
-[ parse-number ]
-test-word
+[ "1e1/2" parse-number ]
+unit-test
 
 [ f ]
-[ "e/2" ]
-[ parse-number ]
-test-word
+[ "e/2" parse-number ]
+unit-test
 
 [ "33/100" ]
-[ "66/200" ]
-[ parse-number unparse ]
-test-word
+[ "66/200" parse-number unparse ]
+unit-test
 
 [ "12" bin> ] unit-test-fails
 [ "fdsf" bin> ] unit-test-fails

library/test/test.factor

@@ -43,14 +43,6 @@ USE: unparser
     #! Assert that the quotation throws an error.
     [ [ not ] catch ] cons [ f ] swap unit-test ;
 
-: test-word ( output input word -- )
-    #! Old-style test.
-    append unit-test ;
-
-: do-not-test-word ( output input word -- )
-    #! Flag for tests that are known not to work.
-    3drop ;
-
 : test ( name -- )
     ! Run the given test.
     depth 1 - >r

library/test/unparser.factor

@@ -8,19 +8,16 @@ USE: kernel
 USE: io-internals
 
 [ "\"hello\\\\backslash\"" ]
-[ "hello\\backslash" ]
-[ unparse ]
-test-word
+[ "hello\\backslash" unparse ]
+unit-test
 
 [ "\"\\u1234\"" ]
-[ "\u1234" ]
-[ unparse ]
-test-word
+[ "\u1234" unparse ]
+unit-test
 
 [ "\"\\e\"" ]
-[ "\e" ]
-[ unparse ]
-test-word
+[ "\e" unparse ]
+unit-test
 
 [ "1.0" ] [ 1.0 unparse ] unit-test
 [ "f" ] [ f unparse ] unit-test

library/test/vectors.factor

@@ -37,14 +37,11 @@ USE: kernel-internals
 [ f ] [ [ 1 2 ] { 1 2 3 } = ] unit-test
 [ f ] [ { 1 2 } [ 1 2 3 ] = ] unit-test
 
-[ [ 1 4 9 16 ] ] [ [ 1 2 3 4 ] ]
-[ list>vector [ dup * ] vector-map vector>list ] test-word
-[ t ] [ [ 1 2 3 4 ] ]
-[ list>vector [ number? ] vector-all? ] test-word
-[ f ] [ [ 1 2 3 4 ] ]
-[ list>vector [ 3 > ] vector-all? ] test-word
-[ t ] [ [ ] ]
-[ list>vector [ 3 > ] vector-all? ] test-word
+[ [ 1 4 9 16 ] ]
+[
+    [ 1 2 3 4 ]
+    list>vector [ dup * ] vector-map vector>list
+] unit-test
 
 [ t ] [ { } hashcode { } hashcode = ] unit-test
 [ t ] [ { 1 2 3 } hashcode { 1 2 3 } hashcode = ] unit-test
@@ -79,6 +76,11 @@ unit-test
 
 [ t ] [
     { 1 2 3 4 } dup vector-array array-capacity
-    >r vector-clone vector-array array-capacity r>
+    >r clone vector-array array-capacity r>
     =
 ] unit-test
+
+[ f ] [
+    { 1 2 3 4 } dup clone
+    swap vector-array swap vector-array eq?
+] unit-test

library/test/words.factor

@@ -11,10 +11,7 @@ USE: kernel
     "poo" [ "scratchpad" ] search execute
 ] unit-test
 
-: words-test ( -- ? )
-    t vocabs [ words [ word? and ] each ] each ;
-
-[ t           ] [                 ] [ words-test        ] test-word
+[ t ] [ t vocabs [ words [ word? and ] each ] each ] unit-test
 
 DEFER: plist-test
 
@@ -28,7 +25,7 @@ DEFER: plist-test
     \ plist-test "sample-property" word-property
 ] unit-test
 
-[ f ] [ 5 ] [ compound? ] test-word
+[ f ] [ 5 compound? ] unit-test
 
 "create-test" "scratchpad" create { 1 2 } "testing" set-word-property
 [ { 1 2 } ] [
@@ -62,4 +59,4 @@ SYMBOL: a-symbol
 : test-last ( -- ) ;
 word word-name "last-word-test" set
 
-[ "test-last" ] [ ] [ "last-word-test" get ] test-word
+[ "test-last" ] [ "last-word-test" get ] unit-test

library/tools/interpreter.factor

@@ -63,8 +63,8 @@ SYMBOL: meta-cf
 
 : copy-interpreter ( -- )
     #! Copy interpreter state from containing namespaces.
-    meta-r [ vector-clone ] change
-    meta-d [ vector-clone ] change
+    meta-r [ clone ] change
+    meta-d [ clone ] change
     meta-n [ ] change
     meta-c [ ] change ;
 
@@ -132,12 +132,12 @@ SYMBOL: meta-cf
 : set-meta-word ( word quot -- )
     "meta-word" set-word-property ;
 
-\ datastack [ meta-d get vector-clone push-d ] set-meta-word
-\ set-datastack [ pop-d vector-clone meta-d set ] set-meta-word
+\ datastack [ meta-d get clone push-d ] set-meta-word
+\ set-datastack [ pop-d clone meta-d set ] set-meta-word
 \ >r   [ pop-d push-r ] set-meta-word
 \ r>   [ pop-r push-d ] set-meta-word
-\ callstack [ meta-r get vector-clone push-d ] set-meta-word
-\ set-callstack [ pop-d vector-clone meta-r set ] set-meta-word
+\ callstack [ meta-r get clone push-d ] set-meta-word
+\ set-callstack [ pop-d clone meta-r set ] set-meta-word
 \ namestack [ meta-n get push-d ] set-meta-word
 \ set-namestack [ pop-d meta-n set ] set-meta-word
 \ catchstack [ meta-c get push-d ] set-meta-word

library/vectors.factor

@@ -70,6 +70,9 @@ IN: kernel-internals
         2drop
     ] ifte ; inline
 
+: copy-array ( to from n -- )
+    [ 3dup swap array-nth pick rot set-array-nth ] repeat 2drop ;
+
 IN: vectors
 
 : vector-nth ( n vec -- obj )
@@ -123,13 +126,6 @@ IN: vectors
         swap >r apply r> tuck vector-push
     ] vector-each nip ; inline
 
-: vector-and ( vector -- ? )
-    #! Logical and of all elements in the vector.
-    t swap [ and ] vector-each ;
-
-: vector-all? ( vector pred -- ? )
-    vector-map vector-and ; inline
-
 : vector-nappend ( v1 v2 -- )
     #! Destructively append v2 to v1.
     [ over vector-push ] vector-each drop ;
@@ -148,9 +144,10 @@ IN: vectors
     #! in a new vector.
     project list>vector ; inline
 
-: vector-clone ( vector -- vector )
-    #! Shallow copy of a vector.
-    [ ] vector-map ;
+M: vector clone ( vector -- vector )
+    dup vector-length dup empty-vector [
+        vector-array rot vector-array rot copy-array
+    ] keep ;
 
 : vector-length= ( vec vec -- ? )
     vector-length swap vector-length number= ;

library/vocabularies.factor

@@ -68,12 +68,12 @@ USE: strings
         2drop f
     ] ifte ;
 
-: <plist> ( name vocab -- plist )
-    "vocabulary" swons swap "name" swons 2list ;
+: <props> ( name vocab -- plist )
+    "vocabulary" swons swap "name" swons 2list alist>hash ;
 
 : (create) ( name vocab -- word )
     #! Create an undefined word without adding to a vocabulary.
-    <plist> <word> [ set-word-plist ] keep ;
+    <props> <word> [ set-word-props ] keep ;
 
 : reveal ( word -- )
     #! Add a new word to its vocabulary.

library/words.factor

@@ -2,7 +2,7 @@
 
 ! $Id$
 !
-! Copyright (C) 2003 Slava Pestov.
+! Copyright (C) 2003, 2005 Slava Pestov.
 ! 
 ! Redistribution and use in source and binary forms, with or without
 ! modification, are permitted provided that the following conditions are met:
@@ -49,8 +49,8 @@ M: word hashcode 1 slot %fixnum ;
 : word-parameter     ( w -- obj ) >word 4 slot ; inline
 : set-word-parameter ( obj w -- ) >word 4 set-slot ; inline
 
-: word-plist     ( w -- obj ) >word 5 slot ; inline
-: set-word-plist ( obj w -- ) >word 5 set-slot ; inline
+: word-props     ( w -- obj ) >word 5 slot ; inline
+: set-word-props ( obj w -- ) >word 5 set-slot ; inline
 
 : call-count     ( w -- n ) >word 6 integer-slot ; inline
 : set-call-count ( n w -- ) >word 6 set-integer-slot ; inline
@@ -61,12 +61,10 @@ M: word hashcode 1 slot %fixnum ;
 SYMBOL: vocabularies
 
 : word-property ( word pname -- pvalue )
-    swap word-plist assoc ; inline
+    swap word-props hash ; inline
 
 : set-word-property ( word pvalue pname -- )
-    pick word-plist
-    pick [ set-assoc ] [ remove-assoc nip ] ifte
-    swap set-word-plist ; inline
+    rot word-props set-hash ; inline
 
 PREDICATE: word compound  ( obj -- ? ) word-primitive 1 = ;
 PREDICATE: word primitive ( obj -- ? ) word-primitive 2 > ;