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

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

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

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

@ -7,7 +7,7 @@ math.parser classes alien.arrays alien.c-types alien.strings
alien.structs alien.syntax cpu.architecture alien inspector
quotations assocs kernel.private threads continuations.private
libc combinators compiler.errors continuations layouts accessors
init ;
init sets ;
IN: alien.compiler
TUPLE: #alien-node < node return parameters abi ;
@ -339,7 +339,7 @@ SYMBOL: callbacks
[ 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
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"
"Utility operations built up from the " { $link "assocs-protocol" } ":"
{ $subsection delete-at* }
{ $subsection delete-any }
{ $subsection rename-at }
{ $subsection change-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." }
{ $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
{ $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" } "." }

6
core/assocs/assocs.factor
View File

@ -76,12 +76,6 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
: rename-at ( newkey key assoc -- )
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-size zero? ;

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

@ -1,5 +1,5 @@
USING: arrays help.markup help.syntax kernel
kernel.private prettyprint strings vectors sbufs ;
kernel.private math prettyprint strings vectors sbufs ;
IN: bit-arrays
ARTICLE: "bit-arrays" "Bit arrays"
@ -17,7 +17,10 @@ $nl
{ $subsection <bit-array> }
"Efficiently setting and clearing all bits in a bit array:"
{ $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"
@ -47,3 +50,13 @@ HELP: set-bits
{ $code "[ drop t ] change-each" }
}
{ $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
[ -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
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

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

@ -397,7 +397,7 @@ M: quotation '
[
{
dictionary source-files builtins
update-map class<=-cache
update-map implementors-map class<=-cache
class-not-cache classes-intersect-cache class-and-cache
class-or-cache
} [ 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 source-files set
H{ } clone update-map set
H{ } clone implementors-map set
init-caches
! Vocabulary for slot accessors
@ -492,7 +493,8 @@ tuple
"curry" "kernel" lookup
[ 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
tuple
@ -513,7 +515,8 @@ tuple
"compose" "kernel" lookup
[ 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
: 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
"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
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" } } ;
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
{ $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
classes.private classes.union classes.mixin classes.predicate
classes.algebra vectors definitions source-files
compiler.units kernel.private ;
compiler.units kernel.private sorting vocabs ;
IN: classes.tests
! DEFER: bah
@ -169,3 +169,9 @@ M: method-forget-class method-forget-test ;
[ f ] [ \ method-forget-test "methods" word-prop assoc-empty? ] unit-test
[ ] [ [ \ method-forget-class forget ] with-compilation-unit ] 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.
USING: arrays definitions assocs kernel kernel.private
slots.private namespaces sequences strings words vectors math
quotations combinators sorting effects graphs vocabs ;
quotations combinators sorting effects graphs vocabs sets ;
IN: classes
SYMBOL: class<=-cache
@ -27,24 +27,24 @@ SYMBOL: class-or-cache
SYMBOL: update-map
SYMBOL: implementors-map
PREDICATE: class < word
"class" word-prop ;
PREDICATE: tuple-class < class
"metaclass" word-prop tuple-class eq? ;
: classes ( -- seq ) all-words [ class? ] filter ;
: classes ( -- seq ) implementors-map get keys ;
: predicate-word ( word -- predicate )
[ word-name "?" append ] keep word-vocabulary create ;
: predicate-effect T{ effect f 1 { "?" } } ;
PREDICATE: predicate < word "predicating" word-prop >boolean ;
: define-predicate ( class quot -- )
>r "predicate" word-prop first
r> predicate-effect define-declared ;
r> (( object -- ? )) define-declared ;
: superclass ( class -- super )
#! Output f for non-classes to work with algebra code
@ -67,6 +67,8 @@ GENERIC: reset-class ( class -- )
M: word reset-class drop ;
GENERIC: implementors ( class/classes -- seq )
! update-map
: class-uses ( class -- seq )
[
@ -76,8 +78,8 @@ M: word reset-class drop ;
tri
] { } make ;
: class-usages ( class -- assoc )
[ update-map get at ] closure ;
: class-usages ( class -- seq )
[ update-map get at ] closure keys ;
<PRIVATE
@ -87,6 +89,16 @@ M: word reset-class drop ;
: update-map- ( class -- )
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 )
[
{
@ -99,8 +111,8 @@ M: word reset-class drop ;
: (define-class) ( word props -- )
>r
dup class? [ dup [ implementors-map+ ] [ new-class ] bi ] unless
dup reset-class
dup class? [ dup new-class ] unless
dup deferred? [ dup define-symbol ] when
dup word-props
r> assoc-union over set-word-props
@ -116,13 +128,11 @@ GENERIC: update-class ( class -- )
M: class update-class drop ;
GENERIC: update-methods ( class assoc -- )
GENERIC: update-methods ( class seq -- )
: update-classes ( class -- )
dup class-usages
[ nip keys [ update-class ] each ]
[ update-methods ]
2bi ;
[ nip [ update-class ] each ] [ update-methods ] 2bi ;
: define-class ( word superclass members participants metaclass -- )
#! If it was already a class, update methods after.
@ -133,6 +143,31 @@ GENERIC: update-methods ( class assoc -- )
[ drop update-map+ ]
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 )
: instance? ( obj class -- ? )

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

@ -39,7 +39,7 @@ TUPLE: check-mixin-class mixin ;
: update-classes/new ( mixin -- )
class-usages
[ keys [ update-class ] each ]
[ [ update-class ] each ]
[ implementors [ make-generic ] each ] bi ;
: add-mixin-instance ( class mixin -- )
@ -51,8 +51,12 @@ TUPLE: check-mixin-class mixin ;
#! updated by transitivity; the mixins usages appear in
#! class-usages of the member, now that it's been added.
[ 2drop ] [
[ [ suffix ] change-mixin-class ] 2keep drop
dup new-class? [ update-classes/new ] [ update-classes ] if
[ [ suffix ] change-mixin-class ] 2keep
tuck [ new-class? ] either? [
update-classes/new
] [
update-classes
] if
] if-mixin-member? ;
: 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
[ ] [ \ yo-momma forget ] unit-test
[ ] [ \ <yo-momma> forget ] unit-test
[ f ] [ \ yo-momma update-map get values memq? ] 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
[ H{ { subclass-forget-test-2 subclass-forget-test-2 } } ]
[ { subclass-forget-test-2 } ]
[ subclass-forget-test-2 class-usages ]
unit-test
[ H{ { subclass-forget-test-3 subclass-forget-test-3 } } ]
[ { subclass-forget-test-3 } ]
[ subclass-forget-test-3 class-usages ]
unit-test
@ -565,3 +566,32 @@ unit-test
[ subclass-forget-test-3 new ] 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 ;
: subclasses ( class -- classes )
class-usages keys [ tuple-class? ] filter ;
class-usages [ tuple-class? ] filter ;
: each-subclass ( class quot -- )
>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
continuations vocabs assocs alien.compiler dlists optimizer
definitions math compiler.errors threads graphs generic
inference combinators ;
inference combinators dequeues search-dequeues ;
IN: compiler
: ripple-up ( word -- )
compiled-usage [ drop queue-compile ] assoc-each ;
SYMBOL: +failed+
: 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 -- )
[
over "compiled-effect" word-prop = [
dup "compiled-uses" word-prop
[ dup ripple-up ] when
] unless drop
]
[ "compiled-effect" set-word-prop ] 2bi ;
[ dupd ripple-up? [ ripple-up ] [ drop ] if ]
[ "compiled-effect" set-word-prop ]
2bi ;
: compile-begins ( word -- )
f swap compiler-error ;
@ -26,9 +31,10 @@ IN: compiler
[ swap compiler-error ]
[
drop
[ compiled-unxref ]
[ f swap compiled get set-at ]
[ f save-effect ]
bi
[ +failed+ save-effect ]
tri
] 2bi ;
: compile-succeeded ( effect word -- )
@ -40,6 +46,7 @@ IN: compiler
] tri ;
: (compile) ( word -- )
dup dup "compile-count" word-prop 0 or 1 + "compile-count" set-word-prop
[
H{ } clone dependencies set
@ -54,19 +61,15 @@ IN: compiler
} cleave
] curry with-return ;
: compile-loop ( assoc -- )
dup assoc-empty? [ drop ] [
dup delete-any drop (compile)
yield
compile-loop
] if ;
: compile-loop ( dequeue -- )
[ (compile) yield ] slurp-dequeue ;
: decompile ( word -- )
f 2array 1array t modify-code-heap ;
: optimized-recompile-hook ( words -- alist )
[
H{ } clone compile-queue set
<hashed-dlist> compile-queue set
H{ } clone compiled set
[ queue-compile ] each
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 ( -- )
update-tuples-hook get call ;
: unxref-forgotten-definitions ( -- )
forgotten-definitions get
keys [ word? ] filter
[ delete-compiled-xref ] each ;
: finish-compilation-unit ( -- )
call-recompile-hook
call-update-tuples-hook
unxref-forgotten-definitions
dup [ drop crossref? ] assoc-contains? modify-code-heap ;
: with-nested-compilation-unit ( quot -- )

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

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

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

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

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

@ -9,7 +9,7 @@ big-endian off
1 jit-code-format set
: stack-frame-size 4 bootstrap-cells ;
: stack-frame-size ( -- n ) 4 bootstrap-cells ;
[
! 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
ARTICLE: "dlists" "Doubly-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."
ARTICLE: "dlists" "Double-linked lists"
"A double-linked list is the canonical implementation of a " { $link dequeue } "."
$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."
$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:"
"Double-linked lists form a class:"
{ $subsection dlist }
{ $subsection dlist? }
"Constructing a dlist:"
"Constructing a double-linked list:"
{ $subsection <dlist> }
"Working with the front of the list:"
{ $subsection push-front }
{ $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 }
"Double-linked lists support all the operations of the dequeue protocol (" { $link "dequeues" } ") as well as the following."
$nl
"Iterating over elements:"
{ $subsection dlist-each }
{ $subsection dlist-find }
{ $subsection dlist-contains? }
"Deleting a node:"
{ $subsection delete-node }
{ $subsection dlist-delete }
"Deleting a node matching a predicate:"
{ $subsection delete-node-if* }
{ $subsection delete-node-if }
"Consuming all nodes:"
{ $subsection dlist-slurp } ;
{ $subsection delete-node-if } ;
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
{ $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." }

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

@ -1,17 +1,17 @@
USING: dlists dlists.private kernel tools.test random assocs
sets sequences namespaces sorting debugger io prettyprint
USING: dequeues dlists dlists.private kernel tools.test random
assocs sets sequences namespaces sorting debugger io prettyprint
math accessors classes ;
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 } ]
[ <dlist> 1 over push-front ] unit-test
! Make sure empty lists are empty
[ t ] [ <dlist> dlist-empty? ] unit-test
[ f ] [ <dlist> 1 over push-front dlist-empty? ] unit-test
[ f ] [ <dlist> 1 over push-back dlist-empty? ] unit-test
[ t ] [ <dlist> dequeue-empty? ] unit-test
[ f ] [ <dlist> 1 over push-front dequeue-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-back ] unit-test
@ -25,22 +25,22 @@ IN: dlists.tests
! Test the prev,next links for two nodes
[ f ] [
<dlist> 1 over push-back 2 over push-back
dlist-front dlist-node-prev
front>> prev>>
] unit-test
[ 2 ] [
<dlist> 1 over push-back 2 over push-back
dlist-front dlist-node-next dlist-node-obj
front>> next>> obj>>
] unit-test
[ 1 ] [
<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
[ f ] [
<dlist> 1 over push-back 2 over push-back
dlist-front dlist-node-next dlist-node-next
front>> next>> next>>
] 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
[ 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 dlist-empty? ] unit-test
[ 0 ] [ <dlist> 1 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 dlist-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 [ 2 = ] 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 dlist-length ] 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 dequeue-empty? ] 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 dequeue-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 dequeue-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
[ 1 ] [ <dlist> 1 over push-front dlist-length ] unit-test
[ 0 ] [ <dlist> 1 over push-front dup pop-front* dlist-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
[ 0 ] [ <dlist> dequeue-length ] unit-test
[ 1 ] [ <dlist> 1 over push-front dequeue-length ] unit-test
[ 0 ] [ <dlist> 1 over push-front dup pop-front* dequeue-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>> 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
[ ] [ <dlist> 4 over push-back 5 over push-back [ drop ] dlist-each ] unit-test
[ <dlist> peek-front ] must-fail
[ <dlist> peek-back ] must-fail
[ <dlist> peek-front ] [ empty-dlist? ] must-fail-with
[ <dlist> peek-back ] [ empty-dlist? ] must-fail-with
[ <dlist> pop-front ] [ 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,
! Slava Pestov.
! 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
TUPLE: dlist front back length ;
: <dlist> ( -- obj )
dlist new
0 >>length ;
0 >>length ;
: dlist-empty? ( dlist -- ? ) front>> not ;
M: dlist dequeue-length length>> ;
<PRIVATE
@ -18,6 +19,8 @@ TUPLE: dlist-node obj prev next ;
C: <dlist-node> dlist-node
M: dlist-node node-value obj>> ;
: inc-length ( dlist -- )
[ 1+ ] change-length drop ; inline
@ -57,69 +60,59 @@ C: <dlist-node> dlist-node
: dlist-each-node ( dlist quot -- )
[ 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>
: 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) ] keep
[ set-back-to-front ] keep
inc-length ;
: push-front ( obj dlist -- )
push-front* drop ;
: push-all-front ( seq dlist -- )
[ push-front ] curry each ;
: push-back* ( obj dlist -- dlist-node )
M: dlist push-back* ( obj dlist -- dlist-node )
[ back>> f <dlist-node> ] keep
[ back>> set-next-when ] 2keep
[ (>>back) ] 2keep
[ set-front-to-back ] keep
inc-length ;
: push-back ( obj dlist -- )
push-back* drop ;
: push-all-back ( seq dlist -- )
[ push-back ] curry each ;
ERROR: empty-dlist ;
M: empty-dlist summary ( dlist -- )
drop "Emtpy dlist" ;
drop "Empty dlist" ;
: peek-front ( dlist -- obj )
front>> [ empty-dlist ] unless* obj>> ;
M: dlist peek-front ( dlist -- obj )
front>> [ obj>> ] [ empty-dlist ] if* ;
: pop-front ( dlist -- obj )
dup front>> [ empty-dlist ] unless*
M: dlist pop-front* ( dlist -- )
dup front>> [ empty-dlist ] unless
[
dup front>>
dup next>>
f rot (>>next)
f over set-prev-when
swap (>>front)
] 2keep obj>>
swap [ normalize-back ] keep dec-length ;
] keep
[ normalize-back ] keep
dec-length ;
: pop-front* ( dlist -- )
pop-front drop ;
M: dlist peek-back ( dlist -- obj )
back>> [ obj>> ] [ empty-dlist ] if* ;
: peek-back ( dlist -- obj )
back>> [ empty-dlist ] unless* obj>> ;
: pop-back ( dlist -- obj )
dup back>> [ empty-dlist ] unless*
M: dlist pop-back* ( dlist -- )
dup back>> [ empty-dlist ] unless
[
dup back>>
dup prev>>
f rot (>>prev)
f over set-next-when
swap (>>back)
] 2keep obj>>
swap [ normalize-front ] keep dec-length ;
: pop-back* ( dlist -- )
pop-back drop ;
] keep
[ normalize-front ] keep
dec-length ;
: dlist-find ( dlist quot -- obj/f ? )
[ obj>> ] prepose
@ -128,21 +121,20 @@ M: empty-dlist summary ( dlist -- )
: dlist-contains? ( dlist quot -- ? )
dlist-find nip ; inline
: unlink-node ( dlist-node -- )
dup prev>> over next>> set-prev-when
dup next>> swap prev>> set-next-when ;
M: dlist dequeue-member? ( value dlist -- ? )
[ = ] curry dlist-contains? ;
: delete-node ( dlist dlist-node -- )
M: dlist delete-node ( dlist-node dlist -- )
{
{ [ over front>> over eq? ] [ drop pop-front* ] }
{ [ over back>> over eq? ] [ drop pop-back* ] }
[ unlink-node dec-length ]
{ [ 2dup front>> eq? ] [ nip pop-front* ] }
{ [ 2dup back>> eq? ] [ nip pop-back* ] }
[ dec-length unlink-node ]
} cond ;
: delete-node-if* ( dlist quot -- obj/f ? )
dupd dlist-find-node [
dup [
[ delete-node ] keep obj>> t
[ swap delete-node ] keep obj>> t
] [
2drop f f
] if
@ -151,13 +143,9 @@ M: empty-dlist summary ( dlist -- )
] if ; inline
: delete-node-if ( dlist quot -- obj/f )
[ obj>> ] prepose
delete-node-if* drop ; inline
[ obj>> ] prepose delete-node-if* drop ; inline
: dlist-delete ( obj dlist -- obj/f )
swap [ eq? ] curry delete-node-if ;
: dlist-delete-all ( dlist -- )
M: dlist clear-dequeue ( dlist -- )
f >>front
f >>back
0 >>length
@ -166,9 +154,6 @@ M: empty-dlist summary ( dlist -- )
: dlist-each ( dlist quot -- )
[ 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 ;
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:"
{ $table
{ { { $snippet "?" } } "a boolean" }
{ { { $snippet "<=>" } } { "an ordering sepcifier; see " { $link "order-specifiers" } } }
{ { { $snippet "elt" } } "an object which is an element of a sequence" }
{ { { $snippet "m" } ", " { $snippet "n" } } "an integer" }
{ { { $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.
USING: arrays assocs classes combinators cpu.architecture
effects generator.fixup generator.registers generic hashtables
inference inference.backend inference.dataflow io kernel
kernel.private layouts math namespaces optimizer
optimizer.specializers prettyprint quotations sequences system
threads words vectors ;
threads words vectors sets dequeues ;
IN: generator
SYMBOL: compile-queue
@ -16,7 +16,7 @@ SYMBOL: compiled
{ [ dup compiled get key? ] [ drop ] }
{ [ dup inlined-block? ] [ drop ] }
{ [ dup primitive? ] [ drop ] }
[ dup compile-queue get set-at ]
[ compile-queue get push-front ]
} cond ;
: maybe-compile ( word -- )
@ -72,10 +72,12 @@ GENERIC: generate-node ( node -- next )
: word-dataflow ( word -- effect dataflow )
[
dup "cannot-infer" word-prop [ cannot-infer-effect ] when
dup "no-compile" word-prop [ cannot-infer-effect ] when
dup specialized-def over dup 2array 1array infer-quot
finish-word
[
dup "cannot-infer" word-prop [ cannot-infer-effect ] when
dup "no-compile" word-prop [ cannot-infer-effect ] when
dup specialized-def over dup 2array 1array infer-quot
finish-word
] maybe-cannot-infer
] with-infer ;
: intrinsics ( #call -- quot )

81
core/generic/generic.factor
View File

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

4
core/graphs/graphs.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel namespaces sequences ;
USING: assocs kernel namespaces sequences sets ;
IN: graphs
SYMBOL: graph
@ -41,7 +41,7 @@ SYMBOL: previous
over previous get key? [
2drop
] [
over dup previous get set-at
over previous get conjoin
dup slip
[ nip (closure) ] curry assoc-each
] 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." }
{ $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
{ $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>
@ -41,7 +41,7 @@ HELP: <groups>
{ $description "Outputs a virtual sequence whose elements are disjoint subsequences of " { $snippet "n" } " elements from the underlying sequence." }
{ $examples
{ $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 }"
}
} ;
@ -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." }
{ $examples
{ $example
"USING: arrays kernel prettyprint sequences splitting ;"
"USING: arrays kernel prettyprint sequences grouping ;"
"9 >array 3 <sliced-groups>"
"dup [ reverse-here ] each concat >array ."
"{ 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." }
{ $errors "Throws an error if " { $snippet "n" } " is smaller than the length of the sequence." }
{ $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>
@ -77,7 +77,7 @@ HELP: <clumps>
{ $examples
"Running averages:"
{ $example
"USING: splitting sequences math prettyprint kernel ;"
"USING: grouping sequences math prettyprint kernel ;"
"IN: scratchpad"
": share-price"
" { 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
sequences strings vectors words quotations effects classes
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
: recursive-label ( word -- label/f )
@ -28,7 +29,7 @@ SYMBOL: visited
: (redefined) ( word -- )
dup visited get key? [ drop ] [
[ reset-on-redefine reset-props ]
[ dup visited get set-at ]
[ visited get conjoin ]
[
crossref get at keys
[ word? ] filter
@ -420,6 +421,9 @@ TUPLE: missing-effect word ;
[ "inferred-effect" set-word-prop ]
2tri ;
: maybe-cannot-infer ( word quot -- )
[ ] [ t "cannot-infer" set-word-prop ] cleanup ; inline
: infer-word ( word -- effect )
[
[
@ -430,7 +434,7 @@ TUPLE: missing-effect word ;
finish-word
current-effect
] with-scope
] [ ] [ t "cannot-infer" set-word-prop ] cleanup ;
] maybe-cannot-infer ;
: custom-infer ( word -- )
#! 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
! : inference-invalidation-a ( -- );
! : inference-invalidation-b ( quot -- ) [ inference-invalidation-a ] dip call ; inline
! : inference-invalidation-c ( a b -- c ) [ + ] inference-invalidation-b ;
!
! [ 7 ] [ 4 3 inference-invalidation-c ] unit-test
!
! { 2 1 } [ [ + ] inference-invalidation-b ] must-infer-as
!
! [ ] [ "IN: inference.tests : inference-invalidation-a 1 2 ;" eval ] unit-test
!
! [ 3 ] [ inference-invalidation-c ] unit-test
!
! { 0 1 } [ inference-invalidation-c ] must-infer-as
!
! GENERIC: inference-invalidation-d ( obj -- )
!
! M: object inference-invalidation-d inference-invalidation-c 2drop ;
!
! \ inference-invalidation-d must-infer
!
! [ ] [ "IN: inference.tests : inference-invalidation-a ;" eval ] unit-test
!
! [ [ inference-invalidation-d ] infer ] must-fail
: inference-invalidation-a ( -- ) ;
: inference-invalidation-b ( quot -- ) [ inference-invalidation-a ] dip call ; inline
: inference-invalidation-c ( a b -- c ) [ + ] inference-invalidation-b ; inline
[ 7 ] [ 4 3 inference-invalidation-c ] unit-test
{ 2 1 } [ [ + ] inference-invalidation-b ] must-infer-as
[ ] [ "IN: inference.tests : inference-invalidation-a ( -- a b ) 1 2 ;" eval ] unit-test
[ 3 ] [ inference-invalidation-c ] unit-test
{ 0 1 } [ inference-invalidation-c ] must-infer-as
GENERIC: inference-invalidation-d ( obj -- )
M: object inference-invalidation-d inference-invalidation-c 2drop ;
\ inference-invalidation-d must-infer
[ ] [ "IN: inference.tests : inference-invalidation-a ( -- ) ;" eval ] unit-test
[ [ inference-invalidation-d ] infer ] must-fail

5
core/inference/inference.factor
View File

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

6
core/inspector/inspector.factor
View File

@ -95,10 +95,8 @@ SYMBOL: +editable+
: describe ( obj -- ) H{ } describe* ;
: namestack. ( seq -- )
[
[ global eq? not ] filter
[ keys ] map concat prune
] keep [ dupd assoc-stack ] curry H{ } map>assoc describe ;
[ [ global eq? not ] filter [ keys ] gather ] keep
[ dupd assoc-stack ] curry H{ } map>assoc describe ;
: .vars ( -- )
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 )
: replacement-char HEX: fffd ;
: replacement-char HEX: fffd ; inline
TUPLE: decoder stream code cr ;
@ -121,14 +121,28 @@ M: encoder stream-flush encoder-stream stream-flush ;
INSTANCE: encoder plain-writer
PRIVATE>
: re-encode ( stream encoding -- newstream )
over encoder? [ >r encoder-stream r> ] when <encoder> ;
GENERIC# re-encode 1 ( stream encoding -- newstream )
M: object re-encode <encoder> ;
M: encoder re-encode [ stream>> ] dip re-encode ;
: encode-output ( encoding -- )
output-stream [ swap re-encode ] change ;
: re-decode ( stream encoding -- newstream )
over decoder? [ >r decoder-stream r> ] when <decoder> ;
: with-encoded-output ( encoding quot -- )
[ [ 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 -- )
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
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 ;
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
: 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" } }
{ $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" } }
{ $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" } }
{ $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" } }
{ $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." } ;
@ -692,26 +692,26 @@ HELP: tri@
}
} ;
HELP: if ( cond true false -- )
{ $values { "cond" "a generalized boolean" } { "true" quotation } { "false" quotation } }
HELP: if
{ $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."
$nl
"The " { $snippet "cond" } " value is removed from the stack before either quotation is called." } ;
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."
$nl
"The " { $snippet "cond" } " value is removed from the stack before the quotation is called." } ;
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."
$nl
"The " { $snippet "cond" } " value is removed from the stack before the quotation is called." } ;
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."
$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."
@ -720,14 +720,14 @@ $nl
{ $code "X [ Y ] [ Z ] if*" "X dup [ Y ] [ drop Z ] if" } } ;
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."
$nl
"The following two lines are equivalent:"
{ $code "X [ Y ] when*" "X dup [ Y ] [ drop ] if" } } ;
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." }
{ $notes
"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" } } }
{ $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 } }
{ $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." }
@ -832,7 +832,7 @@ HELP: with
{ $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 } }
{ $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } " followed by " { $snippet "quot2" } "." }
{ $notes

10
core/kernel/kernel.factor
View File

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

4
core/libc/libc.factor
View File

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

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

@ -24,7 +24,7 @@ ABOUT: "floats"
HELP: float
{ $class-description "The class of double-precision floating point numbers." } ;
HELP: >float ( x -- y )
HELP: >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." } ;

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

@ -23,17 +23,21 @@ ABOUT: "integers"
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." } ;
HELP: >fixnum ( x -- n )
HELP: >fixnum
{ $values { "x" real } { "n" fixnum } }
{ $description "Converts a real number to a fixnum, with a possible loss of precision and overflow." } ;
HELP: bignum
{ $class-description "The class of bignums, which are heap-allocated arbitrary-precision integers." } ;
HELP: >bignum ( x -- n )
HELP: >bignum
{ $values { "x" real } { "n" bignum } }
{ $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
{ $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 ;
IN: math
GENERIC: >fixnum ( x -- y ) foldable
GENERIC: >bignum ( x -- y ) foldable
GENERIC: >integer ( x -- y ) foldable
GENERIC: >fixnum ( x -- n ) foldable
GENERIC: >bignum ( x -- n ) foldable
GENERIC: >integer ( x -- n ) foldable
GENERIC: >float ( 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
HELP: <=>
{ $values { "obj1" object } { "obj2" object } { "symbol" symbol } }
{ $values { "obj1" object } { "obj2" object } { "<=>" "an ordering specifier" } }
{ $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
"The output value is one of the following:"
{ $list
@ -16,23 +16,23 @@ HELP: <=>
} ;
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+
{ $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+
{ $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
{ $values { "symbol" symbol }
{ "new-symbol" symbol } }
{ $description "Invert the comparison symbol returned by " { $link <=> } ". The output for the symbol " { $snippet "+eq+" } " is itself." }
{ $values { "<=>" symbol }
{ "<=>'" symbol } }
{ $description "Invert the comparison symbol returned by " { $link <=> } "." }
{ $examples
{ $example "USING: math.order prettyprint ;" "+lt+ invert-comparison ." "+gt+" } } ;
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 <=> } "." }
{ $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 } }
{ $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:"
{ $subsection <=> }
{ $subsection compare }
{ $subsection invert-comparison }
"The above words return one of the following symbols:"
{ $subsection +lt+ }
{ $subsection +eq+ }
{ $subsection +gt+ }
"The above words output order specifiers."
{ $subsection "order-specifiers" }
"Utilities for comparing objects:"
{ $subsection after? }
{ $subsection before? }
{ $subsection after=? }
{ $subsection before=? } ;
{ $subsection before=? }
{ $see-also "sequences-sorting" } ;
ABOUT: "math.order"

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

@ -7,11 +7,11 @@ SYMBOL: +lt+
SYMBOL: +eq+
SYMBOL: +gt+
: invert-comparison ( symbol -- new-symbol )
: invert-comparison ( <=> -- <=>' )
#! Can't use case, index or nth here
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 ;
@ -38,4 +38,4 @@ M: real after=? ( obj1 obj2 -- ? ) >= ;
: [-] ( 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
] times
[ ] [ "parser" reload ] unit-test
[ ] [
[ "this-better-not-exist" forget-vocab ] with-compilation-unit
] unit-test

2
core/parser/parser.factor
View File

@ -539,7 +539,7 @@ SYMBOL: interactive-vocabs
: reset-removed-classes ( -- )
removed-classes
filter-moved [ class? ] filter [ reset-class ] each ;
filter-moved [ class? ] filter [ forget-class ] each ;
: fix-class-words ( -- )
#! 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
namespaces sequences strings io.styles vectors words
prettyprint.config splitting classes continuations
io.streams.nested accessors ;
io.streams.nested accessors sets ;
IN: prettyprint.sections
! State
@ -20,7 +20,7 @@ TUPLE: pprinter last-newline line-count indent ;
: <pprinter> ( -- pprinter ) 0 1 0 pprinter boa ;
: record-vocab ( word -- )
word-vocabulary [ dup pprinter-use get set-at ] when* ;
word-vocabulary [ pprinter-use get conjoin ] when* ;
! Utility words
: 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 = ] left-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
[ [ (prune) ] 2curry each ] keep ;
: gather ( seq quot -- newseq )
map concat prune ; inline
: unique ( seq -- assoc )
[ dup ] H{ } map>assoc ;

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

@ -3,12 +3,8 @@ sequences math.order ;
IN: sorting
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:"
{ $list
{ "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 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" } "."
$nl
"Sorting a sequence with a custom comparator:"
{ $subsection sort }
"Sorting a sequence with common comparators:"
@ -19,8 +15,10 @@ ARTICLE: "sequences-sorting" "Sorting and binary search"
{ $subsection binsearch }
{ $subsection binsearch* } ;
ABOUT: "sequences-sorting"
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" } "." } ;
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." } ;
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" } "."
$nl
"Outputs f if the sequence is empty. If the sequence has at least one element, this word always outputs a valid index." } ;
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."
$nl
"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 ( path -- source-file )
dup string? [ "Invalid source file path" throw ] unless
source-files get [ <source-file> ] cache ;
: reset-checksums ( -- )

4
core/syntax/syntax.factor
View File

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

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

@ -1,6 +1,6 @@
USING: help.markup help.syntax kernel kernel.private io
threads.private continuations dlists init quotations strings
assocs heaps boxes namespaces ;
assocs heaps boxes namespaces dequeues ;
IN: 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
namespaces sequences vectors continuations continuations.private
dlists assocs system combinators init boxes accessors
math.order ;
math.order dequeues ;
IN: threads
SYMBOL: initial-thread
@ -86,7 +86,7 @@ PRIVATE>
: sleep-time ( -- ms/f )
{
{ [ run-queue dlist-empty? not ] [ 0 ] }
{ [ run-queue dequeue-empty? not ] [ 0 ] }
{ [ sleep-queue heap-empty? ] [ f ] }
[ sleep-queue heap-peek nip millis [-] ]
} cond ;
@ -146,7 +146,7 @@ DEFER: next
: next ( -- * )
expire-sleep-loop
run-queue dup dlist-empty? [
run-queue dup dequeue-empty? [
drop no-runnable-threads
] [
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
[ ] [ "IN: words.tests : decl-forget-test ;" eval ] 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: word (quot-uses)
>r dup crossref? [ dup r> set-at ] [ r> 2drop ] if ;
M: word (quot-uses) over crossref? [ conjoin ] [ 2drop ] if ;
: seq-uses ( seq assoc -- ) [ (quot-uses) ] curry each ;
@ -103,12 +102,16 @@ compiled-crossref global [ H{ } assoc-like ] change-at
: compiled-xref ( word dependencies -- )
[ drop crossref? ] assoc-filter
2dup "compiled-uses" set-word-prop
compiled-crossref get add-vertex* ;
[ "compiled-uses" set-word-prop ]
[ compiled-crossref get add-vertex* ]
2bi ;
: 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 -- )
dup compiled-unxref
@ -141,6 +144,18 @@ M: object redefined drop ;
dup +inlined+ changed-definition
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 -- )
pick swap "declared-effect" set-word-prop
define ;
@ -177,9 +192,10 @@ GENERIC: subwords ( word -- seq )
M: word subwords drop f ;
: reset-generic ( word -- )
dup subwords forget-all
dup reset-word
{ "methods" "combination" "default-method" } reset-props ;
[ subwords forget-all ]
[ reset-word ]
[ { "methods" "combination" "default-method" } reset-props ]
tri ;
: gensym ( -- 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 forget*
dup "forgotten" word-prop [
dup delete-xref
dup delete-compiled-xref
dup word-name over word-vocabulary vocab-words delete-at
dup t "forgotten" set-word-prop
] unless drop ;
dup "forgotten" word-prop [ drop ] [
[ delete-xref ]
[ [ word-name ] [ word-vocabulary vocab-words ] bi delete-at ]
[ t "forgotten" set-word-prop ]
tri
] if ;
M: word hashcode*
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/" ;
: download-checksums ( -- alist )
url "checksums.txt" append http-get
url "checksums.txt" append http-get nip
string-lines [ " " split1 ] { } map>assoc ;
: 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) ;
: time-thread ( -- )
[ (time-thread) ] "Time model update" spawn drop ;
[
init-namespaces
(time-thread)
] "Time model update" spawn drop ;
f <model> time set-global
[ 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
! 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
cocoa.runtime sequences threads debugger init inspector
kernel.private ;
@ -19,6 +19,8 @@ IN: cocoa.application
: NSApp ( -- app ) NSApplication -> sharedApplication ;
FUNCTION: void NSBeep ( ) ;
: with-cocoa ( quot -- )
[ 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-circuit ( quots quot default -- quot )
! 1quotation -rot { } map>assoc <reversed> alist>quot ;
: short-circuit ( quots quot default -- quot )
1quotation -rot { } map>assoc <reversed> alist>quot ;
! MACRO: && ( quots -- ? )
! [ [ not ] append [ f ] ] t short-circuit ;

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

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

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

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: dlists kernel threads continuations math
USING: dequeues dlists kernel threads continuations math
concurrency.conditions ;
IN: concurrency.locks
@ -80,7 +80,7 @@ TUPLE: rw-lock readers writers reader# writer ;
: release-write-lock ( lock -- )
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 ;
: 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.
! See http://factorcode.org/license.txt for BSD license.
IN: concurrency.mailboxes
USING: dlists threads sequences continuations destructors
namespaces random math quotations words kernel arrays assocs
init system concurrency.conditions accessors debugger ;
USING: dlists dequeues threads sequences continuations
destructors namespaces random math quotations words kernel
arrays assocs init system concurrency.conditions accessors
debugger ;
TUPLE: mailbox threads data disposed ;
@ -13,7 +14,7 @@ M: mailbox dispose* threads>> notify-all ;
<dlist> <dlist> f mailbox boa ;
: mailbox-empty? ( mailbox -- bool )
data>> dlist-empty? ;
data>> dequeue-empty? ;
: mailbox-put ( obj mailbox -- )
[ 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.
!
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
concurrency.count-downs accessors ;
IN: concurrency.messaging.tests
[ ] [ my-mailbox mailbox-data dlist-delete-all ] unit-test
[ ] [ my-mailbox mailbox-data clear-dequeue ] unit-test
[ "received" ] [
[

4
extra/db/db.factor
View File

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

@ -1,14 +1,9 @@
USING: kernel
combinators
sequences
math
io.sockets
unicode.case
accessors
USING: kernel combinators sequences sets math
io.sockets unicode.case accessors
combinators.cleave combinators.lib
newfx
dns dns.util ;
dns dns.util dns.misc ;
IN: dns.server
@ -27,6 +22,69 @@ IN: dns.server
: matching-rrs ( query -- rrs ) records [ rr=query? ] with filter ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! zones
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: zones ( -- names ) records [ type>> NS = ] filter [ name>> ] map prune ;
: my-zones ( -- names ) records [ type>> SOA = ] filter [ name>> ] map ;
: delegated-zones ( -- names ) zones my-zones diff ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! name->zone
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: name->zone ( name -- zone/f )
zones sort-largest-first [ name-in-domain? ] with find nip ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! name->authority
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: name->authority ( name -- rrs-ns ) name->zone NS IN query boa matching-rrs ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! extract-names
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: rr->rdata-names ( rr -- names/f )
{
{ [ dup type>> NS = ] [ rdata>> {1} ] }
{ [ dup type>> MX = ] [ rdata>> exchange>> {1} ] }
{ [ t ] [ drop f ] }
}
cond ;
: extract-rdata-names ( message -- names )
[ answer-section>> ] [ authority-section>> ] bi append
[ rr->rdata-names ] map concat ;
: extract-names ( message -- names )
[ message-query name>> ] [ extract-rdata-names ] bi prefix-on ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! fill-authority
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: fill-authority ( message -- message )
dup
extract-names [ name->authority ] map concat prune
over answer-section>> diff
>>authority-section ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! fill-additional
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: name->rrs-a ( name -- rrs-a ) A IN query boa matching-rrs ;
: fill-additional ( message -- message )
dup
extract-rdata-names [ name->rrs-a ] map concat prune
over answer-section>> diff
>>additional-section ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! query->rrs
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -49,8 +107,11 @@ DEFER: query->rrs
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: have-answers ( message -- message/f )
dup message-query query->rrs ! message rrs/f
[ empty? ] [ 2drop f ] [ >>answer-section ] 1if ;
dup message-query query->rrs
[ empty? ]
[ 2drop f ]
[ >>answer-section fill-authority fill-additional ]
1if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! have-delegates?
@ -64,13 +125,13 @@ DEFER: query->rrs
NS IN query boa matching-rrs [ empty? ] [ drop f ] [ ] 1if ;
: name->delegates ( name -- rrs-ns )
{
[ "" = { } and ]
[ is-soa? { } and ]
[ have-ns? ]
[ cdr-name name->delegates ]
}
1|| ;
{
[ "" = { } and ]
[ is-soa? { } and ]
[ have-ns? ]
[ cdr-name name->delegates ]
}
1|| ;
: have-delegates ( message -- message/f )
dup message-query name>> name->delegates ! message rrs-ns
@ -85,20 +146,49 @@ DEFER: query->rrs
]
1if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! outsize-zones
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: outside-zones ( message -- message/f )
dup message-query name>> name->zone f =
[ ]
[ drop f ]
if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! is-nx
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: is-nx ( message -- message/f )
[ 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 ]
1if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: none-of-type ( message -- message )
dup
message-query name>> name->zone SOA IN query boa matching-rrs
>>authority-section ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: 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
@ -8,4 +8,12 @@ IN: dns.util
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
io.streams.string http.client sequences.lib combinators
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
: db-path ( -- path ) "IpToCountry.csv" temp-file ;
@ -32,15 +32,20 @@ MEMO: ip-db ( -- seq )
[ "#" head? not ] filter "\n" join <string-reader> csv
[ parse-ip-entry ] map ;
: filter-overlaps ( alist -- alist' )
2 clump
[ first2 [ first second ] [ first first ] bi* < ] filter
[ first ] map ;
MEMO: ip-intervals ( -- interval-map )
ip-db [ [ [ from>> ] [ to>> ] bi [a,b] ] keep ] { } map>assoc
<interval-map> ;
ip-db [ [ [ from>> ] [ to>> ] bi 2array ] keep ] { } map>assoc
filter-overlaps <interval-map> ;
GENERIC: lookup-ip ( ip -- ip-entry )
M: string lookup-ip
"." split [ string>number ] map
{ HEX: 1000000 HEX: 10000 HEX: 100 1 } v.
{ HEX: 1000000 HEX: 10000 HEX: 100 HEX: 1 } v.
lookup-ip ;
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:"
{ $table
{ "Term" "Definition" }
{ "alist" { "an association list. See " { $link "alists" } } }
{ "assoc" "an associative mapping" }
{ "alist" { "an association list; see " { $link "alists" } } }
{ "assoc" { "an associative mapping; see " { $link "assocs" } } }
{ "associative mapping" { "an object whose class implements the " { $link "assocs-protocol" } } }
{ "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" } } }
@ -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" } } }
{ "method" { "a specialized behavior of a generic word on a class. See " { $link "generic" } } }
{ "object" { "any datum which can be identified" } }
{ "ordering specifier" { "see " { $link "order-specifiers" } } }
{ "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" } }
{ "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 } } }
@ -157,12 +158,17 @@ ARTICLE: "collections" "Collections"
{ $subsection "hashtables" }
{ $subsection "alists" }
{ $subsection "enums" }
{ $heading "Double-ended queues" }
{ $subsection "dequeues" }
"Implementations:"
{ $subsection "dlists" }
{ $subsection "search-dequeues" }
{ $heading "Other collections" }
{ $subsection "boxes" }
{ $subsection "dlists" }
{ $subsection "heaps" }
{ $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
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
combinators splitting debugger hashtables sorting effects vocabs
vocabs.loader assocs editors continuations classes.predicate
macros combinators.lib sequences.lib math sets ;
macros math sets ;
IN: help.lint
: check-example ( element -- )
@ -46,16 +46,15 @@ IN: help.lint
: check-values ( word element -- )
{
[ over "declared-effect" word-prop ]
[ dup contains-funky-elements? not ]
[ over macro? not ]
{ [ over "declared-effect" word-prop ] [ 2drop ] }
{ [ dup contains-funky-elements? not ] [ 2drop ] }
{ [ over macro? not ] [ 2drop ] }
[
2dup extract-values >array
>r effect-values >array
r> assert=
t
[ effect-values >array ]
[ extract-values >array ]
bi* assert=
]
} 0&& 3drop ;
} cond ;
: check-see-also ( word element -- )
nip \ $see-also swap elements [
@ -114,7 +113,10 @@ M: help-error error.
vocabs [ dup vocab-docs-path swap ] H{ } map>assoc
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
] keep ;

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

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

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