diff --git a/library/arrays.factor b/library/arrays.factor index 0e052d9b7c..2d12372dd7 100644 --- a/library/arrays.factor +++ b/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 diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index fdd77c2046..d7cc3a86e3 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/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" diff --git a/library/bootstrap/boot.factor b/library/bootstrap/boot.factor index d991caa709..981d27daa9 100644 --- a/library/bootstrap/boot.factor +++ b/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, diff --git a/library/bootstrap/image.factor b/library/bootstrap/image.factor index 3115837abc..2594c13fc9 100644 --- a/library/bootstrap/image.factor +++ b/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 ) diff --git a/library/cons.factor b/library/cons.factor index d3af62c203..b8ec600864 100644 --- a/library/cons.factor +++ b/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. diff --git a/library/hashtables.factor b/library/hashtables.factor index 1bcc3fe9d1..73a31e081a 100644 --- a/library/hashtables.factor +++ b/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 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 swap [ unswons pick set-hash ] each ; + dup length 1 max 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 [ + 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 ; diff --git a/library/inference/branches.factor b/library/inference/branches.factor index d78fe2a164..c5cff70a5f 100644 --- a/library/inference/branches.factor +++ b/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 ) diff --git a/library/kernel.factor b/library/kernel.factor index fb3c4544af..2bc2bd6f0a 100644 --- a/library/kernel.factor +++ b/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 ; diff --git a/library/test/crashes.factor b/library/test/crashes.factor index 2a1bcb3fe4..eadb5b4f3d 100644 --- a/library/test/crashes.factor +++ b/library/test/crashes.factor @@ -25,7 +25,7 @@ USE: prettyprint 10 "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 ] [ 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 diff --git a/library/test/hashtables.factor b/library/test/hashtables.factor index 37e74d53d7..bffd04b84c 100644 --- a/library/test/hashtables.factor +++ b/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 "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 diff --git a/library/test/httpd/httpd.factor b/library/test/httpd/httpd.factor index 94409070fe..9d604042ba 100644 --- a/library/test/httpd/httpd.factor +++ b/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" ] [ [ diff --git a/library/test/inference.factor b/library/test/inference.factor index eb06775ab9..bb53417af0 100644 --- a/library/test/inference.factor +++ b/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 diff --git a/library/test/lists/namespaces.factor b/library/test/lists/namespaces.factor index 190e781399..2f26ad1bd6 100644 --- a/library/test/lists/namespaces.factor +++ b/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 diff --git a/library/test/math/complex.factor b/library/test/math/complex.factor index 1c509a5b43..4f41d25ae1 100644 --- a/library/test/math/complex.factor +++ b/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 diff --git a/library/test/parse-number.factor b/library/test/parse-number.factor index 42555574c0..26a334f9ff 100644 --- a/library/test/parse-number.factor +++ b/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 diff --git a/library/test/test.factor b/library/test/test.factor index 2a8fe1063f..e412cf6d91 100644 --- a/library/test/test.factor +++ b/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 diff --git a/library/test/unparser.factor b/library/test/unparser.factor index 99c12fde8d..4756c09b51 100644 --- a/library/test/unparser.factor +++ b/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 diff --git a/library/test/vectors.factor b/library/test/vectors.factor index d55b1fe168..9726a57c50 100644 --- a/library/test/vectors.factor +++ b/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 diff --git a/library/test/words.factor b/library/test/words.factor index e8198c12e1..c4fe3179f7 100644 --- a/library/test/words.factor +++ b/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 diff --git a/library/tools/interpreter.factor b/library/tools/interpreter.factor index c6a8297c10..7955f3050c 100644 --- a/library/tools/interpreter.factor +++ b/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 diff --git a/library/vectors.factor b/library/vectors.factor index 57124a65cd..6853420256 100644 --- a/library/vectors.factor +++ b/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= ; diff --git a/library/vocabularies.factor b/library/vocabularies.factor index 9b4ad2c544..f1d1e3178f 100644 --- a/library/vocabularies.factor +++ b/library/vocabularies.factor @@ -68,12 +68,12 @@ USE: strings 2drop f ] ifte ; -: ( name vocab -- plist ) - "vocabulary" swons swap "name" swons 2list ; +: ( name vocab -- plist ) + "vocabulary" swons swap "name" swons 2list alist>hash ; : (create) ( name vocab -- word ) #! Create an undefined word without adding to a vocabulary. - [ set-word-plist ] keep ; + [ set-word-props ] keep ; : reveal ( word -- ) #! Add a new word to its vocabulary. diff --git a/library/words.factor b/library/words.factor index fcfbf800dd..e05aa95fca 100644 --- a/library/words.factor +++ b/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 > ;