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

Merge branch 'master' of git://factorcode.org/git/factor

db4
Bruno Deferrari 2008-06-13 01:04:25 -03:00
parent c7d53deaf4 5249016972
commit fac1feaf15
171 changed files with 1799 additions and 946 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
core/alien/compiler/compiler.factor
View File

@ -7,7 +7,7 @@ math.parser classes alien.arrays alien.c-types alien.strings
alien.structs alien.syntax cpu.architecture alien inspector alien.structs alien.syntax cpu.architecture alien inspector
quotations assocs kernel.private threads continuations.private quotations assocs kernel.private threads continuations.private
libc combinators compiler.errors continuations layouts accessors libc combinators compiler.errors continuations layouts accessors
init ; init sets ;
IN: alien.compiler IN: alien.compiler
TUPLE: #alien-node < node return parameters abi ; TUPLE: #alien-node < node return parameters abi ;
@ -339,7 +339,7 @@ SYMBOL: callbacks
[ H{ } clone callbacks set-global ] "alien.compiler" add-init-hook [ H{ } clone callbacks set-global ] "alien.compiler" add-init-hook
: register-callback ( word -- ) dup callbacks get set-at ; : register-callback ( word -- ) callbacks get conjoin ;
M: alien-callback-error summary M: alien-callback-error summary
drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ; drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ;

7
core/assocs/assocs-docs.factor
View File

@ -79,7 +79,6 @@ ARTICLE: "assocs-sets" "Set-theoretic operations on assocs"
ARTICLE: "assocs-mutation" "Storing keys and values in assocs" ARTICLE: "assocs-mutation" "Storing keys and values in assocs"
"Utility operations built up from the " { $link "assocs-protocol" } ":" "Utility operations built up from the " { $link "assocs-protocol" } ":"
{ $subsection delete-at* } { $subsection delete-at* }
{ $subsection delete-any }
{ $subsection rename-at } { $subsection rename-at }
{ $subsection change-at } { $subsection change-at }
{ $subsection at+ } { $subsection at+ }
@ -242,12 +241,6 @@ HELP: delete-at*
{ $description "Removes an entry from the assoc and outputs the previous value together with a boolean indicating whether it was present." } { $description "Removes an entry from the assoc and outputs the previous value together with a boolean indicating whether it was present." }
{ $side-effects "assoc" } ; { $side-effects "assoc" } ;
HELP: delete-any
{ $values { "assoc" assoc } { "key" "a key" } { "value" "a value" } }
{ $description "Removes an undetermined entry from the assoc and outputs it." }
{ $errors "Throws an error if the assoc is empty." }
{ $notes "This word is useful when using an assoc as an unordered queue which requires constant-time membership tests. Entries are enqueued with " { $link set-at } " and dequeued with " { $link delete-any } "." } ;
HELP: rename-at HELP: rename-at
{ $values { "newkey" object } { "key" object } { "assoc" assoc } } { $values { "newkey" object } { "key" object } { "assoc" assoc } }
{ $description "Removes the values associated to " { $snippet "key" } " and re-adds it as " { $snippet "newkey" } ". Does nothing if the assoc does not contain " { $snippet "key" } "." } { $description "Removes the values associated to " { $snippet "key" } " and re-adds it as " { $snippet "newkey" } ". Does nothing if the assoc does not contain " { $snippet "key" } "." }

6
core/assocs/assocs.factor
View File

@ -76,12 +76,6 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
: rename-at ( newkey key assoc -- ) : rename-at ( newkey key assoc -- )
tuck delete-at* [ -rot set-at ] [ 3drop ] if ; tuck delete-at* [ -rot set-at ] [ 3drop ] if ;
: delete-any ( assoc -- key value )
[
[ 2drop t ] assoc-find
[ "Assoc is empty" throw ] unless over
] keep delete-at ;
: assoc-empty? ( assoc -- ? ) : assoc-empty? ( assoc -- ? )
assoc-size zero? ; assoc-size zero? ;

17
core/bit-arrays/bit-arrays-docs.factor
View File

@ -1,5 +1,5 @@
USING: arrays help.markup help.syntax kernel USING: arrays help.markup help.syntax kernel
kernel.private prettyprint strings vectors sbufs ; kernel.private math prettyprint strings vectors sbufs ;
IN: bit-arrays IN: bit-arrays
ARTICLE: "bit-arrays" "Bit arrays" ARTICLE: "bit-arrays" "Bit arrays"
@ -17,7 +17,10 @@ $nl
{ $subsection <bit-array> } { $subsection <bit-array> }
"Efficiently setting and clearing all bits in a bit array:" "Efficiently setting and clearing all bits in a bit array:"
{ $subsection set-bits } { $subsection set-bits }
{ $subsection clear-bits } ; { $subsection clear-bits }
"Converting between unsigned integers and their binary representation:"
{ $subsection integer>bit-array }
{ $subsection bit-array>integer } ;
ABOUT: "bit-arrays" ABOUT: "bit-arrays"
@ -47,3 +50,13 @@ HELP: set-bits
{ $code "[ drop t ] change-each" } { $code "[ drop t ] change-each" }
} }
{ $side-effects "bit-array" } ; { $side-effects "bit-array" } ;
HELP: integer>bit-array
{ $values { "integer" integer } { "bit-array" bit-array } }
{ $description "Outputs a freshly-allocated bit array whose elements correspond to the bits in the binary representation of the given unsigned integer value." }
{ $notes "The bits of the integer are stored in the resulting bit array in order of ascending significance, least significant bit first. This word will fail if passed a negative integer. If you want the two's-complement binary representation of a negative number, use " { $link bitnot } " to get the complement of the number first. This word works with fixnums or bignums of any size; it is not limited by fixnum size or machine word size." } ;
HELP: bit-array>integer
{ $values { "bit-array" bit-array } { "integer" integer } }
{ $description "Outputs the unsigned integer whose binary representation corresponds to the contents of the given bit array." }
{ $notes "The bits of the integer are taken from the bit array in order of ascending significance, least significant bit first. This word is able to return fixnums or bignums of any size; it is not limited by fixnum size or machine word size." } ;

20
core/bit-arrays/bit-arrays-tests.factor
View File

@ -52,3 +52,23 @@ IN: bit-arrays.tests
[ ?{ t t } ] [ 2 ?{ t t f t f t f t t t f t } resize-bit-array ] unit-test [ ?{ t t } ] [ 2 ?{ t t f t f t f t t t f t } resize-bit-array ] unit-test
[ -10 ?{ } resize-bit-array ] must-fail [ -10 ?{ } resize-bit-array ] must-fail
[ -1 integer>bit-array ] must-fail
[ ?{ f t } ] [ 2 integer>bit-array ] unit-test
[ ?{ t t t t t t t t t } ] [ 511 integer>bit-array ] unit-test
[ ?{
t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
} ] [
HEX: ffffffffffffffffffffffffffffffff integer>bit-array
] unit-test
[ 14 ] [ ?{ f t t t } bit-array>integer ] unit-test
[ HEX: ffffffffffffffffffffffffffffffff ] [ ?{
t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
} bit-array>integer ] unit-test

13
core/bit-arrays/bit-arrays.factor
View File

@ -51,4 +51,17 @@ M: bit-array equal?
M: bit-array resize M: bit-array resize
resize-bit-array ; resize-bit-array ;
: integer>bit-array ( int -- bit-array )
[ log2 1+ <bit-array> 0 ] keep
[ dup zero? not ] [
[ -8 shift ] [ 255 bitand ] bi
-roll [ [ set-alien-unsigned-1 ] 2keep 1+ ] dip
] [ ] while
2drop ;
: bit-array>integer ( bit-array -- int )
dup >r length 7 + n>byte 0 r> [
swap alien-unsigned-1 swap 8 shift bitor
] curry reduce ;
INSTANCE: bit-array sequence INSTANCE: bit-array sequence

2
core/bootstrap/image/image.factor
View File

