steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

new hashtable

cvs
Slava Pestov 2005-11-27 22:45:48 +00:00
parent eca20beec0
commit 9ef9193308
36 changed files with 703 additions and 679 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
TODO.FACTOR.txt
View File

@ -13,13 +13,13 @@
- fix up the min thumb size hack - fix up the min thumb size hack
- callbacks - callbacks
- better prettyprinting of cond - better prettyprinting of cond
- investigate if rehashing on startup is really necessary
- remove word transfer hack in bootstrap - remove word transfer hack in bootstrap
- the invalid recursion form case needs to be fixed, for inlines too - the invalid recursion form case needs to be fixed, for inlines too
- what about tasks and timers between image restarts - what about tasks and timers between image restarts
- new hashtable
- bootstrap it in - double hash
- double hash - empty key change
- if hash is full and we change existing key, it should not grow
+ ui: + ui:

12
library/alien/c-types.factor
View File

@ -7,12 +7,12 @@ sequences sequences-internals strings words ;
: <c-type> ( -- type ) : <c-type> ( -- type )
H{ H{
[[ "setter" [ "No setter" throw ] ]] { "setter" [ "No setter" throw ] }
[[ "getter" [ "No getter" throw ] ]] { "getter" [ "No getter" throw ] }
[[ "boxer" "no boxer" ]] { "boxer" "no boxer" }
[[ "unboxer" "no unboxer" ]] { "unboxer" "no unboxer" }
[[ "reg-class" T{ int-regs f } ]] { "reg-class" T{ int-regs f } }
[[ "width" 0 ]] { "width" 0 }
} clone ; } clone ;
SYMBOL: c-types SYMBOL: c-types

3
library/bootstrap/boot-stage1.factor
View File

@ -35,7 +35,6 @@ vectors words ;
"/library/collections/arrays.factor" "/library/collections/arrays.factor"
"/library/collections/strings.factor" "/library/collections/strings.factor"
"/library/collections/sbuf.factor" "/library/collections/sbuf.factor"
"/library/collections/assoc.factor"
"/library/collections/lists.factor" "/library/collections/lists.factor"
"/library/collections/vectors.factor" "/library/collections/vectors.factor"
"/library/collections/hashtables.factor" "/library/collections/hashtables.factor"
@ -148,7 +147,7 @@ vectors words ;
} [ dup print parse-resource % ] each } [ dup print parse-resource % ] each
[ [
[ "/library/bootstrap/boot-stage2.factor" run-resource ] "/library/bootstrap/boot-stage2.factor" run-resource
[ print-error die ] recover [ print-error die ] recover
] % ] %
] [ ] make ] [ ] make

16
library/bootstrap/image.factor
View File

