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
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/math/ratio.factor"\r
"/library/math/float.factor"\r
"/library/math/complex.factor"\r
- "/library/words.factor"\r
"/library/lists.factor"\r
"/library/vectors.factor"\r
"/library/strings.factor"\r
"/library/hashtables.factor"\r
+ "/library/words.factor"\r
"/library/namespaces.factor"\r
"/library/sbuf.factor"\r
"/library/errors.factor"\r
"/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,
0 ,
dup word-primitive ,
dup word-parameter ' ,
- dup word-plist ' ,
+ dup word-props ' ,
0 ,
0 ,
] make-list
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 )
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 )
#! 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.
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
#! 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.
! 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
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 ;
#! 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.
#! 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.
: 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 ;
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 )
! $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:
GENERIC: = ( obj obj -- ? )
M: object = eq? ;
+GENERIC: clone ( obj -- obj )
+M: object clone ;
+
: cpu ( -- arch )
#! Returns one of "x86" or "unknown".
7 getenv ;
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
: 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
[ 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" ]]
! 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
"X-Spyware-Requested: yes" header-line
] unit-test
-[ ] [ "404 not found" ] [ httpd-error ] test-word
+[ ] [ "404 not found" httpd-error ] unit-test
[ "arg" ] [
[
[ [ [ 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
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
[ 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
-
-[ #{ 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
-
-[ #{ 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
-
-[ #{ 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
-
-[ -1 ] [ i -i ] [ / ] test-word
-[ #{ 0 1 }# ] [ 1 -i ] [ / ] test-word
-[ t ] [ #{ 12 13 }# #{ 13 14 }# / #{ 13 14 }# * #{ 12 13 }# ] [ = ] test-word
-
-[ #{ -3 4 }# ] [ #{ 3 -4 }# ] [ neg ] 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> ] 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 - ] 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 * ] 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 / ] unit-test
+[ #{ 0 1 }# ] [ 1 -i / ] unit-test
+[ t ] [ #{ 12 13 }# #{ 13 14 }# / #{ 13 14 }# * #{ 12 13 }# = ] unit-test
+
+[ #{ -3 4 }# ] [ #{ 3 -4 }# neg ] unit-test
[ 5 ] [ #{ 3 4 }# abs ] unit-test
[ 5 ] [ -5.0 abs ] unit-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
#! 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
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
[ 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
[ 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
"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
\ 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 } ] [
: 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
: 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 ;
: 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
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 )
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 ;
#! 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= ;
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.
! $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:
: 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
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 > ;
projects / factor.git / commitdiff