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

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

db4
Joe Groff 2008-06-11 18:31:51 -07:00
parent 0c51a5b1ec 31ff6e93bb
commit 960bc6989a
97 changed files with 1225 additions and 657 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? ;

12
core/classes/classes.factor
View File

@ -76,8 +76,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
@ -99,8 +99,8 @@ M: word reset-class drop ;
: (define-class) ( word props -- )
>r
dup reset-class
dup class? [ dup new-class ] unless
dup reset-class
dup deferred? [ dup define-symbol ] when
dup word-props
r> assoc-union over set-word-props
@ -116,13 +116,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.

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 )

60
core/generic/generic.factor
View File

@ -58,18 +58,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 +80,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 )
[
@ -106,8 +105,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,13 +136,15 @@ 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 [ call-next-method ] [
dup
[ "method-class" word-prop ]
[ "method-generic" word-prop ] bi
3dup method eq? [
[ delete-at ] with-methods
call-next-method
] [ 3drop ] if
] if
]
[ t "forgotten" set-word-prop ] bi
] if ;
@ -156,29 +157,32 @@ GENERIC: implementors ( class/classes -- seq )
M: class implementors
all-words [ "methods" word-prop key? ] with filter ;
M: assoc implementors
M: sequence implementors
all-words [
"methods" word-prop keys
swap [ key? ] curry contains?
swap [ memq? ] curry contains?
] with filter ;
: forget-methods ( class -- )
[ implementors ] [ [ swap 2array ] curry ] bi map forget-all ;
M: class forget* ( class -- )
[
class-usages [
drop
: forget-class ( class -- )
class-usages [
{
[ "predicate" word-prop [ forget ] each ]
[ forget-methods ]
[ update-map- ]
[ reset-class ]
tri
] assoc-each
]
[ call-next-method ] bi ;
} cleave
] each ;
M: assoc update-methods ( class assoc -- )
implementors [ update-generic ] with each ;
M: class forget* ( class -- )
[ forget-class ] [ call-next-method ] bi ;
M: sequence update-methods ( class seq -- )
implementors [
[ update-generic ] [ make-generic drop ] 2bi
] with each ;
: define-generic ( word combination -- )
over "combination" word-prop over = [

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/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

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 -- )
[

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

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." } ;

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

42
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,14 @@ 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 [ redefined ] [ +inlined+ changed-definition ] bi ]
2bi
] if ;
: define-declared ( word def effect -- )
pick swap "declared-effect" set-word-prop
define ;
@ -177,9 +188,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 +228,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 ;

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/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" ] [
[

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/inverse/inverse.factor
View File

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

4
extra/io/paths/paths.factor
View File

@ -1,5 +1,5 @@
USING: io.files kernel sequences accessors
dlists arrays sequences.lib ;
dlists dequeues arrays sequences.lib ;
IN: io.paths
TUPLE: directory-iterator path bfs queue ;
@ -18,7 +18,7 @@ TUPLE: directory-iterator path bfs queue ;
dup path>> over push-directory ;
: next-file ( iter -- file/f )
dup queue>> dlist-empty? [ drop f ] [
dup queue>> dequeue-empty? [ drop f ] [
dup queue>> pop-back first2
[ over push-directory next-file ] [ nip ] if
] if ;

89
extra/irc/client/client-docs.factor Normal file
View File

@ -0,0 +1,89 @@
USING: help.markup help.syntax quotations kernel ;
IN: irc.client
HELP: irc-client "IRC Client object"
"blah" ;
HELP: irc-server-listener "Listener for server messages unmanaged by other listeners"
"blah" ;
HELP: irc-channel-listener "Listener for irc channels"
"blah" ;
HELP: irc-nick-listener "Listener for irc users"
"blah" ;
HELP: irc-profile "IRC Client profile object"
"blah" ;
HELP: connect-irc "Connecting to an irc server"
{ $values { "irc-client" "an irc client object" } }
{ $description "Connects and logins " { $link irc-client } " using the settings specified on its " { $link irc-profile } "." } ;
HELP: add-listener "Listening to irc channels/users/etc"
{ $values { "irc-client" "an irc client object" } { "irc-listener" "an irc listener object" } }
{ $description "Registers " { $snippet "irc-listener" } " with " { $snippet "irc-client" } " and starts listening." } ;
HELP: terminate-irc "Terminates an irc client"
{ $values { "irc-client" "an irc client object" } }
{ $description "Terminates all activity by " { $link irc-client } " cleaning up resources and notifying listeners." } ;
ARTICLE: "irc.client" "IRC Client"
"An IRC Client library"
{ $heading "IRC objects:" }
{ $subsection irc-client }
{ $heading "Listener objects:" }
{ $subsection irc-server-listener }
{ $subsection irc-channel-listener }
{ $subsection irc-nick-listener }
{ $heading "Setup objects:" }
{ $subsection irc-profile }
{ $heading "Words:" }
{ $subsection connect-irc }
{ $subsection terminate-irc }
{ $subsection add-listener }
{ $heading "IRC messages" }
"Some of the RFC defined irc messages as objects:"
{ $table
{ { $link irc-message } "base of all irc messages" }
{ { $link logged-in } "logged in to server" }
{ { $link ping } "ping message" }
{ { $link join } "channel join" }
{ { $link part } "channel part" }
{ { $link quit } "quit from irc" }
{ { $link privmsg } "private message (to client or channel)" }
{ { $link kick } "kick from channel" }
{ { $link roomlist } "list of participants in channel" }
{ { $link nick-in-use } "chosen nick is in use by another client" }
{ { $link notice } "notice message" }
{ { $link mode } "mode change" }
{ { $link unhandled } "uninmplemented/unhandled message" }
}
{ $heading "Special messages" }
"Some special messages that are created by the library and not by the irc server."
{ $table
{ { $link irc-end } " sent when the client isn't running anymore, listeners should stop after this." }
{ { $link irc-disconnected } " sent to notify listeners that connection was lost." }
{ { $link irc-connected } " sent to notify listeners that a connection with the irc server was established." } }
{ $heading "Example:" }
{ $code
"USING: irc.client concurrency.mailboxes ;"
"SYMBOL: bot"
"SYMBOL: mychannel"
"! Create the profile and client objects"
"\"irc.freenode.org\" irc-port \"mybot123\" f <irc-profile> <irc-client> bot set"
"! Connect to the server"
"bot get connect-irc"
"! Create a channel listener"
"\"#mychannel123\" <irc-channel-listener> mychannel set"
"! Register and start listener (this joins the channel)"
"bot get mychannel get add-listener"
"! Send a message to the channel"
"\"what's up?\" mychannel get out-messages>> mailbox-put"
"! Read a message from the channel"
"mychannel get in-messages>> mailbox-get"
}
;
ABOUT: "irc.client"

79
extra/irc/client/client-tests.factor Normal file
View File

@ -0,0 +1,79 @@
USING: kernel tools.test accessors arrays sequences qualified
io.streams.string io.streams.duplex namespaces threads
calendar irc.client.private ;
EXCLUDE: irc.client => join ;
IN: irc.client.tests
! Utilities
: <test-stream> ( lines -- stream )
"\n" join <string-reader> <string-writer> <duplex-stream> ;
: make-client ( lines -- irc-client )
"someserver" irc-port "factorbot" f <irc-profile> <irc-client>
swap [ 2nip <test-stream> f ] curry >>connect ;
: set-nick ( irc-client nickname -- )
[ nick>> ] dip >>name drop ;
: with-dummy-client ( quot -- )
rot with-variable ; inline
! Parsing tests
irc-message new
":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line
"someuser!n=user@some.where" >>prefix
"PRIVMSG" >>command
{ "#factortest" } >>parameters
"hi" >>trailing
1array
[ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
string>irc-message f >>timestamp ] unit-test
privmsg new
":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line
"someuser!n=user@some.where" >>prefix
"PRIVMSG" >>command
{ "#factortest" } >>parameters
"hi" >>trailing
"#factortest" >>name
1array
[ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
parse-irc-line f >>timestamp ] unit-test
{ "" } make-client dup "factorbot" set-nick current-irc-client [
{ t } [ irc> nick>> name>> me? ] unit-test
{ "factorbot" } [ irc> nick>> name>> ] unit-test
{ "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
{ "#factortest" } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
parse-irc-line irc-message-origin ] unit-test
{ "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi"
parse-irc-line irc-message-origin ] unit-test
] with-variable
! Test login and nickname set
{ "factorbot" } [ { "NOTICE AUTH :*** Looking up your hostname..."
"NOTICE AUTH :*** Checking ident"
"NOTICE AUTH :*** Found your hostname"
"NOTICE AUTH :*** No identd (auth) response"
":some.where 001 factorbot :Welcome factorbot"
} make-client
[ connect-irc ] keep 1 seconds sleep
nick>> name>> ] unit-test
! TODO: Channel join messages
! { ":factorbot!n=factorbo@some.where JOIN :#factortest"
! ":ircserver.net MODE #factortest +ns"
! ":ircserver.net 353 factorbot @ #factortest :@factorbot "
! ":ircserver.net 366 factorbot #factortest :End of /NAMES list."
! ":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah"
! } make-client dup "factorbot" set-nick
! TODO: user join
! ":somedude!n=user@isp.net JOIN :#factortest"
! TODO: channel message
! ":somedude!n=user@isp.net PRIVMSG #factortest :hello"
! TODO: direct private message
! ":somedude!n=user@isp.net PRIVMSG factorbot2 :hello"

242
extra/irc/client/client.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2007 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators concurrency.mailboxes concurrency.futures io
USING: arrays combinators concurrency.mailboxes fry io strings
io.encodings.8-bit io.sockets kernel namespaces sequences
sequences.lib splitting threads calendar classes.tuple
ascii assocs accessors destructors ;
classes ascii assocs accessors destructors continuations ;
IN: irc.client
! ======================================
@ -18,28 +18,42 @@ SYMBOL: current-irc-client
TUPLE: irc-profile server port nickname password ;
C: <irc-profile> irc-profile
TUPLE: irc-channel-profile name password ;
: <irc-channel-profile> ( -- irc-channel-profile ) irc-channel-profile new ;
! "live" objects
TUPLE: nick name channels log ;
C: <nick> nick
TUPLE: irc-client profile nick stream in-messages out-messages join-messages
listeners is-running ;
listeners is-running connect reconnect-time ;
: <irc-client> ( profile -- irc-client )
f V{ } clone V{ } clone <nick>
f <mailbox> <mailbox> <mailbox> H{ } clone f irc-client boa ;
f <mailbox> <mailbox> <mailbox> H{ } clone f
[ <inet> latin1 <client> ] 15 seconds irc-client boa ;
TUPLE: irc-listener in-messages out-messages ;
: <irc-listener> ( -- irc-listener )
<mailbox> <mailbox> irc-listener boa ;
TUPLE: irc-server-listener < irc-listener ;
TUPLE: irc-channel-listener < irc-listener name password timeout ;
TUPLE: irc-nick-listener < irc-listener name ;
UNION: irc-named-listener irc-nick-listener irc-channel-listener ;
: <irc-listener> ( -- irc-listener ) <mailbox> <mailbox> irc-listener boa ;
: <irc-server-listener> ( -- irc-server-listener )
<mailbox> <mailbox> irc-server-listener boa ;
: <irc-channel-listener> ( name -- irc-channel-listener )
<mailbox> <mailbox> rot f 60 seconds irc-channel-listener boa ;
: <irc-nick-listener> ( name -- irc-nick-listener )
<mailbox> <mailbox> rot irc-nick-listener boa ;
! ======================================
! Message objects
! ======================================
SINGLETON: irc-end ! Message used when the client isn't running anymore
SINGLETON: irc-end ! sent when the client isn't running anymore
SINGLETON: irc-disconnected ! sent when connection is lost
SINGLETON: irc-connected ! sent when connection is established
UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ;
TUPLE: irc-message line prefix command parameters trailing timestamp ;
TUPLE: logged-in < irc-message name ;
@ -55,14 +69,20 @@ TUPLE: notice < irc-message type ;
TUPLE: mode < irc-message name channel mode ;
TUPLE: unhandled < irc-message ;
: terminate-irc ( irc-client -- )
[ in-messages>> irc-end swap mailbox-put ]
[ f >>is-running drop ]
[ stream>> dispose ]
tri ;
<PRIVATE
! ======================================
! Shortcuts
! ======================================
: irc-client> ( -- irc-client ) current-irc-client get ;
: irc-stream> ( -- stream ) irc-client> stream>> ;
: irc> ( -- irc-client ) current-irc-client get ;
: irc-stream> ( -- stream ) irc> stream>> ;
: irc-write ( s -- ) irc-stream> stream-write ;
: irc-print ( s -- ) irc-stream> [ stream-print ] keep stream-flush ;
@ -79,7 +99,7 @@ TUPLE: unhandled < irc-message ;
" hostname servername :irc.factor" irc-print ;
: /CONNECT ( server port -- stream )
<inet> latin1 <client> drop ;
irc> connect>> call drop ;
: /JOIN ( channel password -- )
"JOIN " irc-write
@ -106,48 +126,12 @@ TUPLE: unhandled < irc-message ;
: /PONG ( text -- )
"PONG " irc-write irc-print ;
! ======================================
! Server message handling
! ======================================
USE: prettyprint
GENERIC: handle-incoming-irc ( irc-message -- )
M: irc-message handle-incoming-irc ( irc-message -- )
. ;
M: logged-in handle-incoming-irc ( logged-in -- )
name>> irc-client> nick>> (>>name) ;
M: ping handle-incoming-irc ( ping -- )
trailing>> /PONG ;
M: nick-in-use handle-incoming-irc ( nick-in-use -- )
name>> "_" append /NICK ;
M: privmsg handle-incoming-irc ( privmsg -- )
dup name>> irc-client> listeners>> at
[ in-messages>> mailbox-put ] [ drop ] if* ;
M: join handle-incoming-irc ( join -- )
irc-client> join-messages>> mailbox-put ;
! ======================================
! Client message handling
! ======================================
GENERIC: handle-outgoing-irc ( obj -- )
M: privmsg handle-outgoing-irc ( privmsg -- )
[ name>> ] [ trailing>> ] bi /PRIVMSG ;
! ======================================
! Message parsing
! ======================================
: split-at-first ( seq separators -- before after )
dupd [ member? ] curry find
dupd '[ , member? ] find
[ cut 1 tail ]
[ swap ]
if ;
@ -188,50 +172,115 @@ M: privmsg handle-outgoing-irc ( privmsg -- )
} case
[ [ tuple-slots ] [ parameters>> ] bi append ] dip prefix >tuple ;
! ======================================
! Server message handling
! ======================================
: me? ( string -- ? )
irc> nick>> name>> = ;
: irc-message-origin ( irc-message -- name )
dup name>> me? [ prefix>> parse-name ] [ name>> ] if ;
: broadcast-message-to-listeners ( message -- )
irc> listeners>> values [ in-messages>> mailbox-put ] with each ;
GENERIC: handle-incoming-irc ( irc-message -- )
M: irc-message handle-incoming-irc ( irc-message -- )
f irc> listeners>> at
[ in-messages>> mailbox-put ] [ drop ] if* ;
M: logged-in handle-incoming-irc ( logged-in -- )
name>> irc> nick>> (>>name) ;
M: ping handle-incoming-irc ( ping -- )
trailing>> /PONG ;
M: nick-in-use handle-incoming-irc ( nick-in-use -- )
name>> "_" append /NICK ;
M: privmsg handle-incoming-irc ( privmsg -- )
dup irc-message-origin irc> listeners>> [ at ] keep
'[ f , at ] unless* [ in-messages>> mailbox-put ] [ drop ] if* ;
M: join handle-incoming-irc ( join -- )
irc> join-messages>> mailbox-put ;
M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- )
broadcast-message-to-listeners ;
! ======================================
! Client message handling
! ======================================
GENERIC: handle-outgoing-irc ( obj -- )
M: privmsg handle-outgoing-irc ( privmsg -- )
[ name>> ] [ trailing>> ] bi /PRIVMSG ;
! ======================================
! Reader/Writer
! ======================================
: stream-readln-or-close ( stream -- str/f )
dup stream-readln [ nip ] [ dispose f ] if* ;
: irc-mailbox-get ( mailbox quot -- )
swap 5 seconds
'[ , , , mailbox-get-timeout swap call ]
[ drop ] recover ; inline
: handle-reader-message ( irc-message -- )
irc-client> in-messages>> mailbox-put ;
irc> in-messages>> mailbox-put ;
: handle-stream-close ( -- )
irc-client> f >>is-running in-messages>> irc-end swap mailbox-put ;
DEFER: (connect-irc)
: (handle-disconnect) ( -- )
irc>
[ in-messages>> irc-disconnected swap mailbox-put ]
[ dup reconnect-time>> sleep (connect-irc) ]
[ profile>> nickname>> /LOGIN ]
tri ;
: handle-disconnect ( error -- )
drop irc> is-running>> [ (handle-disconnect) ] when ;
: (reader-loop) ( -- )
irc> stream>> [
|dispose stream-readln [
parse-irc-line handle-reader-message
] [
irc> terminate-irc
] if*
] with-destructors ;
: reader-loop ( -- )
irc-client> stream>> stream-readln-or-close [
parse-irc-line handle-reader-message
] [
handle-stream-close
] if* ;
[ (reader-loop) ] [ handle-disconnect ] recover ;
: writer-loop ( -- )
irc-client> out-messages>> mailbox-get handle-outgoing-irc ;
irc> out-messages>> [ handle-outgoing-irc ] irc-mailbox-get ;
! ======================================
! Processing loops
! ======================================
: in-multiplexer-loop ( -- )
irc-client> in-messages>> mailbox-get handle-incoming-irc ;
irc> in-messages>> [ handle-incoming-irc ] irc-mailbox-get ;
! FIXME: Hack, this should be handled better
GENERIC: add-name ( name obj -- obj )
M: object add-name nip ;
M: privmsg add-name swap >>name ;
: listener-loop ( name -- ) ! FIXME: take different values from the stack?
dup irc-client> listeners>> at [
out-messages>> mailbox-get add-name
irc-client> out-messages>>
mailbox-put
] [ drop ] if* ;
: strings>privmsg ( name string -- privmsg )
privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ;
: maybe-annotate-with-name ( name obj -- obj )
{
{ [ dup string? ] [ strings>privmsg ] }
{ [ dup privmsg instance? ] [ swap >>name ] }
} cond ;
: listener-loop ( name listener -- )
out-messages>> swap
'[ , swap maybe-annotate-with-name irc> out-messages>> mailbox-put ]
irc-mailbox-get ;
: spawn-irc-loop ( quot name -- )
[ [ irc-client> is-running>> ] compose ] dip
[ '[ irc> is-running>> [ @ ] when irc> is-running>> ] ] dip
spawn-server drop ;
: spawn-irc ( -- )
@ -243,23 +292,33 @@ M: privmsg add-name swap >>name ;
! Listener join request handling
! ======================================
: make-registered-listener ( join -- listener )
<irc-listener> swap trailing>>
dup [ listener-loop ] curry "listener" spawn-irc-loop
[ irc-client> listeners>> set-at ] curry keep ;
: set+run-listener ( name irc-listener -- )
[ '[ , , listener-loop ] "listener" spawn-irc-loop ]
[ swap irc> listeners>> set-at ]
2bi ;
: make-join-future ( name -- future )
[ [ swap trailing>> = ] curry ! compare name with channel name
irc-client> join-messages>> 60 seconds rot mailbox-get-timeout?
make-registered-listener ]
curry future ;
GENERIC: (add-listener) ( irc-listener -- )
M: irc-channel-listener (add-listener) ( irc-channel-listener -- )
[ [ name>> ] [ password>> ] bi /JOIN ]
[ [ [ drop irc> join-messages>> ]
[ timeout>> ]
[ name>> '[ trailing>> , = ] ]
tri mailbox-get-timeout? trailing>> ] keep set+run-listener
] bi ;
PRIVATE>
M: irc-nick-listener (add-listener) ( irc-nick-listener -- )
[ name>> ] keep set+run-listener ;
M: irc-server-listener (add-listener) ( irc-server-listener -- )
f swap set+run-listener ;
: (connect-irc) ( irc-client -- )
[ profile>> [ server>> ] keep port>> /CONNECT ] keep
swap >>stream
t >>is-running drop ;
[ profile>> [ server>> ] [ port>> ] bi /CONNECT ] keep
swap >>stream
t >>is-running
in-messages>> irc-connected swap mailbox-put ;
PRIVATE>
: connect-irc ( irc-client -- )
dup current-irc-client [
@ -267,9 +326,6 @@ PRIVATE>
spawn-irc
] with-variable ;
: listen-to ( irc-client name -- future )
swap current-irc-client [ [ f /JOIN ] keep make-join-future ] with-variable ;
! shorcut for privmsgs, etc
: sender>> ( obj -- string )
prefix>> parse-name ;
GENERIC: add-listener ( irc-client irc-listener -- )
M: irc-listener add-listener ( irc-client irc-listener -- )
current-irc-client swap '[ , (add-listener) ] with-variable ;

2
extra/lcs/lcs.factor
View File

@ -56,7 +56,7 @@ TUPLE: trace-state old new table i j ;
{
[ i>> 0 > ] [ j>> 0 > ]
[ [ old-nth ] [ new-nth ] bi = ]
} <-&& ;
} 1&& ;
: do-retain ( state -- state )
dup old-nth retain boa ,

64
extra/lisp/lisp-tests.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
USING: lisp lisp.parser tools.test sequences math kernel parser arrays ;
USING: lisp lisp.parser tools.test sequences math kernel parser arrays lists
quotations ;
IN: lisp.test
@ -13,33 +14,36 @@ IN: lisp.test
"+" "math" "+" define-primitive
"-" "math" "-" define-primitive
"cons" "lists" "cons" define-primitive
"car" "lists" "car" define-primitive
"cdr" "lists" "cdr" define-primitive
"append" "lists" "lappend" define-primitive
"nil" "lists" "nil" define-primitive
"nil?" "lists" "nil?" define-primitive
[ seq>list ] "##list" lisp-define
"define" "lisp" "defun" define-primitive
"(lambda (&rest xs) xs)" lisp-string>factor "list" lisp-define
{ 5 } [
[ 2 3 ] "+" <lisp-symbol> funcall
! [ 2 3 ] "+" <lisp-symbol> funcall
"(+ 2 3)" lisp-eval
] unit-test
{ 8.3 } [
[ 10.4 2.1 ] "-" <lisp-symbol> funcall
! [ 10.4 2.1 ] "-" <lisp-symbol> funcall
"(- 10.4 2.1)" lisp-eval
] unit-test
{ 3 } [
"((lambda (x y) (+ x y)) 1 2)" lisp-eval
] unit-test
{ 42 } [
"((lambda (x y z) (+ x (- y z))) 40 3 1)" lisp-eval
] unit-test
{ T{ lisp-symbol f "if" } } [
"(defmacro if (pred tr fl) (quasiquote (cond ((unquote pred) (unquote tr)) (#t (unquote fl)))))" lisp-eval
] unit-test
{ t } [
T{ lisp-symbol f "if" } lisp-macro?
] unit-test
{ 1 } [
"(if #t 1 2)" lisp-eval
] unit-test
! { 42 } [
! "((lambda (x y z) (+ x (- y z))) 40 3 1)" lisp-eval
! ] unit-test
{ "b" } [
"(cond (#f \"a\") (#t \"b\"))" lisp-eval
@ -49,8 +53,28 @@ IN: lisp.test
"(begin (+ 1 4))" lisp-eval
] unit-test
{ 3 } [
"((lambda (x) (if x (begin (+ 1 2)) (- 3 5))) #t)" lisp-eval
{ { 1 2 3 4 5 } } [
"(list 1 2 3 4 5)" lisp-eval list>seq
] unit-test
{ { 1 2 { 3 { 4 } 5 } } } [
"(list 1 2 (list 3 (list 4) 5))" lisp-eval cons>seq
] unit-test
{ T{ lisp-symbol f "if" } } [
"(defmacro if (pred tr fl) (list (quote cond) (list (list pred tr) (list t fl))))" lisp-eval
] unit-test
{ t } [
T{ lisp-symbol f "if" } lisp-macro?
] unit-test
! { 1 } [
! "(if #t 1 2)" lisp-eval
! ] unit-test
! { 3 } [
! "((lambda (x) (if x (begin (+ 1 2)) (- 3 5))) #t)" lisp-eval
! ] unit-test
] with-interactive-vocabs

76
extra/lisp/lisp.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
USING: kernel peg sequences arrays strings combinators.lib
namespaces combinators math locals locals.private accessors
namespaces combinators math locals locals.private locals.backend accessors
vectors syntax lisp.parser assocs parser sequences.lib words
quotations fry lists inspector ;
IN: lisp
@ -11,19 +11,23 @@ DEFER: funcall
DEFER: lookup-var
DEFER: lookup-macro
DEFER: lisp-macro?
DEFER: lisp-var?
DEFER: macro-expand
DEFER: define-lisp-macro
ERROR: no-such-var variable-name ;
M: no-such-var summary drop "No such variable" ;
! Functions to convert s-exps to quotations
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: convert-body ( cons -- quot )
[ ] [ convert-form compose ] foldl ; inline
: convert-begin ( cons -- quot )
cdr [ convert-form ] [ ] lmap-as '[ , [ funcall ] each ] ;
cdr [ convert-form ] [ ] lmap-as '[ , [ call ] each ] ;
: convert-cond ( cons -- quot )
cdr [ 2car [ convert-form ] bi@ [ '[ @ funcall ] ] dip 2array ]
cdr [ 2car [ convert-form ] bi@ [ '[ @ call ] ] dip 2array ]
{ } lmap-as '[ , cond ] ;
: convert-general-form ( cons -- quot )
@ -32,49 +36,33 @@ DEFER: define-lisp-macro
! words for convert-lambda
<PRIVATE
: localize-body ( assoc body -- assoc newbody )
[ lisp-symbol? ] pick '[ [ name>> , at ] [ ] bi or ] traverse ;
{
{ [ dup list? ] [ [ lisp-symbol? ] pick '[ [ name>> , at ] [ ] bi or ] traverse ] }
{ [ dup lisp-symbol? ] [ name>> over at ] }
[ ]
} cond ;
: localize-lambda ( body vars -- newbody newvars )
: localize-lambda ( body vars -- newvars newbody )
make-locals dup push-locals swap
[ swap localize-body convert-form swap pop-locals ] dip swap ;
: split-lambda ( cons -- body-cons vars-seq )
3car -rot nip [ name>> ] lmap>array ; inline
: split-lambda ( cons -- body-cons vars-seq )
cdr uncons [ car ] [ [ name>> ] lmap>array ] bi* ; inline
: rest-lambda ( body vars -- quot )
"&rest" swap [ index ] [ remove ] 2bi
localize-lambda <lambda>
'[ , cut '[ @ , ] , compose ] ;
swapd localize-lambda <lambda>
'[ , cut '[ @ , seq>list ] call , call ] ;
: normal-lambda ( body vars -- quot )
localize-lambda <lambda> '[ , compose ] ;
localize-lambda <lambda> lambda-rewrite [ compose call ] compose 1quotation ;
PRIVATE>
: convert-lambda ( cons -- quot )
split-lambda "&rest" over member? [ rest-lambda ] [ normal-lambda ] if ;
: convert-quoted ( cons -- quot )
cdr 1quotation ;
: convert-unquoted ( cons -- quot )
"unquote not valid outside of quasiquote!" throw ;
: convert-unquoted-splicing ( cons -- quot )
"unquote-splicing not valid outside of quasiquote!" throw ;
<PRIVATE
: quasiquote-unquote ( cons -- newcons )
[ { [ dup list? ] [ car dup lisp-symbol? ] [ name>> "unquote" equal? dup ] } && nip ]
[ cadr ] traverse ;
: quasiquote-unquote-splicing ( cons -- newcons )
[ { [ dup list? ] [ dup cdr [ cons? ] [ car cons? ] bi and ]
[ dup cadr car lisp-symbol? ] [ cadr car name>> "unquote-splicing" equal? dup ] } && nip ]
[ dup cadr cdr >>cdr ] traverse ;
PRIVATE>
: convert-quasiquoted ( cons -- newcons )
quasiquote-unquote quasiquote-unquote-splicing ;
cadr 1quotation ;
: convert-defmacro ( cons -- quot )
cdr [ car ] keep [ convert-lambda ] [ car name>> ] bi define-lisp-macro 1quotation ;
@ -84,9 +72,6 @@ PRIVATE>
{ { "lambda" [ convert-lambda ] }
{ "defmacro" [ convert-defmacro ] }
{ "quote" [ convert-quoted ] }
{ "unquote" [ convert-unquoted ] }
{ "unquote-splicing" [ convert-unquoted-splicing ] }
{ "quasiquote" [ convert-quasiquoted ] }
{ "begin" [ convert-begin ] }
{ "cond" [ convert-cond ] }
[ drop convert-general-form ]
@ -102,6 +87,7 @@ PRIVATE>
: convert-form ( lisp-form -- quot )
{
{ [ dup cons? ] [ convert-list-form ] }
{ [ dup lisp-var? ] [ lookup-var 1quotation ] }
{ [ dup lisp-symbol? ] [ '[ , lookup-var ] ] }
[ 1quotation ]
} cond ;
@ -109,11 +95,8 @@ PRIVATE>
: compile-form ( lisp-ast -- quot )
convert-form lambda-rewrite call ; inline
: macro-call ( lambda -- cons )
call ; inline
: macro-expand ( cons -- quot )
uncons [ list>seq [ ] like ] [ lookup-macro macro-call compile-form ] bi* ;
uncons [ list>seq [ ] like ] [ lookup-macro lambda-rewrite call ] bi* call compile-form call ;
: lisp-string>factor ( str -- quot )
lisp-expr parse-result-ast compile-form ;
@ -125,9 +108,6 @@ PRIVATE>
SYMBOL: lisp-env
SYMBOL: macro-env
ERROR: no-such-var variable-name ;
M: no-such-var summary drop "No such variable" ;
: init-env ( -- )
H{ } clone lisp-env set
@ -136,17 +116,27 @@ M: no-such-var summary drop "No such variable" ;
: lisp-define ( quot name -- )
lisp-env get set-at ;
: defun ( name quot -- name )
over name>> lisp-define ;
: lisp-get ( name -- word )
dup lisp-env get at [ ] [ no-such-var ] ?if ;
: lookup-var ( lisp-symbol -- quot )
name>> lisp-get ;
: lisp-var? ( lisp-symbol -- ? )
dup lisp-symbol? [ name>> lisp-env get key? ] [ drop f ] if ;
: funcall-arg-list ( args -- newargs )
[ ] [ dup \ funcall = [ drop 2 cut* [ funcall ] compose call ] when suffix ] reduce ;
: funcall ( quot sym -- * )
dup lisp-symbol? [ lookup-var ] when call ; inline
[ funcall-arg-list ] dip
dup lisp-symbol? [ lookup-var ] when curry call ; inline
: define-primitive ( name vocab word -- )
swap lookup 1quotation '[ , compose call ] swap lisp-define ;
swap lookup 1quotation '[ , compose call ] swap lisp-define ; ! '[ , compose call ] swap lisp-define ;
: lookup-macro ( lisp-symbol -- lambda )
name>> macro-env get at ;

2
extra/lisp/parser/parser.factor
View File

@ -34,6 +34,6 @@ string = dquote ( escaped | !(dquote) . )* dquote => [[ second >string ]]
atom = number
| identifier
| string
list-item = _ ( atom | s-expression ) _ => [[ second ]]
s-expression = LPAREN (list-item)* RPAREN => [[ second seq>cons ]]
list-item = _ ( atom | s-expression ) _ => [[ second ]]
;EBNF

2
extra/lists/lazy/examples/examples-tests.factor
View File

@ -1,4 +1,4 @@
USING: lists.lazy.examples lazy-lists tools.test ;
USING: lists.lazy.examples lists.lazy tools.test ;
IN: lists.lazy.examples.tests
[ { 1 3 5 7 } ] [ 4 odds ltake list>array ] unit-test

4
extra/lists/lists-tests.factor
View File

@ -63,4 +63,8 @@ IN: lists.tests
{ { 3 4 { 5 6 { 7 } } } } [
{ 1 2 { 3 4 { 5 } } } seq>cons [ atom? ] [ 2 + ] traverse cons>seq
] unit-test
{ { 1 2 3 4 5 6 } } [
{ 1 2 3 } seq>list { 4 5 6 } seq>list lappend list>seq
] unit-test

5
extra/lists/lists.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008 Chris Double & James Cash
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences accessors math arrays vectors classes words locals ;
@ -75,6 +75,9 @@ M: object nil? drop f ;
: lreverse ( list -- newlist )
nil [ swap cons ] foldl ;
: lappend ( list1 list2 -- newlist )
[ lreverse ] dip [ swap cons ] foldl ;
: seq>list ( seq -- list )
<reversed> nil [ swap cons ] reduce ;

25
extra/logging/logging.factor
View File

@ -4,7 +4,7 @@ USING: logging.server sequences namespaces concurrency.messaging
words kernel arrays shuffle tools.annotations
prettyprint.config prettyprint debugger io.streams.string
splitting continuations effects arrays.lib parser strings
combinators.lib quotations fry symbols accessors ;
quotations fry symbols accessors ;
IN: logging
SYMBOLS: DEBUG NOTICE WARNING ERROR CRITICAL ;
@ -42,21 +42,18 @@ SYMBOL: log-service
<PRIVATE
: one-string? ( obj -- ? )
{
[ dup array? ]
[ dup length 1 = ]
[ dup first string? ]
} 0&& nip ;
PREDICATE: one-string-array < array
[ length 1 = ] [ [ string? ] all? ] bi and ;
: stack>message ( obj -- inputs>message )
dup one-string? [ first ] [
H{
{ string-limit f }
{ line-limit 1 }
{ nesting-limit 3 }
{ margin 0 }
} clone [ unparse ] bind
dup one-string-array? [ first ] [
[
string-limit off
1 line-limit set
3 nesting-limit set
0 margin set
unparse
] with-scope
] if ;
PRIVATE>

7
extra/logging/server/server.factor
View File

@ -93,7 +93,12 @@ SYMBOL: log-files
} case log-server-loop ;
: log-server ( -- )
[ [ log-server-loop ] [ error. (close-logs) ] recover t ]
[
init-namespaces
[ log-server-loop ]
[ error. (close-logs) ]
recover t
]
"Log server" spawn-server
"log-server" set-global ;

5
extra/macros/macros-docs.factor
View File

@ -21,7 +21,7 @@ HELP: macro-expand
{ $values { "..." "inputs to a macro" } { "word" macro } { "quot" quotation } }
{ $description "Expands a macro. Useful for debugging." }
{ $examples
{ $code "{ [ dup integer? ] [ dup 0 > ] [ dup 13 mod zero? ] } \ && macro-expand ." }
{ $code "USING: math macros combinators.lib ;" "{ [ integer? ] [ 0 > ] [ 13 mod zero? ] } \ 1&& macro-expand ." }
} ;
ARTICLE: "macros" "Macros"
@ -31,9 +31,6 @@ $nl
{ $subsection POSTPONE: MACRO: }
"Expanding macros for debugging purposes:"
{ $subsection macro-expand }
! "Two sample macros which implement short-circuiting boolean operators (as found in C, Java and similar languages):"
! { $subsection && }
! { $subsection || }
"Macros are really just a very thin layer of syntax sugar over " { $link "compiler-transforms" } "." ;
ABOUT: "macros"

3
extra/macros/macros-tests.factor
View File

@ -12,3 +12,6 @@ unit-test
"USING: math ;\nIN: macros.tests\n: see-test ( a b -- c ) - ;\n" dup eval
[ \ see-test see ] with-string-writer =
] unit-test
[ ] [ "USING: macros inference kernel ; IN: hanging-macro MACRO: c ( quot -- ) infer drop [ ] ; : a ( -- ) [ a ] c ;" eval ] unit-test

2
extra/math/text/english/english.factor
View File

@ -26,7 +26,7 @@ IN: math.text.english
SYMBOL: and-needed?
: set-conjunction ( seq -- )
first { [ dup 100 < ] [ dup 0 > ] } && and-needed? set drop ;
first { [ dup 100 < ] [ dup 0 > ] } 0&& and-needed? set drop ;
: negative-text ( n -- str )
0 < "Negative " "" ? ;

2
extra/multi-methods/multi-methods.factor
View File

@ -154,7 +154,7 @@ M: method-body stack-effect
"multi-method-generic" word-prop stack-effect ;
M: method-body crossref?
drop t ;
"forgotten" word-prop not ;
: method-word-name ( specializer generic -- string )
[ word-name % "-" % unparse % ] "" make ;

2
extra/peg/ebnf/ebnf.factor
View File

@ -87,7 +87,7 @@ C: <ebnf> ebnf
[ dup CHAR: ? = ]
[ dup CHAR: : = ]
[ dup CHAR: ~ = ]
} || not nip
} 0|| not nip
] satisfy repeat1 [ >string <ebnf-non-terminal> ] action ;
: 'terminal' ( -- parser )

2
extra/project-euler/014/014.factor
View File

@ -59,7 +59,7 @@ PRIVATE>
<PRIVATE
: worth-calculating? ( n -- ? )
{ [ dup 1- 3 mod zero? ] [ dup 1- 3 / even? ] } && nip ;
{ [ dup 1- 3 mod zero? ] [ dup 1- 3 / even? ] } 0&& nip ;
PRIVATE>

2
extra/project-euler/021/021.factor
View File

@ -27,7 +27,7 @@ IN: project-euler.021
: amicable? ( n -- ? )
dup sum-proper-divisors
{ [ 2dup = not ] [ 2dup sum-proper-divisors = ] } && 2nip ;
{ [ 2dup = not ] [ 2dup sum-proper-divisors = ] } 0&& 2nip ;
: euler021 ( -- answer )
10000 [1,b] [ dup amicable? [ drop 0 ] unless ] sigma ;

2
extra/project-euler/036/036.factor
View File

@ -27,7 +27,7 @@ IN: project-euler.036
: both-bases? ( n -- ? )
{ [ dup palindrome? ]
[ dup >bin dup reverse = ] } && nip ;
[ dup >bin dup reverse = ] } 0&& nip ;
PRIVATE>

2
extra/project-euler/043/043.factor
View File

@ -47,7 +47,7 @@ IN: project-euler.043
[ 5 4 pick subseq-divisible? ]
[ 3 3 pick subseq-divisible? ]
[ 2 2 pick subseq-divisible? ]
} && nip ;
} 0&& nip ;
PRIVATE>

2
extra/project-euler/052/052.factor
View File

@ -29,7 +29,7 @@ IN: project-euler.052
[ number>digits natural-sort ] map all-equal? ;
: candidate? ( n -- ? )
{ [ dup odd? ] [ dup 3 mod zero? ] } && nip ;
{ [ dup odd? ] [ dup 3 mod zero? ] } 0&& nip ;
: next-all-same ( x n -- n )
dup candidate? [

1
extra/sequences/deep/tags.txt Normal file
View File

@ -0,0 +1 @@
collections

1
extra/sequences/modified/tags.txt Normal file
View File

@ -0,0 +1 @@
collections

1
extra/sequences/repeating/tags.txt Normal file
View File

@ -0,0 +1 @@
collections

13
extra/serialize/serialize-tests.factor
View File

@ -4,7 +4,7 @@
USING: tools.test kernel serialize io io.streams.byte-array math
alien arrays byte-arrays sequences math prettyprint parser
classes math.constants io.encodings.binary random
combinators.lib assocs ;
assocs ;
IN: serialize.tests
: test-serialize-cell
@ -15,12 +15,11 @@ IN: serialize.tests
[ t ] [
100 [
drop
{
[ 40 [ test-serialize-cell ] all? ]
[ 4 [ 40 * test-serialize-cell ] all? ]
[ 4 [ 400 * test-serialize-cell ] all? ]
[ 4 [ 4000 * test-serialize-cell ] all? ]
} &&
40 [ test-serialize-cell ] all?
4 [ 40 * test-serialize-cell ] all?
4 [ 400 * test-serialize-cell ] all?
4 [ 4000 * test-serialize-cell ] all?
and and and
] all?
] unit-test

4
extra/tools/deploy/shaker/strip-debugger.factor
View File

@ -1,8 +1,8 @@
USING: kernel threads threads.private ;
IN: debugger
: print-error die ;
: print-error ( error -- ) die drop ;
: error. die ;
: error. ( error -- ) die drop ;
M: thread error-in-thread ( error thread -- ) die 2drop ;

8
extra/tools/deploy/shaker/strip-libc.factor
View File

@ -1,10 +1,10 @@
USING: libc.private ;
IN: libc
: malloc (malloc) check-ptr ;
: malloc ( size -- newalien ) (malloc) check-ptr ;
: realloc (realloc) check-ptr ;
: realloc ( alien size -- newalien ) (realloc) check-ptr ;
: calloc (calloc) check-ptr ;
: calloc ( size count -- newalien ) (calloc) check-ptr ;
: free (free) ;
: free ( alien -- ) (free) ;

14
extra/ui/gadgets/gadgets-tests.factor
View File

@ -1,6 +1,6 @@
IN: ui.gadgets.tests
USING: ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test
namespaces models kernel dlists math sets
namespaces models kernel dlists dequeues math sets
math.parser ui sequences hashtables assocs io arrays
prettyprint io.streams.string ;
@ -130,26 +130,26 @@ M: mock-gadget ungraft*
[
<dlist> \ graft-queue [
[ ] [ <mock-gadget> dup queue-graft unqueue-graft ] unit-test
[ t ] [ graft-queue dlist-empty? ] unit-test
[ t ] [ graft-queue dequeue-empty? ] unit-test
] with-variable
<dlist> \ graft-queue [
[ t ] [ graft-queue dlist-empty? ] unit-test
[ t ] [ graft-queue dequeue-empty? ] unit-test
<mock-gadget> "g" set
[ ] [ "g" get queue-graft ] unit-test
[ f ] [ graft-queue dlist-empty? ] unit-test
[ f ] [ graft-queue dequeue-empty? ] unit-test
[ { f t } ] [ "g" get gadget-graft-state ] unit-test
[ ] [ "g" get graft-later ] unit-test
[ { f t } ] [ "g" get gadget-graft-state ] unit-test
[ ] [ "g" get ungraft-later ] unit-test
[ { f f } ] [ "g" get gadget-graft-state ] unit-test
[ t ] [ graft-queue dlist-empty? ] unit-test
[ t ] [ graft-queue dequeue-empty? ] unit-test
[ ] [ "g" get ungraft-later ] unit-test
[ ] [ "g" get graft-later ] unit-test
[ ] [ notify-queued ] unit-test
[ { t t } ] [ "g" get gadget-graft-state ] unit-test
[ t ] [ graft-queue dlist-empty? ] unit-test
[ t ] [ graft-queue dequeue-empty? ] unit-test
[ ] [ "g" get graft-later ] unit-test
[ 1 ] [ "g" get mock-gadget-graft-called ] unit-test
[ ] [ "g" get ungraft-later ] unit-test
@ -185,7 +185,7 @@ M: mock-gadget ungraft*
[ { f t } ] [ "1" get gadget-graft-state ] unit-test
[ { f t } ] [ "2" get gadget-graft-state ] unit-test
[ { f t } ] [ "3" get gadget-graft-state ] unit-test
[ ] [ [ "x" print notify ] graft-queue swap dlist-slurp ] unit-test
[ ] [ graft-queue [ "x" print notify ] slurp-dequeue ] unit-test
[ ] [ notify-queued ] unit-test
[ V{ { t t } } ] [ status-flags ] unit-test
] with-variable ;

15
extra/ui/gadgets/gadgets.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays hashtables kernel models math namespaces sequences
quotations math.vectors combinators sorting vectors dlists
models threads concurrency.flags math.order ;
USING: accessors arrays hashtables kernel models math namespaces
sequences quotations math.vectors combinators sorting vectors
dlists dequeues models threads concurrency.flags math.order ;
IN: ui.gadgets
SYMBOL: ui-notify-flag
@ -252,13 +252,12 @@ M: gadget layout* drop ;
: graft-queue ( -- dlist ) \ graft-queue get ;
: unqueue-graft ( gadget -- )
graft-queue over gadget-graft-node delete-node
dup gadget-graft-state first { t t } { f f } ?
swap set-gadget-graft-state ;
[ graft-node>> graft-queue delete-node ]
[ [ first { t t } { f f } ? ] change-graft-state drop ] bi ;
: (queue-graft) ( gadget flags -- )
over set-gadget-graft-state
dup graft-queue push-front* swap set-gadget-graft-node
>>graft-state
dup graft-queue push-front* >>graft-node drop
notify-ui-thread ;
: queue-graft ( gadget -- )

2
extra/ui/tools/browser/browser.factor
View File

@ -14,7 +14,7 @@ TUPLE: browser-gadget pane history ;
>r >link r> history>> set-model ;
: <help-pane> ( browser-gadget -- gadget )
history>> [ [ dup help ] try drop ] <pane-control> ;
history>> [ [ help ] curry try ] <pane-control> ;
: init-history ( browser-gadget -- )
"handbook" >link <history> >>history drop ;

8
extra/ui/ui.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs io kernel math models namespaces
prettyprint dlists sequences threads sequences words
prettyprint dlists dequeues sequences threads sequences words
debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks
ui.gestures ui.backend ui.render continuations init combinators
hashtables concurrency.flags sets ;
@ -15,7 +15,7 @@ SYMBOL: stop-after-last-window?
: event-loop? ( -- ? )
{
{ [ stop-after-last-window? get not ] [ t ] }
{ [ graft-queue dlist-empty? not ] [ t ] }
{ [ graft-queue dequeue-empty? not ] [ t ] }
{ [ windows get-global empty? not ] [ t ] }
[ f ]
} cond ;
@ -126,7 +126,7 @@ SYMBOL: ui-hook
in-layout? on
layout-queue [
dup layout find-world [ , ] when*
] dlist-slurp
] slurp-dequeue
] { } make prune ;
: redraw-worlds ( seq -- )
@ -141,7 +141,7 @@ SYMBOL: ui-hook
} case ;
: notify-queued ( -- )
graft-queue [ notify ] dlist-slurp ;
graft-queue [ notify ] slurp-dequeue ;
: update-ui ( -- )
[ notify-queued layout-queued redraw-worlds ] assert-depth ;

6
extra/xmode/marker/marker.factor
View File

@ -19,7 +19,7 @@ strings regexp splitting parser-combinators ascii unicode.case ;
dup [ dupd matches? ] [ drop f ] if
] unless*
]
} && nip ;
} 0&& nip ;
: mark-number ( keyword -- id )
keyword-number? DIGIT and ;
@ -50,7 +50,7 @@ M: rule match-position drop position get ;
[ over matcher-at-line-start? over zero? implies ]
[ over matcher-at-whitespace-end? over whitespace-end get = implies ]
[ over matcher-at-word-start? over last-offset get = implies ]
} && 2nip ;
} 0&& 2nip ;
: rest-of-line ( -- str )
line get position get tail-slice ;
@ -273,7 +273,7 @@ M: mark-previous-rule handle-rule-start
[ check-end-delegate ]
[ check-every-rule ]
[ check-word-break ]
} || drop
} 0|| drop
position inc
mark-token-loop