@ -252,14 +252,20 @@ M: string ' ( string -- pointer )
( elements -- ) emit-seq ( elements -- ) emit-seq
align-here r> ; align-here r> ;
: transfer-tuple ( tuple -- tuple )
tuple>array
dup first transfer-word 0 pick set-nth
array>tuple ;
M: tuple ' ( tuple -- pointer ) M: tuple ' ( tuple -- pointer )
tuple>array tuple-type emit-array ; transfer-tuple
objects get [ tuple>array tuple-type emit-array ] cache ;
M: array ' ( array -- pointer ) M: array ' ( array -- pointer )
array-type emit-array ; array-type emit-array ;
M: vector ' ( vector -- pointer ) M: vector ' ( vector -- pointer )
dup array-type emit-array swap length dup underlying ' swap length
object-tag here-as >r object-tag here-as >r
vector-type >header emit vector-type >header emit
emit-fixnum ( length ) emit-fixnum ( length )
@ -269,11 +275,11 @@ M: vector ' ( vector -- pointer )
( Hashes ) ( Hashes )
M: hashtable ' ( hashtable -- pointer ) M: hashtable ' ( hashtable -- pointer )
dup underlying array-type emit-array [ underlying ' ] keep
swap hash-size
object-tag here-as >r object-tag here-as >r
hashtable-type >header emit hashtable-type >header emit
emit-fixnum ( length ) dup hash-count emit-fixnum
hash-deleted emit-fixnum
emit ( array ptr ) emit ( array ptr )
align-here r> ; align-here r> ;

7
library/bootstrap/primitives.factor
View File

@ -190,7 +190,7 @@ vocabularies get [ "syntax" set [ reveal ] each ] bind
{ "set-char-slot" "kernel-internals" } { "set-char-slot" "kernel-internals" }
{ "resize-array" "arrays" } { "resize-array" "arrays" }
{ "resize-string" "strings" } { "resize-string" "strings" }
{ "<hashtable>" "hashtables" } { "(hashtable)" "hashtables-internals" }
{ "<array>" "arrays" } { "<array>" "arrays" }
{ "<tuple>" "kernel-internals" } { "<tuple>" "kernel-internals" }
{ "begin-scan" "memory" } { "begin-scan" "memory" }
@ -315,8 +315,9 @@ num-types <array> builtins set
"hashtable?" "hashtables" create t "inline" set-word-prop "hashtable?" "hashtables" create t "inline" set-word-prop
"hashtable" "hashtables" create 10 "hashtable?" "hashtables" create "hashtable" "hashtables" create 10 "hashtable?" "hashtables" create
{ {
{ 1 { "hash-size" "hashtables" } { "set-hash-size" "kernel-internals" } } { 1 { "hash-count" "hashtables" } { "set-hash-count" "hashtables-internals" } }
{ 2 { "underlying" "sequences-internals" } { "set-underlying" "sequences-internals" } } { 2 { "hash-deleted" "hashtables" } { "set-hash-deleted" "hashtables-internals" } }
{ 3 { "underlying" "sequences-internals" } { "set-underlying" "sequences-internals" } }
} define-builtin } define-builtin
"vector?" "vectors" create t "inline" set-word-prop "vector?" "vectors" create t "inline" set-word-prop

23
library/collections/assoc.factor
View File

@ -1,23 +0,0 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: lists USING: kernel sequences ;
: assoc* ( key alist -- [[ key value ]] )
#! Look up a key/value pair.
[ car = ] find-with nip ;
: assoc ( key alist -- value ) assoc* cdr ;
: remove-assoc ( key alist -- alist )
#! Remove all key/value pairs with this key.
[ car = not ] subset-with ;
: acons ( value key alist -- alist )
#! Adds the key/value pair to the alist. Existing pairs with
#! this key are not removed; the new pair simply shadows
#! existing pairs.
>r swons r> cons ;
: set-assoc ( value key alist -- alist )
#! Adds the key/value pair to the alist.
dupd remove-assoc acons ;

364
library/collections/hashtables.factor
View File

@ -1,166 +1,225 @@
! Copyright (C) 2004, 2005 Slava Pestov. IN: hashtables-internals
! See http://factor.sf.net/license.txt for BSD license. USING: arrays hashtables kernel math sequences
IN: hashtables sequences-internals ;
USING: arrays generic kernel lists math sequences vectors
kernel-internals sequences-internals ;
! A hashtable is implemented as an array of buckets. The ! This hashtable implementation uses only one auxilliary array
! array index is determined using a hash function, and the ! in addition to the hashtable tuple itself. The array stores
! buckets are associative lists which are searched ! keys in even slots and values in odd slots. Values are looked
! linearly. ! up with a hashing strategy that uses linear probing to resolve
! collisions.
! The unsafe words go in kernel internals. Everything else, even ! There are two special objects: the ((tombstone)) marker and
! if it is somewhat 'implementation detail', is in the ! the ((empty)) marker. Neither of these markers can be used as
! public 'hashtables' vocabulary. ! hashtable keys.
: bucket-count ( hash -- n ) underlying array-capacity ; ! hash-count is the number of entries including deleted entries.
! hash-deleted is the number of deleted entries.
IN: kernel-internals TUPLE: tombstone ;
: hash-bucket ( n hash -- alist ) : ((empty)) T{ tombstone f } ; inline
>r >fixnum r> underlying array-nth ; : ((tombstone)) T{ tombstone t } ; inline
: set-hash-bucket ( obj n hash -- ) : hash@ ( key keys -- n )
>r >fixnum r> underlying set-array-nth ; #! Return an even key index.
>r hashcode r> length 2 /i rem 2 * ;
: change-bucket ( n hash quot -- ) : probe ( heys i -- hash i ) 2 + over length mod ;
-rot underlying
[ array-nth swap call ] 2keep
set-array-nth ; inline
: each-bucket ( hash quot -- | quot: n hash -- ) : (key@) ( key keys i -- n )
over bucket-count [ [ -rot call ] 3keep ] repeat 2drop ; 3dup swap nth-unsafe {
inline { [ dup ((tombstone)) eq? ] [ 2drop probe (key@) ] }
{ [ dup ((empty)) eq? ] [ 2drop 3drop -1 ] }
{ [ = ] [ 2nip ] }
{ [ t ] [ probe (key@) ] }
} cond ;
: hash-size+ ( hash -- ) dup hash-size 1+ swap set-hash-size ; : key@ ( key hash -- n )
: hash-size- ( hash -- ) dup hash-size 1- swap set-hash-size ; underlying 2dup hash@ (key@) ;
: grow-hash ( hash -- ) : if-key ( key hash true false -- | true: index key hash -- )
#! A good way to earn a living. >r >r [ key@ ] 2keep pick -1 > r> r> if ; inline
dup hash-size 2 * <array> swap set-underlying ;
: (set-bucket-count) ( n hash -- ) : <hash-array> ( n -- array )
>r <array> r> set-underlying ; 1+ 4 * ((empty)) <repeated> >array ;
IN: hashtables
: (hashcode) ( key table -- index ) : reset-hash ( n hash -- )
#! Compute the index of the bucket for a key. swap <hash-array> over set-underlying
>r hashcode r> bucket-count rem ; inline 0 over set-hash-count 0 swap set-hash-deleted ;
: hash* ( key table -- [[ key value ]] ) : (new-key@) ( key keys i -- n )
#! Look up a value in the hashtable. 3dup swap nth-unsafe dup tombstone? [
2dup (hashcode) swap hash-bucket assoc* ; flushable 2drop 2nip
: hash ( key table -- value ) hash* cdr ; flushable
: 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.
-rot 2dup (hashcode) over [
( quot key hash assoc -- )
swapd 2dup
assoc* [ rot hash-size- ] [ rot drop ] if
rot call
] change-bucket ; inline
: grow-hash? ( hash -- ? )
dup bucket-count 3 * 2 /i swap hash-size < ;
: hash>alist ( hash -- alist )
#! Push a list of key/value pairs in a hashtable.
underlying concat ; flushable
: (set-hash) ( value key hash -- )
dup hash-size+ [ set-assoc ] set-hash* ;
: set-bucket-count ( new hash -- )
dup hash>alist >r [ (set-bucket-count) ] keep r>
0 pick set-hash-size
[ unswons rot (set-hash) ] each-with ;
: grow-hash ( hash -- )
#! Increase the hashtable size if its too small.
dup grow-hash? [
dup hash-size new-size swap set-bucket-count
] [ ] [
drop = [ 2nip ] [ probe (new-key@) ] if
] if ; ] if ;
: set-hash ( value key table -- ) : new-key@ ( key hash -- n )
#! Store the value in the hashtable. Either replaces an underlying 2dup hash@ (new-key@) ;
#! existing value in the appropriate bucket, or adds a new
#! key/value pair.
dup grow-hash (set-hash) ;
: remove-hash ( key table -- ) : nth-pair ( n seq -- key value )
#! Remove a value from a hashtable. [ nth-unsafe ] 2keep >r 1+ r> nth-unsafe ;
[ remove-assoc ] set-hash* ;
: hash-clear ( hash -- ) : set-nth-pair ( value key n seq -- )
0 over set-hash-size [ f -rot set-hash-bucket ] each-bucket ; [ set-nth-unsafe ] 2keep >r 1+ r> set-nth-unsafe ;
: hash-count+ dup hash-count 1+ swap set-hash-count ;
: hash-deleted+ dup hash-deleted 1+ swap set-hash-deleted ;
: hash-deleted- dup hash-deleted 1- swap set-hash-deleted ;
: change-size ( hash old -- )
dup ((tombstone)) eq? [
drop hash-deleted-
] [
((empty)) eq? [ hash-count+ ] [ drop ] if
] if ;
: (set-hash) ( value key hash -- )
#! Store a value without growing the hashtable. Internal.
2dup new-key@ swap
[ underlying 2dup nth-unsafe ] keep
( value key n underlying old hash )
swap change-size set-nth-pair ;
: (each-pair) ( quot array i -- | quot: k v -- )
over length over number= [
3drop
] [
[
swap nth-pair over tombstone?
[ 3drop ] [ rot call ] if
] 3keep 2 + (each-pair)
] if ; inline
: each-pair ( array quot -- | quot: k v -- )
swap 0 (each-pair) ; inline
: (all-pairs?) ( quot array i -- ? | quot: k v -- ? )
over length over number= [
3drop t
] [
3dup >r >r >r swap nth-pair over tombstone? [
3drop r> r> r> 2 + (all-pairs?)
] [
rot call
[ r> r> r> 2 + (all-pairs?) ] [ r> r> r> 3drop f ] if
] if
] if ; inline
: all-pairs? ( array quot -- ? | quot: k v -- ? )
swap 0 (all-pairs?) ; inline
: hash>seq ( i hash -- seq )
underlying dup length 2 /i
[ 2 * pick + over nth-unsafe ] map
[ tombstone? not ] subset 2nip ;
IN: hashtables
: <hashtable> ( capacity -- hashtable )
(hashtable) [ reset-hash ] keep ;
: hash* ( key hash -- value ? )
[
nip >r 1+ r> underlying nth-unsafe t
] [
3drop f f
] if-key ;
: hash-contains? ( key hash -- ? )
[ 3drop t ] [ 3drop f ] if-key ;
: ?hash* ( key hash -- value/f ? )
dup [ hash* ] [ 2drop f f ] if ;
: hash ( key hash -- value ) hash* drop ; inline
: ?hash ( key hash -- value )
dup [ hash ] [ 2drop f ] if ;
: clear-hash ( hash -- )
[ underlying length ] keep reset-hash ;
: remove-hash ( key hash -- )
[
nip
dup hash-deleted+
underlying >r >r ((tombstone)) dup r> r> set-nth-pair
] [
3drop
] if-key ;
: hash-size ( hash -- n ) dup hash-count swap hash-deleted - ;
: grow-hash ( hash -- )
[ underlying ] keep
[ >r length r> reset-hash ] 2keep
swap [ swap pick (set-hash) ] each-pair drop ;
: ?grow-hash ( hash -- )
dup hash-count 1+ 4 * over underlying length >
[ dup grow-hash ] when drop ;
: set-hash ( value key hash -- ) dup ?grow-hash (set-hash) ;
: hash-keys ( hash -- keys ) 0 swap hash>seq ;
: hash-values ( hash -- keys ) 1 swap hash>seq ;
: hash>alist ( hash -- assoc )
dup hash-keys swap hash-values 2array flip ;
: alist>hash ( alist -- hash ) : alist>hash ( alist -- hash )
dup length 1 max <hashtable> swap [ length <hashtable> ] keep
[ unswons pick set-hash ] each ; foldable [ first2 swap pick (set-hash) ] each ;
: hash-keys ( hash -- list ) : hash-each ( hash quot -- | quot: k v -- )
hash>alist [ car ] map ; flushable #! Apply a quotation to each key/value pair.
>r underlying r> each-pair ; inline
: hash-values ( hash -- alist ) : hash-each-with ( obj hash quot -- | quot: obj k v -- )
hash>alist [ cdr ] map ; flushable swap [ 2swap [ >r -rot r> call ] 2keep ] hash-each 2drop ;
inline
: hash-each ( hash quot -- | quot: [[ k v ]] -- ) : hash-all? ( hash quot -- | quot: k v -- ? )
swap underlying [ swap each ] each-with ; inline #! Tests if every key/value pair satisfies the predicate.
>r underlying r> all-pairs? ; inline
: hash-each-with ( obj hash quot -- | quot: obj [[ k v ]] -- ) : hash-all-with? ( obj hash quot -- | quot: obj k v -- ? )
swap [ with ] hash-each 2drop ; inline swap
[ 2swap [ >r -rot r> call ] 2keep rot ] hash-all? 2nip ;
inline
: hash-all? ( hash quot -- | quot: [[ k v ]] -- ? ) : subhash? ( h1 h2 -- ? )
swap underlying [ swap all? ] all-with? ; inline
: hash-all-with? ( obj hash quot -- ? | quot: [[ k v ]] -- ? )
swap [ with rot ] hash-all? 2nip ; inline
: hash-contained? ( h1 h2 -- ? )
#! Test if h2 contains all the key/value pairs of h1. #! Test if h2 contains all the key/value pairs of h1.
swap [ swap [
uncons >r swap hash* dup [ >r swap hash* [ r> = ] [ r> 2drop f ] if
cdr r> =
] [
r> 2drop f
] if
] hash-all-with? ; flushable ] hash-all-with? ; flushable
: hash-filter-step ( quot assoc -- assoc n ) : hash-subset ( hash quot -- hash | quot: k v -- ? )
[ swap subset dup length ] keep length - ; inline
: (hash-filter) ( quot hash -- n )
#! Output the number of key/value pairs that were removed.
0 swap underlying [
pick >r swap >r hash-filter-step r> + swap r> -rot
] inject nip ; inline
: hash-filter ( hash quot -- | quot: [[ k v ]] -- ? )
#! Remove all key/value pairs that do not satisfy the
#! predicate.
swap [ (hash-filter) ] keep
[ hash-size + ] keep
set-hash-size ; inline
: hash-subset ( hash quot -- hash | quot: [[ k v ]] -- ? )
#! Make a new hash that only includes the key/value pairs #! Make a new hash that only includes the key/value pairs
#! which satisfy the predicate. #! which satisfy the predicate.
>r clone r> over >r hash-filter r> ; inline over hash-size <hashtable> rot [
2swap [
>r pick pick >r >r call [
r> r> swap r> set-hash
] [
r> r> r> 3drop
] if
] 2keep
] hash-each nip ; inline
: hash-subset-with ( obj hash quot -- hash ) : hash-subset-with ( obj hash quot -- hash | quot: obj { k v } -- ? )
swap [ with rot ] hash-subset 2nip ; inline swap
[ 2swap [ >r -rot r> call ] 2keep rot ] hash-subset 2nip ;
inline
M: hashtable clone ( hash -- hash ) clone-growable ; M: hashtable clone ( hash -- hash ) clone-growable ;
: hashtable= ( hash hash -- ? ) : hashtable= ( hash hash -- ? )
2dup hash-contained? >r swap hash-contained? r> and ; 2dup subhash? >r swap subhash? r> and ;
M: hashtable = ( obj hash -- ? ) M: hashtable = ( obj hash -- ? )
{ {
@ -170,41 +229,32 @@ M: hashtable = ( obj hash -- ? )
{ [ t ] [ hashtable= ] } { [ t ] [ hashtable= ] }
} cond ; } cond ;
M: hashtable hashcode ( hash -- n )
#! Poor.
hash-size ;
: cache ( key hash quot -- value | quot: key -- value )
pick pick hash [
>r 3drop r>
] [
pick rot >r >r call dup r> r> set-hash
] if* ; inline
: map>hash ( seq quot -- hash | quot: elt -- value )
over >r map r> dup length <hashtable> -rot
[ pick set-hash ] 2each ; inline
: ?hash ( key hash/f -- value/f ) : ?hash ( key hash/f -- value/f )
dup [ hash ] [ 2drop f ] if ; flushable dup [ hash ] [ 2drop f ] if ; flushable
: ?hash* ( key hash/f -- value/f ) : ?hash* ( key hash/f -- value/f )
dup [ hash* ] [ 2drop f ] if ; flushable dup [ hash* ] [ 2drop f f ] if ; flushable
: ?set-hash ( value key hash/f -- hash ) : ?set-hash ( value key hash/f -- hash )
[ 1 <hashtable> ] unless* [ set-hash ] keep ; [ 2 <hashtable> ] unless* [ set-hash ] keep ;
: hash-stack ( key seq -- value )
#! Searches for a key in a sequence of hashtables,
#! where the most recently pushed hashtable is searched
#! first.
[ dupd hash-contains? ] find-last nip ?hash ; flushable
: hash-intersect ( hash1 hash2 -- hash1/\hash2 ) : hash-intersect ( hash1 hash2 -- hash1/\hash2 )
#! Remove all keys from hash2 not in hash1. #! Remove all keys from hash2 not in hash1.
[ car swap hash ] hash-subset-with ; [ drop swap hash ] hash-subset-with ;
: hash-diff ( hash1 hash2 -- hash2-hash1 ) : hash-diff ( hash1 hash2 -- hash2-hash1 )
#! Remove all keys from hash2 in hash1. #! Remove all keys from hash2 in hash1.
[ car swap hash not ] hash-subset-with ; [ drop swap hash not ] hash-subset-with ;
: hash-update ( hash1 hash2 -- ) : hash-update ( hash1 hash2 -- )
#! Add all key/value pairs from hash2 to hash1. #! Add all key/value pairs from hash2 to hash1.
[ unswons rot set-hash ] hash-each-with ; [ swap rot set-hash ] hash-each-with ;
: hash-union ( hash1 hash2 -- hash1\/hash2 ) : hash-union ( hash1 hash2 -- hash1\/hash2 )
#! Make a new hashtable with all key/value pairs from #! Make a new hashtable with all key/value pairs from
@ -214,10 +264,18 @@ M: hashtable hashcode ( hash -- n )
: remove-all ( hash seq -- seq ) : remove-all ( hash seq -- seq )
#! Remove all elements from the sequence that are keys #! Remove all elements from the sequence that are keys
#! in the hashtable. #! in the hashtable.
[ swap hash* not ] subset-with ; flushable [ swap hash-contains? not ] subset-with ; flushable
: hash-stack ( key seq -- value ) : cache ( key hash quot -- value | quot: key -- value )
#! Searches for a key in a sequence of hashtables, pick pick hash [
#! where the most recently pushed hashtable is searched >r 3drop r>
#! first. ] [
[ dupd hash* ] find-last nip ?hash ; flushable pick rot >r >r call dup r> r> set-hash
] if* ; inline
: map>hash ( seq quot -- hash | quot: key -- value )
#! Construct a hashtable with keys from the sequence, and
#! values obtained by applying the quotation to each key.
swap [ length <hashtable> ] keep
[ -rot [ >r over >r call r> r> set-hash ] 2keep ] each nip ;
inline

