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

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

db4
Joe Groff 2008-06-12 16:12:02 -07:00
parent 4cfe0c6f0a b75f322d6e
commit a2d49242ba
162 changed files with 1935 additions and 951 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" ] [
[ [

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? ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

116
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,53 @@ 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 ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! fill-authority
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: fill-authority ( message -- message )
[ ]
[ message-query name>> name->zone NS IN query boa matching-rrs ]
[ answer-section>> ]
tri
diff >>authority-section ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! fill-additional
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: rr->rdata-names ( rr -- names/f )
{
{ [ dup type>> NS = ] [ rdata>> {1} ] }
{ [ dup type>> MX = ] [ rdata>> exchange>> {1} ] }
{ [ t ] [ drop f ] }
}
cond ;
: fill-additional ( message -- message )
dup
[ answer-section>> ] [ authority-section>> ] bi append
[ rr->rdata-names ] map concat
[ A IN query boa matching-rrs ] map concat prune
over answer-section>> diff
>>additional-section ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! query->rrs ! query->rrs
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -48,9 +90,16 @@ DEFER: query->rrs
! have-answers ! have-answers
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! : have-answers ( message -- message/f )
! dup message-query query->rrs ! message rrs/f
! [ empty? ] [ 2drop f ] [ >>answer-section ] 1if ;
: 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 +113,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 +134,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

59
extra/http/client/client.factor
View File

@ -3,8 +3,13 @@
USING: assocs http kernel math math.parser namespaces sequences USING: assocs http kernel math math.parser namespaces sequences
io io.sockets io.streams.string io.files io.timeouts strings io io.sockets io.streams.string io.files io.timeouts strings
splitting calendar continuations accessors vectors math.order splitting calendar continuations accessors vectors math.order
io.encodings.8-bit io.encodings.binary io.streams.duplex io.encodings
fry debugger inspector ascii urls ; io.encodings.string
io.encodings.ascii
io.encodings.8-bit
io.encodings.binary
io.streams.duplex
fry debugger inspector ascii urls present ;
IN: http.client IN: http.client
: max-redirects 10 ; : max-redirects 10 ;
@ -15,7 +20,7 @@ M: too-many-redirects summary
drop drop
[ "Redirection limit of " % max-redirects # " exceeded" % ] "" make ; [ "Redirection limit of " % max-redirects # " exceeded" % ] "" make ;
DEFER: http-request DEFER: (http-request)
<PRIVATE <PRIVATE
@ -31,7 +36,7 @@ SYMBOL: redirects
redirects get max-redirects < [ redirects get max-redirects < [
request get request get
swap "location" header redirect-url swap "location" header redirect-url
"GET" >>method http-request "GET" >>method (http-request)
] [ ] [
too-many-redirects too-many-redirects
] if ] if
@ -45,15 +50,21 @@ PRIVATE>
: read-chunks ( -- ) : read-chunks ( -- )
read-chunk-size dup zero? read-chunk-size dup zero?
[ drop ] [ read % read-crlf "" assert= read-chunks ] if ; [ drop ] [ read % read-crlf B{ } assert= read-chunks ] if ;
: read-response-body ( response -- response data ) : read-response-body ( response -- response data )
dup "transfer-encoding" header "chunked" = dup "transfer-encoding" header "chunked" = [
[ [ read-chunks ] "" make ] [ input-stream get contents ] if ; binary decode-input
[ read-chunks ] B{ } make
over content-charset>> decode
] [
dup content-charset>> decode-input
input-stream get contents
] if ;
: http-request ( request -- response data ) : (http-request) ( request -- response data )
dup request [ dup request [
dup url>> url-addr latin1 [ dup url>> url-addr ascii [
1 minutes timeouts 1 minutes timeouts
write-request write-request
read-response read-response
@ -62,14 +73,6 @@ PRIVATE>
do-redirect do-redirect
] with-variable ; ] with-variable ;
: <get-request> ( url -- request )
<request>
"GET" >>method
swap >url ensure-port >>url ;
: http-get* ( url -- response data )
<get-request> http-request ;
: success? ( code -- ? ) 200 = ; : success? ( code -- ? ) 200 = ;
ERROR: download-failed response body ; ERROR: download-failed response body ;
@ -84,18 +87,28 @@ M: download-failed error.
] ]
[ body>> write ] bi ; [ body>> write ] bi ;
: check-response ( response string -- string ) : check-response ( response data -- response data )
over code>> success? [ nip ] [ download-failed ] if ; over code>> success? [ download-failed ] unless ;
: http-get ( url -- string ) : http-request ( request -- response data )
http-get* check-response ; (http-request) check-response ;
: <get-request> ( url -- request )
<request>
"GET" >>method
swap >url ensure-port >>url ;
: http-get ( url -- response data )
<get-request> http-request ;
: download-name ( url -- name ) : download-name ( url -- name )
file-name "?" split1 drop "/" ?tail drop ; present file-name "?" split1 drop "/" ?tail drop ;
: download-to ( url file -- ) : download-to ( url file -- )
#! Downloads the contents of a URL to a file. #! Downloads the contents of a URL to a file.
[ http-get ] dip latin1 [ write ] with-file-writer ; swap http-get
[ content-charset>> ] [ '[ , write ] ] bi*
with-file-writer ;
: download ( url -- ) : download ( url -- )
dup download-name download-to ; dup download-name download-to ;

31
extra/http/http-tests.factor
View File

@ -1,5 +1,6 @@
USING: http tools.test multiline tuple-syntax USING: http tools.test multiline tuple-syntax
io.streams.string kernel arrays splitting sequences io.streams.string io.encodings.utf8 io.encodings.string
kernel arrays splitting sequences
assocs io.sockets db db.sqlite continuations urls hashtables ; assocs io.sockets db db.sqlite continuations urls hashtables ;
IN: http.tests IN: http.tests
@ -78,7 +79,7 @@ must-fail-with
STRING: read-response-test-1 STRING: read-response-test-1
HTTP/1.1 404 not found HTTP/1.1 404 not found
Content-Type: text/html; charset=UTF8 Content-Type: text/html; charset=UTF-8
blah blah
; ;
@ -88,10 +89,10 @@ blah
version: "1.1" version: "1.1"
code: 404 code: 404
message: "not found" message: "not found"
header: H{ { "content-type" "text/html; charset=UTF8" } } header: H{ { "content-type" "text/html; charset=UTF-8" } }
cookies: { } cookies: { }
content-type: "text/html" content-type: "text/html"
content-charset: "UTF8" content-charset: utf8
} }
] [ ] [
read-response-test-1 lf>crlf read-response-test-1 lf>crlf
@ -101,7 +102,7 @@ blah
STRING: read-response-test-1' STRING: read-response-test-1'
HTTP/1.1 404 not found HTTP/1.1 404 not found
content-type: text/html; charset=UTF8 content-type: text/html; charset=UTF-8
; ;
@ -160,14 +161,14 @@ test-db [
[ t ] [ [ t ] [
"resource:extra/http/test/foo.html" ascii file-contents "resource:extra/http/test/foo.html" ascii file-contents
"http://localhost:1237/nested/foo.html" http-get = "http://localhost:1237/nested/foo.html" http-get nip ascii decode =
] unit-test ] unit-test
[ "http://localhost:1237/redirect-loop" http-get ] [ "http://localhost:1237/redirect-loop" http-get nip ]
[ too-many-redirects? ] must-fail-with [ too-many-redirects? ] must-fail-with
[ "Goodbye" ] [ [ "Goodbye" ] [
"http://localhost:1237/quit" http-get "http://localhost:1237/quit" http-get nip
] unit-test ] unit-test
! Dispatcher bugs ! Dispatcher bugs
@ -194,12 +195,12 @@ test-db [
: 404? [ download-failed? ] [ response>> code>> 404 = ] bi and ; : 404? [ download-failed? ] [ response>> code>> 404 = ] bi and ;
! This should give a 404 not an infinite redirect loop ! This should give a 404 not an infinite redirect loop
[ "http://localhost:1237/d/blah" http-get ] [ 404? ] must-fail-with [ "http://localhost:1237/d/blah" http-get nip ] [ 404? ] must-fail-with
! This should give a 404 not an infinite redirect loop ! This should give a 404 not an infinite redirect loop
[ "http://localhost:1237/blah/" http-get ] [ 404? ] must-fail-with [ "http://localhost:1237/blah/" http-get nip ] [ 404? ] must-fail-with
[ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test [ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test
[ ] [ [ ] [
[ [
@ -218,9 +219,9 @@ test-db [
[ ] [ 100 sleep ] unit-test [ ] [ 100 sleep ] unit-test
[ "Hi" ] [ "http://localhost:1237/" http-get ] unit-test [ "Hi" ] [ "http://localhost:1237/" http-get nip ] unit-test
[ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test [ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test
USING: html.components html.elements xml xml.utilities validators USING: html.components html.elements xml xml.utilities validators
furnace furnace.flash ; furnace furnace.flash ;
@ -253,7 +254,7 @@ SYMBOL: a
: test-a string>xml "input" tag-named "value" swap at ; : test-a string>xml "input" tag-named "value" swap at ;
[ "3" ] [ [ "3" ] [
"http://localhost:1237/" http-get* "http://localhost:1237/" http-get
swap dup cookies>> "cookies" set session-id-key get-cookie swap dup cookies>> "cookies" set session-id-key get-cookie
value>> "session-id" set test-a value>> "session-id" set test-a
] unit-test ] unit-test
@ -273,4 +274,4 @@ SYMBOL: a
[ 4 ] [ a get-global ] unit-test [ 4 ] [ a get-global ] unit-test
[ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test [ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test

25
extra/http/http.factor
View File

@ -7,6 +7,7 @@ strings vectors hashtables quotations arrays byte-arrays
math.parser calendar calendar.format present math.parser calendar calendar.format present
io io.server io.sockets.secure io io.server io.sockets.secure
io.encodings.iana io.encodings.binary io.encodings.8-bit
unicode.case unicode.categories qualified unicode.case unicode.categories qualified
@ -28,7 +29,8 @@ IN: http
"header" get "header" get
add-header add-header
] [ ] [
": " split1 dup [ ":" split1 dup [
[ blank? ] left-trim
swap >lower dup "last-header" set swap >lower dup "last-header" set
"header" get add-header "header" get add-header
] [ ] [
@ -36,20 +38,20 @@ IN: http
] if ] if
] if ; ] if ;
: read-lf ( -- string ) : read-lf ( -- bytes )
"\n" read-until CHAR: \n assert= ; "\n" read-until CHAR: \n assert= ;
: read-crlf ( -- string ) : read-crlf ( -- bytes )
"\r" read-until "\r" read-until
[ CHAR: \r assert= read1 CHAR: \n assert= ] when* ; [ CHAR: \r assert= read1 CHAR: \n assert= ] when* ;
: read-header-line ( -- ) : (read-header) ( -- )
read-crlf dup read-crlf dup
empty? [ drop ] [ header-line read-header-line ] if ; empty? [ drop ] [ header-line (read-header) ] if ;
: read-header ( -- assoc ) : read-header ( -- assoc )
H{ } clone [ H{ } clone [
"header" [ read-header-line ] with-variable "header" [ (read-header) ] with-variable
] keep ; ] keep ;
: header-value>string ( value -- string ) : header-value>string ( value -- string )
@ -66,7 +68,8 @@ IN: http
: write-header ( assoc -- ) : write-header ( assoc -- )
>alist sort-keys [ >alist sort-keys [
swap url-encode write ": " write swap
check-header-string write ": " write
header-value>string check-header-string write crlf header-value>string check-header-string write crlf
] assoc-each crlf ; ] assoc-each crlf ;
@ -299,6 +302,7 @@ body ;
H{ } clone >>header H{ } clone >>header
"close" "connection" set-header "close" "connection" set-header
now timestamp>http-string "date" set-header now timestamp>http-string "date" set-header
latin1 >>content-charset
V{ } clone >>cookies ; V{ } clone >>cookies ;
: read-response-version ( response -- response ) : read-response-version ( response -- response )
@ -319,7 +323,9 @@ body ;
read-header >>header read-header >>header
dup "set-cookie" header parse-cookies >>cookies dup "set-cookie" header parse-cookies >>cookies
dup "content-type" header [ dup "content-type" header [
parse-content-type [ >>content-type ] [ >>content-charset ] bi* parse-content-type
[ >>content-type ]
[ name>encoding binary or >>content-charset ] bi*
] when* ; ] when* ;
: read-response ( -- response ) : read-response ( -- response )
@ -341,7 +347,8 @@ body ;
: unparse-content-type ( request -- content-type ) : unparse-content-type ( request -- content-type )
[ content-type>> "application/octet-stream" or ] [ content-type>> "application/octet-stream" or ]
[ content-charset>> ] bi [ content-charset>> encoding>name ]
bi
[ "; charset=" swap 3append ] when* ; [ "; charset=" swap 3append ] when* ;
: write-response-header ( response -- response ) : write-response-header ( response -- response )

3
extra/http/server/responses/responses.factor
View File

@ -1,13 +1,14 @@
! 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: html.elements math.parser http accessors kernel USING: html.elements math.parser http accessors kernel
io io.streams.string ; io io.streams.string io.encodings.utf8 ;
IN: http.server.responses IN: http.server.responses
: <content> ( body content-type -- response ) : <content> ( body content-type -- response )
<response> <response>
200 >>code 200 >>code
"Document follows" >>message "Document follows" >>message
utf8 >>content-charset
swap >>content-type swap >>content-type
swap >>body ; swap >>body ;

57
extra/http/server/server.factor
View File

@ -1,10 +1,21 @@
! Copyright (C) 2003, 2008 Slava Pestov. ! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences arrays namespaces splitting USING: kernel accessors sequences arrays namespaces splitting
vocabs.loader http http.server.responses logging calendar vocabs.loader destructors assocs debugger continuations
destructors html.elements html.streams io.server tools.vocabs math
io.encodings.8-bit io.timeouts io assocs debugger continuations io
fry tools.vocabs math ; io.server
io.encodings
io.encodings.utf8
io.encodings.ascii
io.encodings.binary
io.streams.limited
io.timeouts
fry logging calendar
http
http.server.responses
html.elements
html.streams ;
IN: http.server IN: http.server
SYMBOL: responder-nesting SYMBOL: responder-nesting
@ -43,19 +54,29 @@ main-responder global [ <404> <trivial-responder> or ] change-at
swap development-mode get [ '[ , http-error. ] >>body ] [ drop ] if ; swap development-mode get [ '[ , http-error. ] >>body ] [ drop ] if ;
: do-response ( response -- ) : do-response ( response -- )
dup write-response [ write-response ]
request get method>> "HEAD" = [ drop ] [ [
'[ , write-response-body ] request get method>> "HEAD" = [ drop ] [
[ '[
development-mode get ,
[ http-error. ] [ drop "Response error" ] if [ content-charset>> encode-output ]
] recover [ write-response-body ]
] if ; bi
]
[
utf8 [
development-mode get
[ http-error. ] [ drop "Response error" throw ] if
] with-encoded-output
] recover
] if
] bi ;
LOG: httpd-hit NOTICE LOG: httpd-hit NOTICE
: log-request ( request -- ) : log-request ( request -- )
[ method>> ] [ url>> [ host>> ] [ path>> ] bi ] bi 3array httpd-hit ; [ method>> ] [ url>> [ host>> ] [ path>> ] bi ] bi
3array httpd-hit ;
: split-path ( string -- path ) : split-path ( string -- path )
"/" split harvest ; "/" split harvest ;
@ -79,9 +100,15 @@ LOG: httpd-hit NOTICE
development-mode get-global development-mode get-global
[ global [ refresh-all ] bind ] when ; [ global [ refresh-all ] bind ] when ;
: setup-limits ( -- )
1 minutes timeouts
64 1024 * limit-input ;
: handle-client ( -- ) : handle-client ( -- )
[ [
1 minutes timeouts setup-limits
ascii decode-input
ascii encode-output
?refresh-all ?refresh-all
read-request read-request
do-request do-request
@ -90,7 +117,7 @@ LOG: httpd-hit NOTICE
: httpd ( port -- ) : httpd ( port -- )
dup integer? [ internet-server ] when dup integer? [ internet-server ] when
"http.server" latin1 [ handle-client ] with-server ; "http.server" binary [ handle-client ] with-server ;
: httpd-main ( -- ) : httpd-main ( -- )
8888 httpd ; 8888 httpd ;

5
extra/http/server/static/static.factor
View File

@ -29,7 +29,10 @@ TUPLE: file-responder root hook special allow-listings ;
H{ } clone >>special ; H{ } clone >>special ;
: (serve-static) ( path mime-type -- response ) : (serve-static) ( path mime-type -- response )
[ [ binary <file-reader> &dispose ] dip <content> ] [
[ binary <file-reader> &dispose ] dip
<content> binary >>content-charset
]
[ drop file-info [ size>> ] [ modified>> ] bi ] 2bi [ drop file-info [ size>> ] [ modified>> ] bi ] 2bi
[ "content-length" set-header ] [ "content-length" set-header ]
[ "last-modified" set-header ] bi* ; [ "last-modified" set-header ] bi* ;

2
extra/inverse/inverse.factor
View File

@ -77,7 +77,7 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
{ [ word? ] [ primitive? not ] [ { [ word? ] [ primitive? not ] [
{ "inverse" "math-inverse" "pop-inverse" } { "inverse" "math-inverse" "pop-inverse" }
[ word-prop ] with contains? not [ word-prop ] with contains? not
] } <-&& ; ] } 1&& ;
: (flatten) ( quot -- ) : (flatten) ( quot -- )
[ dup flattenable? [ word-def (flatten) ] [ , ] if ] each ; [ dup flattenable? [ word-def (flatten) ] [ , ] if ] each ;

15
extra/io/buffers/buffers-docs.factor
View File

@ -1,4 +1,4 @@
USING: help.markup help.syntax byte-arrays alien ; USING: help.markup help.syntax byte-arrays alien destructors ;
IN: io.buffers IN: io.buffers
ARTICLE: "buffers" "Locked I/O buffers" ARTICLE: "buffers" "Locked I/O buffers"
@ -7,8 +7,8 @@ $nl
"Buffer words are found in the " { $vocab-link "buffers" } " vocabulary." "Buffer words are found in the " { $vocab-link "buffers" } " vocabulary."
{ $subsection buffer } { $subsection buffer }
{ $subsection <buffer> } { $subsection <buffer> }
"Buffers must be manually deallocated:" "Buffers must be manually deallocated by calling " { $link dispose } "."
{ $subsection buffer-free } $nl
"Buffer operations:" "Buffer operations:"
{ $subsection buffer-reset } { $subsection buffer-reset }
{ $subsection buffer-length } { $subsection buffer-length }
@ -40,11 +40,6 @@ HELP: <buffer>
{ $values { "n" "a non-negative integer" } { "buffer" buffer } } { $values { "n" "a non-negative integer" } { "buffer" buffer } }
{ $description "Creates a buffer with an initial capacity of " { $snippet "n" } " bytes." } ; { $description "Creates a buffer with an initial capacity of " { $snippet "n" } " bytes." } ;
HELP: buffer-free
{ $values { "buffer" buffer } }
{ $description "De-allocates a buffer's underlying storage. The buffer may not be used after being freed." }
{ $warning "You " { $emphasis "must" } " free a buffer using this word, before letting the GC collect the buffer tuple instance." } ;
HELP: buffer-reset HELP: buffer-reset
{ $values { "n" "a non-negative integer" } { "buffer" buffer } } { $values { "n" "a non-negative integer" } { "buffer" buffer } }
{ $description "Resets the fill pointer to 0 and the position to " { $snippet "count" } "." } ; { $description "Resets the fill pointer to 0 and the position to " { $snippet "count" } "." } ;
@ -61,10 +56,6 @@ HELP: buffer-end
{ $values { "buffer" buffer } { "alien" alien } } { $values { "buffer" buffer } { "alien" alien } }
{ $description "Outputs the memory address of the current fill-pointer." } ; { $description "Outputs the memory address of the current fill-pointer." } ;
HELP: (buffer-read)
{ $values { "n" "a non-negative integer" } { "buffer" buffer } { "byte-array" byte-array } }
{ $description "Outputs a byte array of the first " { $snippet "n" } " bytes at the buffer's current position. If there are less than " { $snippet "n" } " bytes available, the output is truncated." } ;
HELP: buffer-read HELP: buffer-read
{ $values { "n" "a non-negative integer" } { "buffer" buffer } { "byte-array" byte-array } } { $values { "n" "a non-negative integer" } { "buffer" buffer } { "byte-array" byte-array } }
{ $description "Collects a byte array of " { $snippet "n" } " bytes starting from the buffer's current position, and advances the position accordingly. If there are less than " { $snippet "n" } " bytes available, the output is truncated." } ; { $description "Collects a byte array of " { $snippet "n" } " bytes starting from the buffer's current position, and advances the position accordingly. If there are less than " { $snippet "n" } " bytes available, the output is truncated." } ;

19
extra/io/buffers/buffers-tests.factor
View File

@ -1,6 +1,7 @@
IN: io.buffers.tests IN: io.buffers.tests
USING: alien alien.c-types io.buffers kernel kernel.private libc USING: alien alien.c-types io.buffers kernel kernel.private libc
sequences tools.test namespaces byte-arrays strings accessors ; sequences tools.test namespaces byte-arrays strings accessors
destructors ;
: buffer-set ( string buffer -- ) : buffer-set ( string buffer -- )
over >byte-array over buffer-ptr byte-array>memory over >byte-array over buffer-ptr byte-array>memory
@ -18,7 +19,7 @@ sequences tools.test namespaces byte-arrays strings accessors ;
65536 <buffer> 65536 <buffer>
dup buffer-read-all dup buffer-read-all
over buffer-capacity over buffer-capacity
rot buffer-free rot dispose
] unit-test ] unit-test
[ "hello world" "" ] [ [ "hello world" "" ] [
@ -26,34 +27,34 @@ sequences tools.test namespaces byte-arrays strings accessors ;
dup buffer-read-all >string dup buffer-read-all >string
0 pick buffer-reset 0 pick buffer-reset
over buffer-read-all >string over buffer-read-all >string
rot buffer-free rot dispose
] unit-test ] unit-test
[ "hello" ] [ [ "hello" ] [
"hello world" string>buffer "hello world" string>buffer
5 over buffer-read >string swap buffer-free 5 over buffer-read >string swap dispose
] unit-test ] unit-test
[ 11 ] [ [ 11 ] [
"hello world" string>buffer "hello world" string>buffer
[ buffer-length ] keep buffer-free [ buffer-length ] keep dispose
] unit-test ] unit-test
[ "hello world" ] [ [ "hello world" ] [
"hello" 1024 <buffer> [ buffer-set ] keep "hello" 1024 <buffer> [ buffer-set ] keep
" world" >byte-array over >buffer " world" >byte-array over >buffer
dup buffer-read-all >string swap buffer-free dup buffer-read-all >string swap dispose
] unit-test ] unit-test
[ CHAR: e ] [ [ CHAR: e ] [
"hello" string>buffer "hello" string>buffer
1 over buffer-consume [ buffer-pop ] keep buffer-free 1 over buffer-consume [ buffer-pop ] keep dispose
] unit-test ] unit-test
"hello world" string>buffer "b" set "hello world" string>buffer "b" set
[ "hello world" ] [ 1000 "b" get buffer-read >string ] unit-test [ "hello world" ] [ 1000 "b" get buffer-read >string ] unit-test
"b" get buffer-free "b" get dispose
100 <buffer> "b" set 100 <buffer> "b" set
[ 1000 "b" get n>buffer >string ] must-fail [ 1000 "b" get n>buffer >string ] must-fail
"b" get buffer-free "b" get dispose

132
extra/io/buffers/buffers.factor
View File

@ -1,77 +1,101 @@
! Copyright (C) 2004, 2005 Mackenzie Straight. ! Copyright (C) 2004, 2005 Mackenzie Straight.
! Copyright (C) 2006, 2008 Slava Pestov. ! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.accessors alien.c-types alien.syntax kernel USING: accessors alien alien.accessors alien.c-types
kernel.private libc math sequences byte-arrays strings hints alien.syntax kernel libc math sequences byte-arrays strings
accessors math.order ; hints accessors math.order destructors combinators ;
IN: io.buffers IN: io.buffers
TUPLE: buffer size ptr fill pos ; TUPLE: buffer size ptr fill pos disposed ;
: <buffer> ( n -- buffer ) : <buffer> ( n -- buffer )
dup malloc 0 0 buffer boa ; dup malloc 0 0 f buffer boa ;
: buffer-free ( buffer -- ) M: buffer dispose* ptr>> free ;
dup buffer-ptr free f swap set-buffer-ptr ;
: buffer-reset ( n buffer -- ) : buffer-reset ( n buffer -- )
0 swap { set-buffer-fill set-buffer-pos } set-slots ; swap >>fill 0 >>pos drop ;
: buffer-consume ( n buffer -- )
[ buffer-pos + ] keep
[ buffer-fill min ] keep
[ set-buffer-pos ] keep
dup buffer-pos over buffer-fill >= [
0 over set-buffer-pos
0 over set-buffer-fill
] when drop ;
: buffer@ ( buffer -- alien )
dup buffer-pos swap buffer-ptr <displaced-alien> ;
: buffer-end ( buffer -- alien )
dup buffer-fill swap buffer-ptr <displaced-alien> ;
: buffer-peek ( buffer -- byte )
buffer@ 0 alien-unsigned-1 ;
: buffer-pop ( buffer -- byte )
dup buffer-peek 1 rot buffer-consume ;
: (buffer-read) ( n buffer -- byte-array )
[ [ fill>> ] [ pos>> ] bi - min ] keep
buffer@ swap memory>byte-array ;
: buffer-read ( n buffer -- byte-array )
[ (buffer-read) ] [ buffer-consume ] 2bi ;
: buffer-length ( buffer -- n )
[ fill>> ] [ pos>> ] bi - ;
: buffer-capacity ( buffer -- n ) : buffer-capacity ( buffer -- n )
[ size>> ] [ fill>> ] bi - ; [ size>> ] [ fill>> ] bi - ; inline
: buffer-empty? ( buffer -- ? ) : buffer-empty? ( buffer -- ? )
fill>> zero? ; fill>> zero? ;
: buffer-consume ( n buffer -- )
[ + ] change-pos
dup [ pos>> ] [ fill>> ] bi <
[ 0 >>pos 0 >>fill ] unless drop ; inline
: buffer-peek ( buffer -- byte )
[ ptr>> ] [ pos>> ] bi alien-unsigned-1 ; inline
: buffer-pop ( buffer -- byte )
[ buffer-peek ] [ 1 swap buffer-consume ] bi ;
HINTS: buffer-pop buffer ;
: buffer-length ( buffer -- n )
[ fill>> ] [ pos>> ] bi - ; inline
: buffer@ ( buffer -- alien )
[ pos>> ] [ ptr>> ] bi <displaced-alien> ;
: buffer-read ( n buffer -- byte-array )
[ buffer-length min ] keep
[ buffer@ ] [ buffer-consume ] 2bi
swap memory>byte-array ;
HINTS: buffer-read fixnum buffer ;
: extend-buffer ( n buffer -- ) : extend-buffer ( n buffer -- )
2dup buffer-ptr swap realloc 2dup ptr>> swap realloc >>ptr swap >>size drop ;
over set-buffer-ptr set-buffer-size ; inline
: check-overflow ( n buffer -- ) : check-overflow ( n buffer -- )
2dup buffer-capacity > [ extend-buffer ] [ 2drop ] if ; 2dup buffer-capacity > [ extend-buffer ] [ 2drop ] if ;
inline
: >buffer ( byte-array buffer -- ) : buffer-end ( buffer -- alien )
over length over check-overflow [ fill>> ] [ ptr>> ] bi <displaced-alien> ; inline
[ buffer-end byte-array>memory ] 2keep
[ buffer-fill swap length + ] keep set-buffer-fill ;
: byte>buffer ( byte buffer -- )
1 over check-overflow
[ buffer-end 0 set-alien-unsigned-1 ] keep
[ 1+ ] change-fill drop ;
: n>buffer ( n buffer -- ) : n>buffer ( n buffer -- )
[ buffer-fill + ] keep [ + ] change-fill
[ buffer-size > [ "Buffer overflow" throw ] when ] 2keep [ fill>> ] [ size>> ] bi >
set-buffer-fill ; [ "Buffer overflow" throw ] when ; inline
: >buffer ( byte-array buffer -- )
[ [ length ] dip check-overflow ]
[ buffer-end byte-array>memory ]
[ [ length ] dip n>buffer ]
2tri ;
HINTS: >buffer byte-array buffer ;
: byte>buffer ( byte buffer -- )
[ 1 swap check-overflow ]
[ [ ptr>> ] [ fill>> ] bi set-alien-unsigned-1 ]
[ 1 swap n>buffer ]
tri ;
HINTS: byte>buffer fixnum buffer ;
: search-buffer-until ( pos fill ptr separators -- n )
[ [ swap alien-unsigned-1 ] dip memq? ] 2curry find-from drop ;
: finish-buffer-until ( buffer n -- byte-array separator )
[
over pos>> -
over buffer-read
swap buffer-pop
] [
[ buffer-length ] keep
buffer-read f
] if* ;
: buffer-until ( separators buffer -- byte-array separator )
swap [ { [ ] [ pos>> ] [ fill>> ] [ ptr>> ] } cleave ] dip
search-buffer-until
finish-buffer-until ;
HINTS: buffer-until { string buffer } ;

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