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
- callbacks
- better prettyprinting of cond
- investigate if rehashing on startup is really necessary
- remove word transfer hack in bootstrap
- the invalid recursion form case needs to be fixed, for inlines too
- 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:

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

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

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

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

16
library/bootstrap/image.factor
View File

@ -252,14 +252,20 @@ M: string ' ( string -- pointer )
( elements -- ) emit-seq
align-here r> ;
: transfer-tuple ( tuple -- tuple )
tuple>array
dup first transfer-word 0 pick set-nth
array>tuple ;
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 )
array-type emit-array ;
M: vector ' ( vector -- pointer )
dup array-type emit-array swap length
dup underlying ' swap length
object-tag here-as >r
vector-type >header emit
emit-fixnum ( length )
@ -269,11 +275,11 @@ M: vector ' ( vector -- pointer )
( Hashes )
M: hashtable ' ( hashtable -- pointer )
dup underlying array-type emit-array
swap hash-size
[ underlying ' ] keep
object-tag here-as >r
hashtable-type >header emit
emit-fixnum ( length )
dup hash-count emit-fixnum
hash-deleted emit-fixnum
emit ( array ptr )
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" }
{ "resize-array" "arrays" }
{ "resize-string" "strings" }
{ "<hashtable>" "hashtables" }
{ "(hashtable)" "hashtables-internals" }
{ "<array>" "arrays" }
{ "<tuple>" "kernel-internals" }
{ "begin-scan" "memory" }
@ -315,8 +315,9 @@ num-types <array> builtins set
"hashtable?" "hashtables" create t "inline" set-word-prop
"hashtable" "hashtables" create 10 "hashtable?" "hashtables" create
{
{ 1 { "hash-size" "hashtables" } { "set-hash-size" "kernel-internals" } }
{ 2 { "underlying" "sequences-internals" } { "set-underlying" "sequences-internals" } }
{ 1 { "hash-count" "hashtables" } { "set-hash-count" "hashtables-internals" } }
{ 2 { "hash-deleted" "hashtables" } { "set-hash-deleted" "hashtables-internals" } }
{ 3 { "underlying" "sequences-internals" } { "set-underlying" "sequences-internals" } }
} define-builtin
"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.
! See http://factor.sf.net/license.txt for BSD license.
IN: hashtables
USING: arrays generic kernel lists math sequences vectors
kernel-internals sequences-internals ;
IN: hashtables-internals
USING: arrays hashtables kernel math sequences
sequences-internals ;
! A hashtable is implemented as an array of buckets. The
! array index is determined using a hash function, and the
! buckets are associative lists which are searched
! linearly.
! This hashtable implementation uses only one auxilliary array
! in addition to the hashtable tuple itself. The array stores
! keys in even slots and values in odd slots. Values are looked
! up with a hashing strategy that uses linear probing to resolve
! collisions.
! The unsafe words go in kernel internals. Everything else, even
! if it is somewhat 'implementation detail', is in the
! public 'hashtables' vocabulary.
! There are two special objects: the ((tombstone)) marker and
! the ((empty)) marker. Neither of these markers can be used as
! 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 )
>r >fixnum r> underlying array-nth ;
: ((empty)) T{ tombstone f } ; inline
: ((tombstone)) T{ tombstone t } ; inline
: set-hash-bucket ( obj n hash -- )
>r >fixnum r> underlying set-array-nth ;
: hash@ ( key keys -- n )
#! Return an even key index.
>r hashcode r> length 2 /i rem 2 * ;
: change-bucket ( n hash quot -- )
-rot underlying
[ array-nth swap call ] 2keep
set-array-nth ; inline
: probe ( heys i -- hash i ) 2 + over length mod ;
: each-bucket ( hash quot -- | quot: n hash -- )
over bucket-count [ [ -rot call ] 3keep ] repeat 2drop ;
inline
: (key@) ( key keys i -- n )
3dup swap nth-unsafe {
{ [ 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 ;
: hash-size- ( hash -- ) dup hash-size 1- swap set-hash-size ;
: key@ ( key hash -- n )
underlying 2dup hash@ (key@) ;
: grow-hash ( hash -- )
#! A good way to earn a living.
dup hash-size 2 * <array> swap set-underlying ;
: if-key ( key hash true false -- | true: index key hash -- )
>r >r [ key@ ] 2keep pick -1 > r> r> if ; inline
: (set-bucket-count) ( n hash -- )
>r <array> r> set-underlying ;
IN: hashtables
: <hash-array> ( n -- array )
1+ 4 * ((empty)) <repeated> >array ;
: (hashcode) ( key table -- index )
#! Compute the index of the bucket for a key.
>r hashcode r> bucket-count rem ; inline
: reset-hash ( n hash -- )
swap <hash-array> over set-underlying
0 over set-hash-count 0 swap set-hash-deleted ;
: hash* ( key table -- [[ key value ]] )
#! Look up a value in the hashtable.
2dup (hashcode) swap hash-bucket assoc* ; flushable
: 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
: (new-key@) ( key keys i -- n )
3dup swap nth-unsafe dup tombstone? [
2drop 2nip
] [
drop
= [ 2nip ] [ probe (new-key@) ] if
] if ;
: 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 grow-hash (set-hash) ;
: new-key@ ( key hash -- n )
underlying 2dup hash@ (new-key@) ;
: remove-hash ( key table -- )
#! Remove a value from a hashtable.
[ remove-assoc ] set-hash* ;
: nth-pair ( n seq -- key value )
[ nth-unsafe ] 2keep >r 1+ r> nth-unsafe ;
: hash-clear ( hash -- )
0 over set-hash-size [ f -rot set-hash-bucket ] each-bucket ;
: set-nth-pair ( value key n seq -- )
[ 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 )
dup length 1 max <hashtable> swap
[ unswons pick set-hash ] each ; foldable
[ length <hashtable> ] keep
[ first2 swap pick (set-hash) ] each ;
: hash-keys ( hash -- list )
hash>alist [ car ] map ; flushable
: hash-each ( hash quot -- | quot: k v -- )
#! Apply a quotation to each key/value pair.
>r underlying r> each-pair ; inline
: hash-values ( hash -- alist )
hash>alist [ cdr ] map ; flushable
: hash-each-with ( obj hash quot -- | quot: obj k v -- )
swap [ 2swap [ >r -rot r> call ] 2keep ] hash-each 2drop ;
inline
: hash-each ( hash quot -- | quot: [[ k v ]] -- )
swap underlying [ swap each ] each-with ; inline
: hash-all? ( hash quot -- | quot: k v -- ? )
#! 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 ]] -- )
swap [ with ] hash-each 2drop ; inline
: hash-all-with? ( obj hash quot -- | quot: obj k v -- ? )
swap
[ 2swap [ >r -rot r> call ] 2keep rot ] hash-all? 2nip ;
inline
: hash-all? ( hash quot -- | quot: [[ k v ]] -- ? )
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 -- ? )
: subhash? ( h1 h2 -- ? )
#! Test if h2 contains all the key/value pairs of h1.
swap [
uncons >r swap hash* dup [
cdr r> =
] [
r> 2drop f
] if
>r swap hash* [ r> = ] [ r> 2drop f ] if
] hash-all-with? ; flushable
: hash-filter-step ( quot assoc -- assoc n )
[ 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 ]] -- ? )
: hash-subset ( hash quot -- hash | quot: k v -- ? )
#! Make a new hash that only includes the key/value pairs
#! 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 )
swap [ with rot ] hash-subset 2nip ; inline
: hash-subset-with ( obj hash quot -- hash | quot: obj { k v } -- ? )
swap
[ 2swap [ >r -rot r> call ] 2keep rot ] hash-subset 2nip ;
inline
M: hashtable clone ( hash -- hash ) clone-growable ;
: hashtable= ( hash hash -- ? )
2dup hash-contained? >r swap hash-contained? r> and ;
2dup subhash? >r swap subhash? r> and ;
M: hashtable = ( obj hash -- ? )
{
@ -170,41 +229,32 @@ M: hashtable = ( obj hash -- ? )
{ [ t ] [ hashtable= ] }
} 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 )
dup [ hash ] [ 2drop f ] if ; flushable
: ?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 )
[ 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 )
#! 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 )
#! 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 -- )
#! 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 )
#! 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 elements from the sequence that are keys
#! in the hashtable.
[ swap hash* not ] subset-with ; flushable
[ swap hash-contains? not ] subset-with ; flushable
: 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* ] find-last nip ?hash ; flushable
: 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: 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? ;
: curry ( obj quot -- quot )
>r literalize r> cons ;
: curry ( obj quot -- quot ) >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 -- )
tuck hash dup [
hash-keys [
dup dup closure, [ 2drop ] [ swap (closure) ] if
] each-with
[
drop dup dup closure,
[ 2drop ] [ swap (closure) ] if
] hash-each-with
] [
2drop
] if ;
@ -108,7 +109,7 @@ SYMBOL: hash-buffer
IN: lists
: alist>quot ( default alist -- quot )
[ unswons [ % , , \ if , ] [ ] make ] each ;
[ [ first2 swap % , , \ if , ] [ ] make ] each ;
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 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 -- )
#! 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.
! See http://factor.sf.net/license.txt for BSD license.
IN: compiler
USING: assembler errors generic kernel lists math namespaces
prettyprint sequences strings vectors words ;
USING: assembler errors generic hashtables kernel lists math
namespaces prettyprint sequences strings vectors words ;
! We use a hashtable "compiled-xts" that maps words to
! xt's that are currently being compiled. The commit-xt's word
@ -16,16 +16,16 @@ prettyprint sequences strings vectors words ;
SYMBOL: compiled-xts
: save-xt ( word -- )
compiled-offset swap compiled-xts [ acons ] change ;
compiled-offset swap compiled-xts set-hash ;
: commit-xts ( -- )
#! We must flush the instruction cache on PowerPC.
flush-icache
compiled-xts get [ unswons set-word-xt ] each
compiled-xts get [ swap set-word-xt ] hash-each
compiled-xts off ;
: 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
! 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? [
drop t
] [
compiled-xts get assoc
compiled-xts get hash
] if
] if ;
@ -133,7 +133,7 @@ M: absolute-16/16 fixup ( absolute -- ) >absolute fixup-16/16 ;
: with-compiler ( quot -- )
[
deferred-xts off
compiled-xts off
H{ } clone compiled-xts set
V{ } clone compile-words set
call
fixup-xts

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

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

2
library/freetype/load.factor
View File

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

17
library/generic/generic.factor
View File

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

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

@ -1,6 +1,6 @@
IN: generic
USING: errors hashtables kernel kernel-internals lists math
namespaces sequences vectors words ;
USING: arrays errors hashtables kernel kernel-internals lists
math namespaces sequences vectors words ;
: error-method ( picker word -- method )
[ no-method ] curry append ;
@ -15,36 +15,39 @@ namespaces sequences vectors words ;
] if ;
: 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 )
#! Input is a predicate -> method association.
#! n is vtable size (either num-types or num-tags).
[
type>class [ object bootstrap-word ] unless*
swap [ car classes-intersect? ] subset-with
swap [ first classes-intersect? ] subset-with
] map-with ;
: simplify-alist ( class alist -- default alist )
: simplify-alist ( class assoc -- default assoc )
dup cdr [
2dup cdr car car class< [
2dup cdr car first class< [
cdr simplify-alist
] [
uncons >r cdr nip r>
uncons >r second nip r>
] if
] [
nip car cdr [ ]
nip car second [ ]
] if ;
: vtable-methods ( picker alist-seq -- alist-seq )
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
] 2map nip ;
: <vtable> ( picker word n -- vtable )
#! n is vtable size; either num-types or num-tags.
>r 2dup empty-method \ object bootstrap-word
swons >r methods r> swons r> sort-methods vtable-methods ;
>r 2dup empty-method \ object bootstrap-word swap 2array
>r methods >list r> swons r> sort-methods vtable-methods ;
: small-generic ( picker word -- def )
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-in-d [
dup literal?
[ 2drop t ] [ swap node-literals ?hash* ] if
[ 2drop t ] [ swap node-literals ?hash* nip ] if
] all-with?
] [
drop f

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

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

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

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

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

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

14
library/syntax/prettyprint.factor
View File

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

12
library/syntax/see.factor
View File

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

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

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

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

@ -1,5 +1,4 @@
IN: temporary
USE: hashtables
USE: kernel
USE: lists
USE: math
@ -8,15 +7,16 @@ USE: test
USE: vectors
USE: sequences
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
[ f ]
[ 1000 >list [ silly-key/value "testhash" get hash = not ] subset ]
[ V{ } ]
[ 1000 [ dup sq swap "testhash" get hash = not ] subset ]
unit-test
[ t ]
@ -46,25 +46,60 @@ f 100000000000000000000000000 "testhash" get set-hash
{ } { [ { } ] } "testhash" get set-hash
[ t ] [ C{ 2 3 } "testhash" get hash ] unit-test
[ f ] [ 100000000000000000000000000 "testhash" get hash* cdr ] unit-test
[ { } ] [ { [ { } ] } clone "testhash" get hash* cdr ] unit-test
[ f ] [ 100000000000000000000000000 "testhash" get hash* drop ] unit-test
[ { } ] [ { [ { } ] } clone "testhash" get hash* drop ] unit-test
[
[[ "salmon" "fish" ]]
[[ "crocodile" "reptile" ]]
[[ "cow" "mammal" ]]
[[ "visual basic" "language" ]]
] alist>hash "testhash" set
{
{ "salmon" "fish" }
{ "crocodile" "reptile" }
{ "cow" "mammal" }
{ "visual basic" "language" }
} alist>hash "testhash" set
[ f ] [
[ f f ] [
"visual basic" "testhash" get remove-hash
"visual basic" "testhash" get hash*
] unit-test
[ 4 ] [
"hey"
H{ [[ "hey" 4 ]] [[ "whey" 5 ]] } 2dup (hashcode)
swap underlying nth assoc
[ t ] [ H{ } dup subhash? ] unit-test
[ f ] [ H{ { 1 3 } } H{ } subhash? ] unit-test
[ t ] [ H{ } H{ { 1 3 } } subhash? ] unit-test
[ 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
! Testing the hash element counting
@ -79,22 +114,6 @@ H{ } clone "counting" set
"key" "counting" get remove-hash
[ 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
2 <hashtable> "rehash" set
@ -110,7 +129,7 @@ H{ } clone "counting" set
[ 6 ] [ "rehash" get clone hash-size ] unit-test
"rehash" get hash-clear
"rehash" get clear-hash
[ 0 ] [ "rehash" get hash-size ] unit-test
@ -118,8 +137,8 @@ H{ } clone "counting" set
3
] [
2 H{
[[ 1 2 ]]
[[ 2 3 ]]
{ 1 2 }
{ 2 3 }
} clone hash
] unit-test
@ -132,11 +151,11 @@ H{ } clone "counting" set
[ 21 ] [
0 H{
[[ 1 2 ]]
[[ 3 4 ]]
[[ 5 6 ]]
{ 1 2 }
{ 3 4 }
{ 5 6 }
} [
uncons + +
+ +
] hash-each
] unit-test
@ -148,42 +167,26 @@ H{ } clone "cache-test" set
[ 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" ]] [[ 1 2 ]] [[ 2 3 ]] [[ 3 4 ]] }
H{ { "factor" "rocks" } { "dup" "sq" } { 3 4 } }
H{ { "factor" "rocks" } { 1 2 } { 2 3 } { 3 4 } }
hash-intersect
] unit-test
[
H{ [[ 1 2 ]] [[ 2 3 ]] }
H{ { 1 2 } { 2 3 } }
] [
H{ [[ "factor" "rocks" ]] [[ "dup" "sq" ]] [[ 3 4 ]] }
H{ [[ "factor" "rocks" ]] [[ 1 2 ]] [[ 2 3 ]] [[ 3 4 ]] }
H{ { "factor" "rocks" } { "dup" "sq" } { 3 4 } }
H{ { "factor" "rocks" } { 1 2 } { 2 3 } { 3 4 } }
hash-diff
] unit-test
[
2
H{ { 1 2 } { 2 3 } { 6 5 } }
] [
H{ [[ "factor" "rocks" ]] [[ "dup" "sq" ]] [[ 3 4 ]] }
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 ]] }
H{ { 2 4 } { 6 5 } } H{ { 1 2 } { 2 3 } }
hash-union
] 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
! Test method inlining
[ f ] [ fixnum { } min-class ] unit-test
[ string ] [
\ string
[ repeated integer string array reversed sbuf
slice vector general-list ]
min-class
[ class-compare ] sort min-class
] unit-test
[ f ] [
\ fixnum
[ fixnum integer letter ]
min-class
[ class-compare ] sort min-class
] unit-test
[ fixnum ] [
\ fixnum
[ fixnum integer object ]
min-class
[ class-compare ] sort min-class
] unit-test
[ integer ] [
\ fixnum
[ integer float object ]
min-class
[ class-compare ] sort min-class
] unit-test
[ object ] [
\ word
[ integer float object ]
min-class
[ class-compare ] sort min-class
] unit-test
GENERIC: xyz
@ -232,9 +234,16 @@ TUPLE: pred-test ;
[ ] [ double-recursion ] unit-test
! regression
: double-label-1
[ f double-label-1 ] [ swap nth-unsafe ] if ; inline
: double-label-2
dup general-list? [ ] [ ] if 0 t double-label-1 ; compiled
[ 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
{
"lists/cons" "lists/lists" "lists/assoc"
"lists/cons" "lists/lists"
"lists/namespaces"
"combinators"
"continuations" "errors"

6
library/test/words.factor
View File

@ -1,6 +1,6 @@
IN: temporary
USING: generic hashtables kernel lists math namespaces sequences
test words ;
USING: arrays generic hashtables kernel lists math namespaces
sequences test words ;
[ 4 ] [
"poo" "scratchpad" create [ 2 2 + ] define-compound
@ -38,7 +38,7 @@ DEFER: plist-test
"test-scope" [ "scratchpad" ] search word-name
] unit-test
[ t ] [ vocabs list? ] unit-test
[ t ] [ vocabs array? ] unit-test
[ t ] [ vocabs [ words [ word? ] all? ] all? ] 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 -- )
H{
[[ [ gain-focus ] [ focus-editor ] ]]
[[ [ lose-focus ] [ unfocus-editor ] ]]
[[ [ button-down 1 ] [ click-editor ] ]]
[[ [ "BACKSPACE" ] [ [ T{ char-elt } delete-prev-elt ] with-editor ] ]]
[[ [ "DELETE" ] [ [ T{ char-elt } delete-next-elt ] with-editor ] ]]
[[ [ "CTRL" "BACKSPACE" ] [ [ T{ word-elt } delete-prev-elt ] with-editor ] ]]
[[ [ "CTRL" "DELETE" ] [ [ T{ word-elt } delete-next-elt ] with-editor ] ]]
[[ [ "ALT" "BACKSPACE" ] [ [ T{ document-elt } delete-prev-elt ] with-editor ] ]]
[[ [ "ALT" "DELETE" ] [ [ T{ document-elt } delete-next-elt ] with-editor ] ]]
[[ [ "LEFT" ] [ [ T{ char-elt } prev-elt ] with-editor ] ]]
[[ [ "RIGHT" ] [ [ T{ char-elt } next-elt ] with-editor ] ]]
[[ [ "CTRL" "LEFT" ] [ [ T{ word-elt } prev-elt ] with-editor ] ]]
[[ [ "CTRL" "RIGHT" ] [ [ T{ word-elt } next-elt ] with-editor ] ]]
[[ [ "HOME" ] [ [ T{ document-elt } prev-elt ] with-editor ] ]]
[[ [ "END" ] [ [ T{ document-elt } next-elt ] with-editor ] ]]
[[ [ "CTRL" "k" ] [ [ line-clear ] with-editor ] ]]
[[ [ "TAB" ] [ do-completion ] ]]
{ [ gain-focus ] [ focus-editor ] }
{ [ lose-focus ] [ unfocus-editor ] }
{ [ button-down 1 ] [ click-editor ] }
{ [ "BACKSPACE" ] [ [ T{ char-elt } delete-prev-elt ] with-editor ] }
{ [ "DELETE" ] [ [ T{ char-elt } delete-next-elt ] with-editor ] }
{ [ "CTRL" "BACKSPACE" ] [ [ T{ word-elt } delete-prev-elt ] with-editor ] }
{ [ "CTRL" "DELETE" ] [ [ T{ word-elt } delete-next-elt ] with-editor ] }
{ [ "ALT" "BACKSPACE" ] [ [ T{ document-elt } delete-prev-elt ] with-editor ] }
{ [ "ALT" "DELETE" ] [ [ T{ document-elt } delete-next-elt ] with-editor ] }
{ [ "LEFT" ] [ [ T{ char-elt } prev-elt ] with-editor ] }
{ [ "RIGHT" ] [ [ T{ char-elt } next-elt ] with-editor ] }
{ [ "CTRL" "LEFT" ] [ [ T{ word-elt } prev-elt ] with-editor ] }
{ [ "CTRL" "RIGHT" ] [ [ T{ word-elt } next-elt ] with-editor ] }
{ [ "HOME" ] [ [ T{ document-elt } prev-elt ] with-editor ] }
{ [ "END" ] [ [ T{ document-elt } next-elt ] with-editor ] }
{ [ "CTRL" "k" ] [ [ line-clear ] with-editor ] }
{ [ "TAB" ] [ do-completion ] }
} add-actions ;
C: editor ( text -- )

10
library/ui/panes.factor
View File

@ -74,11 +74,11 @@ SYMBOL: structured-input
: pane-actions ( line -- )
H{
[[ [ button-down 1 ] [ pane-input [ click-editor ] when* ] ]]
[[ [ "RETURN" ] [ pane-return ] ]]
[[ [ "UP" ] [ pane-input [ [ history-prev ] with-editor ] when* ] ]]
[[ [ "DOWN" ] [ pane-input [ [ history-next ] with-editor ] when* ] ]]
[[ [ "CTRL" "l" ] [ pane get pane-clear ] ]]
{ [ button-down 1 ] [ pane-input [ click-editor ] when* ] }
{ [ "RETURN" ] [ pane-return ] }
{ [ "UP" ] [ pane-input [ [ history-prev ] with-editor ] when* ] }
{ [ "DOWN" ] [ pane-input [ [ history-next ] with-editor ] when* ] }
{ [ "CTRL" "l" ] [ pane get pane-clear ] }
} add-actions ;
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 -- )
[
cdr dup io-task-port timeout? [
nip dup io-task-port timeout? [
dup io-task-port "Timeout" swap report-error
nip pop-callback continue
] [
@ -146,7 +146,7 @@ GENERIC: task-container ( task -- vector )
: init-fdset ( fdset tasks -- )
>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 )
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
#! returned.
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 )
>r "<" swap ">" append3 r> create ;
@ -75,9 +75,12 @@ SYMBOL: vocabularies
crossref get [ dupd remove-hash ] when*
dup word-name swap word-vocabulary vocab remove-hash ;
: target-word ( word -- word )
dup word-name swap word-vocabulary lookup ;
: interned? ( word -- ? )
#! 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 )
dup word-name swap word-vocabulary
@ -85,9 +88,6 @@ SYMBOL: vocabularies
dup "syntax" = [ drop "!syntax" ] when
] when lookup ;
: target-word ( word -- word )
dup word-name swap word-vocabulary lookup ;
"scratchpad" "in" set
[
"scratchpad"

5
library/words.factor
View File

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

18
native/hashtable.c
View File

@ -1,20 +1,14 @@
#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)
{
F_HASHTABLE* hash;
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)

4
native/hashtable.h
View File

@ -3,12 +3,12 @@ typedef struct {
CELL header;
/* tagged */
CELL count;
/* tagged */
CELL deleted;
/* tagged */
CELL array;
} F_HASHTABLE;
F_HASHTABLE* hashtable(F_FIXNUM capacity);
void primitive_hashtable(void);
void fixup_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->primitive = tag_fixnum(0);
word->def = F;
word->props = tag_object(hashtable(8));
word->props = F;
word->xt = (CELL)undefined;
dpush(tag_object(word));
}