5
library/collections/lists.factor
View File

@ -78,5 +78,6 @@ M: cons = ( obj cons -- ? )
M: f = ( obj f -- ? ) eq? ; M: f = ( obj f -- ? ) eq? ;
: curry ( obj quot -- quot ) : curry ( obj quot -- quot ) >r literalize r> cons ;
>r literalize r> cons ;
: assoc ( key alist -- value ) [ car = ] find-with nip cdr ;

9
library/collections/namespaces.factor
View File

@ -91,9 +91,10 @@ SYMBOL: hash-buffer
: (closure) ( key hash -- ) : (closure) ( key hash -- )
tuck hash dup [ tuck hash dup [
hash-keys [ [
dup dup closure, [ 2drop ] [ swap (closure) ] if drop dup dup closure,
] each-with [ 2drop ] [ swap (closure) ] if
] hash-each-with
] [ ] [
2drop 2drop
] if ; ] if ;
@ -108,7 +109,7 @@ SYMBOL: hash-buffer
IN: lists IN: lists
: alist>quot ( default alist -- quot ) : alist>quot ( default alist -- quot )
[ unswons [ % , , \ if , ] [ ] make ] each ; [ [ first2 swap % , , \ if , ] [ ] make ] each ;
IN: kernel-internals IN: kernel-internals

2
library/compiler/basic-blocks.factor
View File

@ -113,7 +113,7 @@ M: %peek trim-dead* ( tail vop -- )
: forget-stack-loc ( loc -- ) : forget-stack-loc ( loc -- )
#! Forget that any vregs hold this stack location. #! Forget that any vregs hold this stack location.
vreg-contents [ [ cdr swap = not ] hash-subset-with ] change ; vreg-contents [ [ nip swap = not ] hash-subset-with ] change ;
: remember-replace ( vop -- ) : remember-replace ( vop -- )
#! If a vreg claims to hold the stack location we are #! If a vreg claims to hold the stack location we are

14
library/compiler/xt.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2004, 2005 Slava Pestov. ! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license. ! See http://factor.sf.net/license.txt for BSD license.
IN: compiler IN: compiler
USING: assembler errors generic kernel lists math namespaces USING: assembler errors generic hashtables kernel lists math
prettyprint sequences strings vectors words ; namespaces prettyprint sequences strings vectors words ;
! We use a hashtable "compiled-xts" that maps words to ! We use a hashtable "compiled-xts" that maps words to
! xt's that are currently being compiled. The commit-xt's word ! xt's that are currently being compiled. The commit-xt's word
@ -16,16 +16,16 @@ prettyprint sequences strings vectors words ;
SYMBOL: compiled-xts SYMBOL: compiled-xts
: save-xt ( word -- ) : save-xt ( word -- )
compiled-offset swap compiled-xts [ acons ] change ; compiled-offset swap compiled-xts set-hash ;
: commit-xts ( -- ) : commit-xts ( -- )
#! We must flush the instruction cache on PowerPC. #! We must flush the instruction cache on PowerPC.
flush-icache flush-icache
compiled-xts get [ unswons set-word-xt ] each compiled-xts get [ swap set-word-xt ] hash-each
compiled-xts off ; compiled-xts off ;
: compiled-xt ( word -- xt ) : compiled-xt ( word -- xt )
dup compiled-xts get assoc [ ] [ word-xt ] ?if ; dup compiled-xts get hash [ ] [ word-xt ] ?if ;
! When a word is encountered that has not been previously ! When a word is encountered that has not been previously
! compiled, it is pushed onto this vector. Compilation stops ! compiled, it is pushed onto this vector. Compilation stops
@ -123,7 +123,7 @@ M: absolute-16/16 fixup ( absolute -- ) >absolute fixup-16/16 ;
dup compile-words get member? [ dup compile-words get member? [
drop t drop t
] [ ] [
compiled-xts get assoc compiled-xts get hash
] if ] if
] if ; ] if ;
@ -133,7 +133,7 @@ M: absolute-16/16 fixup ( absolute -- ) >absolute fixup-16/16 ;
: with-compiler ( quot -- ) : with-compiler ( quot -- )
[ [
deferred-xts off deferred-xts off
compiled-xts off H{ } clone compiled-xts set
V{ } clone compile-words set V{ } clone compile-words set
call call
fixup-xts fixup-xts

24
library/freetype/freetype-gl.factor
View File

@ -54,18 +54,18 @@ M: font = eq? ;
: ttf-name ( font style -- name ) : ttf-name ( font style -- name )
cons H{ cons H{
[[ [[ "Monospaced" plain ]] "VeraMono" ]] { [[ "Monospaced" plain ]] "VeraMono" }
[[ [[ "Monospaced" bold ]] "VeraMoBd" ]] { [[ "Monospaced" bold ]] "VeraMoBd" }
[[ [[ "Monospaced" bold-italic ]] "VeraMoBI" ]] { [[ "Monospaced" bold-italic ]] "VeraMoBI" }
[[ [[ "Monospaced" italic ]] "VeraMoIt" ]] { [[ "Monospaced" italic ]] "VeraMoIt" }
[[ [[ "Sans Serif" plain ]] "Vera" ]] { [[ "Sans Serif" plain ]] "Vera" }
[[ [[ "Sans Serif" bold ]] "VeraBd" ]] { [[ "Sans Serif" bold ]] "VeraBd" }
[[ [[ "Sans Serif" bold-italic ]] "VeraBI" ]] { [[ "Sans Serif" bold-italic ]] "VeraBI" }
[[ [[ "Sans Serif" italic ]] "VeraIt" ]] { [[ "Sans Serif" italic ]] "VeraIt" }
[[ [[ "Serif" plain ]] "VeraSe" ]] { [[ "Serif" plain ]] "VeraSe" }
[[ [[ "Serif" bold ]] "VeraSeBd" ]] { [[ "Serif" bold ]] "VeraSeBd" }
[[ [[ "Serif" bold-italic ]] "VeraBI" ]] { [[ "Serif" bold-italic ]] "VeraBI" }
[[ [[ "Serif" italic ]] "VeraIt" ]] { [[ "Serif" italic ]] "VeraIt" }
} hash ; } hash ;
: ttf-path ( name -- string ) : ttf-path ( name -- string )

2
library/freetype/load.factor
View File

@ -1,7 +1,7 @@
USING: alien io kernel parser sequences ; USING: alien io kernel parser sequences ;
"freetype" { "freetype" {
{ [ os "macosx" = ] [ "libfreetype.dylib.6" ] } { [ os "macosx" = ] [ "libfreetype.dylib" ] }
{ [ os "win32" = ] [ "freetype6.dll" ] } { [ os "win32" = ] [ "freetype6.dll" ] }
{ [ t ] [ "libfreetype.so.6" ] } { [ t ] [ "libfreetype.so.6" ] }
} cond "cdecl" add-library } cond "cdecl" add-library

17
library/generic/generic.factor
View File

@ -42,7 +42,7 @@ SYMBOL: builtins
: (types) ( class -- ) : (types) ( class -- )
#! Only valid for a flattened class. #! Only valid for a flattened class.
flatten [ flatten [
car dup superclass drop dup superclass
[ (types) ] [ "type" word-prop dup set ] ?if [ (types) ] [ "type" word-prop dup set ] ?if
] hash-each ; ] hash-each ;
@ -73,10 +73,11 @@ DEFER: class<
2dup eq? [ 2drop 0 ] [ class< 1 -1 ? ] if ; 2dup eq? [ 2drop 0 ] [ class< 1 -1 ? ] if ;
: methods ( generic -- alist ) : methods ( generic -- alist )
"methods" word-prop hash>alist [ 2car class-compare ] sort ; "methods" word-prop hash>alist
[ [ first ] 2apply class-compare ] sort ;
: order ( generic -- list ) : order ( generic -- list )
methods [ car ] map ; "methods" word-prop hash-keys [ class-compare ] sort ;
PREDICATE: compound generic ( word -- ? ) PREDICATE: compound generic ( word -- ? )
"combination" word-prop ; "combination" word-prop ;
@ -162,9 +163,9 @@ M: generic definer drop \ G: ;
: min-class ( class seq -- class/f ) : min-class ( class seq -- class/f )
#! Is this class the smallest class in the sequence? #! Is this class the smallest class in the sequence?
[ dupd classes-intersect? ] subset [ dupd classes-intersect? ] subset reverse-slice
[ class-compare neg ] sort tuck [ class< ] all-with? over empty? not and
tuck [ class< ] all-with? [ first ] [ drop f ] if ; [ first ] [ drop f ] if ;
: define-class ( class -- ) : define-class ( class -- )
dup t "class" set-word-prop dup t "class" set-word-prop
@ -173,7 +174,7 @@ M: generic definer drop \ G: ;
: implementors ( class -- list ) : implementors ( class -- list )
#! Find a list of generics that implement a method #! Find a list of generics that implement a method
#! specializing on this class. #! specializing on this class.
[ "methods" word-prop ?hash ] word-subset-with ; [ "methods" word-prop ?hash* nip ] word-subset-with ;
: classes ( -- list ) : classes ( -- list )
#! Output a list of all defined classes. #! Output a list of all defined classes.
@ -192,7 +193,7 @@ PREDICATE: word predicate "definition" word-prop ;
! Union classes for dispatch on multiple classes. ! Union classes for dispatch on multiple classes.
: union-predicate ( members -- list ) : union-predicate ( members -- list )
[ [
"predicate" word-prop \ dup swons [ drop t ] cons "predicate" word-prop \ dup swons [ drop t ] 2array
] map [ drop f ] swap alist>quot ; ] map [ drop f ] swap alist>quot ;
: set-members ( class members -- ) : set-members ( class members -- )

25
library/generic/standard-combination.factor
View File

@ -1,6 +1,6 @@
IN: generic IN: generic
USING: errors hashtables kernel kernel-internals lists math USING: arrays errors hashtables kernel kernel-internals lists
namespaces sequences vectors words ; math namespaces sequences vectors words ;
: error-method ( picker word -- method ) : error-method ( picker word -- method )
[ no-method ] curry append ; [ no-method ] curry append ;
@ -15,36 +15,39 @@ namespaces sequences vectors words ;
] if ; ] if ;
: class-predicates ( picker assoc -- assoc ) : class-predicates ( picker assoc -- assoc )
[ uncons >r "predicate" word-prop append r> cons ] map-with ; [
first2 >r "predicate" word-prop append r> 2array
] map-with ;
: sort-methods ( assoc n -- vtable ) : sort-methods ( assoc n -- vtable )
#! Input is a predicate -> method association. #! Input is a predicate -> method association.
#! n is vtable size (either num-types or num-tags).
[ [
type>class [ object bootstrap-word ] unless* type>class [ object bootstrap-word ] unless*
swap [ car classes-intersect? ] subset-with swap [ first classes-intersect? ] subset-with
] map-with ; ] map-with ;
: simplify-alist ( class alist -- default alist ) : simplify-alist ( class assoc -- default assoc )
dup cdr [ dup cdr [
2dup cdr car car class< [ 2dup cdr car first class< [
cdr simplify-alist cdr simplify-alist
] [ ] [
uncons >r cdr nip r> uncons >r second nip r>
] if ] if
] [ ] [
nip car cdr [ ] nip car second [ ]
] if ; ] if ;
: vtable-methods ( picker alist-seq -- alist-seq ) : vtable-methods ( picker alist-seq -- alist-seq )
dup length [ dup length [
type>class [ swap simplify-alist ] [ car cdr [ ] ] if* type>class [ swap simplify-alist ] [ car second [ ] ] if*
>r over r> class-predicates alist>quot >r over r> class-predicates alist>quot
] 2map nip ; ] 2map nip ;
: <vtable> ( picker word n -- vtable ) : <vtable> ( picker word n -- vtable )
#! n is vtable size; either num-types or num-tags. #! n is vtable size; either num-types or num-tags.
>r 2dup empty-method \ object bootstrap-word >r 2dup empty-method \ object bootstrap-word swap 2array
swons >r methods r> swons r> sort-methods vtable-methods ; >r methods >list r> swons r> sort-methods vtable-methods ;
: small-generic ( picker word -- def ) : small-generic ( picker word -- def )
2dup methods class-predicates >r empty-method r> alist>quot ; 2dup methods class-predicates >r empty-method r> alist>quot ;