@ -397,7 +397,7 @@ M: quotation '
[ [
{ {
dictionary source-files builtins dictionary source-files builtins
update-map class<=-cache update-map implementors-map class<=-cache
class-not-cache classes-intersect-cache class-and-cache class-not-cache classes-intersect-cache class-and-cache
class-or-cache class-or-cache
} [ dup get swap bootstrap-word set ] each } [ dup get swap bootstrap-word set ] each

7
core/bootstrap/primitives.factor
View File

@ -37,6 +37,7 @@ H{ } clone forgotten-definitions set
H{ } clone root-cache set H{ } clone root-cache set
H{ } clone source-files set H{ } clone source-files set
H{ } clone update-map set H{ } clone update-map set
H{ } clone implementors-map set
init-caches init-caches
! Vocabulary for slot accessors ! Vocabulary for slot accessors
@ -492,7 +493,8 @@ tuple
"curry" "kernel" lookup "curry" "kernel" lookup
[ f "inline" set-word-prop ] [ f "inline" set-word-prop ]
[ ] [ ]
[ tuple-layout [ <tuple-boa> ] curry ] tri define [ tuple-layout [ <tuple-boa> ] curry ] tri
(( obj quot -- curry )) define-declared
"compose" "kernel" create "compose" "kernel" create
tuple tuple
@ -513,7 +515,8 @@ tuple
"compose" "kernel" lookup "compose" "kernel" lookup
[ f "inline" set-word-prop ] [ f "inline" set-word-prop ]
[ ] [ ]
[ tuple-layout [ <tuple-boa> ] curry ] tri define [ tuple-layout [ <tuple-boa> ] curry ] tri
(( quot1 quot2 -- compose )) define-declared
! Primitive words ! Primitive words
: make-primitive ( word vocab n -- ) : make-primitive ( word vocab n -- )

2
core/bootstrap/stage2.factor
View File

@ -49,7 +49,7 @@ millis >r
default-image-name "output-image" set-global default-image-name "output-image" set-global
"math compiler help random tools ui ui.tools io handbook" "include" set-global "math compiler help io random tools ui ui.tools unicode handbook" "include" set-global
"" "exclude" set-global "" "exclude" set-global
parse-command-line parse-command-line

5
core/classes/classes-docs.factor
View File

@ -68,7 +68,10 @@ HELP: tuple-class
{ $examples { $example "USING: classes prettyprint ;" "IN: scratchpad" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ; { $examples { $example "USING: classes prettyprint ;" "IN: scratchpad" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ;
HELP: update-map HELP: update-map
{ $var-description "Hashtable mapping each class to a set of classes defined in terms of this class. The " { $link define-class } " word uses this information to update generic words when classes are redefined." } ; { $var-description "Assoc mapping each class to a set of classes defined in terms of this class. The " { $link define-class } " word uses this information to update generic words when classes are redefined." } ;
! HELP: implementors-map
! { $var-description "Assoc mapping each class to a set of generic words defining methods on this class." } ;
HELP: predicate-word HELP: predicate-word
{ $values { "word" "a word" } { "predicate" "a predicate word" } } { $values { "word" "a word" } { "predicate" "a predicate word" } }

8
core/classes/classes-tests.factor
View File

@ -3,7 +3,7 @@ kernel math namespaces parser prettyprint sequences strings
tools.test vectors words quotations classes tools.test vectors words quotations classes
classes.private classes.union classes.mixin classes.predicate classes.private classes.union classes.mixin classes.predicate
classes.algebra vectors definitions source-files classes.algebra vectors definitions source-files
compiler.units kernel.private ; compiler.units kernel.private sorting vocabs ;
IN: classes.tests IN: classes.tests
! DEFER: bah ! DEFER: bah
@ -169,3 +169,9 @@ M: method-forget-class method-forget-test ;
[ f ] [ \ method-forget-test "methods" word-prop assoc-empty? ] unit-test [ f ] [ \ method-forget-test "methods" word-prop assoc-empty? ] unit-test
[ ] [ [ \ method-forget-class forget ] with-compilation-unit ] unit-test [ ] [ [ \ method-forget-class forget ] with-compilation-unit ] unit-test
[ t ] [ \ method-forget-test "methods" word-prop assoc-empty? ] unit-test [ t ] [ \ method-forget-test "methods" word-prop assoc-empty? ] unit-test
[ t ] [
all-words [ class? ] filter
implementors-map get keys
[ natural-sort ] bi@ =
] unit-test

59
core/classes/classes.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions assocs kernel kernel.private USING: arrays definitions assocs kernel kernel.private
slots.private namespaces sequences strings words vectors math slots.private namespaces sequences strings words vectors math
quotations combinators sorting effects graphs vocabs ; quotations combinators sorting effects graphs vocabs sets ;
IN: classes IN: classes
SYMBOL: class<=-cache SYMBOL: class<=-cache
@ -27,24 +27,24 @@ SYMBOL: class-or-cache
SYMBOL: update-map SYMBOL: update-map
SYMBOL: implementors-map
PREDICATE: class < word PREDICATE: class < word
"class" word-prop ; "class" word-prop ;
PREDICATE: tuple-class < class PREDICATE: tuple-class < class
"metaclass" word-prop tuple-class eq? ; "metaclass" word-prop tuple-class eq? ;
: classes ( -- seq ) all-words [ class? ] filter ; : classes ( -- seq ) implementors-map get keys ;
: predicate-word ( word -- predicate ) : predicate-word ( word -- predicate )
[ word-name "?" append ] keep word-vocabulary create ; [ word-name "?" append ] keep word-vocabulary create ;
: predicate-effect T{ effect f 1 { "?" } } ;
PREDICATE: predicate < word "predicating" word-prop >boolean ; PREDICATE: predicate < word "predicating" word-prop >boolean ;
: define-predicate ( class quot -- ) : define-predicate ( class quot -- )
>r "predicate" word-prop first >r "predicate" word-prop first
r> predicate-effect define-declared ; r> (( object -- ? )) define-declared ;
: superclass ( class -- super ) : superclass ( class -- super )
#! Output f for non-classes to work with algebra code #! Output f for non-classes to work with algebra code
@ -67,6 +67,8 @@ GENERIC: reset-class ( class -- )
M: word reset-class drop ; M: word reset-class drop ;
GENERIC: implementors ( class/classes -- seq )
! update-map ! update-map
: class-uses ( class -- seq ) : class-uses ( class -- seq )
[ [
@ -76,8 +78,8 @@ M: word reset-class drop ;
tri tri
] { } make ; ] { } make ;
: class-usages ( class -- assoc ) : class-usages ( class -- seq )
[ update-map get at ] closure ; [ update-map get at ] closure keys ;
<PRIVATE <PRIVATE
@ -87,6 +89,16 @@ M: word reset-class drop ;
: update-map- ( class -- ) : update-map- ( class -- )
dup class-uses update-map get remove-vertex ; dup class-uses update-map get remove-vertex ;
M: class implementors implementors-map get at keys ;
M: sequence implementors [ implementors ] gather ;
: implementors-map+ ( class -- )
H{ } clone swap implementors-map get set-at ;
: implementors-map- ( class -- )
implementors-map get delete-at ;
: make-class-props ( superclass members participants metaclass -- assoc ) : make-class-props ( superclass members participants metaclass -- assoc )
[ [
{ {
@ -99,8 +111,8 @@ M: word reset-class drop ;
: (define-class) ( word props -- ) : (define-class) ( word props -- )
>r >r
dup class? [ dup [ implementors-map+ ] [ new-class ] bi ] unless
dup reset-class dup reset-class
dup class? [ dup new-class ] unless
dup deferred? [ dup define-symbol ] when dup deferred? [ dup define-symbol ] when
dup word-props dup word-props
r> assoc-union over set-word-props r> assoc-union over set-word-props
@ -116,13 +128,11 @@ GENERIC: update-class ( class -- )
M: class update-class drop ; M: class update-class drop ;
GENERIC: update-methods ( class assoc -- ) GENERIC: update-methods ( class seq -- )
: update-classes ( class -- ) : update-classes ( class -- )
dup class-usages dup class-usages
[ nip keys [ update-class ] each ] [ nip [ update-class ] each ] [ update-methods ] 2bi ;
[ update-methods ]
2bi ;
: define-class ( word superclass members participants metaclass -- ) : define-class ( word superclass members participants metaclass -- )
#! If it was already a class, update methods after. #! If it was already a class, update methods after.
@ -133,6 +143,31 @@ GENERIC: update-methods ( class assoc -- )
[ drop update-map+ ] [ drop update-map+ ]
2tri ; 2tri ;
: forget-predicate ( class -- )
dup "predicate" word-prop
dup length 1 = [
first
tuck "predicating" word-prop =
[ forget ] [ drop ] if
] [ 2drop ] if ;
: forget-methods ( class -- )
[ implementors ] [ [ swap 2array ] curry ] bi map forget-all ;
: forget-class ( class -- )
class-usages [
{
[ forget-predicate ]
[ forget-methods ]
[ implementors-map- ]
[ update-map- ]
[ reset-class ]
} cleave
] each ;
M: class forget* ( class -- )
[ forget-class ] [ call-next-method ] bi ;
GENERIC: class ( object -- class ) GENERIC: class ( object -- class )
: instance? ( obj class -- ? ) : instance? ( obj class -- ? )

10
core/classes/mixin/mixin.factor
View File

@ -39,7 +39,7 @@ TUPLE: check-mixin-class mixin ;
: update-classes/new ( mixin -- ) : update-classes/new ( mixin -- )
class-usages class-usages
[ keys [ update-class ] each ] [ [ update-class ] each ]
[ implementors [ make-generic ] each ] bi ; [ implementors [ make-generic ] each ] bi ;
: add-mixin-instance ( class mixin -- ) : add-mixin-instance ( class mixin -- )
@ -51,8 +51,12 @@ TUPLE: check-mixin-class mixin ;
#! updated by transitivity; the mixins usages appear in #! updated by transitivity; the mixins usages appear in
#! class-usages of the member, now that it's been added. #! class-usages of the member, now that it's been added.
[ 2drop ] [ [ 2drop ] [
[ [ suffix ] change-mixin-class ] 2keep drop [ [ suffix ] change-mixin-class ] 2keep
dup new-class? [ update-classes/new ] [ update-classes ] if tuck [ new-class? ] either? [
update-classes/new
] [
update-classes
] if
] if-mixin-member? ; ] if-mixin-member? ;
: remove-mixin-instance ( class mixin -- ) : remove-mixin-instance ( class mixin -- )

34
core/classes/tuple/tuple-tests.factor
View File

@ -109,6 +109,7 @@ TUPLE: yo-momma ;
[ [
[ t ] [ \ yo-momma class? ] unit-test [ t ] [ \ yo-momma class? ] unit-test
[ ] [ \ yo-momma forget ] unit-test [ ] [ \ yo-momma forget ] unit-test
[ ] [ \ <yo-momma> forget ] unit-test
[ f ] [ \ yo-momma update-map get values memq? ] unit-test [ f ] [ \ yo-momma update-map get values memq? ] unit-test
[ f ] [ \ yo-momma crossref get at ] unit-test [ f ] [ \ yo-momma crossref get at ] unit-test
@ -552,11 +553,11 @@ TUPLE: subclass-forget-test-3 < subclass-forget-test-2 ;
[ ] [ "IN: classes.tuple.tests FORGET: subclass-forget-test" eval ] unit-test [ ] [ "IN: classes.tuple.tests FORGET: subclass-forget-test" eval ] unit-test
[ H{ { subclass-forget-test-2 subclass-forget-test-2 } } ] [ { subclass-forget-test-2 } ]
[ subclass-forget-test-2 class-usages ] [ subclass-forget-test-2 class-usages ]
unit-test unit-test
[ H{ { subclass-forget-test-3 subclass-forget-test-3 } } ] [ { subclass-forget-test-3 } ]
[ subclass-forget-test-3 class-usages ] [ subclass-forget-test-3 class-usages ]
unit-test unit-test
@ -565,3 +566,32 @@ unit-test
[ subclass-forget-test-3 new ] must-fail [ subclass-forget-test-3 new ] must-fail
[ "IN: classes.tuple.tests TUPLE: subclass-forget-test-4 < subclass-forget-test-2 ;" eval ] must-fail [ "IN: classes.tuple.tests TUPLE: subclass-forget-test-4 < subclass-forget-test-2 ;" eval ] must-fail
! More
DEFER: subclass-reset-test
DEFER: subclass-reset-test-1
DEFER: subclass-reset-test-2
DEFER: subclass-reset-test-3
GENERIC: break-me ( obj -- )
[ ] [ [ { integer break-me } forget ] with-compilation-unit ] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test ;" <string-reader> "subclass-reset-test" parse-stream drop ] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-1 < subclass-reset-test ;" eval ] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-2 < subclass-reset-test ;" eval ] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-3 < subclass-reset-test-2 ;" eval ] unit-test
[ ] [ "IN: classes.tuple.tests USE: kernel M: subclass-reset-test-1 break-me drop ;" eval ] unit-test
[ ] [ "IN: classes.tuple.tests : subclass-reset-test ;" <string-reader> "subclass-reset-test" parse-stream drop ] unit-test
[ f ] [ subclass-reset-test-1 tuple-class? ] unit-test
[ f ] [ subclass-reset-test-2 tuple-class? ] unit-test
[ subclass-forget-test-3 new ] must-fail
[ t ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test
[ ] [ "IN: classes.tuple.tests USE: math USE: kernel M: integer break-me drop ;" eval ] unit-test
[ f ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test

2
core/classes/tuple/tuple.factor
View File

@ -166,7 +166,7 @@ M: tuple-class update-class
3tri ; 3tri ;
: subclasses ( class -- classes ) : subclasses ( class -- classes )
class-usages keys [ tuple-class? ] filter ; class-usages [ tuple-class? ] filter ;
: each-subclass ( class quot -- ) : each-subclass ( class quot -- )
>r subclasses r> each ; inline >r subclasses r> each ; inline

41
core/compiler/compiler.factor
View File

@ -4,20 +4,25 @@ USING: kernel namespaces arrays sequences io inference.backend
inference.state generator debugger words compiler.units inference.state generator debugger words compiler.units
continuations vocabs assocs alien.compiler dlists optimizer continuations vocabs assocs alien.compiler dlists optimizer
definitions math compiler.errors threads graphs generic definitions math compiler.errors threads graphs generic
inference combinators ; inference combinators dequeues search-dequeues ;
IN: compiler IN: compiler
: ripple-up ( word -- ) SYMBOL: +failed+
compiled-usage [ drop queue-compile ] assoc-each ;
: ripple-up ( words -- )
dup "compiled-effect" word-prop +failed+ eq?
[ usage [ word? ] filter ] [ compiled-usage keys ] if
[ queue-compile ] each ;
: ripple-up? ( word effect -- ? )
#! If the word has previously been compiled and had a
#! different stack effect, we have to recompile any callers.
swap "compiled-effect" word-prop [ = not ] keep and ;
: save-effect ( word effect -- ) : save-effect ( word effect -- )
[ [ dupd ripple-up? [ ripple-up ] [ drop ] if ]
over "compiled-effect" word-prop = [ [ "compiled-effect" set-word-prop ]
dup "compiled-uses" word-prop 2bi ;
[ dup ripple-up ] when
] unless drop
]
[ "compiled-effect" set-word-prop ] 2bi ;
: compile-begins ( word -- ) : compile-begins ( word -- )
f swap compiler-error ; f swap compiler-error ;
@ -26,9 +31,10 @@ IN: compiler
[ swap compiler-error ] [ swap compiler-error ]
[ [
drop drop
[ compiled-unxref ]
[ f swap compiled get set-at ] [ f swap compiled get set-at ]
[ f save-effect ] [ +failed+ save-effect ]
bi tri
] 2bi ; ] 2bi ;
: compile-succeeded ( effect word -- ) : compile-succeeded ( effect word -- )
@ -40,6 +46,7 @@ IN: compiler
] tri ; ] tri ;
: (compile) ( word -- ) : (compile) ( word -- )
dup dup "compile-count" word-prop 0 or 1 + "compile-count" set-word-prop
[ [
H{ } clone dependencies set H{ } clone dependencies set
@ -54,19 +61,15 @@ IN: compiler
} cleave } cleave
] curry with-return ; ] curry with-return ;
: compile-loop ( assoc -- ) : compile-loop ( dequeue -- )
dup assoc-empty? [ drop ] [ [ (compile) yield ] slurp-dequeue ;
dup delete-any drop (compile)
yield
compile-loop
] if ;
: decompile ( word -- ) : decompile ( word -- )
f 2array 1array t modify-code-heap ; f 2array 1array t modify-code-heap ;
: optimized-recompile-hook ( words -- alist ) : optimized-recompile-hook ( words -- alist )
[ [
H{ } clone compile-queue set <hashed-dlist> compile-queue set
H{ } clone compiled set H{ } clone compiled set
[ queue-compile ] each [ queue-compile ] each
compile-queue get compile-loop compile-queue get compile-loop

4
core/compiler/tests/insane.factor Normal file
View File

@ -0,0 +1,4 @@
IN: compiler.tests
USING: words kernel inference alien.strings tools.test ;
[ ] [ \ if redefined [ string>alien ] infer. ] unit-test

14
core/compiler/tests/redefine.factor
View File

@ -1,14 +0,0 @@
IN: compiler.tests
USING: compiler tools.test math parser ;
GENERIC: method-redefine-test ( a -- b )
M: integer method-redefine-test 3 + ;
: method-redefine-test-1 ( -- b ) 3 method-redefine-test ;
[ 6 ] [ method-redefine-test-1 ] unit-test
[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-test 4 + ;" eval ] unit-test
[ 7 ] [ method-redefine-test-1 ] unit-test

67
core/compiler/tests/redefine1.factor Normal file
View File

@ -0,0 +1,67 @@
IN: compiler.tests
USING: compiler compiler.units tools.test math parser kernel
sequences sequences.private classes.mixin generic definitions
arrays words assocs ;
GENERIC: method-redefine-test ( a -- b )
M: integer method-redefine-test 3 + ;
: method-redefine-test-1 ( -- b ) 3 method-redefine-test ;
[ 6 ] [ method-redefine-test-1 ] unit-test
[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-test 4 + ;" eval ] unit-test
[ 7 ] [ method-redefine-test-1 ] unit-test
[ ] [ [ fixnum \ method-redefine-test method forget ] with-compilation-unit ] unit-test
[ 6 ] [ method-redefine-test-1 ] unit-test
! Test ripple-up behavior
: hey ( -- ) ;
: there ( -- ) hey ;
[ t ] [ \ hey compiled? ] unit-test
[ t ] [ \ there compiled? ] unit-test
[ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" eval ] unit-test
[ f ] [ \ hey compiled? ] unit-test
[ f ] [ \ there compiled? ] unit-test
[ ] [ "IN: compiler.tests : hey ( -- ) ;" eval ] unit-test
[ t ] [ \ there compiled? ] unit-test
! Just changing the stack effect didn't mark a word for recompilation
DEFER: change-effect
[ ] [ "IN: compiler.tests GENERIC: change-effect ( a -- b )" eval ] unit-test
{ 1 1 } [ change-effect ] must-infer-as
[ ] [ "IN: compiler.tests GENERIC: change-effect ( a -- )" eval ] unit-test
{ 1 0 } [ change-effect ] must-infer-as
: good ( -- ) ;
: bad ( -- ) good ;
: ugly ( -- ) bad ;
[ t ] [ \ good compiled? ] unit-test
[ t ] [ \ bad compiled? ] unit-test
[ t ] [ \ ugly compiled? ] unit-test
[ f ] [ \ good compiled-usage assoc-empty? ] unit-test
[ ] [ "IN: compiler.tests : good ( -- ) 3 ;" eval ] unit-test
[ f ] [ \ good compiled? ] unit-test
[ f ] [ \ bad compiled? ] unit-test
[ f ] [ \ ugly compiled? ] unit-test
[ t ] [ \ good compiled-usage assoc-empty? ] unit-test
[ ] [ "IN: compiler.tests : good ( -- ) ;" eval ] unit-test
[ t ] [ \ good compiled? ] unit-test
[ t ] [ \ bad compiled? ] unit-test
[ t ] [ \ ugly compiled? ] unit-test
[ f ] [ \ good compiled-usage assoc-empty? ] unit-test

18
core/compiler/tests/redefine2.factor Normal file
View File

@ -0,0 +1,18 @@
IN: compiler.tests
USING: compiler compiler.units tools.test math parser kernel
sequences sequences.private classes.mixin generic definitions
arrays words assocs ;
DEFER: blah
[ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: blah ; M: blah nth 2drop 3 ; INSTANCE: blah sequence" eval ] unit-test
[ t ] [ blah new sequence? ] unit-test
[ 3 ] [ 0 blah new nth-unsafe ] unit-test
[ ] [ [ blah sequence remove-mixin-instance ] with-compilation-unit ] unit-test
[ f ] [ blah new sequence? ] unit-test
[ 0 blah new nth-unsafe ] must-fail

32
core/compiler/tests/redefine3.factor Normal file
View File

@ -0,0 +1,32 @@
IN: compiler.tests
USING: compiler compiler.units tools.test math parser kernel
sequences sequences.private classes.mixin generic definitions
arrays words assocs ;
GENERIC: sheeple ( obj -- x )
M: object sheeple drop "sheeple" ;
MIXIN: empty-mixin
M: empty-mixin sheeple drop "wake up" ;
: sheeple-test ( -- string ) { } sheeple ;
[ "sheeple" ] [ sheeple-test ] unit-test
[ t ] [ \ sheeple-test compiled? ] unit-test
[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ ] [ "IN: compiler.tests USE: arrays INSTANCE: array empty-mixin" eval ] unit-test
[ "wake up" ] [ sheeple-test ] unit-test
[ f ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ t ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ ] [ [ array empty-mixin remove-mixin-instance ] with-compilation-unit ] unit-test
[ "sheeple" ] [ sheeple-test ] unit-test
[ t ] [ \ sheeple-test compiled? ] unit-test
[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test

6
core/compiler/tests/reload.factor Normal file
View File

@ -0,0 +1,6 @@
IN: compiler.tests
USE: vocabs.loader
"parser" reload
"sequences" reload
"kernel" reload

6
core/compiler/units/units.factor
View File

@ -79,9 +79,15 @@ SYMBOL: update-tuples-hook
: call-update-tuples-hook ( -- ) : call-update-tuples-hook ( -- )
update-tuples-hook get call ; update-tuples-hook get call ;
: unxref-forgotten-definitions ( -- )
forgotten-definitions get
keys [ word? ] filter
[ delete-compiled-xref ] each ;
: finish-compilation-unit ( -- ) : finish-compilation-unit ( -- )
call-recompile-hook call-recompile-hook
call-update-tuples-hook call-update-tuples-hook
unxref-forgotten-definitions
dup [ drop crossref? ] assoc-contains? modify-code-heap ; dup [ drop crossref? ] assoc-contains? modify-code-heap ;
: with-nested-compilation-unit ( quot -- ) : with-nested-compilation-unit ( quot -- )

14
core/cpu/x86/32/bootstrap.factor
View File

@ -6,13 +6,13 @@ IN: bootstrap.x86
4 \ cell set 4 \ cell set
: arg0 EAX ; : arg0 ( -- reg ) EAX ;
: arg1 EDX ; : arg1 ( -- reg ) EDX ;
: temp-reg EBX ; : temp-reg ( -- reg ) EBX ;
: stack-reg ESP ; : stack-reg ( -- reg ) ESP ;
: ds-reg ESI ; : ds-reg ( -- reg ) ESI ;
: fixnum>slot@ arg0 1 SAR ; : fixnum>slot@ ( -- ) arg0 1 SAR ;
: rex-length 0 ; : rex-length ( -- n ) 0 ;
<< "resource:core/cpu/x86/bootstrap.factor" parse-file parsed >> << "resource:core/cpu/x86/bootstrap.factor" parse-file parsed >>
call call

14
core/cpu/x86/64/bootstrap.factor
View File

@ -6,13 +6,13 @@ IN: bootstrap.x86
8 \ cell set 8 \ cell set
: arg0 RDI ; : arg0 ( -- reg ) RDI ;
: arg1 RSI ; : arg1 ( -- reg ) RSI ;
: temp-reg RBX ; : temp-reg ( -- reg ) RBX ;
: stack-reg RSP ; : stack-reg ( -- reg ) RSP ;
: ds-reg R14 ; : ds-reg ( -- reg ) R14 ;
: fixnum>slot@ ; : fixnum>slot@ ( -- ) ;
: rex-length 1 ; : rex-length ( -- n ) 1 ;
<< "resource:core/cpu/x86/bootstrap.factor" parse-file parsed >> << "resource:core/cpu/x86/bootstrap.factor" parse-file parsed >>
call call

2
core/cpu/x86/bootstrap.factor
View File

@ -9,7 +9,7 @@ big-endian off
1 jit-code-format set 1 jit-code-format set
: stack-frame-size 4 bootstrap-cells ; : stack-frame-size ( -- n ) 4 bootstrap-cells ;
[ [
! Load word ! Load word

1
core/dequeues/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

89
core/dequeues/dequeues-docs.factor Normal file
View File

@ -0,0 +1,89 @@
IN: dequeues
USING: help.markup help.syntax kernel ;
ARTICLE: "dequeues" "Dequeues"
"A dequeue is a data structure with constant-time insertion and removal of elements at both ends. Dequeue operations are defined in the " { $vocab-link "dequeues" } " vocabulary."
$nl
"Dequeues must be instances of a mixin class:"
{ $subsection dequeue }
"Dequeues must implement a protocol."
$nl
"Querying the dequeue:"
{ $subsection peek-front }
{ $subsection peek-back }
{ $subsection dequeue-length }
{ $subsection dequeue-member? }
"Adding and removing elements:"
{ $subsection push-front* }
{ $subsection push-back* }
{ $subsection pop-front* }
{ $subsection pop-back* }
{ $subsection clear-dequeue }
"Working with node objects output by " { $link push-front* } " and " { $link push-back* } ":"
{ $subsection delete-node }
{ $subsection node-value }
"Utility operations built in terms of the above:"
{ $subsection dequeue-empty? }
{ $subsection push-front }
{ $subsection push-all-front }
{ $subsection push-back }
{ $subsection push-all-back }
{ $subsection pop-front }
{ $subsection pop-back }
{ $subsection slurp-dequeue }
"When using a dequeue as a queue, the convention is to queue elements with " { $link push-front } " and dequeue them with " { $link pop-back } "." ;
ABOUT: "dequeues"
HELP: dequeue-empty?
{ $values { "dequeue" { $link dequeue } } { "?" "a boolean" } }
{ $description "Returns true if a dequeue is empty." }
{ $notes "This operation is O(1)." } ;
HELP: push-front
{ $values { "obj" object } { "dequeue" dequeue } }
{ $description "Push the object onto the front of the dequeue." }
{ $notes "This operation is O(1)." } ;
HELP: push-front*
{ $values { "obj" object } { "dequeue" dequeue } { "node" "a node" } }
{ $description "Push the object onto the front of the dequeue and return the newly created node." }
{ $notes "This operation is O(1)." } ;
HELP: push-back
{ $values { "obj" object } { "dequeue" dequeue } }
{ $description "Push the object onto the back of the dequeue." }
{ $notes "This operation is O(1)." } ;
HELP: push-back*
{ $values { "obj" object } { "dequeue" dequeue } { "node" "a node" } }
{ $description "Push the object onto the back of the dequeue and return the newly created node." }
{ $notes "This operation is O(1)." } ;
HELP: peek-front
{ $values { "dequeue" dequeue } { "obj" object } }
{ $description "Returns the object at the front of the dequeue." } ;
HELP: pop-front
{ $values { "dequeue" dequeue } { "obj" object } }
{ $description "Pop the object off the front of the dequeue and return the object." }
{ $notes "This operation is O(1)." } ;
HELP: pop-front*
{ $values { "dequeue" dequeue } }
{ $description "Pop the object off the front of the dequeue." }
{ $notes "This operation is O(1)." } ;
HELP: peek-back
{ $values { "dequeue" dequeue } { "obj" object } }
{ $description "Returns the object at the back of the dequeue." } ;
HELP: pop-back
{ $values { "dequeue" dequeue } { "obj" object } }
{ $description "Pop the object off the back of the dequeue and return the object." }
{ $notes "This operation is O(1)." } ;
HELP: pop-back*
{ $values { "dequeue" dequeue } }
{ $description "Pop the object off the back of the dequeue." }
{ $notes "This operation is O(1)." } ;

44
core/dequeues/dequeues.factor Normal file
View File

@ -0,0 +1,44 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences math ;
IN: dequeues
GENERIC: push-front* ( obj dequeue -- node )
GENERIC: push-back* ( obj dequeue -- node )
GENERIC: peek-front ( dequeue -- obj )
GENERIC: peek-back ( dequeue -- obj )
GENERIC: pop-front* ( dequeue -- )
GENERIC: pop-back* ( dequeue -- )
GENERIC: delete-node ( node dequeue -- )
GENERIC: dequeue-length ( dequeue -- n )
GENERIC: dequeue-member? ( value dequeue -- ? )
GENERIC: clear-dequeue ( dequeue -- )
GENERIC: node-value ( node -- value )
: dequeue-empty? ( dequeue -- ? )
dequeue-length zero? ;
: push-front ( obj dequeue -- )
push-front* drop ;
: push-all-front ( seq dequeue -- )
[ push-front ] curry each ;
: push-back ( obj dequeue -- )
push-back* drop ;
: push-all-back ( seq dequeue -- )
[ push-back ] curry each ;
: pop-front ( dequeue -- obj )
[ peek-front ] [ pop-front* ] bi ;
: pop-back ( dequeue -- obj )
[ peek-back ] [ pop-back* ] bi ;
: slurp-dequeue ( dequeue quot -- )
over dequeue-empty? [ 2drop ] [
[ [ pop-back ] dip call ] [ slurp-dequeue ] 2bi
] if ; inline
MIXIN: dequeue

1
core/dequeues/summary.txt Normal file
View File

@ -0,0 +1 @@
Double-ended queue protocol and common operations

1
core/dequeues/tags.txt Normal file
View File

@ -0,0 +1 @@
collections

94
core/dlists/dlists-docs.factor
View File

@ -1,103 +1,27 @@
USING: help.markup help.syntax kernel quotations dlists.private ; USING: help.markup help.syntax kernel quotations
dequeues ;
IN: dlists IN: dlists
ARTICLE: "dlists" "Doubly-linked lists" ARTICLE: "dlists" "Double-linked lists"
"A doubly-linked list, or dlist, is a list of nodes. Each node has a link to the previous and next nodes, and a slot to store an object." "A double-linked list is the canonical implementation of a " { $link dequeue } "."
$nl $nl
"While nodes can be modified directly, the fundamental protocol support by doubly-linked lists is that of a double-ended queue with a few additional operations. Elements can be added or removed at both ends of the dlist in constant time." "Double-linked lists form a class:"
$nl
"When using a dlist as a simple queue, the convention is to queue elements with " { $link push-front } " and dequeue them with " { $link pop-back } "."
$nl
"Dlists form a class:"
{ $subsection dlist } { $subsection dlist }
{ $subsection dlist? } { $subsection dlist? }
"Constructing a dlist:" "Constructing a double-linked list:"
{ $subsection <dlist> } { $subsection <dlist> }
"Working with the front of the list:" "Double-linked lists support all the operations of the dequeue protocol (" { $link "dequeues" } ") as well as the following."
{ $subsection push-front } $nl
{ $subsection push-front* }
{ $subsection peek-front }
{ $subsection pop-front }
{ $subsection pop-front* }
"Working with the back of the list:"
{ $subsection push-back }
{ $subsection push-back* }
{ $subsection peek-back }
{ $subsection pop-back }
{ $subsection pop-back* }
"Finding out the length:"
{ $subsection dlist-empty? }
{ $subsection dlist-length }
"Iterating over elements:" "Iterating over elements:"
{ $subsection dlist-each } { $subsection dlist-each }
{ $subsection dlist-find } { $subsection dlist-find }
{ $subsection dlist-contains? } { $subsection dlist-contains? }
"Deleting a node:"
{ $subsection delete-node }
{ $subsection dlist-delete }
"Deleting a node matching a predicate:" "Deleting a node matching a predicate:"
{ $subsection delete-node-if* } { $subsection delete-node-if* }
{ $subsection delete-node-if } { $subsection delete-node-if } ;
"Consuming all nodes:"
{ $subsection dlist-slurp } ;
ABOUT: "dlists" ABOUT: "dlists"
HELP: dlist-empty?
{ $values { "dlist" { $link dlist } } { "?" "a boolean" } }
{ $description "Returns true if a " { $link dlist } " is empty." }
{ $notes "This operation is O(1)." } ;
HELP: push-front
{ $values { "obj" "an object" } { "dlist" dlist } }
{ $description "Push the object onto the front of the " { $link dlist } "." }
{ $notes "This operation is O(1)." } ;
HELP: push-front*
{ $values { "obj" "an object" } { "dlist" dlist } { "dlist-node" dlist-node } }
{ $description "Push the object onto the front of the " { $link dlist } " and return the newly created " { $snippet "dlist-node" } "." }
{ $notes "This operation is O(1)." } ;
HELP: push-back
{ $values { "obj" "an object" } { "dlist" dlist } }
{ $description "Push the object onto the back of the " { $link dlist } "." }
{ $notes "This operation is O(1)." } ;
HELP: push-back*
{ $values { "obj" "an object" } { "dlist" dlist } { "dlist-node" dlist-node } }
{ $description "Push the object onto the back of the " { $link dlist } " and return the newly created " { $snippet "dlist-node" } "." }
{ $notes "This operation is O(1)." } ;
HELP: peek-front
{ $values { "dlist" dlist } { "obj" "an object" } }
{ $description "Returns the object at the front of the " { $link dlist } "." } ;
HELP: pop-front
{ $values { "dlist" dlist } { "obj" "an object" } }
{ $description "Pop the object off the front of the " { $link dlist } " and return the object." }
{ $notes "This operation is O(1)." } ;
HELP: pop-front*
{ $values { "dlist" dlist } }
{ $description "Pop the object off the front of the " { $link dlist } "." }
{ $notes "This operation is O(1)." } ;
HELP: peek-back
{ $values { "dlist" dlist } { "obj" "an object" } }
{ $description "Returns the object at the back of the " { $link dlist } "." } ;
HELP: pop-back
{ $values { "dlist" dlist } { "obj" "an object" } }
{ $description "Pop the object off the back of the " { $link dlist } " and return the object." }
{ $notes "This operation is O(1)." } ;
HELP: pop-back*
{ $values { "dlist" dlist } }
{ $description "Pop the object off the back of the " { $link dlist } "." }
{ $notes "This operation is O(1)." } ;
{ push-front push-front* push-back push-back* peek-front pop-front pop-front* peek-back pop-back pop-back* } related-words
HELP: dlist-find HELP: dlist-find
{ $values { "dlist" { $link dlist } } { "quot" quotation } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } } { $values { "dlist" { $link dlist } } { "quot" quotation } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
{ $description "Applies the quotation to each element of the " { $link dlist } " in turn, until it outputs a true value or the end of the " { $link dlist } " is reached. Outputs either the object it found or " { $link f } ", and a boolean which is true if an object is found." } { $description "Applies the quotation to each element of the " { $link dlist } " in turn, until it outputs a true value or the end of the " { $link dlist } " is reached. Outputs either the object it found or " { $link f } ", and a boolean which is true if an object is found." }

75
core/dlists/dlists-tests.factor
View File

@ -1,17 +1,17 @@
USING: dlists dlists.private kernel tools.test random assocs USING: dequeues dlists dlists.private kernel tools.test random
sets sequences namespaces sorting debugger io prettyprint assocs sets sequences namespaces sorting debugger io prettyprint
math accessors classes ; math accessors classes ;
IN: dlists.tests IN: dlists.tests
[ t ] [ <dlist> dlist-empty? ] unit-test [ t ] [ <dlist> dequeue-empty? ] unit-test
[ T{ dlist f T{ dlist-node f 1 f f } T{ dlist-node f 1 f f } 1 } ] [ T{ dlist f T{ dlist-node f 1 f f } T{ dlist-node f 1 f f } 1 } ]
[ <dlist> 1 over push-front ] unit-test [ <dlist> 1 over push-front ] unit-test
! Make sure empty lists are empty ! Make sure empty lists are empty
[ t ] [ <dlist> dlist-empty? ] unit-test [ t ] [ <dlist> dequeue-empty? ] unit-test
[ f ] [ <dlist> 1 over push-front dlist-empty? ] unit-test [ f ] [ <dlist> 1 over push-front dequeue-empty? ] unit-test
[ f ] [ <dlist> 1 over push-back dlist-empty? ] unit-test [ f ] [ <dlist> 1 over push-back dequeue-empty? ] unit-test
[ 1 ] [ <dlist> 1 over push-front pop-front ] unit-test [ 1 ] [ <dlist> 1 over push-front pop-front ] unit-test
[ 1 ] [ <dlist> 1 over push-front pop-back ] unit-test [ 1 ] [ <dlist> 1 over push-front pop-back ] unit-test
@ -25,22 +25,22 @@ IN: dlists.tests
! Test the prev,next links for two nodes ! Test the prev,next links for two nodes
[ f ] [ [ f ] [
<dlist> 1 over push-back 2 over push-back <dlist> 1 over push-back 2 over push-back
dlist-front dlist-node-prev front>> prev>>
] unit-test ] unit-test
[ 2 ] [ [ 2 ] [
<dlist> 1 over push-back 2 over push-back <dlist> 1 over push-back 2 over push-back
dlist-front dlist-node-next dlist-node-obj front>> next>> obj>>
] unit-test ] unit-test
[ 1 ] [ [ 1 ] [
<dlist> 1 over push-back 2 over push-back <dlist> 1 over push-back 2 over push-back
dlist-front dlist-node-next dlist-node-prev dlist-node-obj front>> next>> prev>> obj>>
] unit-test ] unit-test
[ f ] [ [ f ] [
<dlist> 1 over push-back 2 over push-back <dlist> 1 over push-back 2 over push-back
dlist-front dlist-node-next dlist-node-next front>> next>> next>>
] unit-test ] unit-test
[ f f ] [ <dlist> [ 1 = ] dlist-find ] unit-test [ f f ] [ <dlist> [ 1 = ] dlist-find ] unit-test
@ -50,55 +50,24 @@ IN: dlists.tests
[ t ] [ <dlist> 1 over push-back [ 1 = ] dlist-contains? ] unit-test [ t ] [ <dlist> 1 over push-back [ 1 = ] dlist-contains? ] unit-test
[ 1 ] [ <dlist> 1 over push-back [ 1 = ] delete-node-if ] unit-test [ 1 ] [ <dlist> 1 over push-back [ 1 = ] delete-node-if ] unit-test
[ t ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop dlist-empty? ] unit-test [ t ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop dequeue-empty? ] unit-test
[ t ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop dlist-empty? ] unit-test [ t ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop dequeue-empty? ] unit-test
[ 0 ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop dlist-length ] unit-test [ 0 ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop dequeue-length ] unit-test
[ 1 ] [ <dlist> 1 over push-back 2 over push-back dup [ 1 = ] delete-node-if drop dlist-length ] unit-test [ 1 ] [ <dlist> 1 over push-back 2 over push-back dup [ 1 = ] delete-node-if drop dequeue-length ] unit-test
[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 1 = ] delete-node-if drop dlist-length ] unit-test [ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 1 = ] delete-node-if drop dequeue-length ] unit-test
[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 2 = ] delete-node-if drop dlist-length ] unit-test [ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 2 = ] delete-node-if drop dequeue-length ] unit-test
[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 3 = ] delete-node-if drop dlist-length ] unit-test [ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 3 = ] delete-node-if drop dequeue-length ] unit-test
[ 0 ] [ <dlist> dlist-length ] unit-test [ 0 ] [ <dlist> dequeue-length ] unit-test
[ 1 ] [ <dlist> 1 over push-front dlist-length ] unit-test [ 1 ] [ <dlist> 1 over push-front dequeue-length ] unit-test
[ 0 ] [ <dlist> 1 over push-front dup pop-front* dlist-length ] unit-test [ 0 ] [ <dlist> 1 over push-front dup pop-front* dequeue-length ] unit-test
: assert-same-elements
[ prune natural-sort ] bi@ assert= ;
: dlist-delete-all [ dlist-delete drop ] curry each ;
: dlist>array [ [ , ] dlist-slurp ] { } make ;
[ ] [
5 [ drop 30 random >fixnum ] map prune
6 [ drop 30 random >fixnum ] map prune [
<dlist>
[ push-all-front ]
[ dlist-delete-all ]
[ dlist>array ] tri
] 2keep swap diff assert-same-elements
] unit-test
[ ] [
<dlist> "d" set
1 "d" get push-front
2 "d" get push-front
3 "d" get push-front
4 "d" get push-front
2 "d" get dlist-delete drop
3 "d" get dlist-delete drop
4 "d" get dlist-delete drop
] unit-test
[ 1 ] [ "d" get dlist-length ] unit-test
[ 1 ] [ "d" get dlist>array length ] unit-test
[ t ] [ <dlist> 4 over push-back 5 over push-back [ obj>> 4 = ] dlist-find-node drop class dlist-node = ] unit-test [ t ] [ <dlist> 4 over push-back 5 over push-back [ obj>> 4 = ] dlist-find-node drop class dlist-node = ] unit-test
[ t ] [ <dlist> 4 over push-back 5 over push-back [ obj>> 5 = ] dlist-find-node drop class dlist-node = ] unit-test [ t ] [ <dlist> 4 over push-back 5 over push-back [ obj>> 5 = ] dlist-find-node drop class dlist-node = ] unit-test
[ t ] [ <dlist> 4 over push-back 5 over push-back* [ = ] curry dlist-find-node drop class dlist-node = ] unit-test [ t ] [ <dlist> 4 over push-back 5 over push-back* [ = ] curry dlist-find-node drop class dlist-node = ] unit-test
[ ] [ <dlist> 4 over push-back 5 over push-back [ drop ] dlist-each ] unit-test [ ] [ <dlist> 4 over push-back 5 over push-back [ drop ] dlist-each ] unit-test
[ <dlist> peek-front ] must-fail [ <dlist> peek-front ] [ empty-dlist? ] must-fail-with
[ <dlist> peek-back ] must-fail [ <dlist> peek-back ] [ empty-dlist? ] must-fail-with
[ <dlist> pop-front ] [ empty-dlist? ] must-fail-with [ <dlist> pop-front ] [ empty-dlist? ] must-fail-with
[ <dlist> pop-back ] [ empty-dlist? ] must-fail-with [ <dlist> pop-back ] [ empty-dlist? ] must-fail-with

95
core/dlists/dlists.factor
View File

@ -1,16 +1,17 @@
! Copyright (C) 2007, 2008 Mackenzie Straight, Doug Coleman, ! Copyright (C) 2007, 2008 Mackenzie Straight, Doug Coleman,
! Slava Pestov. ! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: combinators kernel math sequences accessors inspector ; USING: combinators kernel math sequences accessors inspector
dequeues ;
IN: dlists IN: dlists
TUPLE: dlist front back length ; TUPLE: dlist front back length ;
: <dlist> ( -- obj ) : <dlist> ( -- obj )
dlist new dlist new
0 >>length ; 0 >>length ;
: dlist-empty? ( dlist -- ? ) front>> not ; M: dlist dequeue-length length>> ;
<PRIVATE <PRIVATE
@ -18,6 +19,8 @@ TUPLE: dlist-node obj prev next ;
C: <dlist-node> dlist-node C: <dlist-node> dlist-node
M: dlist-node node-value obj>> ;
: inc-length ( dlist -- ) : inc-length ( dlist -- )
[ 1+ ] change-length drop ; inline [ 1+ ] change-length drop ; inline
@ -57,69 +60,59 @@ C: <dlist-node> dlist-node
: dlist-each-node ( dlist quot -- ) : dlist-each-node ( dlist quot -- )
[ f ] compose dlist-find-node 2drop ; inline [ f ] compose dlist-find-node 2drop ; inline
: unlink-node ( dlist-node -- )
dup prev>> over next>> set-prev-when
dup next>> swap prev>> set-next-when ;
PRIVATE> PRIVATE>
: push-front* ( obj dlist -- dlist-node ) M: dlist push-front* ( obj dlist -- dlist-node )
[ front>> f swap <dlist-node> dup dup set-next-prev ] keep [ front>> f swap <dlist-node> dup dup set-next-prev ] keep
[ (>>front) ] keep [ (>>front) ] keep
[ set-back-to-front ] keep [ set-back-to-front ] keep
inc-length ; inc-length ;
: push-front ( obj dlist -- ) M: dlist push-back* ( obj dlist -- dlist-node )
push-front* drop ;
: push-all-front ( seq dlist -- )
[ push-front ] curry each ;
: push-back* ( obj dlist -- dlist-node )
[ back>> f <dlist-node> ] keep [ back>> f <dlist-node> ] keep
[ back>> set-next-when ] 2keep [ back>> set-next-when ] 2keep
[ (>>back) ] 2keep [ (>>back) ] 2keep
[ set-front-to-back ] keep [ set-front-to-back ] keep
inc-length ; inc-length ;
: push-back ( obj dlist -- )
push-back* drop ;
: push-all-back ( seq dlist -- )
[ push-back ] curry each ;
ERROR: empty-dlist ; ERROR: empty-dlist ;
M: empty-dlist summary ( dlist -- ) M: empty-dlist summary ( dlist -- )
drop "Emtpy dlist" ; drop "Empty dlist" ;
: peek-front ( dlist -- obj ) M: dlist peek-front ( dlist -- obj )
front>> [ empty-dlist ] unless* obj>> ; front>> [ obj>> ] [ empty-dlist ] if* ;
: pop-front ( dlist -- obj ) M: dlist pop-front* ( dlist -- )
dup front>> [ empty-dlist ] unless* dup front>> [ empty-dlist ] unless
[ [
dup front>>
dup next>> dup next>>
f rot (>>next) f rot (>>next)
f over set-prev-when f over set-prev-when
swap (>>front) swap (>>front)
] 2keep obj>> ] keep
swap [ normalize-back ] keep dec-length ; [ normalize-back ] keep
dec-length ;
: pop-front* ( dlist -- ) M: dlist peek-back ( dlist -- obj )
pop-front drop ; back>> [ obj>> ] [ empty-dlist ] if* ;
: peek-back ( dlist -- obj ) M: dlist pop-back* ( dlist -- )
back>> [ empty-dlist ] unless* obj>> ; dup back>> [ empty-dlist ] unless
: pop-back ( dlist -- obj )
dup back>> [ empty-dlist ] unless*
[ [
dup back>>
dup prev>> dup prev>>
f rot (>>prev) f rot (>>prev)
f over set-next-when f over set-next-when
swap (>>back) swap (>>back)
] 2keep obj>> ] keep
swap [ normalize-front ] keep dec-length ; [ normalize-front ] keep
dec-length ;
: pop-back* ( dlist -- )
pop-back drop ;
: dlist-find ( dlist quot -- obj/f ? ) : dlist-find ( dlist quot -- obj/f ? )
[ obj>> ] prepose [ obj>> ] prepose
@ -128,21 +121,20 @@ M: empty-dlist summary ( dlist -- )
: dlist-contains? ( dlist quot -- ? ) : dlist-contains? ( dlist quot -- ? )
dlist-find nip ; inline dlist-find nip ; inline
: unlink-node ( dlist-node -- ) M: dlist dequeue-member? ( value dlist -- ? )
dup prev>> over next>> set-prev-when [ = ] curry dlist-contains? ;
dup next>> swap prev>> set-next-when ;
: delete-node ( dlist dlist-node -- ) M: dlist delete-node ( dlist-node dlist -- )
{ {
{ [ over front>> over eq? ] [ drop pop-front* ] } { [ 2dup front>> eq? ] [ nip pop-front* ] }
{ [ over back>> over eq? ] [ drop pop-back* ] } { [ 2dup back>> eq? ] [ nip pop-back* ] }
[ unlink-node dec-length ] [ dec-length unlink-node ]
} cond ; } cond ;
: delete-node-if* ( dlist quot -- obj/f ? ) : delete-node-if* ( dlist quot -- obj/f ? )
dupd dlist-find-node [ dupd dlist-find-node [
dup [ dup [
[ delete-node ] keep obj>> t [ swap delete-node ] keep obj>> t
] [ ] [
2drop f f 2drop f f
] if ] if
@ -151,13 +143,9 @@ M: empty-dlist summary ( dlist -- )
] if ; inline ] if ; inline
: delete-node-if ( dlist quot -- obj/f ) : delete-node-if ( dlist quot -- obj/f )
[ obj>> ] prepose [ obj>> ] prepose delete-node-if* drop ; inline
delete-node-if* drop ; inline
: dlist-delete ( obj dlist -- obj/f ) M: dlist clear-dequeue ( dlist -- )
swap [ eq? ] curry delete-node-if ;
: dlist-delete-all ( dlist -- )
f >>front f >>front
f >>back f >>back
0 >>length 0 >>length
@ -166,9 +154,6 @@ M: empty-dlist summary ( dlist -- )
: dlist-each ( dlist quot -- ) : dlist-each ( dlist quot -- )
[ obj>> ] prepose dlist-each-node ; inline [ obj>> ] prepose dlist-each-node ; inline
: dlist-slurp ( dlist quot -- )
over dlist-empty?
[ 2drop ] [ [ >r pop-back r> call ] 2keep dlist-slurp ] if ;
inline
: 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ; : 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;
INSTANCE: dlist dequeue

1
core/effects/effects-docs.factor
View File

@ -11,6 +11,7 @@ $nl
"Stack elements in a stack effect are ordered so that the top of the stack is on the right side. Each value can be named by a data type or description. The following are some examples of value names:" "Stack elements in a stack effect are ordered so that the top of the stack is on the right side. Each value can be named by a data type or description. The following are some examples of value names:"
{ $table { $table
{ { { $snippet "?" } } "a boolean" } { { { $snippet "?" } } "a boolean" }
{ { { $snippet "<=>" } } { "an ordering sepcifier; see " { $link "order-specifiers" } } }
{ { { $snippet "elt" } } "an object which is an element of a sequence" } { { { $snippet "elt" } } "an object which is an element of a sequence" }
{ { { $snippet "m" } ", " { $snippet "n" } } "an integer" } { { { $snippet "m" } ", " { $snippet "n" } } "an integer" }
{ { { $snippet "obj" } } "an object" } { { { $snippet "obj" } } "an object" }

16
core/generator/generator.factor
View File

@ -1,11 +1,11 @@
! Copyright (C) 2004, 2008 Slava Pestov. ! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes combinators cpu.architecture USING: arrays assocs classes combinators cpu.architecture
effects generator.fixup generator.registers generic hashtables effects generator.fixup generator.registers generic hashtables
inference inference.backend inference.dataflow io kernel inference inference.backend inference.dataflow io kernel
kernel.private layouts math namespaces optimizer kernel.private layouts math namespaces optimizer
optimizer.specializers prettyprint quotations sequences system optimizer.specializers prettyprint quotations sequences system
threads words vectors ; threads words vectors sets dequeues ;
IN: generator IN: generator
SYMBOL: compile-queue SYMBOL: compile-queue
@ -16,7 +16,7 @@ SYMBOL: compiled
{ [ dup compiled get key? ] [ drop ] } { [ dup compiled get key? ] [ drop ] }
{ [ dup inlined-block? ] [ drop ] } { [ dup inlined-block? ] [ drop ] }
{ [ dup primitive? ] [ drop ] } { [ dup primitive? ] [ drop ] }
[ dup compile-queue get set-at ] [ compile-queue get push-front ]
} cond ; } cond ;
: maybe-compile ( word -- ) : maybe-compile ( word -- )
@ -72,10 +72,12 @@ GENERIC: generate-node ( node -- next )
: word-dataflow ( word -- effect dataflow ) : word-dataflow ( word -- effect dataflow )
[ [
dup "cannot-infer" word-prop [ cannot-infer-effect ] when [
dup "no-compile" word-prop [ cannot-infer-effect ] when dup "cannot-infer" word-prop [ cannot-infer-effect ] when
dup specialized-def over dup 2array 1array infer-quot dup "no-compile" word-prop [ cannot-infer-effect ] when
finish-word dup specialized-def over dup 2array 1array infer-quot
finish-word
] maybe-cannot-infer
] with-infer ; ] with-infer ;
: intrinsics ( #call -- quot ) : intrinsics ( #call -- quot )

81
core/generic/generic.factor
View File

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: words kernel sequences namespaces assocs hashtables USING: words kernel sequences namespaces assocs hashtables
definitions kernel.private classes classes.private definitions kernel.private classes classes.private
classes.algebra quotations arrays vocabs effects combinators ; classes.algebra quotations arrays vocabs effects combinators
sets ;
IN: generic IN: generic
! Method combination protocol ! Method combination protocol
@ -58,18 +59,17 @@ TUPLE: check-method class generic ;
: affected-methods ( class generic -- seq ) : affected-methods ( class generic -- seq )
"methods" word-prop swap "methods" word-prop swap
[ nip classes-intersect? ] curry assoc-filter [ nip [ classes-intersect? ] [ class<= ] 2bi or ] curry assoc-filter
values ; values ;
: update-generic ( class generic -- ) : update-generic ( class generic -- )
[ affected-methods [ +called+ changed-definition ] each ] affected-methods [ +called+ changed-definition ] each ;
[ make-generic ]
bi ;
: with-methods ( class generic quot -- ) : with-methods ( class generic quot -- )
[ drop update-generic ]
[ [ "methods" word-prop ] dip call ] [ [ "methods" word-prop ] dip call ]
[ drop update-generic ] 3bi ; [ drop make-generic drop ]
inline 3tri ; inline
: method-word-name ( class word -- string ) : method-word-name ( class word -- string )
word-name "/" rot word-name 3append ; word-name "/" rot word-name 3append ;
@ -81,7 +81,7 @@ M: method-body stack-effect
"method-generic" word-prop stack-effect ; "method-generic" word-prop stack-effect ;
M: method-body crossref? M: method-body crossref?
drop t ; "forgotten" word-prop not ;
: method-word-props ( class generic -- assoc ) : method-word-props ( class generic -- assoc )
[ [
@ -95,8 +95,13 @@ M: method-body crossref?
method-word-name f <word> method-word-name f <word>
[ set-word-props ] keep ; [ set-word-props ] keep ;
: with-implementors ( class generic quot -- )
[ swap implementors-map get at ] dip call ; inline
: reveal-method ( method class generic -- ) : reveal-method ( method class generic -- )
[ set-at ] with-methods ; [ [ conjoin ] with-implementors ]
[ [ set-at ] with-methods ]
2bi ;
: create-method ( class generic -- method ) : create-method ( class generic -- method )
2dup method dup [ 2dup method dup [
@ -106,8 +111,8 @@ M: method-body crossref?
] if ; ] if ;
: <default-method> ( generic combination -- method ) : <default-method> ( generic combination -- method )
object bootstrap-word pick <method> [ drop object bootstrap-word swap <method> ] [ make-default-method ] 2bi
[ -rot make-default-method define ] keep ; [ define ] [ drop t "default" set-word-prop ] [ drop ] 2tri ;
: define-default-method ( generic combination -- ) : define-default-method ( generic combination -- )
dupd <default-method> "default-method" set-word-prop ; dupd <default-method> "default-method" set-word-prop ;
@ -137,54 +142,36 @@ M: method-body definer
M: method-body forget* M: method-body forget*
dup "forgotten" word-prop [ drop ] [ dup "forgotten" word-prop [ drop ] [
[ [
[ ] dup "default" word-prop [ drop ] [
[ "method-class" word-prop ] [
[ "method-generic" word-prop ] tri [ "method-class" word-prop ]
3dup method eq? [ [ "method-generic" word-prop ] bi
[ delete-at ] with-methods 2dup method
call-next-method ] keep eq?
] [ 3drop ] if [
[ [ delete-at ] with-methods ]
[ [ delete-at ] with-implementors ]
2bi
] [ 2drop ] if
] if
] ]
[ t "forgotten" set-word-prop ] bi [ call-next-method ] bi
] if ; ] if ;
M: method-body smart-usage M: method-body smart-usage
"method-generic" word-prop smart-usage ; "method-generic" word-prop smart-usage ;
GENERIC: implementors ( class/classes -- seq ) M: sequence update-methods ( class seq -- )
implementors [
M: class implementors [ update-generic ] [ make-generic drop ] 2bi
all-words [ "methods" word-prop key? ] with filter ; ] with each ;
M: assoc implementors
all-words [
"methods" word-prop keys
swap [ key? ] curry contains?
] with filter ;
: forget-methods ( class -- )
[ implementors ] [ [ swap 2array ] curry ] bi map forget-all ;
M: class forget* ( class -- )
[
class-usages [
drop
[ forget-methods ]
[ update-map- ]
[ reset-class ]
tri
] assoc-each
]
[ call-next-method ] bi ;
M: assoc update-methods ( class assoc -- )
implementors [ update-generic ] with each ;
: define-generic ( word combination -- ) : define-generic ( word combination -- )
over "combination" word-prop over = [ over "combination" word-prop over = [
2drop 2drop
] [ ] [
2dup "combination" set-word-prop 2dup "combination" set-word-prop
over "methods" word-prop values forget-all
over H{ } clone "methods" set-word-prop over H{ } clone "methods" set-word-prop
dupd define-default-method dupd define-default-method
make-generic make-generic

2
core/generic/standard/engines/tuple/tuple.factor
View File

@ -64,7 +64,7 @@ M: engine-word stack-effect
[ extra-values ] [ stack-effect ] bi [ extra-values ] [ stack-effect ] bi
dup [ clone [ length + ] change-in ] [ 2drop f ] if ; dup [ clone [ length + ] change-in ] [ 2drop f ] if ;
M: engine-word crossref? drop t ; M: engine-word crossref? "forgotten" word-prop not ;
M: engine-word irrelevant? drop t ; M: engine-word irrelevant? drop t ;

4
core/graphs/graphs.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2006, 2007 Slava Pestov. ! Copyright (C) 2006, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel namespaces sequences ; USING: assocs kernel namespaces sequences sets ;
IN: graphs IN: graphs
SYMBOL: graph SYMBOL: graph
@ -41,7 +41,7 @@ SYMBOL: previous
over previous get key? [ over previous get key? [
2drop 2drop
] [ ] [
over dup previous get set-at over previous get conjoin
dup slip dup slip
[ nip (closure) ] curry assoc-each [ nip (closure) ] curry assoc-each
] if ; inline ] if ; inline

10
core/grouping/grouping-docs.factor
View File

@ -33,7 +33,7 @@ HELP: group
{ $description "Splits the sequence into disjoint groups of " { $snippet "n" } " elements and collects the groups into a new array." } { $description "Splits the sequence into disjoint groups of " { $snippet "n" } " elements and collects the groups into a new array." }
{ $notes "If the sequence length is not a multiple of " { $snippet "n" } ", the final subsequence in the list will be shorter than " { $snippet "n" } " elements." } { $notes "If the sequence length is not a multiple of " { $snippet "n" } ", the final subsequence in the list will be shorter than " { $snippet "n" } " elements." }
{ $examples { $examples
{ $example "USING: splitting prettyprint ;" "{ 3 1 3 3 7 } 2 group ." "{ { 3 1 } { 3 3 } { 7 } }" } { $example "USING: grouping prettyprint ;" "{ 3 1 3 3 7 } 2 group ." "{ { 3 1 } { 3 3 } { 7 } }" }
} ; } ;
HELP: <groups> HELP: <groups>
@ -41,7 +41,7 @@ HELP: <groups>
{ $description "Outputs a virtual sequence whose elements are disjoint subsequences of " { $snippet "n" } " elements from the underlying sequence." } { $description "Outputs a virtual sequence whose elements are disjoint subsequences of " { $snippet "n" } " elements from the underlying sequence." }
{ $examples { $examples
{ $example { $example
"USING: arrays kernel prettyprint sequences splitting ;" "USING: arrays kernel prettyprint sequences grouping ;"
"9 >array 3 <groups> dup reverse-here concat >array ." "{ 6 7 8 3 4 5 0 1 2 }" "9 >array 3 <groups> dup reverse-here concat >array ." "{ 6 7 8 3 4 5 0 1 2 }"
} }
} ; } ;
@ -51,7 +51,7 @@ HELP: <sliced-groups>
{ $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence." } { $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence." }
{ $examples { $examples
{ $example { $example
"USING: arrays kernel prettyprint sequences splitting ;" "USING: arrays kernel prettyprint sequences grouping ;"
"9 >array 3 <sliced-groups>" "9 >array 3 <sliced-groups>"
"dup [ reverse-here ] each concat >array ." "dup [ reverse-here ] each concat >array ."
"{ 2 1 0 5 4 3 8 7 6 }" "{ 2 1 0 5 4 3 8 7 6 }"
@ -68,7 +68,7 @@ HELP: clump
{ $description "Splits the sequence into overlapping clumps of " { $snippet "n" } " elements and collects the clumps into a new array." } { $description "Splits the sequence into overlapping clumps of " { $snippet "n" } " elements and collects the clumps into a new array." }
{ $errors "Throws an error if " { $snippet "n" } " is smaller than the length of the sequence." } { $errors "Throws an error if " { $snippet "n" } " is smaller than the length of the sequence." }
{ $examples { $examples
{ $example "USING: splitting prettyprint ;" "{ 3 1 3 3 7 } 2 clump ." "{ { 3 1 } { 1 3 } { 3 3 } { 3 7 } }" } { $example "USING: grouping prettyprint ;" "{ 3 1 3 3 7 } 2 clump ." "{ { 3 1 } { 1 3 } { 3 3 } { 3 7 } }" }
} ; } ;
HELP: <clumps> HELP: <clumps>
@ -77,7 +77,7 @@ HELP: <clumps>
{ $examples { $examples
"Running averages:" "Running averages:"
{ $example { $example
"USING: splitting sequences math prettyprint kernel ;" "USING: grouping sequences math prettyprint kernel ;"
"IN: scratchpad" "IN: scratchpad"
": share-price" ": share-price"
" { 13/50 51/100 13/50 1/10 4/5 17/20 33/50 3/25 19/100 3/100 } ;" " { 13/50 51/100 13/50 1/10 4/5 17/20 33/50 3/25 19/100 3/100 } ;"

10
core/inference/backend/backend.factor
View File

@ -4,7 +4,8 @@ USING: inference.dataflow inference.state arrays generic io
io.streams.string kernel math namespaces parser prettyprint io.streams.string kernel math namespaces parser prettyprint
sequences strings vectors words quotations effects classes sequences strings vectors words quotations effects classes
continuations debugger assocs combinators compiler.errors continuations debugger assocs combinators compiler.errors
generic.standard.engines.tuple accessors math.order definitions ; generic.standard.engines.tuple accessors math.order definitions
sets ;
IN: inference.backend IN: inference.backend
: recursive-label ( word -- label/f ) : recursive-label ( word -- label/f )
@ -28,7 +29,7 @@ SYMBOL: visited
: (redefined) ( word -- ) : (redefined) ( word -- )
dup visited get key? [ drop ] [ dup visited get key? [ drop ] [
[ reset-on-redefine reset-props ] [ reset-on-redefine reset-props ]
[ dup visited get set-at ] [ visited get conjoin ]
[ [
crossref get at keys crossref get at keys
[ word? ] filter [ word? ] filter
@ -420,6 +421,9 @@ TUPLE: missing-effect word ;
[ "inferred-effect" set-word-prop ] [ "inferred-effect" set-word-prop ]
2tri ; 2tri ;
: maybe-cannot-infer ( word quot -- )
[ ] [ t "cannot-infer" set-word-prop ] cleanup ; inline
: infer-word ( word -- effect ) : infer-word ( word -- effect )
[ [
[ [
@ -430,7 +434,7 @@ TUPLE: missing-effect word ;
finish-word finish-word
current-effect current-effect
] with-scope ] with-scope
] [ ] [ t "cannot-infer" set-word-prop ] cleanup ; ] maybe-cannot-infer ;
: custom-infer ( word -- ) : custom-infer ( word -- )
#! Customized inference behavior #! Customized inference behavior

46
core/inference/inference-tests.factor
View File

@ -546,26 +546,26 @@ ERROR: custom-error ;
[ [ erg's-inference-bug ] infer ] must-fail [ [ erg's-inference-bug ] infer ] must-fail
! : inference-invalidation-a ( -- ); : inference-invalidation-a ( -- ) ;
! : inference-invalidation-b ( quot -- ) [ inference-invalidation-a ] dip call ; inline : inference-invalidation-b ( quot -- ) [ inference-invalidation-a ] dip call ; inline
! : inference-invalidation-c ( a b -- c ) [ + ] inference-invalidation-b ; : inference-invalidation-c ( a b -- c ) [ + ] inference-invalidation-b ; inline
!
! [ 7 ] [ 4 3 inference-invalidation-c ] unit-test [ 7 ] [ 4 3 inference-invalidation-c ] unit-test
!
! { 2 1 } [ [ + ] inference-invalidation-b ] must-infer-as { 2 1 } [ [ + ] inference-invalidation-b ] must-infer-as
!
! [ ] [ "IN: inference.tests : inference-invalidation-a 1 2 ;" eval ] unit-test [ ] [ "IN: inference.tests : inference-invalidation-a ( -- a b ) 1 2 ;" eval ] unit-test
!
! [ 3 ] [ inference-invalidation-c ] unit-test [ 3 ] [ inference-invalidation-c ] unit-test
!
! { 0 1 } [ inference-invalidation-c ] must-infer-as { 0 1 } [ inference-invalidation-c ] must-infer-as
!
! GENERIC: inference-invalidation-d ( obj -- ) GENERIC: inference-invalidation-d ( obj -- )
!
! M: object inference-invalidation-d inference-invalidation-c 2drop ; M: object inference-invalidation-d inference-invalidation-c 2drop ;
!
! \ inference-invalidation-d must-infer \ inference-invalidation-d must-infer
!
! [ ] [ "IN: inference.tests : inference-invalidation-a ;" eval ] unit-test [ ] [ "IN: inference.tests : inference-invalidation-a ( -- ) ;" eval ] unit-test
!
! [ [ inference-invalidation-d ] infer ] must-fail [ [ inference-invalidation-d ] infer ] must-fail

5
core/inference/inference.factor
View File

@ -9,19 +9,22 @@ IN: inference
GENERIC: infer ( quot -- effect ) GENERIC: infer ( quot -- effect )
M: callable infer ( quot -- effect ) M: callable infer ( quot -- effect )
[ f infer-quot ] with-infer drop ; [ recursive-state get infer-quot ] with-infer drop ;
: infer. ( quot -- ) : infer. ( quot -- )
#! Safe to call from inference transforms.
infer effect>string print ; infer effect>string print ;
GENERIC: dataflow ( quot -- dataflow ) GENERIC: dataflow ( quot -- dataflow )
M: callable dataflow M: callable dataflow
#! Not safe to call from inference transforms.
[ f infer-quot ] with-infer nip ; [ f infer-quot ] with-infer nip ;
GENERIC# dataflow-with 1 ( quot stack -- dataflow ) GENERIC# dataflow-with 1 ( quot stack -- dataflow )
M: callable dataflow-with M: callable dataflow-with
#! Not safe to call from inference transforms.
[ [
V{ } like meta-d set V{ } like meta-d set
f infer-quot f infer-quot

6
core/inspector/inspector.factor
View File

@ -95,10 +95,8 @@ SYMBOL: +editable+
: describe ( obj -- ) H{ } describe* ; : describe ( obj -- ) H{ } describe* ;
: namestack. ( seq -- ) : namestack. ( seq -- )
[ [ [ global eq? not ] filter [ keys ] gather ] keep
[ global eq? not ] filter [ dupd assoc-stack ] curry H{ } map>assoc describe ;
[ keys ] map concat prune
] keep [ dupd assoc-stack ] curry H{ } map>assoc describe ;
: .vars ( -- ) : .vars ( -- )
namestack namestack. ; namestack namestack. ;

24
core/io/encodings/encodings.factor
View File

@ -14,7 +14,7 @@ GENERIC: encode-char ( char stream encoding -- )
GENERIC: <decoder> ( stream encoding -- newstream ) GENERIC: <decoder> ( stream encoding -- newstream )
: replacement-char HEX: fffd ; : replacement-char HEX: fffd ; inline
TUPLE: decoder stream code cr ; TUPLE: decoder stream code cr ;
@ -121,14 +121,28 @@ M: encoder stream-flush encoder-stream stream-flush ;
INSTANCE: encoder plain-writer INSTANCE: encoder plain-writer
PRIVATE> PRIVATE>
: re-encode ( stream encoding -- newstream ) GENERIC# re-encode 1 ( stream encoding -- newstream )
over encoder? [ >r encoder-stream r> ] when <encoder> ;
M: object re-encode <encoder> ;
M: encoder re-encode [ stream>> ] dip re-encode ;
: encode-output ( encoding -- ) : encode-output ( encoding -- )
output-stream [ swap re-encode ] change ; output-stream [ swap re-encode ] change ;
: re-decode ( stream encoding -- newstream ) : with-encoded-output ( encoding quot -- )
over decoder? [ >r decoder-stream r> ] when <decoder> ; [ [ output-stream get ] dip re-encode ] dip
with-output-stream* ; inline
GENERIC# re-decode 1 ( stream encoding -- newstream )
M: object re-decode <decoder> ;
M: decoder re-decode [ stream>> ] dip re-decode ;
: decode-input ( encoding -- ) : decode-input ( encoding -- )
input-stream [ swap re-decode ] change ; input-stream [ swap re-decode ] change ;
: with-decoded-input ( encoding quot -- )
[ [ input-stream get ] dip re-decode ] dip
with-input-stream* ; inline

3
core/io/encodings/utf16/utf16-tests.factor
View File

@ -1,5 +1,6 @@
USING: kernel tools.test io.encodings.utf16 arrays sbufs USING: kernel tools.test io.encodings.utf16 arrays sbufs
io.streams.byte-array sequences io.encodings io unicode io.streams.byte-array sequences io.encodings io
bootstrap.unicode
io.encodings.string alien.c-types alien.strings accessors classes ; io.encodings.string alien.c-types alien.strings accessors classes ;
IN: io.encodings.utf16.tests IN: io.encodings.utf16.tests

3
core/io/encodings/utf8/utf8-tests.factor
View File

@ -1,4 +1,5 @@
USING: io.encodings.utf8 tools.test io.encodings.string strings arrays unicode ; USING: io.encodings.utf8 tools.test io.encodings.string strings arrays
bootstrap.unicode ;
IN: io.encodings.utf8.tests IN: io.encodings.utf8.tests
: decode-utf8-w/stream ( array -- newarray ) : decode-utf8-w/stream ( array -- newarray )

22
core/kernel/kernel-docs.factor
View File

@ -401,7 +401,7 @@ HELP: clone
{ $values { "obj" object } { "cloned" "a new object" } } { $values { "obj" object } { "cloned" "a new object" } }
{ $contract "Outputs a new object equal to the given object. This is not guaranteed to actually copy the object; it does nothing with immutable objects, and does not copy words either. However, sequences and tuples can be cloned to obtain a shallow copy of the original." } ; { $contract "Outputs a new object equal to the given object. This is not guaranteed to actually copy the object; it does nothing with immutable objects, and does not copy words either. However, sequences and tuples can be cloned to obtain a shallow copy of the original." } ;
HELP: ? ( ? true false -- true/false ) HELP: ?
{ $values { "?" "a generalized boolean" } { "true" object } { "false" object } { "true/false" "one two input objects" } } { $values { "?" "a generalized boolean" } { "true" object } { "false" object } { "true/false" "one two input objects" } }
{ $description "Chooses between two values depending on the boolean value of " { $snippet "cond" } "." } ; { $description "Chooses between two values depending on the boolean value of " { $snippet "cond" } "." } ;
@ -409,7 +409,7 @@ HELP: >boolean
{ $values { "obj" "a generalized boolean" } { "?" "a boolean" } } { $values { "obj" "a generalized boolean" } { "?" "a boolean" } }
{ $description "Convert a generalized boolean into a boolean. That is, " { $link f } " retains its value, whereas anything else becomes " { $link t } "." } ; { $description "Convert a generalized boolean into a boolean. That is, " { $link f } " retains its value, whereas anything else becomes " { $link t } "." } ;
HELP: not ( obj -- ? ) HELP: not
{ $values { "obj" "a generalized boolean" } { "?" "a boolean" } } { $values { "obj" "a generalized boolean" } { "?" "a boolean" } }
{ $description "For " { $link f } " outputs " { $link t } " and for anything else outputs " { $link f } "." } { $description "For " { $link f } " outputs " { $link t } " and for anything else outputs " { $link f } "." }
{ $notes "This word implements boolean not, so applying it to integers will not yield useful results (all integers have a true value). Bitwise not is the " { $link bitnot } " word." } ; { $notes "This word implements boolean not, so applying it to integers will not yield useful results (all integers have a true value). Bitwise not is the " { $link bitnot } " word." } ;
@ -692,26 +692,26 @@ HELP: tri@
} }
} ; } ;
HELP: if ( cond true false -- ) HELP: if
{ $values { "cond" "a generalized boolean" } { "true" quotation } { "false" quotation } } { $values { "?" "a generalized boolean" } { "true" quotation } { "false" quotation } }
{ $description "If " { $snippet "cond" } " is " { $link f } ", calls the " { $snippet "false" } " quotation. Otherwise calls the " { $snippet "true" } " quotation." { $description "If " { $snippet "cond" } " is " { $link f } ", calls the " { $snippet "false" } " quotation. Otherwise calls the " { $snippet "true" } " quotation."
$nl $nl
"The " { $snippet "cond" } " value is removed from the stack before either quotation is called." } ; "The " { $snippet "cond" } " value is removed from the stack before either quotation is called." } ;
HELP: when HELP: when
{ $values { "cond" "a generalized boolean" } { "true" quotation } } { $values { "?" "a generalized boolean" } { "true" quotation } }
{ $description "If " { $snippet "cond" } " is not " { $link f } ", calls the " { $snippet "true" } " quotation." { $description "If " { $snippet "cond" } " is not " { $link f } ", calls the " { $snippet "true" } " quotation."
$nl $nl
"The " { $snippet "cond" } " value is removed from the stack before the quotation is called." } ; "The " { $snippet "cond" } " value is removed from the stack before the quotation is called." } ;
HELP: unless HELP: unless
{ $values { "cond" "a generalized boolean" } { "false" quotation } } { $values { "?" "a generalized boolean" } { "false" quotation } }
{ $description "If " { $snippet "cond" } " is " { $link f } ", calls the " { $snippet "false" } " quotation." { $description "If " { $snippet "cond" } " is " { $link f } ", calls the " { $snippet "false" } " quotation."
$nl $nl
"The " { $snippet "cond" } " value is removed from the stack before the quotation is called." } ; "The " { $snippet "cond" } " value is removed from the stack before the quotation is called." } ;
HELP: if* HELP: if*
{ $values { "cond" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } { "false" quotation } } { $values { "?" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } { "false" quotation } }
{ $description "Alternative conditional form that preserves the " { $snippet "cond" } " value if it is true." { $description "Alternative conditional form that preserves the " { $snippet "cond" } " value if it is true."
$nl $nl
"If the condition is true, it is retained on the stack before the " { $snippet "true" } " quotation is called. Otherwise, the condition is removed from the stack and the " { $snippet "false" } " quotation is called." "If the condition is true, it is retained on the stack before the " { $snippet "true" } " quotation is called. Otherwise, the condition is removed from the stack and the " { $snippet "false" } " quotation is called."
@ -720,14 +720,14 @@ $nl
{ $code "X [ Y ] [ Z ] if*" "X dup [ Y ] [ drop Z ] if" } } ; { $code "X [ Y ] [ Z ] if*" "X dup [ Y ] [ drop Z ] if" } } ;
HELP: when* HELP: when*
{ $values { "cond" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } } { $values { "?" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } }
{ $description "Variant of " { $link if* } " with no false quotation." { $description "Variant of " { $link if* } " with no false quotation."
$nl $nl
"The following two lines are equivalent:" "The following two lines are equivalent:"
{ $code "X [ Y ] when*" "X dup [ Y ] [ drop ] if" } } ; { $code "X [ Y ] when*" "X dup [ Y ] [ drop ] if" } } ;
HELP: unless* HELP: unless*
{ $values { "cond" "a generalized boolean" } { "false" "a quotation " } } { $values { "?" "a generalized boolean" } { "false" "a quotation " } }
{ $description "Variant of " { $link if* } " with no true quotation." } { $description "Variant of " { $link if* } " with no true quotation." }
{ $notes { $notes
"The following two lines are equivalent:" "The following two lines are equivalent:"
@ -794,7 +794,7 @@ HELP: most
{ $values { "x" object } { "y" object } { "quot" "a quotation with stack effect " { $snippet "( x y -- ? )" } } { "z" "either " { $snippet "x" } " or " { $snippet "y" } } } { $values { "x" object } { "y" object } { "quot" "a quotation with stack effect " { $snippet "( x y -- ? )" } } { "z" "either " { $snippet "x" } " or " { $snippet "y" } } }
{ $description "If the quotation yields a true value when applied to " { $snippet "x" } " and " { $snippet "y" } ", outputs " { $snippet "x" } ", otherwise outputs " { $snippet "y" } "." } ; { $description "If the quotation yields a true value when applied to " { $snippet "x" } " and " { $snippet "y" } ", outputs " { $snippet "x" } ", otherwise outputs " { $snippet "y" } "." } ;
HELP: curry ( obj quot -- curry ) HELP: curry
{ $values { "obj" object } { "quot" callable } { "curry" curry } } { $values { "obj" object } { "quot" callable } { "curry" curry } }
{ $description "Partial application. Outputs a " { $link callable } " which first pushes " { $snippet "obj" } " and then calls " { $snippet "quot" } "." } { $description "Partial application. Outputs a " { $link callable } " which first pushes " { $snippet "obj" } " and then calls " { $snippet "quot" } "." }
{ $class-description "The class of objects created by " { $link curry } ". These objects print identically to quotations and implement the sequence protocol, however they only use two cells of storage; a reference to the object and a reference to the underlying quotation." } { $class-description "The class of objects created by " { $link curry } ". These objects print identically to quotations and implement the sequence protocol, however they only use two cells of storage; a reference to the object and a reference to the underlying quotation." }
@ -832,7 +832,7 @@ HELP: with
{ $example "USING: kernel math prettyprint sequences ;" "2 { 1 2 3 } [ - ] with map ." "{ 1 0 -1 }" } { $example "USING: kernel math prettyprint sequences ;" "2 { 1 2 3 } [ - ] with map ." "{ 1 0 -1 }" }
} ; } ;
HELP: compose ( quot1 quot2 -- compose ) HELP: compose
{ $values { "quot1" callable } { "quot2" callable } { "compose" compose } } { $values { "quot1" callable } { "quot2" callable } { "compose" compose } }
{ $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } " followed by " { $snippet "quot2" } "." } { $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } " followed by " { $snippet "quot2" } "." }
{ $notes { $notes

10
core/kernel/kernel.factor
View File

@ -28,20 +28,20 @@ DEFER: if
: if ( ? true false -- ) ? call ; : if ( ? true false -- ) ? call ;
! Single branch ! Single branch
: unless ( cond false -- ) : unless ( ? false -- )
swap [ drop ] [ call ] if ; inline swap [ drop ] [ call ] if ; inline
: when ( cond true -- ) : when ( ? true -- )
swap [ call ] [ drop ] if ; inline swap [ call ] [ drop ] if ; inline
! Anaphoric ! Anaphoric
: if* ( cond true false -- ) : if* ( ? true false -- )
pick [ drop call ] [ 2nip call ] if ; inline pick [ drop call ] [ 2nip call ] if ; inline
: when* ( cond true -- ) : when* ( ? true -- )
over [ call ] [ 2drop ] if ; inline over [ call ] [ 2drop ] if ; inline
: unless* ( cond false -- ) : unless* ( ? false -- )
over [ drop ] [ nip call ] if ; inline over [ drop ] [ nip call ] if ; inline
! Default ! Default

4
core/libc/libc.factor
View File

@ -3,7 +3,7 @@
! Copyright (C) 2007, 2008 Doug Coleman ! Copyright (C) 2007, 2008 Doug Coleman
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien assocs continuations destructors init kernel USING: alien assocs continuations destructors init kernel
namespaces accessors ; namespaces accessors sets ;
IN: libc IN: libc
<PRIVATE <PRIVATE
@ -38,7 +38,7 @@ ERROR: realloc-error ptr size ;
[ H{ } clone mallocs set-global ] "libc" add-init-hook [ H{ } clone mallocs set-global ] "libc" add-init-hook
: add-malloc ( alien -- ) : add-malloc ( alien -- )
dup mallocs get-global set-at ; mallocs get-global conjoin ;
: delete-malloc ( alien -- ) : delete-malloc ( alien -- )
[ [

2
core/math/floats/floats-docs.factor
View File

@ -24,7 +24,7 @@ ABOUT: "floats"
HELP: float HELP: float
{ $class-description "The class of double-precision floating point numbers." } ; { $class-description "The class of double-precision floating point numbers." } ;
HELP: >float ( x -- y ) HELP: >float
{ $values { "x" real } { "y" float } } { $values { "x" real } { "y" float } }
{ $description "Converts a real to a float. This is the identity on floats, and performs a floating point division on rationals." } ; { $description "Converts a real to a float. This is the identity on floats, and performs a floating point division on rationals." } ;

8
core/math/integers/integers-docs.factor
View File

@ -23,17 +23,21 @@ ABOUT: "integers"
HELP: fixnum HELP: fixnum
{ $class-description "The class of fixnums, which are fixed-width integers small enough to fit in a machine cell. Because they are not heap-allocated, fixnums do not have object identity. Equality of tagged pointer bit patterns is actually " { $emphasis "value" } " equality for fixnums." } ; { $class-description "The class of fixnums, which are fixed-width integers small enough to fit in a machine cell. Because they are not heap-allocated, fixnums do not have object identity. Equality of tagged pointer bit patterns is actually " { $emphasis "value" } " equality for fixnums." } ;
HELP: >fixnum ( x -- n ) HELP: >fixnum
{ $values { "x" real } { "n" fixnum } } { $values { "x" real } { "n" fixnum } }
{ $description "Converts a real number to a fixnum, with a possible loss of precision and overflow." } ; { $description "Converts a real number to a fixnum, with a possible loss of precision and overflow." } ;
HELP: bignum HELP: bignum
{ $class-description "The class of bignums, which are heap-allocated arbitrary-precision integers." } ; { $class-description "The class of bignums, which are heap-allocated arbitrary-precision integers." } ;
HELP: >bignum ( x -- n ) HELP: >bignum
{ $values { "x" real } { "n" bignum } } { $values { "x" real } { "n" bignum } }
{ $description "Converts a real number to a bignum, with a possible loss of precision." } ; { $description "Converts a real number to a bignum, with a possible loss of precision." } ;
HELP: >integer
{ $values { "x" real } { "n" bignum } }
{ $description "Converts a real number to an integer, with a possible loss of precision." } ;
HELP: integer HELP: integer
{ $class-description "The class of integers, which is a disjoint union of fixnums and bignums." } ; { $class-description "The class of integers, which is a disjoint union of fixnums and bignums." } ;

6
core/math/math.factor
View File

@ -3,9 +3,9 @@
USING: kernel math.private ; USING: kernel math.private ;
IN: math IN: math
GENERIC: >fixnum ( x -- y ) foldable GENERIC: >fixnum ( x -- n ) foldable
GENERIC: >bignum ( x -- y ) foldable GENERIC: >bignum ( x -- n ) foldable
GENERIC: >integer ( x -- y ) foldable GENERIC: >integer ( x -- n ) foldable
GENERIC: >float ( x -- y ) foldable GENERIC: >float ( x -- y ) foldable
MATH: number= ( x y -- ? ) foldable MATH: number= ( x y -- ? ) foldable

35
core/math/order/order-docs.factor
View File

@ -3,9 +3,9 @@ math.private words ;
IN: math.order IN: math.order
HELP: <=> HELP: <=>
{ $values { "obj1" object } { "obj2" object } { "symbol" symbol } } { $values { "obj1" object } { "obj2" object } { "<=>" "an ordering specifier" } }
{ $contract { $contract
"Compares two objects using an intrinsic total order, for example, the natural order for real numbers and lexicographic order for strings." "Compares two objects using an intrinsic linear order, for example, the natural order for real numbers and lexicographic order for strings."
$nl $nl
"The output value is one of the following:" "The output value is one of the following:"
{ $list { $list
@ -16,23 +16,23 @@ HELP: <=>
} ; } ;
HELP: +lt+ HELP: +lt+
{ $description "Returned by " { $link <=> } " when the first object is strictly less than the second object." } ; { $description "Output by " { $link <=> } " when the first object is strictly less than the second object." } ;
HELP: +eq+ HELP: +eq+
{ $description "Returned by " { $link <=> } " when the first object is equal to the second object." } ; { $description "Output by " { $link <=> } " when the first object is equal to the second object." } ;
HELP: +gt+ HELP: +gt+
{ $description "Returned by " { $link <=> } " when the first object is strictly greater than the second object." } ; { $description "Output by " { $link <=> } " when the first object is strictly greater than the second object." } ;
HELP: invert-comparison HELP: invert-comparison
{ $values { "symbol" symbol } { $values { "<=>" symbol }
{ "new-symbol" symbol } } { "<=>'" symbol } }
{ $description "Invert the comparison symbol returned by " { $link <=> } ". The output for the symbol " { $snippet "+eq+" } " is itself." } { $description "Invert the comparison symbol returned by " { $link <=> } "." }
{ $examples { $examples
{ $example "USING: math.order prettyprint ;" "+lt+ invert-comparison ." "+gt+" } } ; { $example "USING: math.order prettyprint ;" "+lt+ invert-comparison ." "+gt+" } } ;
HELP: compare HELP: compare
{ $values { "obj1" object } { "obj2" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } { "symbol" "a comparison symbol, +lt+, +eq+, or +gt+" } } { $values { "obj1" object } { "obj2" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } { "<=>" "an ordering specifier" } }
{ $description "Compares the results of applying the quotation to both objects via " { $link <=> } "." } { $description "Compares the results of applying the quotation to both objects via " { $link <=> } "." }
{ $examples { $example "USING: kernel math.order prettyprint sequences ;" "\"hello\" \"hi\" [ length ] compare ." "+gt+" } { $examples { $example "USING: kernel math.order prettyprint sequences ;" "\"hello\" \"hi\" [ length ] compare ." "+gt+" }
} ; } ;
@ -76,19 +76,24 @@ HELP: [-]
{ $values { "x" real } { "y" real } { "z" real } } { $values { "x" real } { "y" real } { "z" real } }
{ $description "Subtracts " { $snippet "y" } " from " { $snippet "x" } ". If the result is less than zero, outputs zero." } ; { $description "Subtracts " { $snippet "y" } " from " { $snippet "x" } ". If the result is less than zero, outputs zero." } ;
ARTICLE: "math.order" "Ordered objects" ARTICLE: "order-specifiers" "Ordering specifiers"
"Ordering words such as " { $link <=> } " output one of the following values, indicating that of two objects being compared, the first is less than the second, the two are equal, or that the first is greater than the second:"
{ $subsection +lt+ }
{ $subsection +eq+ }
{ $subsection +gt+ } ;
ARTICLE: "math.order" "Linear order protocol"
"Some classes have an intrinsic order amongst instances:" "Some classes have an intrinsic order amongst instances:"
{ $subsection <=> } { $subsection <=> }
{ $subsection compare } { $subsection compare }
{ $subsection invert-comparison } { $subsection invert-comparison }
"The above words return one of the following symbols:" "The above words output order specifiers."
{ $subsection +lt+ } { $subsection "order-specifiers" }
{ $subsection +eq+ }
{ $subsection +gt+ }
"Utilities for comparing objects:" "Utilities for comparing objects:"
{ $subsection after? } { $subsection after? }
{ $subsection before? } { $subsection before? }
{ $subsection after=? } { $subsection after=? }
{ $subsection before=? } ; { $subsection before=? }
{ $see-also "sequences-sorting" } ;
ABOUT: "math.order" ABOUT: "math.order"

6
core/math/order/order.factor
View File

@ -7,11 +7,11 @@ SYMBOL: +lt+
SYMBOL: +eq+ SYMBOL: +eq+
SYMBOL: +gt+ SYMBOL: +gt+
: invert-comparison ( symbol -- new-symbol ) : invert-comparison ( <=> -- <=>' )
#! Can't use case, index or nth here #! Can't use case, index or nth here
dup +lt+ eq? [ drop +gt+ ] [ +eq+ eq? +eq+ +lt+ ? ] if ; dup +lt+ eq? [ drop +gt+ ] [ +eq+ eq? +eq+ +lt+ ? ] if ;
GENERIC: <=> ( obj1 obj2 -- symbol ) GENERIC: <=> ( obj1 obj2 -- <=> )
M: real <=> 2dup < [ 2drop +lt+ ] [ number= +eq+ +gt+ ? ] if ; M: real <=> 2dup < [ 2drop +lt+ ] [ number= +eq+ +gt+ ? ] if ;
@ -38,4 +38,4 @@ M: real after=? ( obj1 obj2 -- ? ) >= ;
: [-] ( x y -- z ) - 0 max ; inline : [-] ( x y -- z ) - 0 max ; inline
: compare ( obj1 obj2 quot -- symbol ) bi@ <=> ; inline : compare ( obj1 obj2 quot -- <=> ) bi@ <=> ; inline

2
core/parser/parser-tests.factor
View File

@ -421,8 +421,6 @@ must-fail-with
] unit-test ] unit-test
] times ] times
[ ] [ "parser" reload ] unit-test
[ ] [ [ ] [
[ "this-better-not-exist" forget-vocab ] with-compilation-unit [ "this-better-not-exist" forget-vocab ] with-compilation-unit
] unit-test ] unit-test

2
core/parser/parser.factor
View File

@ -539,7 +539,7 @@ SYMBOL: interactive-vocabs
: reset-removed-classes ( -- ) : reset-removed-classes ( -- )
removed-classes removed-classes
filter-moved [ class? ] filter [ reset-class ] each ; filter-moved [ class? ] filter [ forget-class ] each ;
: fix-class-words ( -- ) : fix-class-words ( -- )
#! If a class word had a compound definition which was #! If a class word had a compound definition which was

4
core/prettyprint/sections/sections.factor
View File

@ -3,7 +3,7 @@
USING: arrays generic hashtables io kernel math assocs USING: arrays generic hashtables io kernel math assocs
namespaces sequences strings io.styles vectors words namespaces sequences strings io.styles vectors words
prettyprint.config splitting classes continuations prettyprint.config splitting classes continuations
io.streams.nested accessors ; io.streams.nested accessors sets ;
IN: prettyprint.sections IN: prettyprint.sections
! State ! State
@ -20,7 +20,7 @@ TUPLE: pprinter last-newline line-count indent ;
: <pprinter> ( -- pprinter ) 0 1 0 pprinter boa ; : <pprinter> ( -- pprinter ) 0 1 0 pprinter boa ;
: record-vocab ( word -- ) : record-vocab ( word -- )
word-vocabulary [ dup pprinter-use get set-at ] when* ; word-vocabulary [ pprinter-use get conjoin ] when* ;
! Utility words ! Utility words
: line-limit? ( -- ? ) : line-limit? ( -- ? )

1
core/search-dequeues/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

21
core/search-dequeues/search-dequeues-docs.factor Normal file
View File

@ -0,0 +1,21 @@
IN: search-dequeues
USING: help.markup help.syntax kernel dlists hashtables
dequeues assocs ;
ARTICLE: "search-dequeues" "Search dequeues"
"A search dequeue is a data structure with constant-time insertion and removal of elements at both ends, and constant-time membership tests. Inserting an element more than once has no effect. Search dequeues implement all dequeue operations in terms of an underlying dequeue, and membership testing with " { $link dequeue-member? } " is implemented with an underlying assoc. Search dequeues are defined in the " { $vocab-link "search-dequeues" } " vocabulary."
$nl
"Creating a search dequeue:"
{ $subsection <search-dequeue> }
"Default implementation:"
{ $subsection <hashed-dlist> } ;
ABOUT: "search-dequeues"
HELP: <search-dequeue> ( assoc dequeue -- search-dequeue )
{ $values { "assoc" assoc } { "dequeue" dequeue } { "search-dequeue" search-dequeue } }
{ $description "Creates a new " { $link search-dequeue } "." } ;
HELP: <hashed-dlist> ( -- search-dequeue )
{ $values { "search-dequeue" search-dequeue } }
{ $description "Creates a new " { $link search-dequeue } " backed by a " { $link dlist } ", with a " { $link hashtable } " for fast membership tests." } ;

35
core/search-dequeues/search-dequeues-tests.factor Normal file
View File

@ -0,0 +1,35 @@
IN: search-dequeues.tests
USING: search-dequeues tools.test namespaces
kernel sequences words dequeues vocabs ;
<hashed-dlist> "h" set
[ t ] [ "h" get dequeue-empty? ] unit-test
[ ] [ 3 "h" get push-front* "1" set ] unit-test
[ ] [ 1 "h" get push-front ] unit-test
[ ] [ 3 "h" get push-front* "2" set ] unit-test
[ ] [ 3 "h" get push-front* "3" set ] unit-test
[ ] [ 7 "h" get push-front ] unit-test
[ t ] [ "1" get "2" get eq? ] unit-test
[ t ] [ "2" get "3" get eq? ] unit-test
[ 3 ] [ "h" get dequeue-length ] unit-test
[ t ] [ 7 "h" get dequeue-member? ] unit-test
[ 3 ] [ "1" get node-value ] unit-test
[ ] [ "1" get "h" get delete-node ] unit-test
[ 2 ] [ "h" get dequeue-length ] unit-test
[ 1 ] [ "h" get pop-back ] unit-test
[ 7 ] [ "h" get pop-back ] unit-test
[ f ] [ 7 "h" get dequeue-member? ] unit-test
[ ] [
<hashed-dlist>
[ all-words swap [ push-front ] curry each ]
[ [ drop ] slurp-dequeue ]
bi
] unit-test

53
core/search-dequeues/search-dequeues.factor Normal file
View File

@ -0,0 +1,53 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel assocs dequeues dlists hashtables ;
IN: search-dequeues
TUPLE: search-dequeue assoc dequeue ;
C: <search-dequeue> search-dequeue
: <hashed-dlist> ( -- search-dequeue )
0 <hashtable> <dlist> <search-dequeue> ;
M: search-dequeue dequeue-length dequeue>> dequeue-length ;
M: search-dequeue peek-front dequeue>> peek-front ;
M: search-dequeue peek-back dequeue>> peek-back ;
M: search-dequeue push-front*
2dup assoc>> at* [ 2nip ] [
drop
[ dequeue>> push-front* ] [ assoc>> ] 2bi
[ 2drop ] [ set-at ] 3bi
] if ;
M: search-dequeue push-back*
2dup assoc>> at* [ 2nip ] [
drop
[ dequeue>> push-back* ] [ assoc>> ] 2bi
[ 2drop ] [ set-at ] 3bi
] if ;
M: search-dequeue pop-front*
[ [ dequeue>> peek-front ] [ assoc>> ] bi delete-at ]
[ dequeue>> pop-front* ]
bi ;
M: search-dequeue pop-back*
[ [ dequeue>> peek-back ] [ assoc>> ] bi delete-at ]
[ dequeue>> pop-back* ]
bi ;
M: search-dequeue delete-node
[ dequeue>> delete-node ]
[ [ node-value ] [ assoc>> ] bi* delete-at ] 2bi ;
M: search-dequeue clear-dequeue
[ dequeue>> clear-dequeue ] [ assoc>> clear-assoc ] bi ;
M: search-dequeue dequeue-member?
assoc>> key? ;
INSTANCE: search-dequeue dequeue

1
core/search-dequeues/summary.txt Normal file
View File

@ -0,0 +1 @@
Double-ended queues with sub-linear membership testing

1
core/search-dequeues/tags.txt Normal file
View File

@ -0,0 +1 @@
collections

3
core/sequences/sequences-tests.factor
View File

@ -243,6 +243,3 @@ unit-test
[ "asdf" ] [ " asdf " [ CHAR: \s = ] trim ] unit-test [ "asdf" ] [ " asdf " [ CHAR: \s = ] trim ] unit-test
[ "asdf " ] [ " asdf " [ CHAR: \s = ] left-trim ] unit-test [ "asdf " ] [ " asdf " [ CHAR: \s = ] left-trim ] unit-test
[ " asdf" ] [ " asdf " [ CHAR: \s = ] right-trim ] unit-test [ " asdf" ] [ " asdf " [ CHAR: \s = ] right-trim ] unit-test
! Hardcore
[ ] [ "sequences" reload ] unit-test

3
core/sets/sets.factor
View File

@ -16,6 +16,9 @@ IN: sets
[ ] [ length <hashtable> ] [ length <vector> ] tri [ ] [ length <hashtable> ] [ length <vector> ] tri
[ [ (prune) ] 2curry each ] keep ; [ [ (prune) ] 2curry each ] keep ;
: gather ( seq quot -- newseq )
map concat prune ; inline
: unique ( seq -- assoc ) : unique ( seq -- assoc )
[ dup ] H{ } map>assoc ; [ dup ] H{ } map>assoc ;

16
core/sorting/sorting-docs.factor
View File

@ -3,12 +3,8 @@ sequences math.order ;
IN: sorting IN: sorting
ARTICLE: "sequences-sorting" "Sorting and binary search" ARTICLE: "sequences-sorting" "Sorting and binary search"
"Sorting and binary search combinators all take comparator quotations with stack effect " { $snippet "( elt1 elt2 -- n )" } " that order the two given elements and output a value whose sign denotes the result:" "Sorting and binary search combinators all take comparator quotations with stack effect " { $snippet "( elt1 elt2 -- <=> )" } ", where the output value is one of the three " { $link "order-specifiers" } "."
{ $list $nl
{ "positive - indicates that " { $snippet "elt1" } " follows " { $snippet "elt2" } }
{ "zero - indicates that " { $snippet "elt1" } " is ordered equivalently to " { $snippet "elt2" } }
{ "negative - indicates that " { $snippet "elt1" } " precedes " { $snippet "elt2" } }
}
"Sorting a sequence with a custom comparator:" "Sorting a sequence with a custom comparator:"
{ $subsection sort } { $subsection sort }
"Sorting a sequence with common comparators:" "Sorting a sequence with common comparators:"
@ -19,8 +15,10 @@ ARTICLE: "sequences-sorting" "Sorting and binary search"
{ $subsection binsearch } { $subsection binsearch }
{ $subsection binsearch* } ; { $subsection binsearch* } ;
ABOUT: "sequences-sorting"
HELP: sort HELP: sort
{ $values { "seq" "a sequence" } { "quot" "a comparator quotation" } { "sortedseq" "a new sorted sequence" } } { $values { "seq" "a sequence" } { "quot" "a quotation with stack effect " { $snippet "( obj1 obj2 -- <=> )" } } { "sortedseq" "a new sorted sequence" } }
{ $description "Sorts the elements into a new sequence of the same class as " { $snippet "seq" } "." } ; { $description "Sorts the elements into a new sequence of the same class as " { $snippet "seq" } "." } ;
HELP: sort-keys HELP: sort-keys
@ -52,13 +50,13 @@ HELP: partition
{ $description "Outputs a slice of the first or second half of the sequence, respectively, depending on the integer's sign." } ; { $description "Outputs a slice of the first or second half of the sequence, respectively, depending on the integer's sign." } ;
HELP: binsearch HELP: binsearch
{ $values { "elt" object } { "seq" "a sorted sequence" } { "quot" "a comparator quotation" } { "i" "the index of the search result" } } { $values { "elt" object } { "seq" "a sorted sequence" } { "quot" "a quotation with stack effect " { $snippet "( obj1 obj2 -- <=> )" } } { "i" "the index of the search result" } }
{ $description "Given a sequence that is sorted with respect to the " { $snippet "quot" } " comparator, searches for an element equal to " { $snippet "elt" } ", or failing that, the greatest element smaller than " { $snippet "elt" } ". Comparison is performed with " { $snippet "quot" } "." { $description "Given a sequence that is sorted with respect to the " { $snippet "quot" } " comparator, searches for an element equal to " { $snippet "elt" } ", or failing that, the greatest element smaller than " { $snippet "elt" } ". Comparison is performed with " { $snippet "quot" } "."
$nl $nl
"Outputs f if the sequence is empty. If the sequence has at least one element, this word always outputs a valid index." } ; "Outputs f if the sequence is empty. If the sequence has at least one element, this word always outputs a valid index." } ;
HELP: binsearch* HELP: binsearch*
{ $values { "elt" object } { "seq" "a sorted sequence" } { "quot" "a comparator quotation" } { "result" "the search result" } } { $values { "elt" object } { "seq" "a sorted sequence" } { "quot" "a quotation with stack effect " { $snippet "( obj1 obj2 -- <=> )" } } { "result" "the search result" } }
{ $description "Variant of " { $link binsearch } " which outputs the found element rather than its index in the sequence." { $description "Variant of " { $link binsearch } " which outputs the found element rather than its index in the sequence."
$nl $nl
"Outputs " { $link f } " if the sequence is empty. If the sequence has at least one element, this word always outputs a sequence element." } ; "Outputs " { $link f } " if the sequence is empty. If the sequence has at least one element, this word always outputs a sequence element." } ;

5
core/source-files/source-files-tests.factor Normal file
View File

@ -0,0 +1,5 @@
IN: source-files.tests
USING: source-files tools.test assocs sequences strings
namespaces kernel ;
[ { } ] [ source-files get keys [ string? not ] filter ] unit-test

1
core/source-files/source-files.factor
View File

@ -44,6 +44,7 @@ uses definitions ;
\ source-file construct ; \ source-file construct ;
: source-file ( path -- source-file ) : source-file ( path -- source-file )
dup string? [ "Invalid source file path" throw ] unless
source-files get [ <source-file> ] cache ; source-files get [ <source-file> ] cache ;
: reset-checksums ( -- ) : reset-checksums ( -- )

4
core/syntax/syntax.factor
View File

@ -182,8 +182,8 @@ IN: bootstrap.syntax
] define-syntax ] define-syntax
"(" [ "(" [
")" parse-effect word ")" parse-effect
[ swap "declared-effect" set-word-prop ] [ drop ] if* word dup [ set-stack-effect ] [ 2drop ] if
] define-syntax ] define-syntax
"((" [ "((" [

2
core/threads/threads-docs.factor
View File

@ -1,6 +1,6 @@
USING: help.markup help.syntax kernel kernel.private io USING: help.markup help.syntax kernel kernel.private io
threads.private continuations dlists init quotations strings threads.private continuations dlists init quotations strings
assocs heaps boxes namespaces ; assocs heaps boxes namespaces dequeues ;
IN: threads IN: threads
ARTICLE: "threads-start/stop" "Starting and stopping threads" ARTICLE: "threads-start/stop" "Starting and stopping threads"

6
core/threads/threads.factor
View File

@ -4,7 +4,7 @@
USING: arrays hashtables heaps kernel kernel.private math USING: arrays hashtables heaps kernel kernel.private math
namespaces sequences vectors continuations continuations.private namespaces sequences vectors continuations continuations.private
dlists assocs system combinators init boxes accessors dlists assocs system combinators init boxes accessors
math.order ; math.order dequeues ;
IN: threads IN: threads
SYMBOL: initial-thread SYMBOL: initial-thread
@ -86,7 +86,7 @@ PRIVATE>
: sleep-time ( -- ms/f ) : sleep-time ( -- ms/f )
{ {
{ [ run-queue dlist-empty? not ] [ 0 ] } { [ run-queue dequeue-empty? not ] [ 0 ] }
{ [ sleep-queue heap-empty? ] [ f ] } { [ sleep-queue heap-empty? ] [ f ] }
[ sleep-queue heap-peek nip millis [-] ] [ sleep-queue heap-peek nip millis [-] ]
} cond ; } cond ;
@ -146,7 +146,7 @@ DEFER: next
: next ( -- * ) : next ( -- * )
expire-sleep-loop expire-sleep-loop
run-queue dup dlist-empty? [ run-queue dup dequeue-empty? [
drop no-runnable-threads drop no-runnable-threads
] [ ] [
pop-back dup array? [ first2 ] [ f swap ] if (next) pop-back dup array? [ first2 ] [ f swap ] if (next)

13
core/words/words-tests.factor
View File

@ -183,3 +183,16 @@ SYMBOL: quot-uses-b
[ t ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test [ t ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test
[ ] [ "IN: words.tests : decl-forget-test ;" eval ] unit-test [ ] [ "IN: words.tests : decl-forget-test ;" eval ] unit-test
[ f ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test [ f ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test
[ { } ]
[
all-words [
"compiled-uses" word-prop
keys [ "forgotten" word-prop ] contains?
] filter
] unit-test
[ { } ] [
crossref get keys
[ word? ] filter [ "forgotten" word-prop ] filter
] unit-test

46
core/words/words.factor
View File

@ -80,8 +80,7 @@ GENERIC# (quot-uses) 1 ( obj assoc -- )
M: object (quot-uses) 2drop ; M: object (quot-uses) 2drop ;
M: word (quot-uses) M: word (quot-uses) over crossref? [ conjoin ] [ 2drop ] if ;
>r dup crossref? [ dup r> set-at ] [ r> 2drop ] if ;
: seq-uses ( seq assoc -- ) [ (quot-uses) ] curry each ; : seq-uses ( seq assoc -- ) [ (quot-uses) ] curry each ;
@ -103,12 +102,16 @@ compiled-crossref global [ H{ } assoc-like ] change-at
: compiled-xref ( word dependencies -- ) : compiled-xref ( word dependencies -- )
[ drop crossref? ] assoc-filter [ drop crossref? ] assoc-filter
2dup "compiled-uses" set-word-prop [ "compiled-uses" set-word-prop ]
compiled-crossref get add-vertex* ; [ compiled-crossref get add-vertex* ]
2bi ;
: compiled-unxref ( word -- ) : compiled-unxref ( word -- )
dup "compiled-uses" word-prop [
compiled-crossref get remove-vertex* ; dup "compiled-uses" word-prop
compiled-crossref get remove-vertex*
]
[ f "compiled-uses" set-word-prop ] bi ;
: delete-compiled-xref ( word -- ) : delete-compiled-xref ( word -- )
dup compiled-unxref dup compiled-unxref
@ -141,6 +144,18 @@ M: object redefined drop ;
dup +inlined+ changed-definition dup +inlined+ changed-definition
dup crossref? [ dup xref ] when drop ; dup crossref? [ dup xref ] when drop ;
: set-stack-effect ( effect word -- )
2dup "declared-effect" word-prop = [ 2drop ] [
swap
[ "declared-effect" set-word-prop ]
[
drop
dup primitive? [ drop ] [
[ redefined ] [ +inlined+ changed-definition ] bi
] if
] 2bi
] if ;
: define-declared ( word def effect -- ) : define-declared ( word def effect -- )
pick swap "declared-effect" set-word-prop pick swap "declared-effect" set-word-prop
define ; define ;
@ -177,9 +192,10 @@ GENERIC: subwords ( word -- seq )
M: word subwords drop f ; M: word subwords drop f ;
: reset-generic ( word -- ) : reset-generic ( word -- )
dup subwords forget-all [ subwords forget-all ]
dup reset-word [ reset-word ]
{ "methods" "combination" "default-method" } reset-props ; [ { "methods" "combination" "default-method" } reset-props ]
tri ;
: gensym ( -- word ) : gensym ( -- word )
"( gensym )" f <word> ; "( gensym )" f <word> ;
@ -216,12 +232,12 @@ M: word where "loc" word-prop ;
M: word set-where swap "loc" set-word-prop ; M: word set-where swap "loc" set-word-prop ;
M: word forget* M: word forget*
dup "forgotten" word-prop [ dup "forgotten" word-prop [ drop ] [
dup delete-xref [ delete-xref ]
dup delete-compiled-xref [ [ word-name ] [ word-vocabulary vocab-words ] bi delete-at ]
dup word-name over word-vocabulary vocab-words delete-at [ t "forgotten" set-word-prop ]
dup t "forgotten" set-word-prop tri
] unless drop ; ] if ;
M: word hashcode* M: word hashcode*
nip 1 slot { fixnum } declare ; nip 1 slot { fixnum } declare ;

2
extra/bootstrap/image/download/download.factor
View File

@ -7,7 +7,7 @@ kernel io.files bootstrap.image sequences io ;
: url "http://factorcode.org/images/latest/" ; : url "http://factorcode.org/images/latest/" ;
: download-checksums ( -- alist ) : download-checksums ( -- alist )
url "checksums.txt" append http-get url "checksums.txt" append http-get nip
string-lines [ " " split1 ] { } map>assoc ; string-lines [ " " split1 ] { } map>assoc ;
: need-new-image? ( image -- ? ) : need-new-image? ( image -- ? )

12
extra/bootstrap/unicode/unicode.factor Executable file
View File

@ -0,0 +1,12 @@
USING: parser kernel namespaces ;
USE: unicode.breaks
USE: unicode.case
USE: unicode.categories
USE: unicode.collation
USE: unicode.data
USE: unicode.normalize
USE: unicode.script
[ name>char [ "Invalid character" throw ] unless* ]
name>char-hook set-global

5
extra/calendar/model/model.factor
View File

@ -10,7 +10,10 @@ SYMBOL: time
1000 sleep (time-thread) ; 1000 sleep (time-thread) ;
: time-thread ( -- ) : time-thread ( -- )
[ (time-thread) ] "Time model update" spawn drop ; [
init-namespaces
(time-thread)
] "Time model update" spawn drop ;
f <model> time set-global f <model> time set-global
[ time-thread ] "calendar.model" add-init-hook [ time-thread ] "calendar.model" add-init-hook

4
extra/cocoa/application/application.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2006, 2007 Slava Pestov ! Copyright (C) 2006, 2007 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien io kernel namespaces core-foundation USING: alien alien.syntax io kernel namespaces core-foundation
core-foundation.run-loop cocoa.messages cocoa cocoa.classes core-foundation.run-loop cocoa.messages cocoa cocoa.classes
cocoa.runtime sequences threads debugger init inspector cocoa.runtime sequences threads debugger init inspector
kernel.private ; kernel.private ;
@ -19,6 +19,8 @@ IN: cocoa.application
: NSApp ( -- app ) NSApplication -> sharedApplication ; : NSApp ( -- app ) NSApplication -> sharedApplication ;
FUNCTION: void NSBeep ( ) ;
: with-cocoa ( quot -- ) : with-cocoa ( quot -- )
[ NSApp drop call ] with-autorelease-pool ; [ NSApp drop call ] with-autorelease-pool ;

4
extra/combinators/lib/lib.factor
View File

@ -63,8 +63,8 @@ MACRO: napply ( n -- )
! short circuiting words ! short circuiting words
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! : short-circuit ( quots quot default -- quot ) : short-circuit ( quots quot default -- quot )
! 1quotation -rot { } map>assoc <reversed> alist>quot ; 1quotation -rot { } map>assoc <reversed> alist>quot ;
! MACRO: && ( quots -- ? ) ! MACRO: && ( quots -- ? )
! [ [ not ] append [ f ] ] t short-circuit ; ! [ [ not ] append [ f ] ] t short-circuit ;

17
extra/concurrency/conditions/conditions.factor
View File

@ -1,21 +1,20 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: dlists dlists.private threads kernel arrays sequences USING: dequeues threads kernel arrays sequences alarms ;
alarms ;
IN: concurrency.conditions IN: concurrency.conditions
: notify-1 ( dlist -- ) : notify-1 ( dequeue -- )
dup dlist-empty? [ drop ] [ pop-back resume-now ] if ; dup dequeue-empty? [ drop ] [ pop-back resume-now ] if ;
: notify-all ( dlist -- ) : notify-all ( dequeue -- )
[ resume-now ] dlist-slurp ; [ resume-now ] slurp-dequeue ;
: queue-timeout ( queue timeout -- alarm ) : queue-timeout ( queue timeout -- alarm )
#! Add an alarm which removes the current thread from the #! Add an alarm which removes the current thread from the
#! queue, and resumes it, passing it a value of t. #! queue, and resumes it, passing it a value of t.
>r self over push-front* [ >r [ self swap push-front* ] keep [
tuck delete-node [ delete-node ] [ drop node-value ] 2bi
dlist-node-obj t swap resume-with t swap resume-with
] 2curry r> later ; ] 2curry r> later ;
: wait ( queue timeout status -- ) : wait ( queue timeout status -- )

4
extra/concurrency/locks/locks.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: dlists kernel threads continuations math USING: dequeues dlists kernel threads continuations math
concurrency.conditions ; concurrency.conditions ;
IN: concurrency.locks IN: concurrency.locks
@ -80,7 +80,7 @@ TUPLE: rw-lock readers writers reader# writer ;
: release-write-lock ( lock -- ) : release-write-lock ( lock -- )
f over set-rw-lock-writer f over set-rw-lock-writer
dup rw-lock-readers dlist-empty? dup rw-lock-readers dequeue-empty?
[ notify-writer ] [ rw-lock-readers notify-all ] if ; [ notify-writer ] [ rw-lock-readers notify-all ] if ;
: reentrant-read-lock-ok? ( lock -- ? ) : reentrant-read-lock-ok? ( lock -- ? )

9
extra/concurrency/mailboxes/mailboxes.factor
View File

@ -1,9 +1,10 @@
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov. ! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: concurrency.mailboxes IN: concurrency.mailboxes
USING: dlists threads sequences continuations destructors USING: dlists dequeues threads sequences continuations
namespaces random math quotations words kernel arrays assocs destructors namespaces random math quotations words kernel
init system concurrency.conditions accessors debugger ; arrays assocs init system concurrency.conditions accessors
debugger ;
TUPLE: mailbox threads data disposed ; TUPLE: mailbox threads data disposed ;
@ -13,7 +14,7 @@ M: mailbox dispose* threads>> notify-all ;
<dlist> <dlist> f mailbox boa ; <dlist> <dlist> f mailbox boa ;
: mailbox-empty? ( mailbox -- bool ) : mailbox-empty? ( mailbox -- bool )
data>> dlist-empty? ; data>> dequeue-empty? ;
: mailbox-put ( obj mailbox -- ) : mailbox-put ( obj mailbox -- )
[ data>> push-front ] [ data>> push-front ]

4
extra/concurrency/messaging/messaging-tests.factor
View File

@ -2,12 +2,12 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
! !
USING: kernel threads vectors arrays sequences USING: kernel threads vectors arrays sequences
namespaces tools.test continuations dlists strings math words namespaces tools.test continuations dequeues strings math words
match quotations concurrency.messaging concurrency.mailboxes match quotations concurrency.messaging concurrency.mailboxes
concurrency.count-downs accessors ; concurrency.count-downs accessors ;
IN: concurrency.messaging.tests IN: concurrency.messaging.tests
[ ] [ my-mailbox mailbox-data dlist-delete-all ] unit-test [ ] [ my-mailbox mailbox-data clear-dequeue ] unit-test
[ "received" ] [ [ "received" ] [
[ [

4
extra/db/db.factor
View File

@ -35,7 +35,7 @@ HOOK: db-close db ( handle -- )
handle>> db-close handle>> db-close
] with-variable ; ] with-variable ;
TUPLE: statement handle sql in-params out-params bind-params bound? type ; TUPLE: statement handle sql in-params out-params bind-params bound? type retries ;
TUPLE: simple-statement < statement ; TUPLE: simple-statement < statement ;
TUPLE: prepared-statement < statement ; TUPLE: prepared-statement < statement ;
@ -89,7 +89,7 @@ M: object execute-statement* ( statement type -- )
swap >>out-params swap >>out-params
swap >>in-params swap >>in-params
swap >>sql ; swap >>sql ;
: sql-row ( result-set -- seq ) : sql-row ( result-set -- seq )
dup #columns [ row-column ] with map ; dup #columns [ row-column ] with map ;

4
extra/db/postgresql/lib/lib.factor
View File

@ -5,7 +5,7 @@ quotations sequences db.postgresql.ffi alien alien.c-types
db.types tools.walker ascii splitting math.parser combinators db.types tools.walker ascii splitting math.parser combinators
libc shuffle calendar.format byte-arrays destructors prettyprint libc shuffle calendar.format byte-arrays destructors prettyprint
accessors strings serialize io.encodings.binary io.encodings.utf8 accessors strings serialize io.encodings.binary io.encodings.utf8
alien.strings io.streams.byte-array inspector ; alien.strings io.streams.byte-array inspector present urls ;
IN: db.postgresql.lib IN: db.postgresql.lib
: postgresql-result-error-message ( res -- str/f ) : postgresql-result-error-message ( res -- str/f )
@ -84,6 +84,7 @@ M: postgresql-result-null summary ( obj -- str )
{ TIME [ dup [ timestamp>hms ] when default-param-value ] } { TIME [ dup [ timestamp>hms ] when default-param-value ] }
{ DATETIME [ dup [ timestamp>ymdhms ] when default-param-value ] } { DATETIME [ dup [ timestamp>ymdhms ] when default-param-value ] }
{ TIMESTAMP [ dup [ timestamp>ymdhms ] when default-param-value ] } { TIMESTAMP [ dup [ timestamp>ymdhms ] when default-param-value ] }
{ URL [ dup [ present ] when default-param-value ] }
[ drop default-param-value ] [ drop default-param-value ]
} case 2array } case 2array
] 2map flip dup empty? [ ] 2map flip dup empty? [
@ -164,6 +165,7 @@ M: postgresql-malloc-destructor dispose ( obj -- )
{ TIMESTAMP [ pq-get-string dup [ ymdhms>timestamp ] when ] } { TIMESTAMP [ pq-get-string dup [ ymdhms>timestamp ] when ] }
{ DATETIME [ pq-get-string dup [ ymdhms>timestamp ] when ] } { DATETIME [ pq-get-string dup [ ymdhms>timestamp ] when ] }
{ BLOB [ pq-get-blob ] } { BLOB [ pq-get-blob ] }
{ URL [ pq-get-string dup [ >url ] when ] }
{ FACTOR-BLOB [ { FACTOR-BLOB [
pq-get-blob pq-get-blob
dup [ bytes>object ] when ] } dup [ bytes>object ] when ] }

1
extra/db/postgresql/postgresql.factor
View File

@ -239,6 +239,7 @@ M: postgresql-db persistent-table ( -- hashtable )
{ TIMESTAMP { "timestamp" "timestamp" f } } { TIMESTAMP { "timestamp" "timestamp" f } }
{ BLOB { "bytea" "bytea" f } } { BLOB { "bytea" "bytea" f } }
{ FACTOR-BLOB { "bytea" "bytea" f } } { FACTOR-BLOB { "bytea" "bytea" f } }
{ URL { "varchar" "varchar" f } }
{ +foreign-id+ { f f "references" } } { +foreign-id+ { f f "references" } }
{ +autoincrement+ { f f "autoincrement" } } { +autoincrement+ { f f "autoincrement" } }
{ +unique+ { f f "unique" } } { +unique+ { f f "unique" } }

59
extra/db/queries/queries.factor
View File

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math namespaces sequences random USING: accessors kernel math namespaces sequences random
strings math.parser math.intervals combinators strings math.parser math.intervals combinators
math.bitfields.lib namespaces.lib db db.tuples db.types ; math.bitfields.lib namespaces.lib db db.tuples db.types
sequences.lib db.sql classes words shuffle arrays ;
IN: db.queries IN: db.queries
GENERIC: where ( specs obj -- ) GENERIC: where ( specs obj -- )
@ -99,16 +100,15 @@ M: string where ( spec obj -- ) object-where ;
] with filter ; ] with filter ;
: where-clause ( tuple specs -- ) : where-clause ( tuple specs -- )
dupd filter-slots dupd filter-slots [
dup empty? [ drop
2drop
] [ ] [
" where " 0% [ " where " 0% [
" and " 0% " and " 0%
] [ ] [
2dup slot-name>> swap get-slot-named where 2dup slot-name>> swap get-slot-named where
] interleave drop ] interleave drop
] if ; ] if-empty ;
M: db <delete-tuples-statement> ( tuple table -- sql ) M: db <delete-tuples-statement> ( tuple table -- sql )
[ [
@ -146,15 +146,52 @@ M: db <select-by-slots-statement> ( tuple class -- statement )
number>string " limit " prepend append number>string " limit " prepend append
] curry change-sql drop ; ] curry change-sql drop ;
: make-advanced-statement ( tuple advanced -- tuple' ) : make-query ( tuple query -- tuple' )
dupd dupd
{ {
[ group>> [ do-group ] [ drop ] if* ] [ group>> [ do-group ] [ drop ] if-seq ]
[ order>> [ do-order ] [ drop ] if* ] [ order>> [ do-order ] [ drop ] if-seq ]
[ limit>> [ do-limit ] [ drop ] if* ] [ limit>> [ do-limit ] [ drop ] if* ]
[ offset>> [ do-offset ] [ drop ] if* ] [ offset>> [ do-offset ] [ drop ] if* ]
} 2cleave ; } 2cleave ;
M: db <advanced-select-statement> ( tuple class group order limit offset -- tuple ) M: db <query> ( tuple class query -- tuple )
advanced-statement boa [ <select-by-slots-statement> ] dip make-query ;
[ <select-by-slots-statement> ] dip make-advanced-statement ;
! select ID, NAME, SCORE from EXAM limit 1 offset 3
: select-tuples* ( tuple -- statement )
dup
[
select 0,
dup class db-columns [ ", " 0, ]
[ dup column-name>> 0, 2, ] interleave
from 0,
class word-name 0,
] { { } { } { } } nmake
>r >r parse-sql 4drop r> r>
<simple-statement> maybe-make-retryable do-select ;
M: db <count-statement> ( tuple class groups -- statement )
\ query new
swap >>group
[ [ "select count(*) from " 0% 0% where-clause ] query-make ]
dip make-query ;
: where-clause* ( tuple specs -- )
dupd filter-slots [
drop
] [
\ where 0,
[ 2dup slot-name>> swap get-slot-named where ] map 2array 0,
drop
] if-empty ;
: delete-tuple* ( tuple -- sql )
dup
[
delete 0, from 0, dup class db-table 0,
dup class db-columns where-clause*
] { { } { } { } } nmake
>r >r parse-sql 4drop r> r>
<simple-statement> maybe-make-retryable do-select ;

30
extra/db/sql/sql.factor
View File

@ -23,12 +23,27 @@ DEFER: sql%
: sql-function, ( seq function -- ) : sql-function, ( seq function -- )
sql% "(" sql% unclip sql% ")" sql% [ sql% ] each ; sql% "(" sql% unclip sql% ")" sql% [ sql% ] each ;
: sql-where ( seq -- )
B
[
[ second 0, ]
[ first 0, ]
[ third 1, \ ? 0, ] tri
] each ;
: sql-array% ( array -- ) : sql-array% ( array -- )
B
unclip unclip
{ {
{ \ create [ "create table" sql% ] }
{ \ drop [ "drop table" sql% ] }
{ \ insert [ "insert into" sql% ] }
{ \ update [ "update" sql% ] }
{ \ delete [ "delete" sql% ] }
{ \ select [ B "select" sql% "," (sql-interleave) ] }
{ \ columns [ "," (sql-interleave) ] } { \ columns [ "," (sql-interleave) ] }
{ \ from [ "from" "," sql-interleave ] } { \ from [ "from" "," sql-interleave ] }
{ \ where [ "where" "and" sql-interleave ] } { \ where [ B "where" 0, sql-where ] }
{ \ group-by [ "group by" "," sql-interleave ] } { \ group-by [ "group by" "," sql-interleave ] }
{ \ having [ "having" "," sql-interleave ] } { \ having [ "having" "," sql-interleave ] }
{ \ order-by [ "order by" "," sql-interleave ] } { \ order-by [ "order by" "," sql-interleave ] }
@ -49,7 +64,7 @@ DEFER: sql%
ERROR: no-sql-match ; ERROR: no-sql-match ;
: sql% ( obj -- ) : sql% ( obj -- )
{ {
{ [ dup string? ] [ " " 0% 0% ] } { [ dup string? ] [ 0, ] }
{ [ dup array? ] [ sql-array% ] } { [ dup array? ] [ sql-array% ] }
{ [ dup number? ] [ number>string sql% ] } { [ dup number? ] [ number>string sql% ] }
{ [ dup symbol? ] [ unparse sql% ] } { [ dup symbol? ] [ unparse sql% ] }
@ -59,13 +74,4 @@ ERROR: no-sql-match ;
} cond ; } cond ;
: parse-sql ( obj -- sql in-spec out-spec in out ) : parse-sql ( obj -- sql in-spec out-spec in out )
[ [ [ sql% ] each ] { { } { } { } } nmake ;
unclip {
{ \ create [ "create table" sql% ] }
{ \ drop [ "drop table" sql% ] }
{ \ insert [ "insert into" sql% ] }
{ \ update [ "update" sql% ] }
{ \ delete [ "delete" sql% ] }
{ \ select [ "select" sql% ] }
} case [ sql% ] each
] { "" { } { } { } { } } nmake ;

4
extra/db/sqlite/lib/lib.factor
View File

@ -4,7 +4,7 @@ USING: alien.c-types arrays assocs kernel math math.parser
namespaces sequences db.sqlite.ffi db combinators namespaces sequences db.sqlite.ffi db combinators
continuations db.types calendar.format serialize continuations db.types calendar.format serialize
io.streams.byte-array byte-arrays io.encodings.binary io.streams.byte-array byte-arrays io.encodings.binary
io.backend db.errors ; io.backend db.errors present urls ;
IN: db.sqlite.lib IN: db.sqlite.lib
ERROR: sqlite-error < db-error n string ; ERROR: sqlite-error < db-error n string ;
@ -107,6 +107,7 @@ ERROR: sqlite-sql-error < sql-error n string ;
object>bytes object>bytes
sqlite-bind-blob-by-name sqlite-bind-blob-by-name
] } ] }
{ URL [ present sqlite-bind-text-by-name ] }
{ +db-assigned-id+ [ sqlite-bind-int-by-name ] } { +db-assigned-id+ [ sqlite-bind-int-by-name ] }
{ +random-id+ [ sqlite-bind-int64-by-name ] } { +random-id+ [ sqlite-bind-int64-by-name ] }
{ NULL [ sqlite-bind-null-by-name ] } { NULL [ sqlite-bind-null-by-name ] }
@ -147,6 +148,7 @@ ERROR: sqlite-sql-error < sql-error n string ;
{ TIMESTAMP [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] } { TIMESTAMP [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] }
{ DATETIME [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] } { DATETIME [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] }
{ BLOB [ sqlite-column-blob ] } { BLOB [ sqlite-column-blob ] }
{ URL [ sqlite3_column_text dup [ >url ] when ] }
{ FACTOR-BLOB [ { FACTOR-BLOB [
sqlite-column-blob sqlite-column-blob
dup [ bytes>object ] when dup [ bytes>object ] when

1
extra/db/sqlite/sqlite.factor
View File

@ -182,6 +182,7 @@ M: sqlite-db persistent-table ( -- assoc )
{ DOUBLE { "real" "real" } } { DOUBLE { "real" "real" } }
{ BLOB { "blob" "blob" } } { BLOB { "blob" "blob" } }
{ FACTOR-BLOB { "blob" "blob" } } { FACTOR-BLOB { "blob" "blob" } }
{ URL { "text" "text" } }
{ +autoincrement+ { f f "autoincrement" } } { +autoincrement+ { f f "autoincrement" } }
{ +unique+ { f f "unique" } } { +unique+ { f f "unique" } }
{ +default+ { f f "default" } } { +default+ { f f "default" } }

56
extra/db/tuples/tuples-tests.factor
View File

@ -4,26 +4,27 @@ USING: io.files kernel tools.test db db.tuples classes
db.types continuations namespaces math math.ranges db.types continuations namespaces math math.ranges
prettyprint calendar sequences db.sqlite math.intervals prettyprint calendar sequences db.sqlite math.intervals
db.postgresql accessors random math.bitfields.lib db.postgresql accessors random math.bitfields.lib
math.ranges strings sequences.lib ; math.ranges strings sequences.lib urls ;
IN: db.tuples.tests IN: db.tuples.tests
TUPLE: person the-id the-name the-number the-real TUPLE: person the-id the-name the-number the-real
ts date time blob factor-blob ; ts date time blob factor-blob url ;
: <person> ( name age real ts date time blob factor-blob -- person ) : <person> ( name age real ts date time blob factor-blob url -- person )
{ person new
set-person-the-name swap >>url
set-person-the-number swap >>factor-blob
set-person-the-real swap >>blob
set-person-ts swap >>time
set-person-date swap >>date
set-person-time swap >>ts
set-person-blob swap >>the-real
set-person-factor-blob swap >>the-number
} person construct ; swap >>the-name ;
: <user-assigned-person> ( id name age real ts date time blob factor-blob -- person ) : <user-assigned-person> ( id name age real ts date time blob factor-blob url -- person )
<person> [ set-person-the-id ] keep ; <person>
swap >>the-id ;
SYMBOL: person1 SYMBOL: person1
SYMBOL: person2 SYMBOL: person2
@ -103,6 +104,7 @@ SYMBOL: person4
T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
f f
H{ { 1 2 } { 3 4 } { 5 "lol" } } H{ { 1 2 } { 3 4 } { 5 "lol" } }
URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search"
} }
] [ T{ person f 4 } select-tuple ] unit-test ] [ T{ person f 4 } select-tuple ] unit-test
@ -120,19 +122,20 @@ SYMBOL: person4
{ "time" "T" TIME } { "time" "T" TIME }
{ "blob" "B" BLOB } { "blob" "B" BLOB }
{ "factor-blob" "FB" FACTOR-BLOB } { "factor-blob" "FB" FACTOR-BLOB }
{ "url" "U" URL }
} define-persistent } define-persistent
"billy" 10 3.14 f f f f f <person> person1 set "billy" 10 3.14 f f f f f f <person> person1 set
"johnny" 10 3.14 f f f f f <person> person2 set "johnny" 10 3.14 f f f f f f <person> person2 set
"teddy" 10 3.14 "teddy" 10 3.14
T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f <person> person3 set B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f f <person> person3 set
"eddie" 10 3.14 "eddie" 10 3.14
T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
f H{ { 1 2 } { 3 4 } { 5 "lol" } } <person> person4 set ; f H{ { 1 2 } { 3 4 } { 5 "lol" } } URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search" <person> person4 set ;
: user-assigned-person-schema ( -- ) : user-assigned-person-schema ( -- )
person "PERSON" person "PERSON"
@ -146,20 +149,21 @@ SYMBOL: person4
{ "time" "T" TIME } { "time" "T" TIME }
{ "blob" "B" BLOB } { "blob" "B" BLOB }
{ "factor-blob" "FB" FACTOR-BLOB } { "factor-blob" "FB" FACTOR-BLOB }
{ "url" "U" URL }
} define-persistent } define-persistent
1 "billy" 10 3.14 f f f f f <user-assigned-person> person1 set 1 "billy" 10 3.14 f f f f f f <user-assigned-person> person1 set
2 "johnny" 10 3.14 f f f f f <user-assigned-person> person2 set 2 "johnny" 10 3.14 f f f f f f <user-assigned-person> person2 set
3 "teddy" 10 3.14 3 "teddy" 10 3.14
T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
B{ 115 116 111 114 101 105 110 97 98 108 111 98 } B{ 115 116 111 114 101 105 110 97 98 108 111 98 }
f <user-assigned-person> person3 set f f <user-assigned-person> person3 set
4 "eddie" 10 3.14 4 "eddie" 10 3.14
T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
f H{ { 1 2 } { 3 4 } { 5 "lol" } } <user-assigned-person> person4 set ; f H{ { 1 2 } { 3 4 } { 5 "lol" } } URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search" <user-assigned-person> person4 set ;
TUPLE: paste n summary author channel mode contents timestamp annotations ; TUPLE: paste n summary author channel mode contents timestamp annotations ;
TUPLE: annotation n paste-id summary author mode contents ; TUPLE: annotation n paste-id summary author mode contents ;
@ -227,7 +231,7 @@ TUPLE: exam id name score ;
: random-exam ( -- exam ) : random-exam ( -- exam )
f f
6 [ CHAR: a CHAR: b [a,b] random ] replicate >string 6 [ CHAR: a CHAR: z [a,b] random ] replicate >string
100 random 100 random
exam boa ; exam boa ;
@ -340,7 +344,9 @@ TUPLE: exam id name score ;
} }
] [ ] [
T{ exam } select-tuples T{ exam } select-tuples
] unit-test ; ] unit-test
[ 4 ] [ T{ exam } f count-tuples ] unit-test ;
TUPLE: bignum-test id m n o ; TUPLE: bignum-test id m n o ;
: <bignum-test> ( m n o -- obj ) : <bignum-test> ( m n o -- obj )

38
extra/db/tuples/tuples.factor
View File

@ -42,8 +42,9 @@ HOOK: <insert-user-assigned-statement> db ( class -- obj )
HOOK: <update-tuple-statement> db ( class -- obj ) HOOK: <update-tuple-statement> db ( class -- obj )
HOOK: <delete-tuples-statement> db ( tuple class -- obj ) HOOK: <delete-tuples-statement> db ( tuple class -- obj )
HOOK: <select-by-slots-statement> db ( tuple class -- tuple ) HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
TUPLE: advanced-statement group order offset limit ; TUPLE: query group order offset limit ;
HOOK: <advanced-select-statement> db ( tuple class group order offset limit -- tuple ) HOOK: <query> db ( tuple class query -- statement' )
HOOK: <count-statement> db ( tuple class groups -- n )
HOOK: insert-tuple* db ( tuple statement -- ) HOOK: insert-tuple* db ( tuple statement -- )
@ -55,6 +56,7 @@ SINGLETON: retryable
[ make-retryable ] map [ make-retryable ] map
] [ ] [
retryable >>type retryable >>type
10 >>retries
] if ; ] if ;
: regenerate-params ( statement -- statement ) : regenerate-params ( statement -- statement )
@ -69,12 +71,13 @@ SINGLETON: retryable
] 2map >>bind-params ; ] 2map >>bind-params ;
M: retryable execute-statement* ( statement type -- ) M: retryable execute-statement* ( statement type -- )
drop drop [
[ [
[ query-results dispose t ] [ query-results dispose t ]
[ ] [ ]
[ regenerate-params bind-statement* f ] cleanup [ regenerate-params bind-statement* f ] cleanup
] curry 10 retry drop ; ] curry
] [ retries>> ] bi retry drop ;
: resulting-tuple ( class row out-params -- tuple ) : resulting-tuple ( class row out-params -- tuple )
rot class new [ rot class new [
@ -146,12 +149,21 @@ M: retryable execute-statement* ( statement type -- )
: do-select ( exemplar-tuple statement -- tuples ) : do-select ( exemplar-tuple statement -- tuples )
[ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ; [ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ;
: query ( tuple query -- tuples )
>r dup dup class r> <query> do-select ;
: select-tuples ( tuple -- tuples ) : select-tuples ( tuple -- tuples )
dup dup class <select-by-slots-statement> do-select ; dup dup class <select-by-slots-statement> do-select ;
: count-tuples ( tuple -- n )
select-tuples length ;
: select-tuple ( tuple -- tuple/f ) : select-tuple ( tuple -- tuple/f )
dup dup class f f f 1 <advanced-select-statement> dup dup class \ query new 1 >>limit <query> do-select ?first ;
do-select ?first ;
: do-count ( exemplar-tuple statement -- tuples )
[
[ bind-tuple ] [ nip default-query ] 2bi
] with-disposal ;
: count-tuples ( tuple groups -- n )
>r dup dup class r> <count-statement> do-count
dup length 1 =
[ first first string>number ] [ [ first string>number ] map ] if ;

2
extra/db/types/types.factor
View File

@ -65,7 +65,7 @@ SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
SYMBOLS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER SYMBOLS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER
DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB
FACTOR-BLOB NULL ; FACTOR-BLOB NULL URL ;
: spec>tuple ( class spec -- tuple ) : spec>tuple ( class spec -- tuple )
3 f pad-right 3 f pad-right

26
extra/dns/misc/misc.factor
View File

@ -1,12 +1,34 @@
USING: kernel sequences splitting io.files io.encodings.utf8 random newfx ; USING: kernel combinators sequences splitting math
io.files io.encodings.utf8 random newfx dns.util ;
IN: dns.misc IN: dns.misc
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: resolv-conf-servers ( -- seq ) : resolv-conf-servers ( -- seq )
"/etc/resolv.conf" utf8 file-lines "/etc/resolv.conf" utf8 file-lines
[ " " split ] map [ " " split ] map
[ 1st "nameserver" = ] filter [ 1st "nameserver" = ] filter
[ 2nd ] map ; [ 2nd ] map ;
: resolv-conf-server ( -- ip ) resolv-conf-servers random ; : resolv-conf-server ( -- ip ) resolv-conf-servers random ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: cdr-name ( name -- name ) dup CHAR: . index 1+ tail ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: domain-has-name? ( domain name -- ? )
{
{ [ 2dup = ] [ 2drop t ] }
{ [ 2dup longer? ] [ 2drop f ] }
{ [ t ] [ cdr-name domain-has-name? ] }
}
cond ;
: name-in-domain? ( name domain -- ? ) swap domain-has-name? ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

128
extra/dns/server/server.factor
View File

@ -1,14 +1,9 @@
USING: kernel USING: kernel combinators sequences sets math
combinators io.sockets unicode.case accessors
sequences
math
io.sockets
unicode.case
accessors
combinators.cleave combinators.lib combinators.cleave combinators.lib
newfx newfx
dns dns.util ; dns dns.util dns.misc ;
IN: dns.server IN: dns.server
@ -27,6 +22,69 @@ IN: dns.server
: matching-rrs ( query -- rrs ) records [ rr=query? ] with filter ; : matching-rrs ( query -- rrs ) records [ rr=query? ] with filter ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! zones
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: zones ( -- names ) records [ type>> NS = ] filter [ name>> ] map prune ;
: my-zones ( -- names ) records [ type>> SOA = ] filter [ name>> ] map ;
: delegated-zones ( -- names ) zones my-zones diff ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! name->zone
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: name->zone ( name -- zone/f )
zones sort-largest-first [ name-in-domain? ] with find nip ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! name->authority
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: name->authority ( name -- rrs-ns ) name->zone NS IN query boa matching-rrs ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! extract-names
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: rr->rdata-names ( rr -- names/f )
{
{ [ dup type>> NS = ] [ rdata>> {1} ] }
{ [ dup type>> MX = ] [ rdata>> exchange>> {1} ] }
{ [ t ] [ drop f ] }
}
cond ;
: extract-rdata-names ( message -- names )
[ answer-section>> ] [ authority-section>> ] bi append
[ rr->rdata-names ] map concat ;
: extract-names ( message -- names )
[ message-query name>> ] [ extract-rdata-names ] bi prefix-on ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! fill-authority
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: fill-authority ( message -- message )
dup
extract-names [ name->authority ] map concat prune
over answer-section>> diff
>>authority-section ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! fill-additional
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: name->rrs-a ( name -- rrs-a ) A IN query boa matching-rrs ;
: fill-additional ( message -- message )
dup
extract-rdata-names [ name->rrs-a ] map concat prune
over answer-section>> diff
>>additional-section ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! query->rrs ! query->rrs
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -49,8 +107,11 @@ DEFER: query->rrs
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: have-answers ( message -- message/f ) : have-answers ( message -- message/f )
dup message-query query->rrs ! message rrs/f dup message-query query->rrs
[ empty? ] [ 2drop f ] [ >>answer-section ] 1if ; [ empty? ]
[ 2drop f ]
[ >>answer-section fill-authority fill-additional ]
1if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! have-delegates? ! have-delegates?
@ -64,13 +125,13 @@ DEFER: query->rrs
NS IN query boa matching-rrs [ empty? ] [ drop f ] [ ] 1if ; NS IN query boa matching-rrs [ empty? ] [ drop f ] [ ] 1if ;
: name->delegates ( name -- rrs-ns ) : name->delegates ( name -- rrs-ns )
{ {
[ "" = { } and ] [ "" = { } and ]
[ is-soa? { } and ] [ is-soa? { } and ]
[ have-ns? ] [ have-ns? ]
[ cdr-name name->delegates ] [ cdr-name name->delegates ]
} }
1|| ; 1|| ;
: have-delegates ( message -- message/f ) : have-delegates ( message -- message/f )
dup message-query name>> name->delegates ! message rrs-ns dup message-query name>> name->delegates ! message rrs-ns
@ -85,20 +146,49 @@ DEFER: query->rrs
] ]
1if ; 1if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! outsize-zones
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: outside-zones ( message -- message/f )
dup message-query name>> name->zone f =
[ ]
[ drop f ]
if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! is-nx ! is-nx
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: is-nx ( message -- message/f ) : is-nx ( message -- message/f )
[ message-query name>> records [ name>> = ] with filter empty? ] [ message-query name>> records [ name>> = ] with filter empty? ]
[ NAME-ERROR >>rcode ] [
NAME-ERROR >>rcode
dup
message-query name>> name->zone SOA IN query boa matching-rrs
>>authority-section
]
[ drop f ] [ drop f ]
1if ; 1if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: none-of-type ( message -- message )
dup
message-query name>> name->zone SOA IN query boa matching-rrs
>>authority-section ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: find-answer ( message -- message ) : find-answer ( message -- message )
{ [ have-answers ] [ have-delegates ] [ is-nx ] [ ] } 1|| ; {
[ have-answers ]
[ have-delegates ]
[ outside-zones ]
[ is-nx ]
[ none-of-type ]
}
1|| ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

12
extra/dns/util/util.factor
View File

@ -1,5 +1,5 @@
USING: kernel macros fry ; USING: kernel sequences sorting math math.order macros fry ;
IN: dns.util IN: dns.util
@ -8,4 +8,12 @@ IN: dns.util
MACRO: 1if ( test then else -- ) '[ dup @ , , if ] ; MACRO: 1if ( test then else -- ) '[ dup @ , , if ] ;
! : 1if ( test then else -- ) >r >r >r dup r> call r> r> if ; inline ; ! : 1if ( test then else -- ) >r >r >r dup r> call r> r> if ; inline ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: sort-largest-first ( seq -- seq ) [ [ length ] compare ] sort reverse ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: longer? ( seq seq -- ? ) [ length ] bi@ > ;

13
extra/geo-ip/geo-ip.factor
View File

@ -1,7 +1,7 @@
USING: kernel sequences io.files io.launcher io.encodings.ascii USING: kernel sequences io.files io.launcher io.encodings.ascii
io.streams.string http.client sequences.lib combinators io.streams.string http.client sequences.lib combinators
math.parser math.vectors math.intervals interval-maps memoize math.parser math.vectors math.intervals interval-maps memoize
csv accessors assocs strings math splitting ; csv accessors assocs strings math splitting grouping arrays ;
IN: geo-ip IN: geo-ip
: db-path ( -- path ) "IpToCountry.csv" temp-file ; : db-path ( -- path ) "IpToCountry.csv" temp-file ;
@ -32,15 +32,20 @@ MEMO: ip-db ( -- seq )
[ "#" head? not ] filter "\n" join <string-reader> csv [ "#" head? not ] filter "\n" join <string-reader> csv
[ parse-ip-entry ] map ; [ parse-ip-entry ] map ;
: filter-overlaps ( alist -- alist' )
2 clump
[ first2 [ first second ] [ first first ] bi* < ] filter
[ first ] map ;
MEMO: ip-intervals ( -- interval-map ) MEMO: ip-intervals ( -- interval-map )
ip-db [ [ [ from>> ] [ to>> ] bi [a,b] ] keep ] { } map>assoc ip-db [ [ [ from>> ] [ to>> ] bi 2array ] keep ] { } map>assoc
<interval-map> ; filter-overlaps <interval-map> ;
GENERIC: lookup-ip ( ip -- ip-entry ) GENERIC: lookup-ip ( ip -- ip-entry )
M: string lookup-ip M: string lookup-ip
"." split [ string>number ] map "." split [ string>number ] map
{ HEX: 1000000 HEX: 10000 HEX: 100 1 } v. { HEX: 1000000 HEX: 10000 HEX: 100 HEX: 1 } v.
lookup-ip ; lookup-ip ;
M: integer lookup-ip ip-intervals interval-at ; M: integer lookup-ip ip-intervals interval-at ;

16
extra/help/handbook/handbook.factor
View File

@ -40,8 +40,8 @@ $nl
"Common terminology and abbreviations used throughout Factor and its documentation:" "Common terminology and abbreviations used throughout Factor and its documentation:"
{ $table { $table
{ "Term" "Definition" } { "Term" "Definition" }
{ "alist" { "an association list. See " { $link "alists" } } } { "alist" { "an association list; see " { $link "alists" } } }
{ "assoc" "an associative mapping" } { "assoc" { "an associative mapping; see " { $link "assocs" } } }
{ "associative mapping" { "an object whose class implements the " { $link "assocs-protocol" } } } { "associative mapping" { "an object whose class implements the " { $link "assocs-protocol" } } }
{ "boolean" { { $link t } " or " { $link f } } } { "boolean" { { $link t } " or " { $link f } } }
{ "class" { "a set of objects identified by a " { $emphasis "class word" } " together with a discriminating predicate. See " { $link "classes" } } } { "class" { "a set of objects identified by a " { $emphasis "class word" } " together with a discriminating predicate. See " { $link "classes" } } }
@ -50,8 +50,9 @@ $nl
{ "generic word" { "a word whose behavior depends can be specialized on the class of one of its inputs. See " { $link "generic" } } } { "generic word" { "a word whose behavior depends can be specialized on the class of one of its inputs. See " { $link "generic" } } }
{ "method" { "a specialized behavior of a generic word on a class. See " { $link "generic" } } } { "method" { "a specialized behavior of a generic word on a class. See " { $link "generic" } } }
{ "object" { "any datum which can be identified" } } { "object" { "any datum which can be identified" } }
{ "ordering specifier" { "see " { $link "order-specifiers" } } }
{ "pathname string" { "an OS-specific pathname which identifies a file" } } { "pathname string" { "an OS-specific pathname which identifies a file" } }
{ "sequence" { "an object whose class implements the " { $link "sequence-protocol" } } } { "sequence" { "a sequence; see " { $link "sequence-protocol" } } }
{ "slot" { "a component of an object which can store a value" } } { "slot" { "a component of an object which can store a value" } }
{ "stack effect" { "a pictorial representation of a word's inputs and outputs, for example " { $snippet "+ ( x y -- z )" } ". See " { $link "effects" } } } { "stack effect" { "a pictorial representation of a word's inputs and outputs, for example " { $snippet "+ ( x y -- z )" } ". See " { $link "effects" } } }
{ "true value" { "any object not equal to " { $link f } } } { "true value" { "any object not equal to " { $link f } } }
@ -157,12 +158,17 @@ ARTICLE: "collections" "Collections"
{ $subsection "hashtables" } { $subsection "hashtables" }
{ $subsection "alists" } { $subsection "alists" }
{ $subsection "enums" } { $subsection "enums" }
{ $heading "Double-ended queues" }
{ $subsection "dequeues" }
"Implementations:"
{ $subsection "dlists" }
{ $subsection "search-dequeues" }
{ $heading "Other collections" } { $heading "Other collections" }
{ $subsection "boxes" } { $subsection "boxes" }
{ $subsection "dlists" }
{ $subsection "heaps" } { $subsection "heaps" }
{ $subsection "graphs" } { $subsection "graphs" }
{ $subsection "buffers" } ; { $subsection "buffers" }
"There are many other collections in " { $snippet "extra/" } ", such as " { $vocab-link "disjoint-set" } ", " { $vocab-link "persistent-vectors" } ", and " { $vocab-link "tuple-arrays" } "." ;
USING: io.sockets io.launcher io.mmap io.monitors USING: io.sockets io.launcher io.mmap io.monitors
io.encodings.utf8 io.encodings.utf16 io.encodings.binary io.encodings.ascii io.files ; io.encodings.utf8 io.encodings.utf16 io.encodings.binary io.encodings.ascii io.files ;

22
extra/help/lint/lint.factor
View File

@ -5,7 +5,7 @@ words strings classes tools.vocabs namespaces io
io.streams.string prettyprint definitions arrays vectors io.streams.string prettyprint definitions arrays vectors
combinators splitting debugger hashtables sorting effects vocabs combinators splitting debugger hashtables sorting effects vocabs
vocabs.loader assocs editors continuations classes.predicate vocabs.loader assocs editors continuations classes.predicate
macros combinators.lib sequences.lib math sets ; macros math sets ;
IN: help.lint IN: help.lint
: check-example ( element -- ) : check-example ( element -- )
@ -46,16 +46,15 @@ IN: help.lint
: check-values ( word element -- ) : check-values ( word element -- )
{ {
[ over "declared-effect" word-prop ] { [ over "declared-effect" word-prop ] [ 2drop ] }
[ dup contains-funky-elements? not ] { [ dup contains-funky-elements? not ] [ 2drop ] }
[ over macro? not ] { [ over macro? not ] [ 2drop ] }
[ [
2dup extract-values >array [ effect-values >array ]
>r effect-values >array [ extract-values >array ]
r> assert= bi* assert=
t
] ]
} 0&& 3drop ; } cond ;
: check-see-also ( word element -- ) : check-see-also ( word element -- )
nip \ $see-also swap elements [ nip \ $see-also swap elements [
@ -114,7 +113,10 @@ M: help-error error.
vocabs [ dup vocab-docs-path swap ] H{ } map>assoc vocabs [ dup vocab-docs-path swap ] H{ } map>assoc
H{ } clone [ H{ } clone [
[ [
>r >r dup >link where ?first r> at r> [ ?push ] change-at >r >r dup >link where dup
[ first r> at r> [ ?push ] change-at ]
[ r> r> 2drop 2drop ]
if
] 2curry each ] 2curry each
] keep ; ] keep ;

2
extra/html/parser/analyzer/analyzer.factor
View File

@ -6,7 +6,7 @@ IN: html.parser.analyzer
TUPLE: link attributes clickable ; TUPLE: link attributes clickable ;
: scrape-html ( url -- vector ) : scrape-html ( url -- vector )
http-get parse-html ; http-get nip parse-html ;
: (find-relative) : (find-relative)
[ >r + dup r> ?nth* [ 2drop f f ] unless ] [ 2drop f ] if ; inline [ >r + dup r> ?nth* [ 2drop f f ] unless ] [ 2drop f ] if ; inline

Some files were not shown because too many files have changed in this diff Show More