2
library/inference/call-optimizers.factor
View File

@ -19,7 +19,7 @@ math math-internals sequences words ;
dup node-param "foldable" word-prop [ dup node-param "foldable" word-prop [
dup node-in-d [ dup node-in-d [
dup literal? dup literal?
[ 2drop t ] [ swap node-literals ?hash* ] if [ 2drop t ] [ swap node-literals ?hash* nip ] if
] all-with? ] all-with?
] [ ] [
drop f drop f

22
library/inference/known-words.factor
View File

@ -1,8 +1,8 @@
IN: inference IN: inference
USING: arrays alien assembler errors generic hashtables USING: arrays alien assembler errors generic hashtables
interpreter io io-internals kernel kernel-internals lists math hashtables-internals interpreter io io-internals kernel
math-internals memory parser sequences strings vectors words kernel-internals lists math math-internals memory parser
prettyprint ; sequences strings vectors words prettyprint ;
! We transform calls to these words into 'branched' forms; ! We transform calls to these words into 'branched' forms;
! eg, there is no VOP for fixnum<=, only fixnum<= followed ! eg, there is no VOP for fixnum<=, only fixnum<= followed
@ -35,17 +35,13 @@ prettyprint ;
dup "infer-effect" word-prop consume/produce dup "infer-effect" word-prop consume/produce
[ [ t ] [ f ] if ] infer-quot ; [ [ t ] [ f ] if ] infer-quot ;
{ fixnum<= fixnum< fixnum>= fixnum> eq? } [ { fixnum<= fixnum< fixnum>= fixnum> eq? }
dup dup literalize [ manual-branch ] cons [ dup [ manual-branch ] curry "infer" set-word-prop ] each
"infer" set-word-prop
] each
! Primitive combinators ! Primitive combinators
\ call [ [ general-list ] [ ] ] "infer-effect" set-word-prop \ call [ [ general-list ] [ ] ] "infer-effect" set-word-prop
\ call [ \ call [ pop-literal infer-quot-value ] "infer" set-word-prop
pop-literal infer-quot-value
] "infer" set-word-prop
\ execute [ [ word ] [ ] ] "infer-effect" set-word-prop \ execute [ [ word ] [ ] ] "infer-effect" set-word-prop
@ -63,7 +59,7 @@ prettyprint ;
\ cond [ [ object ] [ ] ] "infer-effect" set-word-prop \ cond [ [ object ] [ ] ] "infer-effect" set-word-prop
\ cond [ \ cond [
pop-literal [ first2 cons ] map reverse-slice pop-literal reverse-slice
[ no-cond ] swap alist>quot infer-quot-value [ no-cond ] swap alist>quot infer-quot-value
] "infer" set-word-prop ] "infer" set-word-prop
@ -470,8 +466,8 @@ prettyprint ;
\ resize-array [ [ fixnum array ] [ array ] ] "infer-effect" set-word-prop \ resize-array [ [ fixnum array ] [ array ] ] "infer-effect" set-word-prop
\ resize-string [ [ fixnum string ] [ string ] ] "infer-effect" set-word-prop \ resize-string [ [ fixnum string ] [ string ] ] "infer-effect" set-word-prop
\ <hashtable> [ [ number ] [ hashtable ] ] "infer-effect" set-word-prop \ (hashtable) [ [ ] [ hashtable ] ] "infer-effect" set-word-prop
\ <hashtable> t "flushable" set-word-prop \ (hashtable) t "flushable" set-word-prop
\ <array> [ [ number ] [ array ] ] "infer-effect" set-word-prop \ <array> [ [ number ] [ array ] ] "infer-effect" set-word-prop
\ <array> t "flushable" set-word-prop \ <array> t "flushable" set-word-prop

4
library/io/files.factor
View File

@ -13,9 +13,7 @@ styles ;
: directory? ( file -- ? ) stat car ; : directory? ( file -- ? ) stat car ;
: directory ( dir -- list ) : directory ( dir -- list )
(directory) (directory) [ { "." ".." } member? not ] subset string-sort ;
H{ [[ "." "." ]] [[ ".." ".." ]] }
swap remove-all string-sort ;
: file-length ( file -- length ) stat third ; : file-length ( file -- length ) stat third ;

464
library/sdl/sdl-keysym.factor
View File

@ -16,245 +16,245 @@ IN: sdl USING: namespaces ;
: keysyms : keysyms
H{ H{
! The keyboard syms have been cleverly chosen to map to ASCII ! The keyboard syms have been cleverly chosen to map to ASCII
[[ 0 "UNKNOWN" ]] { 0 "UNKNOWN" }
[[ 8 "BACKSPACE" ]] { 8 "BACKSPACE" }
[[ 9 "TAB" ]] { 9 "TAB" }
[[ 12 "CLEAR" ]] { 12 "CLEAR" }
[[ 13 "RETURN" ]] { 13 "RETURN" }
[[ 19 "PAUSE" ]] { 19 "PAUSE" }
[[ 27 "ESCAPE" ]] { 27 "ESCAPE" }
[[ 32 "SPACE" ]] { 32 "SPACE" }
[[ 33 "EXCLAIM" ]] { 33 "EXCLAIM" }
[[ 34 "QUOTEDBL" ]] { 34 "QUOTEDBL" }
[[ 35 "HASH" ]] { 35 "HASH" }
[[ 36 "DOLLAR" ]] { 36 "DOLLAR" }
[[ 38 "AMPERSAND" ]] { 38 "AMPERSAND" }
[[ 39 "QUOTE" ]] { 39 "QUOTE" }
[[ 40 "LEFTPAREN" ]] { 40 "LEFTPAREN" }
[[ 41 "RIGHTPAREN" ]] { 41 "RIGHTPAREN" }
[[ 42 "ASTERISK" ]] { 42 "ASTERISK" }
[[ 43 "PLUS" ]] { 43 "PLUS" }
[[ 44 "COMMA" ]] { 44 "COMMA" }
[[ 45 "MINUS" ]] { 45 "MINUS" }
[[ 46 "PERIOD" ]] { 46 "PERIOD" }
[[ 47 "SLASH" ]] { 47 "SLASH" }
[[ 48 0 ]] { 48 0 }
[[ 49 1 ]] { 49 1 }
[[ 50 2 ]] { 50 2 }
[[ 51 3 ]] { 51 3 }
[[ 52 4 ]] { 52 4 }
[[ 53 5 ]] { 53 5 }
[[ 54 6 ]] { 54 6 }
[[ 55 7 ]] { 55 7 }
[[ 56 8 ]] { 56 8 }
[[ 57 9 ]] { 57 9 }
[[ 58 "COLON" ]] { 58 "COLON" }
[[ 59 "SEMICOLON" ]] { 59 "SEMICOLON" }
[[ 60 "LESS" ]] { 60 "LESS" }
[[ 61 "EQUALS" ]] { 61 "EQUALS" }
[[ 62 "GREATER" ]] { 62 "GREATER" }
[[ 63 "QUESTION" ]] { 63 "QUESTION" }
[[ 64 "AT" ]] { 64 "AT" }
! Skip uppercase letters ! Skip uppercase letters
[[ 91 "LEFTBRACKET" ]] { 91 "LEFTBRACKET" }
[[ 92 "BACKSLASH" ]] { 92 "BACKSLASH" }
[[ 93 "RIGHTBRACKET" ]] { 93 "RIGHTBRACKET" }
[[ 94 "CARET" ]] { 94 "CARET" }
[[ 95 "UNDERSCORE" ]] { 95 "UNDERSCORE" }
[[ 96 "BACKQUOTE" ]] { 96 "BACKQUOTE" }
[[ 97 "a" ]] { 97 "a" }
[[ 98 "b" ]] { 98 "b" }
[[ 99 "c" ]] { 99 "c" }
[[ 100 "d" ]] { 100 "d" }
[[ 101 "e" ]] { 101 "e" }
[[ 102 "f" ]] { 102 "f" }
[[ 103 "g" ]] { 103 "g" }
[[ 104 "h" ]] { 104 "h" }
[[ 105 "i" ]] { 105 "i" }
[[ 106 "j" ]] { 106 "j" }
[[ 107 "k" ]] { 107 "k" }
[[ 108 "l" ]] { 108 "l" }
[[ 109 "m" ]] { 109 "m" }
[[ 110 "n" ]] { 110 "n" }
[[ 111 "o" ]] { 111 "o" }
[[ 112 "p" ]] { 112 "p" }
[[ 113 "q" ]] { 113 "q" }
[[ 114 "r" ]] { 114 "r" }
[[ 115 "s" ]] { 115 "s" }
[[ 116 "t" ]] { 116 "t" }
[[ 117 "u" ]] { 117 "u" }
[[ 118 "v" ]] { 118 "v" }
[[ 119 "w" ]] { 119 "w" }
[[ 120 "x" ]] { 120 "x" }
[[ 121 "y" ]] { 121 "y" }
[[ 122 "z" ]] { 122 "z" }
[[ 127 "DELETE" ]] { 127 "DELETE" }
! End of ASCII mapped keysyms ! End of ASCII mapped keysyms
! International keyboard syms ! International keyboard syms
[[ 160 "WORLD_0" ]] ! 0xA0 { 160 "WORLD_0" } ! 0xA0
[[ 161 "WORLD_1" ]] { 161 "WORLD_1" }
[[ 162 "WORLD_2" ]] { 162 "WORLD_2" }
[[ 163 "WORLD_3" ]] { 163 "WORLD_3" }
[[ 164 "WORLD_4" ]] { 164 "WORLD_4" }
[[ 165 "WORLD_5" ]] { 165 "WORLD_5" }
[[ 166 "WORLD_6" ]] { 166 "WORLD_6" }
[[ 167 "WORLD_7" ]] { 167 "WORLD_7" }
[[ 168 "WORLD_8" ]] { 168 "WORLD_8" }
[[ 169 "WORLD_9" ]] { 169 "WORLD_9" }
[[ 170 "WORLD_10" ]] { 170 "WORLD_10" }
[[ 171 "WORLD_11" ]] { 171 "WORLD_11" }
[[ 172 "WORLD_12" ]] { 172 "WORLD_12" }
[[ 173 "WORLD_13" ]] { 173 "WORLD_13" }
[[ 174 "WORLD_14" ]] { 174 "WORLD_14" }
[[ 175 "WORLD_15" ]] { 175 "WORLD_15" }
[[ 176 "WORLD_16" ]] { 176 "WORLD_16" }
[[ 177 "WORLD_17" ]] { 177 "WORLD_17" }
[[ 178 "WORLD_18" ]] { 178 "WORLD_18" }
[[ 179 "WORLD_19" ]] { 179 "WORLD_19" }
[[ 180 "WORLD_20" ]] { 180 "WORLD_20" }
[[ 181 "WORLD_21" ]] { 181 "WORLD_21" }
[[ 182 "WORLD_22" ]] { 182 "WORLD_22" }
[[ 183 "WORLD_23" ]] { 183 "WORLD_23" }
[[ 184 "WORLD_24" ]] { 184 "WORLD_24" }
[[ 185 "WORLD_25" ]] { 185 "WORLD_25" }
[[ 186 "WORLD_26" ]] { 186 "WORLD_26" }
[[ 187 "WORLD_27" ]] { 187 "WORLD_27" }
[[ 188 "WORLD_28" ]] { 188 "WORLD_28" }
[[ 189 "WORLD_29" ]] { 189 "WORLD_29" }
[[ 190 "WORLD_30" ]] { 190 "WORLD_30" }
[[ 191 "WORLD_31" ]] { 191 "WORLD_31" }
[[ 192 "WORLD_32" ]] { 192 "WORLD_32" }
[[ 193 "WORLD_33" ]] { 193 "WORLD_33" }
[[ 194 "WORLD_34" ]] { 194 "WORLD_34" }
[[ 195 "WORLD_35" ]] { 195 "WORLD_35" }
[[ 196 "WORLD_36" ]] { 196 "WORLD_36" }
[[ 197 "WORLD_37" ]] { 197 "WORLD_37" }
[[ 198 "WORLD_38" ]] { 198 "WORLD_38" }
[[ 199 "WORLD_39" ]] { 199 "WORLD_39" }
[[ 200 "WORLD_40" ]] { 200 "WORLD_40" }
[[ 201 "WORLD_41" ]] { 201 "WORLD_41" }
[[ 202 "WORLD_42" ]] { 202 "WORLD_42" }
[[ 203 "WORLD_43" ]] { 203 "WORLD_43" }
[[ 204 "WORLD_44" ]] { 204 "WORLD_44" }
[[ 205 "WORLD_45" ]] { 205 "WORLD_45" }
[[ 206 "WORLD_46" ]] { 206 "WORLD_46" }
[[ 207 "WORLD_47" ]] { 207 "WORLD_47" }
[[ 208 "WORLD_48" ]] { 208 "WORLD_48" }
[[ 209 "WORLD_49" ]] { 209 "WORLD_49" }
[[ 210 "WORLD_50" ]] { 210 "WORLD_50" }
[[ 211 "WORLD_51" ]] { 211 "WORLD_51" }
[[ 212 "WORLD_52" ]] { 212 "WORLD_52" }
[[ 213 "WORLD_53" ]] { 213 "WORLD_53" }
[[ 214 "WORLD_54" ]] { 214 "WORLD_54" }
[[ 215 "WORLD_55" ]] { 215 "WORLD_55" }
[[ 216 "WORLD_56" ]] { 216 "WORLD_56" }
[[ 217 "WORLD_57" ]] { 217 "WORLD_57" }
[[ 218 "WORLD_58" ]] { 218 "WORLD_58" }
[[ 219 "WORLD_59" ]] { 219 "WORLD_59" }
[[ 220 "WORLD_60" ]] { 220 "WORLD_60" }
[[ 221 "WORLD_61" ]] { 221 "WORLD_61" }
[[ 222 "WORLD_62" ]] { 222 "WORLD_62" }
[[ 223 "WORLD_63" ]] { 223 "WORLD_63" }
[[ 224 "WORLD_64" ]] { 224 "WORLD_64" }
[[ 225 "WORLD_65" ]] { 225 "WORLD_65" }
[[ 226 "WORLD_66" ]] { 226 "WORLD_66" }
[[ 227 "WORLD_67" ]] { 227 "WORLD_67" }
[[ 228 "WORLD_68" ]] { 228 "WORLD_68" }
[[ 229 "WORLD_69" ]] { 229 "WORLD_69" }
[[ 230 "WORLD_70" ]] { 230 "WORLD_70" }
[[ 231 "WORLD_71" ]] { 231 "WORLD_71" }
[[ 232 "WORLD_72" ]] { 232 "WORLD_72" }
[[ 233 "WORLD_73" ]] { 233 "WORLD_73" }
[[ 234 "WORLD_74" ]] { 234 "WORLD_74" }
[[ 235 "WORLD_75" ]] { 235 "WORLD_75" }
[[ 236 "WORLD_76" ]] { 236 "WORLD_76" }
[[ 237 "WORLD_77" ]] { 237 "WORLD_77" }
[[ 238 "WORLD_78" ]] { 238 "WORLD_78" }
[[ 239 "WORLD_79" ]] { 239 "WORLD_79" }
[[ 240 "WORLD_80" ]] { 240 "WORLD_80" }
[[ 241 "WORLD_81" ]] { 241 "WORLD_81" }
[[ 242 "WORLD_82" ]] { 242 "WORLD_82" }
[[ 243 "WORLD_83" ]] { 243 "WORLD_83" }
[[ 244 "WORLD_84" ]] { 244 "WORLD_84" }
[[ 245 "WORLD_85" ]] { 245 "WORLD_85" }
[[ 246 "WORLD_86" ]] { 246 "WORLD_86" }
[[ 247 "WORLD_87" ]] { 247 "WORLD_87" }
[[ 248 "WORLD_88" ]] { 248 "WORLD_88" }
[[ 249 "WORLD_89" ]] { 249 "WORLD_89" }
[[ 250 "WORLD_90" ]] { 250 "WORLD_90" }
[[ 251 "WORLD_91" ]] { 251 "WORLD_91" }
[[ 252 "WORLD_92" ]] { 252 "WORLD_92" }
[[ 253 "WORLD_93" ]] { 253 "WORLD_93" }
[[ 254 "WORLD_94" ]] { 254 "WORLD_94" }
[[ 255 "WORLD_95" ]] ! 0xFF { 255 "WORLD_95" } ! 0xFF
! Numeric keypad ! Numeric keypad
[[ 256 "KP0" ]] { 256 "KP0" }
[[ 257 "KP1" ]] { 257 "KP1" }
[[ 258 "KP2" ]] { 258 "KP2" }
[[ 259 "KP3" ]] { 259 "KP3" }
[[ 260 "KP4" ]] { 260 "KP4" }
[[ 261 "KP5" ]] { 261 "KP5" }
[[ 262 "KP6" ]] { 262 "KP6" }
[[ 263 "KP7" ]] { 263 "KP7" }
[[ 264 "KP8" ]] { 264 "KP8" }
[[ 265 "KP9" ]] { 265 "KP9" }
[[ 266 "KP_PERIOD" ]] { 266 "KP_PERIOD" }
[[ 267 "KP_DIVIDE" ]] { 267 "KP_DIVIDE" }
[[ 268 "KP_MULTIPLY" ]] { 268 "KP_MULTIPLY" }
[[ 269 "KP_MINUS" ]] { 269 "KP_MINUS" }
[[ 270 "KP_PLUS" ]] { 270 "KP_PLUS" }
[[ 271 "KP_ENTER" ]] { 271 "KP_ENTER" }
[[ 272 "KP_EQUALS" ]] { 272 "KP_EQUALS" }
! Arrows + Home/End pad ! Arrows + Home/End pad
[[ 273 "UP" ]] { 273 "UP" }
[[ 274 "DOWN" ]] { 274 "DOWN" }
[[ 275 "RIGHT" ]] { 275 "RIGHT" }
[[ 276 "LEFT" ]] { 276 "LEFT" }
[[ 277 "INSERT" ]] { 277 "INSERT" }
[[ 278 "HOME" ]] { 278 "HOME" }
[[ 279 "END" ]] { 279 "END" }
[[ 280 "PAGEUP" ]] { 280 "PAGEUP" }
[[ 281 "PAGEDOWN" ]] { 281 "PAGEDOWN" }
! Function keys ! Function keys
[[ 282 "F1" ]] { 282 "F1" }
[[ 283 "F2" ]] { 283 "F2" }
[[ 284 "F3" ]] { 284 "F3" }
[[ 285 "F4" ]] { 285 "F4" }
[[ 286 "F5" ]] { 286 "F5" }
[[ 287 "F6" ]] { 287 "F6" }
[[ 288 "F7" ]] { 288 "F7" }
[[ 289 "F8" ]] { 289 "F8" }
[[ 290 "F9" ]] { 290 "F9" }
[[ 291 "F10" ]] { 291 "F10" }
[[ 292 "F11" ]] { 292 "F11" }
[[ 293 "F12" ]] { 293 "F12" }
[[ 294 "F13" ]] { 294 "F13" }
[[ 295 "F14" ]] { 295 "F14" }
[[ 296 "F15" ]] { 296 "F15" }
! Key state modifier keys ! Key state modifier keys
[[ 300 "NUMLOCK" ]] { 300 "NUMLOCK" }
[[ 301 "CAPSLOCK" ]] { 301 "CAPSLOCK" }
[[ 302 "SCROLLOCK" ]] { 302 "SCROLLOCK" }
[[ 303 "RSHIFT" ]] { 303 "RSHIFT" }
[[ 304 "LSHIFT" ]] { 304 "LSHIFT" }
[[ 305 "RCTRL" ]] { 305 "RCTRL" }
[[ 306 "LCTRL" ]] { 306 "LCTRL" }
[[ 307 "RALT" ]] { 307 "RALT" }
[[ 308 "LALT" ]] { 308 "LALT" }
[[ 309 "RMETA" ]] { 309 "RMETA" }
[[ 310 "LMETA" ]] { 310 "LMETA" }
[[ 311 "LSUPER" ]] ! Left "Windows" key { 311 "LSUPER" } ! Left "Windows" key
[[ 312 "RSUPER" ]] ! Right "Windows" key { 312 "RSUPER" } ! Right "Windows" key
[[ 313 "MODE" ]] ! "Alt Gr" key { 313 "MODE" } ! "Alt Gr" key
[[ 314 "COMPOSE" ]] ! Multi-key compose key { 314 "COMPOSE" } ! Multi-key compose key
! Miscellaneous function keys ! Miscellaneous function keys
[[ 315 "HELP" ]] { 315 "HELP" }
[[ 316 "PRINT" ]] { 316 "PRINT" }
[[ 317 "SYSREQ" ]] { 317 "SYSREQ" }
[[ 318 "BREAK" ]] { 318 "BREAK" }
[[ 319 "MENU" ]] { 319 "MENU" }
[[ 320 "POWER" ]] ! Power Macintosh power key { 320 "POWER" } ! Power Macintosh power key
[[ 321 "EURO" ]] ! Some european keyboards { 321 "EURO" } ! Some european keyboards
[[ 322 "UNDO" ]] ! Atari keyboard has Undo { 322 "UNDO" } ! Atari keyboard has Undo
! Add any other keys here ! Add any other keys here
} ; } ;

26
library/syntax/parse-words.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2005 Slava Pestov. ! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license. ! See http://factor.sf.net/license.txt for BSD license.
IN: parser IN: parser
USING: errors kernel lists math namespaces sequences io USING: errors hashtables kernel lists math namespaces sequences
strings words ; io strings words ;
! The parser uses a number of variables: ! The parser uses a number of variables:
! line - the line being parsed ! line - the line being parsed
@ -84,17 +84,17 @@ global [ string-mode off ] bind
(until-eol) (until) ; (until-eol) (until) ;
: escape ( ch -- esc ) : escape ( ch -- esc )
[ H{
[[ CHAR: e CHAR: \e ]] { CHAR: e CHAR: \e }
[[ CHAR: n CHAR: \n ]] { CHAR: n CHAR: \n }
[[ CHAR: r CHAR: \r ]] { CHAR: r CHAR: \r }
[[ CHAR: t CHAR: \t ]] { CHAR: t CHAR: \t }
[[ CHAR: s CHAR: \s ]] { CHAR: s CHAR: \s }
[[ CHAR: \s CHAR: \s ]] { CHAR: \s CHAR: \s }
[[ CHAR: 0 CHAR: \0 ]] { CHAR: 0 CHAR: \0 }
[[ CHAR: \\ CHAR: \\ ]] { CHAR: \\ CHAR: \\ }
[[ CHAR: \" CHAR: \" ]] { CHAR: \" CHAR: \" }
] assoc dup [ "Bad escape" throw ] unless ; } hash dup [ "Bad escape" throw ] unless ;
: next-escape ( n str -- ch n ) : next-escape ( n str -- ch n )
2dup nth CHAR: u = [ 2dup nth CHAR: u = [

14
library/syntax/prettyprint.factor
View File

@ -175,13 +175,13 @@ GENERIC: pprint* ( obj -- )
: vocab-style ( vocab -- style ) : vocab-style ( vocab -- style )
H{ H{
[[ "syntax" [ [[ foreground { 0.5 0.5 0.5 1.0 } ]] ] ]] { "syntax" [ [[ foreground { 0.5 0.5 0.5 1.0 } ]] ] }
[[ "kernel" [ [[ foreground { 0.0 0.0 0.5 1.0 } ]] ] ]] { "kernel" [ [[ foreground { 0.0 0.0 0.5 1.0 } ]] ] }
[[ "sequences" [ [[ foreground { 0.5 0.0 0.0 1.0 } ]] ] ]] { "sequences" [ [[ foreground { 0.5 0.0 0.0 1.0 } ]] ] }
[[ "math" [ [[ foreground { 0.0 0.5 0.0 1.0 } ]] ] ]] { "math" [ [[ foreground { 0.0 0.5 0.0 1.0 } ]] ] }
[[ "math-internals" [ [[ foreground { 0.75 0.0 0.0 1.0 } ]] ] ]] { "math-internals" [ [[ foreground { 0.75 0.0 0.0 1.0 } ]] ] }
[[ "kernel-internals" [ [[ foreground { 0.75 0.0 0.0 1.0 } ]] ] ]] { "kernel-internals" [ [[ foreground { 0.75 0.0 0.0 1.0 } ]] ] }
[[ "io-internals" [ [[ foreground { 0.75 0.0 0.0 1.0 } ]] ] ]] { "io-internals" [ [[ foreground { 0.75 0.0 0.0 1.0 } ]] ] }
} hash ; } hash ;
: word-style ( word -- style ) : word-style ( word -- style )

12
library/syntax/see.factor
View File

@ -70,16 +70,14 @@ M: word (see) drop ;
M: compound (see) M: compound (see)
dup word-def swap see-body ; dup word-def swap see-body ;
: method. ( word [[ class method ]] -- ) : method. ( word class method -- )
\ M: pprint-word \ M: pprint-word
unswons pprint-word >r pprint-word pprint-word r>
swap pprint-word <block pprint-elements pprint-; block; ;
<block pprint-elements pprint-;
block; ;
M: generic (see) M: generic (see)
dup dup "combination" word-prop swap see-body dup dup "combination" word-prop swap see-body
dup methods [ newline method. ] each-with ; dup methods [ newline first2 method. ] each-with ;
GENERIC: class. ( word -- ) GENERIC: class. ( word -- )
@ -88,7 +86,7 @@ GENERIC: class. ( word -- )
dup class? [ dup class? [
dup implementors [ dup implementors [
newline newline
dup in. tuck "methods" word-prop hash* method. dup in. tuck dupd "methods" word-prop hash method.
] each-with ] each-with
] [ ] [
drop drop

24
library/test/benchmark/hashtables.factor
View File

@ -1,17 +1,23 @@
IN: temporary IN: temporary
USING: compiler hashtables kernel math memory namespaces USING: compiler new-hash kernel math memory namespaces
sequences strings test ; sequences strings test ;
: store-hash ( hashtable seq -- ) : hash-bench-step ( hash elt -- )
[ dup pick set-hash ] each drop ; 3 random-int {
{ [ dup 0 = ] [ drop dup rot set-hash ] }
: lookup-hash ( hashtable seq -- ) { [ dup 1 = ] [ drop swap remove-hash ] }
[ over hash drop ] each drop ; { [ dup 2 = ] [ drop swap hash drop ] }
} cond ;
: hashtable-benchmark ( seq -- ) : hashtable-benchmark ( seq -- )
100 [ 10000 <hashtable> swap 10 [
drop drop
100000 <hashtable> swap 2dup store-hash lookup-hash [
] each-with ; compiled [
( hash elt -- )
hash-bench-step
] each-with
] 2keep
] each 2drop ; compiled
[ ] [ [ string? ] instances hashtable-benchmark ] unit-test [ ] [ [ string? ] instances hashtable-benchmark ] unit-test

139
library/test/collections/hashtables.factor
View File

@ -1,5 +1,4 @@
IN: temporary IN: temporary
USE: hashtables
USE: kernel USE: kernel
USE: lists USE: lists
USE: math USE: math
@ -8,15 +7,16 @@ USE: test
USE: vectors USE: vectors
USE: sequences USE: sequences
USE: sequences-internals USE: sequences-internals
USE: hashtables
USE: io
USE: prettyprint
16 <hashtable> "testhash" set [ H{ } ] [ { } [ ] map>hash ] unit-test
: silly-key/value dup dup * swap ; 1000 [ sq ] map>hash "testhash" set
1000 [ silly-key/value "testhash" get set-hash ] each [ V{ } ]
[ 1000 [ dup sq swap "testhash" get hash = not ] subset ]
[ f ]
[ 1000 >list [ silly-key/value "testhash" get hash = not ] subset ]
unit-test unit-test
[ t ] [ t ]
@ -46,25 +46,60 @@ f 100000000000000000000000000 "testhash" get set-hash
{ } { [ { } ] } "testhash" get set-hash { } { [ { } ] } "testhash" get set-hash
[ t ] [ C{ 2 3 } "testhash" get hash ] unit-test [ t ] [ C{ 2 3 } "testhash" get hash ] unit-test
[ f ] [ 100000000000000000000000000 "testhash" get hash* cdr ] unit-test [ f ] [ 100000000000000000000000000 "testhash" get hash* drop ] unit-test
[ { } ] [ { [ { } ] } clone "testhash" get hash* cdr ] unit-test [ { } ] [ { [ { } ] } clone "testhash" get hash* drop ] unit-test
[ {
[[ "salmon" "fish" ]] { "salmon" "fish" }
[[ "crocodile" "reptile" ]] { "crocodile" "reptile" }
[[ "cow" "mammal" ]] { "cow" "mammal" }
[[ "visual basic" "language" ]] { "visual basic" "language" }
] alist>hash "testhash" set } alist>hash "testhash" set
[ f ] [ [ f f ] [
"visual basic" "testhash" get remove-hash "visual basic" "testhash" get remove-hash
"visual basic" "testhash" get hash* "visual basic" "testhash" get hash*
] unit-test ] unit-test
[ 4 ] [ [ t ] [ H{ } dup subhash? ] unit-test
"hey" [ f ] [ H{ { 1 3 } } H{ } subhash? ] unit-test
H{ [[ "hey" 4 ]] [[ "whey" 5 ]] } 2dup (hashcode) [ t ] [ H{ } H{ { 1 3 } } subhash? ] unit-test
swap underlying nth assoc [ t ] [ H{ { 1 3 } } H{ { 1 3 } } subhash? ] unit-test
[ f ] [ H{ { 1 3 } } H{ { 1 "hey" } } subhash? ] unit-test
[ f ] [ H{ { 1 f } } H{ } subhash? ] unit-test
[ t ] [ H{ { 1 f } } H{ { 1 f } } subhash? ] unit-test
[ t ] [ H{ } dup = ] unit-test
[ f ] [ "xyz" H{ } = ] unit-test
[ t ] [ H{ } H{ } = ] unit-test
[ f ] [ H{ { 1 3 } } H{ } = ] unit-test
[ f ] [ H{ } H{ { 1 3 } } = ] unit-test
[ t ] [ H{ { 1 3 } } H{ { 1 3 } } = ] unit-test
[ f ] [ H{ { 1 3 } } H{ { 1 "hey" } } = ] unit-test
! Test some combinators
[
{ 4 14 32 }
] [
[
2 H{
{ 1 2 }
{ 3 4 }
{ 5 6 }
} [ * + , ] hash-each-with
] { } make
] unit-test
[ t ] [ H{ } [ 2drop f ] hash-all? ] unit-test
[ t ] [ H{ { 1 1 } } [ = ] hash-all? ] unit-test
[ f ] [ H{ { 1 2 } } [ = ] hash-all? ] unit-test
[ t ] [ H{ { 1 1 } { 2 2 } } [ = ] hash-all? ] unit-test
[ f ] [ H{ { 1 2 } { 2 2 } } [ = ] hash-all? ] unit-test
[ H{ } ] [ H{ { t f } { f t } } [ 2drop f ] hash-subset ] unit-test
[ H{ { 3 4 } { 4 5 } { 6 7 } } ] [
3 H{ { 1 2 } { 2 3 } { 3 4 } { 4 5 } { 6 7 } }
[ drop <= ] hash-subset-with
] unit-test ] unit-test
! Testing the hash element counting ! Testing the hash element counting
@ -79,22 +114,6 @@ H{ } clone "counting" set
"key" "counting" get remove-hash "key" "counting" get remove-hash
[ 0 ] [ "counting" get hash-size ] unit-test [ 0 ] [ "counting" get hash-size ] unit-test
[ t ] [ H{ } dup hash-contained? ] unit-test
[ f ] [ H{ [[ 1 3 ]] } H{ } hash-contained? ] unit-test
[ t ] [ H{ } H{ [[ 1 3 ]] } hash-contained? ] unit-test
[ t ] [ H{ [[ 1 3 ]] } H{ [[ 1 3 ]] } hash-contained? ] unit-test
[ f ] [ H{ [[ 1 3 ]] } H{ [[ 1 "hey" ]] } hash-contained? ] unit-test
[ f ] [ H{ [[ 1 f ]] } H{ } hash-contained? ] unit-test
[ t ] [ H{ [[ 1 f ]] } H{ [[ 1 f ]] } hash-contained? ] unit-test
[ t ] [ H{ } dup = ] unit-test
[ f ] [ "xyz" H{ } = ] unit-test
[ t ] [ H{ } H{ } = ] unit-test
[ f ] [ H{ [[ 1 3 ]] } H{ } = ] unit-test
[ f ] [ H{ } H{ [[ 1 3 ]] } = ] unit-test
[ t ] [ H{ [[ 1 3 ]] } H{ [[ 1 3 ]] } = ] unit-test
[ f ] [ H{ [[ 1 3 ]] } H{ [[ 1 "hey" ]] } = ] unit-test
! Test rehashing ! Test rehashing
2 <hashtable> "rehash" set 2 <hashtable> "rehash" set
@ -110,7 +129,7 @@ H{ } clone "counting" set
[ 6 ] [ "rehash" get clone hash-size ] unit-test [ 6 ] [ "rehash" get clone hash-size ] unit-test
"rehash" get hash-clear "rehash" get clear-hash
[ 0 ] [ "rehash" get hash-size ] unit-test [ 0 ] [ "rehash" get hash-size ] unit-test
@ -118,8 +137,8 @@ H{ } clone "counting" set
3 3
] [ ] [
2 H{ 2 H{
[[ 1 2 ]] { 1 2 }
[[ 2 3 ]] { 2 3 }
} clone hash } clone hash
] unit-test ] unit-test
@ -132,11 +151,11 @@ H{ } clone "counting" set
[ 21 ] [ [ 21 ] [
0 H{ 0 H{
[[ 1 2 ]] { 1 2 }
[[ 3 4 ]] { 3 4 }
[[ 5 6 ]] { 5 6 }
} [ } [
uncons + + + +
] hash-each ] hash-each
] unit-test ] unit-test
@ -148,42 +167,26 @@ H{ } clone "cache-test" set
[ 5 ] [ 2 "cache-test" get [ 3 + ] cache ] unit-test [ 5 ] [ 2 "cache-test" get [ 3 + ] cache ] unit-test
[ [
H{ [[ "factor" "rocks" ]] [[ 3 4 ]] } H{ { "factor" "rocks" } { 3 4 } }
] [ ] [
H{ [[ "factor" "rocks" ]] [[ "dup" "sq" ]] [[ 3 4 ]] } H{ { "factor" "rocks" } { "dup" "sq" } { 3 4 } }
H{ [[ "factor" "rocks" ]] [[ 1 2 ]] [[ 2 3 ]] [[ 3 4 ]] } H{ { "factor" "rocks" } { 1 2 } { 2 3 } { 3 4 } }
hash-intersect hash-intersect
] unit-test ] unit-test
[ [
H{ [[ 1 2 ]] [[ 2 3 ]] } H{ { 1 2 } { 2 3 } }
] [ ] [
H{ [[ "factor" "rocks" ]] [[ "dup" "sq" ]] [[ 3 4 ]] } H{ { "factor" "rocks" } { "dup" "sq" } { 3 4 } }
H{ [[ "factor" "rocks" ]] [[ 1 2 ]] [[ 2 3 ]] [[ 3 4 ]] } H{ { "factor" "rocks" } { 1 2 } { 2 3 } { 3 4 } }
hash-diff hash-diff
] unit-test ] unit-test
[ [
2 H{ { 1 2 } { 2 3 } { 6 5 } }
] [ ] [
H{ [[ "factor" "rocks" ]] [[ "dup" "sq" ]] [[ 3 4 ]] } H{ { 2 4 } { 6 5 } } H{ { 1 2 } { 2 3 } }
H{ [[ "factor" "rocks" ]] [[ 1 2 ]] [[ 2 3 ]] [[ 3 4 ]] }
hash-diff hash-size
] unit-test
[
t
] [
H{ [[ "hello" "world" ]] }
clone
100 [ 1+ over set-bucket-count hashcode ] map-with all-equal?
] unit-test
[
H{ [[ 1 2 ]] [[ 2 3 ]] [[ 6 5 ]] }
] [
H{ [[ 2 4 ]] [[ 6 5 ]] } H{ [[ 1 2 ]] [[ 2 3 ]] }
hash-union hash-union
] unit-test ] unit-test
[ [ 1 3 ] ] [ H{ [[ 2 2 ]] } [ 1 2 3 ] remove-all ] unit-test [ { 1 3 } ] [ H{ { 2 2 } } { 1 2 3 } remove-all ] unit-test

19
library/test/compiler/optimizer.factor
View File

@ -110,35 +110,37 @@ IN: temporary
] unit-test ] unit-test
! Test method inlining ! Test method inlining
[ f ] [ fixnum { } min-class ] unit-test
[ string ] [ [ string ] [
\ string \ string
[ repeated integer string array reversed sbuf [ repeated integer string array reversed sbuf
slice vector general-list ] slice vector general-list ]
min-class [ class-compare ] sort min-class
] unit-test ] unit-test
[ f ] [ [ f ] [
\ fixnum \ fixnum
[ fixnum integer letter ] [ fixnum integer letter ]
min-class [ class-compare ] sort min-class
] unit-test ] unit-test
[ fixnum ] [ [ fixnum ] [
\ fixnum \ fixnum
[ fixnum integer object ] [ fixnum integer object ]
min-class [ class-compare ] sort min-class
] unit-test ] unit-test
[ integer ] [ [ integer ] [
\ fixnum \ fixnum
[ integer float object ] [ integer float object ]
min-class [ class-compare ] sort min-class
] unit-test ] unit-test
[ object ] [ [ object ] [
\ word \ word
[ integer float object ] [ integer float object ]
min-class [ class-compare ] sort min-class
] unit-test ] unit-test
GENERIC: xyz GENERIC: xyz
@ -232,9 +234,16 @@ TUPLE: pred-test ;
[ ] [ double-recursion ] unit-test [ ] [ double-recursion ] unit-test
! regression
: double-label-1 : double-label-1
[ f double-label-1 ] [ swap nth-unsafe ] if ; inline [ f double-label-1 ] [ swap nth-unsafe ] if ; inline
: double-label-2 : double-label-2
dup general-list? [ ] [ ] if 0 t double-label-1 ; compiled dup general-list? [ ] [ ] if 0 t double-label-1 ; compiled
[ 0 ] [ 10 double-label-2 ] unit-test [ 0 ] [ 10 double-label-2 ] unit-test
! regression
GENERIC: void-generic
: breakage "hi" void-generic ;
[ ] [ \ breakage compile ] unit-test
[ breakage ] unit-test-fails

30
library/test/lists/assoc.factor
View File

@ -1,30 +0,0 @@
IN: temporary
USE: lists
USE: math
USE: namespaces
USE: test
[
[[ "monkey" 1 ]]
[[ "banana" 2 ]]
[[ "Java" 3 ]]
[[ t "true" ]]
[[ f "false" ]]
[[ [ 1 2 ] [ 2 1 ] ]]
] "assoc" set
[ f ] [ "monkey" f assoc ] unit-test
[ f ] [ "donkey" "assoc" get assoc ] unit-test
[ 1 ] [ "monkey" "assoc" get assoc ] unit-test
[ "false" ] [ f "assoc" get assoc ] unit-test
[ [ 2 1 ] ] [ [ 1 2 ] "assoc" get assoc ] unit-test
"is great" "Java" "assoc" get set-assoc "assoc" set
[ "is great" ] [ "Java" "assoc" get assoc ] unit-test
[
[[ "one" 1 ]]
[[ "two" 2 ]]
[[ "four" 4 ]]
] "value-alist" set

2
library/test/test.factor
View File

@ -74,7 +74,7 @@ SYMBOL: failures
: tests : tests
{ {
"lists/cons" "lists/lists" "lists/assoc" "lists/cons" "lists/lists"
"lists/namespaces" "lists/namespaces"
"combinators" "combinators"
"continuations" "errors" "continuations" "errors"

6
library/test/words.factor
View File

@ -1,6 +1,6 @@
IN: temporary IN: temporary
USING: generic hashtables kernel lists math namespaces sequences USING: arrays generic hashtables kernel lists math namespaces
test words ; sequences test words ;
[ 4 ] [ [ 4 ] [
"poo" "scratchpad" create [ 2 2 + ] define-compound "poo" "scratchpad" create [ 2 2 + ] define-compound
@ -38,7 +38,7 @@ DEFER: plist-test
"test-scope" [ "scratchpad" ] search word-name "test-scope" [ "scratchpad" ] search word-name
] unit-test ] unit-test
[ t ] [ vocabs list? ] unit-test [ t ] [ vocabs array? ] unit-test
[ t ] [ vocabs [ words [ word? ] all? ] all? ] unit-test [ t ] [ vocabs [ words [ word? ] all? ] all? ] unit-test
[ f ] [ gensym gensym = ] unit-test [ f ] [ gensym gensym = ] unit-test

34
library/ui/editors.factor
View File

@ -94,23 +94,23 @@ TUPLE: editor line caret font color ;
: editor-actions ( editor -- ) : editor-actions ( editor -- )
H{ H{
[[ [ gain-focus ] [ focus-editor ] ]] { [ gain-focus ] [ focus-editor ] }
[[ [ lose-focus ] [ unfocus-editor ] ]] { [ lose-focus ] [ unfocus-editor ] }
[[ [ button-down 1 ] [ click-editor ] ]] { [ button-down 1 ] [ click-editor ] }
[[ [ "BACKSPACE" ] [ [ T{ char-elt } delete-prev-elt ] with-editor ] ]] { [ "BACKSPACE" ] [ [ T{ char-elt } delete-prev-elt ] with-editor ] }
[[ [ "DELETE" ] [ [ T{ char-elt } delete-next-elt ] with-editor ] ]] { [ "DELETE" ] [ [ T{ char-elt } delete-next-elt ] with-editor ] }
[[ [ "CTRL" "BACKSPACE" ] [ [ T{ word-elt } delete-prev-elt ] with-editor ] ]] { [ "CTRL" "BACKSPACE" ] [ [ T{ word-elt } delete-prev-elt ] with-editor ] }
[[ [ "CTRL" "DELETE" ] [ [ T{ word-elt } delete-next-elt ] with-editor ] ]] { [ "CTRL" "DELETE" ] [ [ T{ word-elt } delete-next-elt ] with-editor ] }
[[ [ "ALT" "BACKSPACE" ] [ [ T{ document-elt } delete-prev-elt ] with-editor ] ]] { [ "ALT" "BACKSPACE" ] [ [ T{ document-elt } delete-prev-elt ] with-editor ] }
[[ [ "ALT" "DELETE" ] [ [ T{ document-elt } delete-next-elt ] with-editor ] ]] { [ "ALT" "DELETE" ] [ [ T{ document-elt } delete-next-elt ] with-editor ] }
[[ [ "LEFT" ] [ [ T{ char-elt } prev-elt ] with-editor ] ]] { [ "LEFT" ] [ [ T{ char-elt } prev-elt ] with-editor ] }
[[ [ "RIGHT" ] [ [ T{ char-elt } next-elt ] with-editor ] ]] { [ "RIGHT" ] [ [ T{ char-elt } next-elt ] with-editor ] }
[[ [ "CTRL" "LEFT" ] [ [ T{ word-elt } prev-elt ] with-editor ] ]] { [ "CTRL" "LEFT" ] [ [ T{ word-elt } prev-elt ] with-editor ] }
[[ [ "CTRL" "RIGHT" ] [ [ T{ word-elt } next-elt ] with-editor ] ]] { [ "CTRL" "RIGHT" ] [ [ T{ word-elt } next-elt ] with-editor ] }
[[ [ "HOME" ] [ [ T{ document-elt } prev-elt ] with-editor ] ]] { [ "HOME" ] [ [ T{ document-elt } prev-elt ] with-editor ] }
[[ [ "END" ] [ [ T{ document-elt } next-elt ] with-editor ] ]] { [ "END" ] [ [ T{ document-elt } next-elt ] with-editor ] }
[[ [ "CTRL" "k" ] [ [ line-clear ] with-editor ] ]] { [ "CTRL" "k" ] [ [ line-clear ] with-editor ] }
[[ [ "TAB" ] [ do-completion ] ]] { [ "TAB" ] [ do-completion ] }
} add-actions ; } add-actions ;
C: editor ( text -- ) C: editor ( text -- )

10
library/ui/panes.factor
View File

@ -74,11 +74,11 @@ SYMBOL: structured-input
: pane-actions ( line -- ) : pane-actions ( line -- )
H{ H{
[[ [ button-down 1 ] [ pane-input [ click-editor ] when* ] ]] { [ button-down 1 ] [ pane-input [ click-editor ] when* ] }
[[ [ "RETURN" ] [ pane-return ] ]] { [ "RETURN" ] [ pane-return ] }
[[ [ "UP" ] [ pane-input [ [ history-prev ] with-editor ] when* ] ]] { [ "UP" ] [ pane-input [ [ history-prev ] with-editor ] when* ] }
[[ [ "DOWN" ] [ pane-input [ [ history-next ] with-editor ] when* ] ]] { [ "DOWN" ] [ pane-input [ [ history-next ] with-editor ] when* ] }
[[ [ "CTRL" "l" ] [ pane get pane-clear ] ]] { [ "CTRL" "l" ] [ pane get pane-clear ] }
} add-actions ; } add-actions ;
C: pane ( input? scrolls? -- pane ) C: pane ( input? scrolls? -- pane )

4
library/unix/io.factor
View File

@ -135,7 +135,7 @@ GENERIC: task-container ( task -- vector )
: handle-fdset ( fdset tasks -- ) : handle-fdset ( fdset tasks -- )
[ [
cdr dup io-task-port timeout? [ nip dup io-task-port timeout? [
dup io-task-port "Timeout" swap report-error dup io-task-port "Timeout" swap report-error
nip pop-callback continue nip pop-callback continue
] [ ] [
@ -146,7 +146,7 @@ GENERIC: task-container ( task -- vector )
: init-fdset ( fdset tasks -- ) : init-fdset ( fdset tasks -- )
>r dup FD_SETSIZE clear-bits r> >r dup FD_SETSIZE clear-bits r>
[ car t swap rot set-bit-nth ] hash-each-with ; [ drop t swap rot set-bit-nth ] hash-each-with ;
: init-fdsets ( -- read write except ) : init-fdsets ( -- read write except )
read-fdset get [ read-tasks get init-fdset ] keep read-fdset get [ read-tasks get init-fdset ] keep

10
library/vocabularies.factor
View File

@ -64,7 +64,7 @@ SYMBOL: vocabularies
#! already contains the word, the existing instance is #! already contains the word, the existing instance is
#! returned. #! returned.
2dup check-create 2dup lookup dup 2dup check-create 2dup lookup dup
[ 2nip ] [ drop <word> dup reveal ] if ; [ 2nip ] [ drop <word> dup init-word dup reveal ] if ;
: constructor-word ( string vocab -- word ) : constructor-word ( string vocab -- word )
>r "<" swap ">" append3 r> create ; >r "<" swap ">" append3 r> create ;
@ -75,9 +75,12 @@ SYMBOL: vocabularies
crossref get [ dupd remove-hash ] when* crossref get [ dupd remove-hash ] when*
dup word-name swap word-vocabulary vocab remove-hash ; dup word-name swap word-vocabulary vocab remove-hash ;
: target-word ( word -- word )
dup word-name swap word-vocabulary lookup ;
: interned? ( word -- ? ) : interned? ( word -- ? )
#! Test if the word is a member of its vocabulary. #! Test if the word is a member of its vocabulary.
dup word-name over word-vocabulary lookup eq? ; dup target-word eq? ;
: bootstrap-word ( word -- word ) : bootstrap-word ( word -- word )
dup word-name swap word-vocabulary dup word-name swap word-vocabulary
@ -85,9 +88,6 @@ SYMBOL: vocabularies
dup "syntax" = [ drop "!syntax" ] when dup "syntax" = [ drop "!syntax" ] when
] when lookup ; ] when lookup ;
: target-word ( word -- word )
dup word-name swap word-vocabulary lookup ;
"scratchpad" "in" set "scratchpad" "in" set
[ [
"scratchpad" "scratchpad"

5
library/words.factor
View File

@ -4,6 +4,9 @@ IN: words
USING: generic hashtables kernel kernel-internals lists math USING: generic hashtables kernel kernel-internals lists math
namespaces sequences strings vectors ; namespaces sequences strings vectors ;
: init-word ( word -- )
H{ } clone swap set-word-props ;
! The basic word type. Words can be named and compared using ! The basic word type. Words can be named and compared using
! identity. They hold a property map. ! identity. They hold a property map.
@ -124,6 +127,6 @@ M: word literalize <wrapper> ;
#! is not contained in any vocabulary. #! is not contained in any vocabulary.
"G:" "G:"
global [ \ gensym dup inc get ] bind global [ \ gensym dup inc get ] bind
number>string append f <word> ; number>string append f <word> dup init-word ;
0 \ gensym global set-hash 0 \ gensym global set-hash

18
native/hashtable.c
View File

@ -1,20 +1,14 @@
#include "factor.h" #include "factor.h"
F_HASHTABLE* hashtable(F_FIXNUM capacity)
{
F_HASHTABLE* hash;
if(capacity < 0)
general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_integer(capacity));
hash = allot_object(HASHTABLE_TYPE,sizeof(F_VECTOR));
hash->count = tag_fixnum(0);
hash->array = tag_object(array(ARRAY_TYPE,capacity,F));
return hash;
}
void primitive_hashtable(void) void primitive_hashtable(void)
{ {
F_HASHTABLE* hash;
maybe_gc(0); maybe_gc(0);
drepl(tag_object(hashtable(to_fixnum(dpeek())))); hash = allot_object(HASHTABLE_TYPE,sizeof(F_VECTOR));
hash->count = F;
hash->deleted = F;
hash->array = F;
dpush(tag_object(hash));
} }
void fixup_hashtable(F_HASHTABLE* hashtable) void fixup_hashtable(F_HASHTABLE* hashtable)

4
native/hashtable.h
View File

@ -3,12 +3,12 @@ typedef struct {
CELL header; CELL header;
/* tagged */ /* tagged */
CELL count; CELL count;
/* tagged */
CELL deleted;
/* tagged */ /* tagged */
CELL array; CELL array;
} F_HASHTABLE; } F_HASHTABLE;
F_HASHTABLE* hashtable(F_FIXNUM capacity);
void primitive_hashtable(void); void primitive_hashtable(void);
void fixup_hashtable(F_HASHTABLE* hashtable); void fixup_hashtable(F_HASHTABLE* hashtable);
void collect_hashtable(F_HASHTABLE* hashtable); void collect_hashtable(F_HASHTABLE* hashtable);

2
native/word.c
View File

@ -24,7 +24,7 @@ void primitive_word(void)
word->vocabulary = vocabulary; word->vocabulary = vocabulary;
word->primitive = tag_fixnum(0); word->primitive = tag_fixnum(0);
word->def = F; word->def = F;
word->props = tag_object(hashtable(8)); word->props = F;
word->xt = (CELL)undefined; word->xt = (CELL)undefined;
dpush(tag_object(word)); dpush(tag_object(word));
} }