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

core, basis, extra: Remove DOS line endings from files. 

Remove whitespace from end of lines.
Add a newline to the end of each file.
db4
Doug Coleman 2015-06-29 16:43:15 -07:00
parent 2c08e9a089
commit 352e5de16a
719 changed files with 13131 additions and 13380 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
basis/alien/arrays/arrays.factor
View File

@ -63,4 +63,3 @@ M: string-type c-type-setter
drop [ set-alien-cell ] ;
[ { c-string utf8 } c-string typedef ] with-compilation-unit

3
basis/alien/endian/endian.factor
View File

@ -65,7 +65,7 @@ ERROR: unknown-endian-c-type symbol ;
[ alien-unsigned-4 4 f byte-reverse 32 shift ]
[ 4 + alien-unsigned-4 4 f byte-reverse ] 2bi bitor
]
] dip [ [ 64 >signed ] compose ] when
] dip [ [ 64 >signed ] compose ] when
>>getter drop
]
[ '[ [ [ _ _ byte-reverse ] 2dip ] prepose ] change-setter ] 3bi
@ -160,4 +160,3 @@ SYNTAX: LE-PACKED-STRUCT:
SYNTAX: BE-PACKED-STRUCT:
parse-struct-definition
big-endian define-endian-packed-struct-class ;

1
basis/alien/libraries/unix/unix.factor
View File

@ -12,4 +12,3 @@ M: unix >deployed-library-path
M: macosx >deployed-library-path
file-name "@executable_path/../Frameworks" prepend-path ;

146
basis/alien/prettyprint/prettyprint-tests.factor
View File

@ -1,73 +1,73 @@
USING: alien.c-types alien.prettyprint alien.syntax
io.streams.string see tools.test prettyprint
io.encodings.ascii ;
IN: alien.prettyprint.tests
CONSTANT: FOO 10
FUNCTION: int function_test ( float x, int[4][FOO] y, char* z, ushort *w ) ;
[ "USING: alien.c-types alien.syntax ;
IN: alien.prettyprint.tests
FUNCTION: int function_test
( float x, int[4][FOO] y, char* z, ushort* w ) ; inline
" ] [
[ \ function_test see ] with-string-writer
] unit-test
FUNCTION-ALIAS: function-test int function_test
( float x, int[4][FOO] y, char* z, ushort *w ) ;
[ "USING: alien.c-types alien.syntax ;
IN: alien.prettyprint.tests
FUNCTION-ALIAS: function-test int function_test
( float x, int[4][FOO] y, char* z, ushort* w ) ; inline
" ] [
[ \ function-test see ] with-string-writer
] unit-test
TYPEDEF: c-string[ascii] string-typedef
TYPEDEF: char[1][2][3] array-typedef
[ "USING: alien.c-types alien.syntax ;
IN: alien.prettyprint.tests
TYPEDEF: c-string[ascii] string-typedef
" ] [
[ \ string-typedef see ] with-string-writer
] unit-test
[ "USING: alien.c-types alien.syntax ;
IN: alien.prettyprint.tests
TYPEDEF: char[1][2][3] array-typedef
" ] [
[ \ array-typedef see ] with-string-writer
] unit-test
C-TYPE: opaque-c-type
[ "USING: alien.syntax ;
IN: alien.prettyprint.tests
C-TYPE: opaque-c-type
" ] [
[ \ opaque-c-type see ] with-string-writer
] unit-test
TYPEDEF: pointer: int pint
[ "USING: alien.c-types alien.syntax ;
IN: alien.prettyprint.tests
TYPEDEF: int* pint
" ] [
[ \ pint see ] with-string-writer
] unit-test
[ "pointer: int" ] [ pointer: int unparse ] unit-test
CALLBACK: void callback-test ( int x, float[4] y ) ;
[ "USING: alien.c-types alien.syntax ;
IN: alien.prettyprint.tests
CALLBACK: void callback-test ( int x, float[4] y ) ;
" ] [
[ \ callback-test see ] with-string-writer
] unit-test
USING: alien.c-types alien.prettyprint alien.syntax
io.streams.string see tools.test prettyprint
io.encodings.ascii ;
IN: alien.prettyprint.tests
CONSTANT: FOO 10
FUNCTION: int function_test ( float x, int[4][FOO] y, char* z, ushort *w ) ;
[ "USING: alien.c-types alien.syntax ;
IN: alien.prettyprint.tests
FUNCTION: int function_test
( float x, int[4][FOO] y, char* z, ushort* w ) ; inline
" ] [
[ \ function_test see ] with-string-writer
] unit-test
FUNCTION-ALIAS: function-test int function_test
( float x, int[4][FOO] y, char* z, ushort *w ) ;
[ "USING: alien.c-types alien.syntax ;
IN: alien.prettyprint.tests
FUNCTION-ALIAS: function-test int function_test
( float x, int[4][FOO] y, char* z, ushort* w ) ; inline
" ] [
[ \ function-test see ] with-string-writer
] unit-test
TYPEDEF: c-string[ascii] string-typedef
TYPEDEF: char[1][2][3] array-typedef
[ "USING: alien.c-types alien.syntax ;
IN: alien.prettyprint.tests
TYPEDEF: c-string[ascii] string-typedef
" ] [
[ \ string-typedef see ] with-string-writer
] unit-test
[ "USING: alien.c-types alien.syntax ;
IN: alien.prettyprint.tests
TYPEDEF: char[1][2][3] array-typedef
" ] [
[ \ array-typedef see ] with-string-writer
] unit-test
C-TYPE: opaque-c-type
[ "USING: alien.syntax ;
IN: alien.prettyprint.tests
C-TYPE: opaque-c-type
" ] [
[ \ opaque-c-type see ] with-string-writer
] unit-test
TYPEDEF: pointer: int pint
[ "USING: alien.c-types alien.syntax ;
IN: alien.prettyprint.tests
TYPEDEF: int* pint
" ] [
[ \ pint see ] with-string-writer
] unit-test
[ "pointer: int" ] [ pointer: int unparse ] unit-test
CALLBACK: void callback-test ( int x, float[4] y ) ;
[ "USING: alien.c-types alien.syntax ;
IN: alien.prettyprint.tests
CALLBACK: void callback-test ( int x, float[4] y ) ;
" ] [
[ \ callback-test see ] with-string-writer
] unit-test

2
basis/alien/prettyprint/prettyprint.factor
View File

@ -110,7 +110,7 @@ M: alien-callback-type-word synopsis*
[ def>> first first pprint-c-type ]
[ pprint-word ]
[
<block "(" text
<block "(" text
[ def>> first second ] [ "callback-effect" word-prop in>> ] bi
pprint-function-args
")" text block>

190
basis/ascii/ascii-docs.factor
View File

@ -1,95 +1,95 @@
USING: help.markup help.syntax kernel strings ;
IN: ascii
HELP: blank?
{ $values { "ch" "a character" } { "?" boolean } }
{ $description "Tests for an ASCII whitespace character." } ;
HELP: letter?
{ $values { "ch" "a character" } { "?" boolean } }
{ $description "Tests for a lowercase alphabet ASCII character." } ;
HELP: LETTER?
{ $values { "ch" "a character" } { "?" boolean } }
{ $description "Tests for a uppercase alphabet ASCII character." } ;
HELP: digit?
{ $values { "ch" "a character" } { "?" boolean } }
{ $description "Tests for an ASCII decimal digit character." } ;
HELP: Letter?
{ $values { "ch" "a character" } { "?" boolean } }
{ $description "Tests for an ASCII alphabet character, both upper and lower case." } ;
HELP: alpha?
{ $values { "ch" "a character" } { "?" boolean } }
{ $description "Tests for an alphanumeric ASCII character." } ;
HELP: printable?
{ $values { "ch" "a character" } { "?" boolean } }
{ $description "Tests for a printable ASCII character." } ;
HELP: control?
{ $values { "ch" "a character" } { "?" boolean } }
{ $description "Tests for an ASCII control character." } ;
HELP: quotable?
{ $values { "ch" "a character" } { "?" boolean } }
{ $description "Tests for characters which may appear in a Factor string literal without escaping." } ;
HELP: ascii?
{ $values { "ch" "a character" } { "?" boolean } }
{ $description "Tests for whether a number is an ASCII character." } ;
HELP: ch>lower
{ $values { "ch" "a character" } { "lower" "a character" } }
{ $description "Converts an ASCII character to lower case." } ;
HELP: ch>upper
{ $values { "ch" "a character" } { "upper" "a character" } }
{ $description "Converts an ASCII character to upper case." } ;
HELP: >lower
{ $values { "str" string } { "lower" string } }
{ $description "Converts an ASCII string to lower case." } ;
HELP: >upper
{ $values { "str" string } { "upper" string } }
{ $description "Converts an ASCII string to upper case." } ;
HELP: >title
{ $values { "str" string } { "title" string } }
{ $description "Converts a string to title case." } ;
HELP: >words
{ $values { "str" string } { "words" "an array of slices" } }
{ $description "Divides the string up into words." } ;
HELP: capitalize
{ $values { "str" string } { "str'" string } }
{ $description "Capitalize all the words in a string." } ;
ARTICLE: "ascii" "ASCII"
"The " { $vocab-link "ascii" } " vocabulary implements support for the legacy ASCII character set. Most applications should use " { $link "unicode" } " instead."
$nl
"ASCII character classes:"
{ $subsections
blank?
letter?
LETTER?
digit?
printable?
control?
quotable?
ascii?
}
"ASCII case conversion:"
{ $subsections
ch>lower
ch>upper
>lower
>upper
>title
} ;
ABOUT: "ascii"
USING: help.markup help.syntax kernel strings ;
IN: ascii
HELP: blank?
{ $values { "ch" "a character" } { "?" boolean } }
{ $description "Tests for an ASCII whitespace character." } ;
HELP: letter?
{ $values { "ch" "a character" } { "?" boolean } }
{ $description "Tests for a lowercase alphabet ASCII character." } ;
HELP: LETTER?
{ $values { "ch" "a character" } { "?" boolean } }
{ $description "Tests for a uppercase alphabet ASCII character." } ;
HELP: digit?
{ $values { "ch" "a character" } { "?" boolean } }
{ $description "Tests for an ASCII decimal digit character." } ;
HELP: Letter?
{ $values { "ch" "a character" } { "?" boolean } }
{ $description "Tests for an ASCII alphabet character, both upper and lower case." } ;
HELP: alpha?
{ $values { "ch" "a character" } { "?" boolean } }
{ $description "Tests for an alphanumeric ASCII character." } ;
HELP: printable?
{ $values { "ch" "a character" } { "?" boolean } }
{ $description "Tests for a printable ASCII character." } ;
HELP: control?
{ $values { "ch" "a character" } { "?" boolean } }
{ $description "Tests for an ASCII control character." } ;
HELP: quotable?
{ $values { "ch" "a character" } { "?" boolean } }
{ $description "Tests for characters which may appear in a Factor string literal without escaping." } ;
HELP: ascii?
{ $values { "ch" "a character" } { "?" boolean } }
{ $description "Tests for whether a number is an ASCII character." } ;
HELP: ch>lower
{ $values { "ch" "a character" } { "lower" "a character" } }
{ $description "Converts an ASCII character to lower case." } ;
HELP: ch>upper
{ $values { "ch" "a character" } { "upper" "a character" } }
{ $description "Converts an ASCII character to upper case." } ;
HELP: >lower
{ $values { "str" string } { "lower" string } }
{ $description "Converts an ASCII string to lower case." } ;
HELP: >upper
{ $values { "str" string } { "upper" string } }
{ $description "Converts an ASCII string to upper case." } ;
HELP: >title
{ $values { "str" string } { "title" string } }
{ $description "Converts a string to title case." } ;
HELP: >words
{ $values { "str" string } { "words" "an array of slices" } }
{ $description "Divides the string up into words." } ;
HELP: capitalize
{ $values { "str" string } { "str'" string } }
{ $description "Capitalize all the words in a string." } ;
ARTICLE: "ascii" "ASCII"
"The " { $vocab-link "ascii" } " vocabulary implements support for the legacy ASCII character set. Most applications should use " { $link "unicode" } " instead."
$nl
"ASCII character classes:"
{ $subsections
blank?
letter?
LETTER?
digit?
printable?
control?
quotable?
ascii?
}
"ASCII case conversion:"
{ $subsections
ch>lower
ch>upper
>lower
>upper
>title
} ;
ABOUT: "ascii"

62
basis/ascii/ascii.factor
View File

@ -1,31 +1,31 @@
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.short-circuit hints kernel math math.order
sequences strings ;
IN: ascii
: ascii? ( ch -- ? ) 0 127 between? ; inline
: blank? ( ch -- ? ) " \t\n\r" member? ; inline
: letter? ( ch -- ? ) CHAR: a CHAR: z between? ; inline
: LETTER? ( ch -- ? ) CHAR: A CHAR: Z between? ; inline
: digit? ( ch -- ? ) CHAR: 0 CHAR: 9 between? ; inline
: printable? ( ch -- ? ) CHAR: \s CHAR: ~ between? ; inline
: control? ( ch -- ? ) { [ 0 0x1F between? ] [ 0x7F = ] } 1|| ; inline
: quotable? ( ch -- ? ) { [ printable? ] [ "\"\\" member? not ] } 1&& ; inline
: Letter? ( ch -- ? ) { [ letter? ] [ LETTER? ] } 1|| ; inline
: alpha? ( ch -- ? ) { [ Letter? ] [ digit? ] } 1|| ; inline
: ch>lower ( ch -- lower ) dup LETTER? [ 0x20 + ] when ; inline
: >lower ( str -- lower ) [ ch>lower ] map ;
: ch>upper ( ch -- upper ) dup letter? [ 0x20 - ] when ; inline
: >upper ( str -- upper ) [ ch>upper ] map ;
: >words ( str -- words )
[ dup empty? not ] [
dup [ blank? ] find drop
[ [ 1 ] when-zero cut-slice swap ]
[ f 0 rot [ length ] keep <slice> ] if*
] produce nip ;
: capitalize ( str -- str' ) unclip [ >lower ] [ ch>upper ] bi* prefix ;
: >title ( str -- title ) >words [ capitalize ] map concat ;
HINTS: >lower string ;
HINTS: >upper string ;
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.short-circuit hints kernel math math.order
sequences strings ;
IN: ascii
: ascii? ( ch -- ? ) 0 127 between? ; inline
: blank? ( ch -- ? ) " \t\n\r" member? ; inline
: letter? ( ch -- ? ) CHAR: a CHAR: z between? ; inline
: LETTER? ( ch -- ? ) CHAR: A CHAR: Z between? ; inline
: digit? ( ch -- ? ) CHAR: 0 CHAR: 9 between? ; inline
: printable? ( ch -- ? ) CHAR: \s CHAR: ~ between? ; inline
: control? ( ch -- ? ) { [ 0 0x1F between? ] [ 0x7F = ] } 1|| ; inline
: quotable? ( ch -- ? ) { [ printable? ] [ "\"\\" member? not ] } 1&& ; inline
: Letter? ( ch -- ? ) { [ letter? ] [ LETTER? ] } 1|| ; inline
: alpha? ( ch -- ? ) { [ Letter? ] [ digit? ] } 1|| ; inline
: ch>lower ( ch -- lower ) dup LETTER? [ 0x20 + ] when ; inline
: >lower ( str -- lower ) [ ch>lower ] map ;
: ch>upper ( ch -- upper ) dup letter? [ 0x20 - ] when ; inline
: >upper ( str -- upper ) [ ch>upper ] map ;
: >words ( str -- words )
[ dup empty? not ] [
dup [ blank? ] find drop
[ [ 1 ] when-zero cut-slice swap ]
[ f 0 rot [ length ] keep <slice> ] if*
] produce nip ;
: capitalize ( str -- str' ) unclip [ >lower ] [ ch>upper ] bi* prefix ;
: >title ( str -- title ) >words [ capitalize ] map concat ;
HINTS: >lower string ;
HINTS: >upper string ;

1
basis/atk/atk.factor
View File

@ -2,4 +2,3 @@
! See http://factorcode.org/license.txt for BSD license.
USING: atk.ffi ;
IN: atk

80
basis/bit-vectors/bit-vectors-docs.factor
View File

@ -1,40 +1,40 @@
USING: help.markup help.syntax sequences ;
IN: bit-vectors
ARTICLE: "bit-vectors" "Bit vectors"
"A bit vector is a resizable mutable sequence of bits. Bit vector words are found in the " { $vocab-link "bit-vectors" } " vocabulary."
$nl
"Bit vectors form a class:"
{ $subsections
bit-vector
bit-vector?
}
"Creating bit vectors:"
{ $subsections
>bit-vector
<bit-vector>
}
"Literal syntax:"
{ $subsections POSTPONE: ?V{ }
"If you don't care about initial capacity, a more elegant way to create a new bit vector is to write:"
{ $code "?V{ } clone" } ;
ABOUT: "bit-vectors"
HELP: bit-vector
{ $description "The class of resizable bit vectors. See " { $link "bit-vectors" } " for information." } ;
HELP: <bit-vector>
{ $values { "capacity" "a positive integer specifying initial capacity" } { "vector" bit-vector } }
{ $description "Creates a new bit vector that can hold " { $snippet "n" } " bits before resizing." } ;
HELP: >bit-vector
{ $values { "seq" sequence } { "vector" bit-vector } }
{ $description "Outputs a freshly-allocated bit vector with the same elements as a given sequence." } ;
HELP: ?V{
{ $syntax "?V{ elements... }" }
{ $values { "elements" "a list of booleans" } }
{ $description "Marks the beginning of a literal bit vector. Literal bit vectors are terminated by " { $link POSTPONE: } } "." }
{ $examples { $code "?V{ t f t }" } } ;
USING: help.markup help.syntax sequences ;
IN: bit-vectors
ARTICLE: "bit-vectors" "Bit vectors"
"A bit vector is a resizable mutable sequence of bits. Bit vector words are found in the " { $vocab-link "bit-vectors" } " vocabulary."
$nl
"Bit vectors form a class:"
{ $subsections
bit-vector
bit-vector?
}
"Creating bit vectors:"
{ $subsections
>bit-vector
<bit-vector>
}
"Literal syntax:"
{ $subsections POSTPONE: ?V{ }
"If you don't care about initial capacity, a more elegant way to create a new bit vector is to write:"
{ $code "?V{ } clone" } ;
ABOUT: "bit-vectors"
HELP: bit-vector
{ $description "The class of resizable bit vectors. See " { $link "bit-vectors" } " for information." } ;
HELP: <bit-vector>
{ $values { "capacity" "a positive integer specifying initial capacity" } { "vector" bit-vector } }
{ $description "Creates a new bit vector that can hold " { $snippet "n" } " bits before resizing." } ;
HELP: >bit-vector
{ $values { "seq" sequence } { "vector" bit-vector } }
{ $description "Outputs a freshly-allocated bit vector with the same elements as a given sequence." } ;
HELP: ?V{
{ $syntax "?V{ elements... }" }
{ $values { "elements" "a list of booleans" } }
{ $description "Marks the beginning of a literal bit vector. Literal bit vectors are terminated by " { $link POSTPONE: } } "." }
{ $examples { $code "?V{ t f t }" } } ;

28
basis/bit-vectors/bit-vectors-tests.factor
View File

@ -1,14 +1,14 @@
USING: tools.test bit-vectors vectors sequences kernel math ;
IN: bit-vectors.tests
[ 0 ] [ 123 <bit-vector> length ] unit-test
: do-it ( seq -- )
1234 swap [ [ even? ] dip push ] curry each-integer ;
[ t ] [
3 <bit-vector> dup do-it
3 <vector> dup do-it sequence=
] unit-test
[ t ] [ ?V{ } bit-vector? ] unit-test
USING: tools.test bit-vectors vectors sequences kernel math ;
IN: bit-vectors.tests
[ 0 ] [ 123 <bit-vector> length ] unit-test
: do-it ( seq -- )
1234 swap [ [ even? ] dip push ] curry each-integer ;
[ t ] [
3 <bit-vector> dup do-it
3 <vector> dup do-it sequence=
] unit-test
[ t ] [ ?V{ } bit-vector? ] unit-test

30
basis/bit-vectors/bit-vectors.factor
View File

@ -1,15 +1,15 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel kernel.private math sequences
sequences.private growable bit-arrays prettyprint.custom
parser accessors vectors.functor classes.parser ;
IN: bit-vectors
<< "bit-vector" create-class-in \ bit-array \ <bit-array> define-vector >>
SYNTAX: ?V{ \ } [ >bit-vector ] parse-literal ;
M: bit-vector contract 2drop ;
M: bit-vector >pprint-sequence ;
M: bit-vector pprint-delims drop \ ?V{ \ } ;
M: bit-vector pprint* pprint-object ;
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel kernel.private math sequences
sequences.private growable bit-arrays prettyprint.custom
parser accessors vectors.functor classes.parser ;
IN: bit-vectors
<< "bit-vector" create-class-in \ bit-array \ <bit-array> define-vector >>
SYNTAX: ?V{ \ } [ >bit-vector ] parse-literal ;
M: bit-vector contract 2drop ;
M: bit-vector >pprint-sequence ;
M: bit-vector pprint-delims drop \ ?V{ \ } ;
M: bit-vector pprint* pprint-object ;

8
basis/bootstrap/handbook/handbook.factor
View File

@ -1,4 +1,4 @@
USING: vocabs.loader vocabs kernel ;
IN: bootstrap.handbook
{ "bootstrap.handbook" "bootstrap.help" } "help.handbook" require-when
USING: vocabs.loader vocabs kernel ;
IN: bootstrap.handbook
{ "bootstrap.handbook" "bootstrap.help" } "help.handbook" require-when

2
basis/bootstrap/unicode/unicode.factor
View File

@ -1 +1 @@
USE: unicode
USE: unicode

78
basis/boxes/boxes-docs.factor
View File

@ -1,39 +1,39 @@
USING: help.markup help.syntax kernel ;
IN: boxes
HELP: box
{ $class-description "A data type holding a single value in the " { $snippet "value" } " slot. The " { $snippet "occupied" } " slot indicates if the value is set." } ;
HELP: <box>
{ $values { "box" box } }
{ $description "Creates a new empty box." } ;
HELP: >box
{ $values { "value" object } { "box" box } }
{ $description "Stores a value into a box." }
{ $errors "Throws an error if the box is full." } ;
HELP: box>
{ $values { "box" box } { "value" "the value of the box" } }
{ $description "Removes a value from a box." }
{ $errors "Throws an error if the box is empty." } ;
HELP: ?box
{ $values { "box" box } { "value/f" "the value of the box or " { $link f } } { "?" boolean } }
{ $description "If the box is full, removes the value from the box and pushes " { $link t } ". If the box is empty pushes " { $snippet "f f" } "." } ;
ARTICLE: "boxes" "Boxes"
"A " { $emphasis "box" } " is a container which can either be empty or hold a single value."
{ $subsections box }
"Creating an empty box:"
{ $subsections <box> }
"Storing a value and removing a value from a box:"
{ $subsections
>box
box>
}
"Safely removing a value:"
{ $subsections ?box }
"Testing if a box is full can be done by reading the " { $snippet "occupied" } " slot." ;
ABOUT: "boxes"
USING: help.markup help.syntax kernel ;
IN: boxes
HELP: box
{ $class-description "A data type holding a single value in the " { $snippet "value" } " slot. The " { $snippet "occupied" } " slot indicates if the value is set." } ;
HELP: <box>
{ $values { "box" box } }
{ $description "Creates a new empty box." } ;
HELP: >box
{ $values { "value" object } { "box" box } }
{ $description "Stores a value into a box." }
{ $errors "Throws an error if the box is full." } ;
HELP: box>
{ $values { "box" box } { "value" "the value of the box" } }
{ $description "Removes a value from a box." }
{ $errors "Throws an error if the box is empty." } ;
HELP: ?box
{ $values { "box" box } { "value/f" "the value of the box or " { $link f } } { "?" boolean } }
{ $description "If the box is full, removes the value from the box and pushes " { $link t } ". If the box is empty pushes " { $snippet "f f" } "." } ;
ARTICLE: "boxes" "Boxes"
"A " { $emphasis "box" } " is a container which can either be empty or hold a single value."
{ $subsections box }
"Creating an empty box:"
{ $subsections <box> }
"Storing a value and removing a value from a box:"
{ $subsections
>box
box>
}
"Safely removing a value:"
{ $subsections ?box }
"Testing if a box is full can be done by reading the " { $snippet "occupied" } " slot." ;
ABOUT: "boxes"

48
basis/boxes/boxes-tests.factor
View File

@ -1,24 +1,24 @@
USING: boxes namespaces tools.test accessors ;
IN: boxes.tests
[ ] [ <box> "b" set ] unit-test
[ ] [ 3 "b" get >box ] unit-test
[ t ] [ "b" get occupied>> ] unit-test
[ 4 "b" >box ] must-fail
[ 3 ] [ "b" get box> ] unit-test
[ f ] [ "b" get occupied>> ] unit-test
[ "b" get box> ] must-fail
[ f f ] [ "b" get ?box ] unit-test
[ ] [ 12 "b" get >box ] unit-test
[ 12 t ] [ "b" get ?box ] unit-test
[ f ] [ "b" get occupied>> ] unit-test
USING: boxes namespaces tools.test accessors ;
IN: boxes.tests
[ ] [ <box> "b" set ] unit-test
[ ] [ 3 "b" get >box ] unit-test
[ t ] [ "b" get occupied>> ] unit-test
[ 4 "b" >box ] must-fail
[ 3 ] [ "b" get box> ] unit-test
[ f ] [ "b" get occupied>> ] unit-test
[ "b" get box> ] must-fail
[ f f ] [ "b" get ?box ] unit-test
[ ] [ 12 "b" get >box ] unit-test
[ 12 t ] [ "b" get ?box ] unit-test
[ f ] [ "b" get occupied>> ] unit-test

70
basis/boxes/boxes.factor
View File

@ -1,35 +1,35 @@
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors ;
IN: boxes
TUPLE: box value occupied ;
: <box> ( -- box ) box new ;
ERROR: box-full box ;
: >box ( value box -- )
dup occupied>>
[ box-full ] [ t >>occupied value<< ] if ; inline
ERROR: box-empty box ;
: check-box ( box -- box )
dup occupied>> [ box-empty ] unless ; inline
<PRIVATE
: box-unsafe> ( box -- value )
[ f ] change-value f >>occupied drop ; inline
PRIVATE>
: box> ( box -- value )
check-box box-unsafe> ; inline
: ?box ( box -- value/f ? )
dup occupied>> [ box-unsafe> t ] [ drop f f ] if ; inline
: if-box? ( box quot -- )
[ ?box ] dip [ drop ] if ; inline
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors ;
IN: boxes
TUPLE: box value occupied ;
: <box> ( -- box ) box new ;
ERROR: box-full box ;
: >box ( value box -- )
dup occupied>>
[ box-full ] [ t >>occupied value<< ] if ; inline
ERROR: box-empty box ;
: check-box ( box -- box )
dup occupied>> [ box-empty ] unless ; inline
<PRIVATE
: box-unsafe> ( box -- value )
[ f ] change-value f >>occupied drop ; inline
PRIVATE>
: box> ( box -- value )
check-box box-unsafe> ; inline
: ?box ( box -- value/f ? )
dup occupied>> [ box-unsafe> t ] [ drop f f ] if ; inline
: if-box? ( box quot -- )
[ ?box ] dip [ drop ] if ; inline

100
basis/cache/cache-tests.factor vendored
View File

@ -1,50 +1,50 @@
USING: cache tools.test accessors destructors kernel assocs
namespaces ;
IN: cache.tests
TUPLE: mock-disposable < disposable n ;
: <mock-disposable> ( n -- mock-disposable )
mock-disposable new-disposable swap >>n ;
M: mock-disposable dispose* drop ;
[ ] [ <cache-assoc> "cache" set ] unit-test
[ 0 ] [ "cache" get assoc-size ] unit-test
[ ] [ "cache" get 2 >>max-age drop ] unit-test
[ ] [ 1 <mock-disposable> dup "a" set 2 "cache" get set-at ] unit-test
[ 1 ] [ "cache" get assoc-size ] unit-test
[ ] [ "cache" get purge-cache ] unit-test
[ ] [ 2 <mock-disposable> 3 "cache" get set-at ] unit-test
[ 2 ] [ "cache" get assoc-size ] unit-test
[ ] [ "cache" get purge-cache ] unit-test
[ 1 ] [ "cache" get assoc-size ] unit-test
[ ] [ 3 <mock-disposable> dup "b" set 4 "cache" get set-at ] unit-test
[ 2 ] [ "cache" get assoc-size ] unit-test
[ ] [ "cache" get purge-cache ] unit-test
[ 1 ] [ "cache" get assoc-size ] unit-test
[ f ] [ 2 "cache" get key? ] unit-test
[ 3 ] [ 4 "cache" get at n>> ] unit-test
[ t ] [ "a" get disposed>> ] unit-test
[ f ] [ "b" get disposed>> ] unit-test
[ ] [ "cache" get clear-assoc ] unit-test
[ t ] [ "b" get disposed>> ] unit-test
USING: cache tools.test accessors destructors kernel assocs
namespaces ;
IN: cache.tests
TUPLE: mock-disposable < disposable n ;
: <mock-disposable> ( n -- mock-disposable )
mock-disposable new-disposable swap >>n ;
M: mock-disposable dispose* drop ;
[ ] [ <cache-assoc> "cache" set ] unit-test
[ 0 ] [ "cache" get assoc-size ] unit-test
[ ] [ "cache" get 2 >>max-age drop ] unit-test
[ ] [ 1 <mock-disposable> dup "a" set 2 "cache" get set-at ] unit-test
[ 1 ] [ "cache" get assoc-size ] unit-test
[ ] [ "cache" get purge-cache ] unit-test
[ ] [ 2 <mock-disposable> 3 "cache" get set-at ] unit-test
[ 2 ] [ "cache" get assoc-size ] unit-test
[ ] [ "cache" get purge-cache ] unit-test
[ 1 ] [ "cache" get assoc-size ] unit-test
[ ] [ 3 <mock-disposable> dup "b" set 4 "cache" get set-at ] unit-test
[ 2 ] [ "cache" get assoc-size ] unit-test
[ ] [ "cache" get purge-cache ] unit-test
[ 1 ] [ "cache" get assoc-size ] unit-test
[ f ] [ 2 "cache" get key? ] unit-test
[ 3 ] [ 4 "cache" get at n>> ] unit-test
[ t ] [ "a" get disposed>> ] unit-test
[ f ] [ "b" get disposed>> ] unit-test
[ ] [ "cache" get clear-assoc ] unit-test
[ t ] [ "b" get disposed>> ] unit-test

12
basis/cairo/ffi/ffi.factor
View File

@ -345,7 +345,7 @@ STRUCT: cairo_rectangle_t
{ y double }
{ width double }
{ height double } ;
STRUCT: cairo_rectangle_list_t
{ status cairo_status_t }
{ rectangles cairo_rectangle_t* }
@ -558,7 +558,7 @@ ENUM: cairo_font_type_t
FUNCTION: cairo_font_type_t
cairo_font_face_get_type ( cairo_font_face_t* font_face ) ;
FUNCTION: void*
FUNCTION: void*
cairo_font_face_get_user_data ( cairo_font_face_t* font_face, cairo_user_data_key_t* key ) ;
FUNCTION: cairo_status_t
@ -584,7 +584,7 @@ cairo_scaled_font_status ( cairo_scaled_font_t* scaled_font ) ;
FUNCTION: cairo_font_type_t
cairo_scaled_font_get_type ( cairo_scaled_font_t* scaled_font ) ;
FUNCTION: void*
FUNCTION: void*
cairo_scaled_font_get_user_data ( cairo_scaled_font_t* scaled_font, cairo_user_data_key_t* key ) ;
FUNCTION: cairo_status_t
@ -743,7 +743,7 @@ STRUCT: cairo_path_data_t-header
{ type cairo_path_data_type_t }
{ length int } ;
UNION-STRUCT: cairo_path_data_t
UNION-STRUCT: cairo_path_data_t
{ point cairo_path_data_t-point }
{ header cairo_path_data_t-header } ;
@ -769,7 +769,7 @@ cairo_path_destroy ( cairo_path_t* path ) ;
FUNCTION: cairo_status_t
cairo_status ( cairo_t* cr ) ;
FUNCTION: c-string
FUNCTION: c-string
cairo_status_to_string ( cairo_status_t status ) ;
! Surface manipulation
@ -822,7 +822,7 @@ cairo_surface_write_to_png ( cairo_surface_t* surface, c-string filename ) ;
FUNCTION: cairo_status_t
cairo_surface_write_to_png_stream ( cairo_surface_t* surface, cairo_write_func_t write_func, void* closure ) ;
FUNCTION: void*
FUNCTION: void*
cairo_surface_get_user_data ( cairo_surface_t* surface, cairo_user_data_key_t* key ) ;
FUNCTION: cairo_status_t

2
basis/calendar/calendar.factor
View File

@ -61,7 +61,7 @@ M: not-a-month summary
PRIVATE>
CONSTANT: month-names
CONSTANT: month-names
{
"January" "February" "March" "April" "May" "June"
"July" "August" "September" "October" "November" "December"

42
basis/calendar/model/model.factor
View File

@ -1,21 +1,21 @@
! Copyright (C) 2008, 2010 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: calendar namespaces models threads kernel init ;
IN: calendar.model
SYMBOL: time
: (time-thread) ( -- )
now time get set-model
1 seconds sleep (time-thread) ;
: time-thread ( -- )
[
init-namespaces
(time-thread)
] "Time model update" spawn drop ;
[
f <model> time set-global
time-thread
] "calendar.model" add-startup-hook
! Copyright (C) 2008, 2010 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: calendar namespaces models threads kernel init ;
IN: calendar.model
SYMBOL: time
: (time-thread) ( -- )
now time get set-model
1 seconds sleep (time-thread) ;
: time-thread ( -- )
[
init-namespaces
(time-thread)
] "Time model update" spawn drop ;
[
f <model> time set-global
time-thread
] "calendar.model" add-startup-hook

12
basis/channels/examples/examples.factor
View File

@ -8,12 +8,12 @@ IN: channels.examples
: (counter) ( channel n -- )
[ swap to ] 2keep 1 + (counter) ;
: counter ( channel -- )
2 (counter) ;
2 (counter) ;
: counter-test ( -- n1 n2 n3 )
<channel> dup [ counter ] curry "Counter" spawn drop
<channel> dup [ counter ] curry "Counter" spawn drop
[ from ] keep [ from ] keep from ;
: filter ( send prime recv -- )
@ -21,7 +21,7 @@ IN: channels.examples
#! filters out all those divisible by 'prime',
#! and sends to the 'recv' channel.
[
from swap dupd mod zero? not [ swap to ] [ 2drop ] if
from swap dupd mod zero? not [ swap to ] [ 2drop ] if
] 3keep filter ;
:: (sieve) ( prime c -- )
@ -31,14 +31,14 @@ IN: channels.examples
[ newc p c filter ] "Filter" spawn drop
prime newc (sieve) ;
: sieve ( prime -- )
: sieve ( prime -- )
#! Send prime numbers to 'prime' channel
<channel> dup [ counter ] curry "Counter" spawn drop
(sieve) ;
: sieve-test ( -- seq )
<channel> dup [ sieve ] curry "Sieve" spawn drop
V{ } clone swap
V{ } clone swap
[ from swap push ] 2keep
[ from swap push ] 2keep
[ from swap push ] 2keep

10
basis/channels/remote/remote.factor
View File

@ -21,7 +21,7 @@ PRIVATE>
: unpublish ( id -- )
remote-channels delete-at ;
<PRIVATE
MATCH-VARS: ?from ?tag ?id ?value ;
@ -43,21 +43,21 @@ TUPLE: from-message id ;
: start-channel-node ( -- )
"remote-channels" get-remote-thread [
[ channel-thread t ] "Remote channels" spawn-server
"remote-channels" register-remote-thread
"remote-channels" register-remote-thread
] unless ;
PRIVATE>
TUPLE: remote-channel node id ;
C: <remote-channel> remote-channel
C: <remote-channel> remote-channel
<PRIVATE
: send-message ( message remote-channel -- value )
node>> "remote-channels" <remote-thread>
node>> "remote-channels" <remote-thread>
send-synchronous dup no-channel = [ no-channel throw ] when* ;
PRIVATE>
M: remote-channel to ( value remote-channel -- )

1
basis/checksums/internet/internet.factor
View File

@ -13,4 +13,3 @@ M: internet checksum-bytes
drop 2 <groups> [ le> ] map-sum
[ -16 shift ] [ 0xffff bitand ] bi +
[ -16 shift ] keep + bitnot 2 >le ;

36
basis/checksums/sha/sha.factor
View File

@ -127,25 +127,25 @@ CONSTANT: K-256
CONSTANT: K-384
{
0x428a2f98d728ae22 0x7137449123ef65cd 0xb5c0fbcfec4d3b2f 0xe9b5dba58189dbbc
0x3956c25bf348b538 0x59f111f1b605d019 0x923f82a4af194f9b 0xab1c5ed5da6d8118
0x428a2f98d728ae22 0x7137449123ef65cd 0xb5c0fbcfec4d3b2f 0xe9b5dba58189dbbc
0x3956c25bf348b538 0x59f111f1b605d019 0x923f82a4af194f9b 0xab1c5ed5da6d8118
0xd807aa98a3030242 0x12835b0145706fbe 0x243185be4ee4b28c 0x550c7dc3d5ffb4e2
0x72be5d74f27b896f 0x80deb1fe3b1696b1 0x9bdc06a725c71235 0xc19bf174cf692694
0xe49b69c19ef14ad2 0xefbe4786384f25e3 0x0fc19dc68b8cd5b5 0x240ca1cc77ac9c65
0x2de92c6f592b0275 0x4a7484aa6ea6e483 0x5cb0a9dcbd41fbd4 0x76f988da831153b5
0x983e5152ee66dfab 0xa831c66d2db43210 0xb00327c898fb213f 0xbf597fc7beef0ee4
0xc6e00bf33da88fc2 0xd5a79147930aa725 0x06ca6351e003826f 0x142929670a0e6e70
0x27b70a8546d22ffc 0x2e1b21385c26c926 0x4d2c6dfc5ac42aed 0x53380d139d95b3df
0x650a73548baf63de 0x766a0abb3c77b2a8 0x81c2c92e47edaee6 0x92722c851482353b
0xa2bfe8a14cf10364 0xa81a664bbc423001 0xc24b8b70d0f89791 0xc76c51a30654be30
0xd192e819d6ef5218 0xd69906245565a910 0xf40e35855771202a 0x106aa07032bbd1b8
0x19a4c116b8d2d0c8 0x1e376c085141ab53 0x2748774cdf8eeb99 0x34b0bcb5e19b48a8
0x391c0cb3c5c95a63 0x4ed8aa4ae3418acb 0x5b9cca4f7763e373 0x682e6ff3d6b2b8a3
0x748f82ee5defb2fc 0x78a5636f43172f60 0x84c87814a1f0ab72 0x8cc702081a6439ec
0x90befffa23631e28 0xa4506cebde82bde9 0xbef9a3f7b2c67915 0xc67178f2e372532b
0xca273eceea26619c 0xd186b8c721c0c207 0xeada7dd6cde0eb1e 0xf57d4f7fee6ed178
0x06f067aa72176fba 0x0a637dc5a2c898a6 0x113f9804bef90dae 0x1b710b35131c471b
0x28db77f523047d84 0x32caab7b40c72493 0x3c9ebe0a15c9bebc 0x431d67c49c100d4c
0x72be5d74f27b896f 0x80deb1fe3b1696b1 0x9bdc06a725c71235 0xc19bf174cf692694
0xe49b69c19ef14ad2 0xefbe4786384f25e3 0x0fc19dc68b8cd5b5 0x240ca1cc77ac9c65
0x2de92c6f592b0275 0x4a7484aa6ea6e483 0x5cb0a9dcbd41fbd4 0x76f988da831153b5
0x983e5152ee66dfab 0xa831c66d2db43210 0xb00327c898fb213f 0xbf597fc7beef0ee4
0xc6e00bf33da88fc2 0xd5a79147930aa725 0x06ca6351e003826f 0x142929670a0e6e70
0x27b70a8546d22ffc 0x2e1b21385c26c926 0x4d2c6dfc5ac42aed 0x53380d139d95b3df
0x650a73548baf63de 0x766a0abb3c77b2a8 0x81c2c92e47edaee6 0x92722c851482353b
0xa2bfe8a14cf10364 0xa81a664bbc423001 0xc24b8b70d0f89791 0xc76c51a30654be30
0xd192e819d6ef5218 0xd69906245565a910 0xf40e35855771202a 0x106aa07032bbd1b8
0x19a4c116b8d2d0c8 0x1e376c085141ab53 0x2748774cdf8eeb99 0x34b0bcb5e19b48a8
0x391c0cb3c5c95a63 0x4ed8aa4ae3418acb 0x5b9cca4f7763e373 0x682e6ff3d6b2b8a3
0x748f82ee5defb2fc 0x78a5636f43172f60 0x84c87814a1f0ab72 0x8cc702081a6439ec
0x90befffa23631e28 0xa4506cebde82bde9 0xbef9a3f7b2c67915 0xc67178f2e372532b
0xca273eceea26619c 0xd186b8c721c0c207 0xeada7dd6cde0eb1e 0xf57d4f7fee6ed178
0x06f067aa72176fba 0x0a637dc5a2c898a6 0x113f9804bef90dae 0x1b710b35131c471b
0x28db77f523047d84 0x32caab7b40c72493 0x3c9ebe0a15c9bebc 0x431d67c49c100d4c
0x4cc5d4becb3e42b6 0x597f299cfc657e2a 0x5fcb6fab3ad6faec 0x6c44198c4a475817
}

4
basis/cocoa/runtime/runtime.factor
View File

@ -70,7 +70,7 @@ FUNCTION: void* method_getTypeEncoding ( Method method ) ;
FUNCTION: SEL method_getName ( Method method ) ;
FUNCTION: void* method_setImplementation ( Method method, void* imp ) ;
FUNCTION: void* method_getImplementation ( Method method ) ;
FUNCTION: void* method_setImplementation ( Method method, void* imp ) ;
FUNCTION: void* method_getImplementation ( Method method ) ;
FUNCTION: Class object_getClass ( id object ) ;

2
basis/combinators/smart/smart.factor
View File

@ -66,7 +66,7 @@ M: object infer-known* drop f ;
: output>array ( quot -- array )
{ } output>sequence ; inline
: cleave>array ( obj quots -- array )
'[ _ cleave ] output>array ; inline

1
basis/command-line/startup/startup.factor
View File

@ -42,4 +42,3 @@ from within Factor for more information.
output-stream get [ stream-flush ] when*
0 exit ;

19
basis/compiler/cfg/comparisons/comparisons.factor
View File

@ -6,7 +6,7 @@ IN: compiler.cfg.comparisons
SYMBOL: +unordered+
SYMBOLS:
cc< cc<= cc= cc> cc>= cc<> cc<>=
cc< cc<= cc= cc> cc>= cc<> cc<>=
cc/< cc/<= cc/= cc/> cc/>= cc/<> cc/<>= ;
SYMBOLS:
@ -23,12 +23,12 @@ SYMBOLS: cc-o cc/o ;
{ cc= cc/= }
{ cc<> cc/<> }
{ cc<>= cc/<>= }
{ cc/< cc< }
{ cc/< cc< }
{ cc/<= cc<= }
{ cc/> cc> }
{ cc/>= cc>= }
{ cc/= cc= }
{ cc/<> cc<> }
{ cc/>= cc>= }
{ cc/= cc= }
{ cc/<> cc<> }
{ cc/<>= cc<>= }
{ cc-o cc/o }
{ cc/o cc-o }
@ -69,12 +69,12 @@ SYMBOLS: cc-o cc/o ;
{ cc= cc= }
{ cc<> cc/= }
{ cc<>= t }
{ cc/< cc>= }
{ cc/< cc>= }
{ cc/<= cc> }
{ cc/> cc<= }
{ cc/>= cc< }
{ cc/= cc/= }
{ cc/<> cc= }
{ cc/>= cc< }
{ cc/= cc/= }
{ cc/<> cc= }
{ cc/<>= f }
} at ;
@ -95,4 +95,3 @@ SYMBOLS: cc-o cc/o ;
{ cc/<> { +eq+ +unordered+ } }
{ cc/<>= { +unordered+ } }
} at member-eq? ;

2
basis/compiler/cfg/value-numbering/expressions/expressions.factor
View File

@ -26,7 +26,7 @@ GENERIC: >expr ( insn -- expr )
: narray-quot ( length -- quot )
[
[ , [ f <array> ] % ]
[
[
dup iota [
- 1 - , [ swap [ set-array-nth ] keep ] %
] with each

2
basis/compiler/cfg/value-numbering/simd/simd.factor
View File

@ -125,7 +125,7 @@ M: ##not-vector vector-not-src
M: ##xor-vector vector-not-src
dup src1>> vreg>insn ##fill-vector? [ src2>> ] [ src1>> ] if ;
M: ##and-vector rewrite
M: ##and-vector rewrite
{
{ [ dup src1>> vreg>insn vector-not? ] [
{

1
basis/compiler/errors/errors.factor
View File

@ -79,4 +79,3 @@ T{ error-type-holder
{ quot [ user-init-errors get-global values ] }
{ forget-quot [ user-init-errors get-global delete-at ] }
} define-error-type

72
basis/compiler/tests/redefine25.factor
View File

@ -1,36 +1,36 @@
USING: tools.test compiler.units classes.mixin definitions
kernel kernel.private ;
IN: compiler.tests.redefine25
MIXIN: empty-mixin
: empty-mixin-test-1 ( a -- ? ) empty-mixin? ;
TUPLE: a-superclass ;
: empty-mixin-test-2 ( a -- ? ) { a-superclass } declare empty-mixin? ;
TUPLE: empty-mixin-member < a-superclass ;
[ f ] [ empty-mixin-member new empty-mixin? ] unit-test
[ f ] [ empty-mixin-member new empty-mixin-test-1 ] unit-test
[ f ] [ empty-mixin-member new empty-mixin-test-2 ] unit-test
[ ] [
[
\ empty-mixin-member \ empty-mixin add-mixin-instance
] with-compilation-unit
] unit-test
[ t ] [ empty-mixin-member new empty-mixin? ] unit-test
[ t ] [ empty-mixin-member new empty-mixin-test-1 ] unit-test
[ t ] [ empty-mixin-member new empty-mixin-test-2 ] unit-test
[ ] [
[
\ empty-mixin forget
\ empty-mixin-member forget
\ empty-mixin-test-1 forget
\ empty-mixin-test-2 forget
] with-compilation-unit
] unit-test
USING: tools.test compiler.units classes.mixin definitions
kernel kernel.private ;
IN: compiler.tests.redefine25
MIXIN: empty-mixin
: empty-mixin-test-1 ( a -- ? ) empty-mixin? ;
TUPLE: a-superclass ;
: empty-mixin-test-2 ( a -- ? ) { a-superclass } declare empty-mixin? ;
TUPLE: empty-mixin-member < a-superclass ;
[ f ] [ empty-mixin-member new empty-mixin? ] unit-test
[ f ] [ empty-mixin-member new empty-mixin-test-1 ] unit-test
[ f ] [ empty-mixin-member new empty-mixin-test-2 ] unit-test
[ ] [
[
\ empty-mixin-member \ empty-mixin add-mixin-instance
] with-compilation-unit
] unit-test
[ t ] [ empty-mixin-member new empty-mixin? ] unit-test
[ t ] [ empty-mixin-member new empty-mixin-test-1 ] unit-test
[ t ] [ empty-mixin-member new empty-mixin-test-2 ] unit-test
[ ] [
[
\ empty-mixin forget
\ empty-mixin-member forget
\ empty-mixin-test-1 forget
\ empty-mixin-test-2 forget
] with-compilation-unit
] unit-test

1
basis/compiler/tree/dead-code/dead-code.factor
View File

@ -11,4 +11,3 @@ IN: compiler.tree.dead-code
mark-live-values
compute-live-values
(remove-dead-code) ;

4
basis/compiler/tree/debugger/debugger.factor
View File

@ -55,7 +55,7 @@ MATCH-VARS: ?a ?b ?c ;
TUPLE: shuffle-node { effect effect } ;
M: shuffle-node pprint* effect>> effect>string text ;
: (shuffle-effect) ( in out #shuffle -- effect )
mapping>> '[ _ at ] map [ >array ] bi@ <effect> ;
@ -214,7 +214,7 @@ SYMBOL: node-count
compute-def-use
remove-dead-code
compute-def-use
optimize-modular-arithmetic
optimize-modular-arithmetic
] with-scope ;
: inlined? ( quot seq/word -- ? )

2
basis/compiler/tree/propagation/simple/simple.factor
View File

@ -148,7 +148,7 @@ M: #call propagate-before
dup word>> {
{ [ 2dup foldable-call? ] [ fold-call ] }
{ [ 2dup do-inlining ] [
[ output-value-infos ] [ drop out-d>> ] 2bi refine-value-infos
[ output-value-infos ] [ drop out-d>> ] 2bi refine-value-infos
] }
[
[ [ output-value-infos ] [ drop out-d>> ] 2bi set-value-infos ]

150
basis/compression/huffman/huffman.factor
View File

@ -1,75 +1,75 @@
! Copyright (C) 2009 Marc Fauconneau.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs fry
hashtables io kernel locals math math.order math.parser
math.ranges multiline sequences bitstreams bit-arrays ;
IN: compression.huffman
QUALIFIED-WITH: bitstreams bs
<PRIVATE
TUPLE: huffman-code
{ value fixnum }
{ size fixnum }
{ code fixnum } ;
: <huffman-code> ( -- huffman-code )
0 0 0 huffman-code boa ; inline
: next-size ( huffman-code -- )
[ 1 + ] change-size
[ 2 * ] change-code drop ; inline
: next-code ( huffman-code -- )
[ 1 + ] change-code drop ; inline
:: all-patterns ( huffman-code n -- seq )
n log2 huffman-code size>> - :> free-bits
free-bits 0 >
[ free-bits 2^ iota [ huffman-code code>> free-bits 2^ * + ] map ]
[ huffman-code code>> free-bits neg 2^ /i 1array ] if ;
:: huffman-each ( ... tdesc quot: ( ... huffman-code -- ... ) -- ... )
<huffman-code> :> code
tdesc
[
code next-size
[ code value<< code clone quot call code next-code ] each
] each ; inline
: update-reverse-table ( huffman-code n table -- )
[ drop all-patterns ]
[ nip '[ _ swap _ set-at ] each ] 3bi ;
:: reverse-table ( tdesc n -- rtable )
n f <array> <enum> :> table
tdesc [ n table update-reverse-table ] huffman-each
table seq>> ;
PRIVATE>
TUPLE: huffman-decoder
{ bs bit-reader }
{ tdesc array }
{ rtable array }
{ bits/level fixnum } ;
: <huffman-decoder> ( bs tdesc -- huffman-decoder )
huffman-decoder new
swap >>tdesc
swap >>bs
16 >>bits/level
dup [ tdesc>> ] [ bits/level>> 2^ ] bi reverse-table >>rtable ; inline
: read1-huff ( huffman-decoder -- elt )
16 over [ bs>> bs:peek ] [ rtable>> nth ] bi
[ size>> swap bs>> bs:seek ] [ value>> ] bi ; inline
: reverse-bits ( value bits -- value' )
[ integer>bit-array ] dip
f pad-tail reverse bit-array>integer ; inline
: read1-huff2 ( huffman-decoder -- elt )
16 over [ bs>> bs:peek 16 reverse-bits ] [ rtable>> nth ] bi
[ size>> swap bs>> bs:seek ] [ value>> ] bi ; inline
! Copyright (C) 2009 Marc Fauconneau.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs fry
hashtables io kernel locals math math.order math.parser
math.ranges multiline sequences bitstreams bit-arrays ;
IN: compression.huffman
QUALIFIED-WITH: bitstreams bs
<PRIVATE
TUPLE: huffman-code
{ value fixnum }
{ size fixnum }
{ code fixnum } ;
: <huffman-code> ( -- huffman-code )
0 0 0 huffman-code boa ; inline
: next-size ( huffman-code -- )
[ 1 + ] change-size
[ 2 * ] change-code drop ; inline
: next-code ( huffman-code -- )
[ 1 + ] change-code drop ; inline
:: all-patterns ( huffman-code n -- seq )
n log2 huffman-code size>> - :> free-bits
free-bits 0 >
[ free-bits 2^ iota [ huffman-code code>> free-bits 2^ * + ] map ]
[ huffman-code code>> free-bits neg 2^ /i 1array ] if ;
:: huffman-each ( ... tdesc quot: ( ... huffman-code -- ... ) -- ... )
<huffman-code> :> code
tdesc
[
code next-size
[ code value<< code clone quot call code next-code ] each
] each ; inline
: update-reverse-table ( huffman-code n table -- )
[ drop all-patterns ]
[ nip '[ _ swap _ set-at ] each ] 3bi ;
:: reverse-table ( tdesc n -- rtable )
n f <array> <enum> :> table
tdesc [ n table update-reverse-table ] huffman-each
table seq>> ;
PRIVATE>
TUPLE: huffman-decoder
{ bs bit-reader }
{ tdesc array }
{ rtable array }
{ bits/level fixnum } ;
: <huffman-decoder> ( bs tdesc -- huffman-decoder )
huffman-decoder new
swap >>tdesc
swap >>bs
16 >>bits/level
dup [ tdesc>> ] [ bits/level>> 2^ ] bi reverse-table >>rtable ; inline
: read1-huff ( huffman-decoder -- elt )
16 over [ bs>> bs:peek ] [ rtable>> nth ] bi
[ size>> swap bs>> bs:seek ] [ value>> ] bi ; inline
: reverse-bits ( value bits -- value' )
[ integer>bit-array ] dip
f pad-tail reverse bit-array>integer ; inline
: read1-huff2 ( huffman-decoder -- elt )
16 over [ bs>> bs:peek 16 reverse-bits ] [ rtable>> nth ] bi
[ size>> swap bs>> bs:seek ] [ value>> ] bi ; inline

2
basis/compression/inflate/inflate.factor
View File

@ -34,7 +34,7 @@ CONSTANT: clen-shuffle { 16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15 }
:: decode-huffman-tables ( bitstream -- tables )
5 bitstream bs:read 257 +
5 bitstream bs:read 1 +
4 bitstream bs:read 4 + clen-shuffle swap head
4 bitstream bs:read 4 + clen-shuffle swap head
dup length [ 3 bitstream bs:read ] replicate
get-table

4
basis/compression/run-length/run-length.factor
View File

@ -36,7 +36,7 @@ IN: compression.run-length
[ sp next 8hi-lo 2array <repetition> concat ] [ head ] bi
[ j matrix i swap nth copy ] [ length j + j! ] bi
] if
! j stride >= [ i 1 + i! 0 j! ] when
j stride >= [ 0 j! ] when
done? not
@ -67,7 +67,7 @@ IN: compression.run-length
] [
sp next <array> [ j matrix i swap nth copy ] [ length j + j! ] bi
] if
! j stride >= [ i 1 + i! 0 j! ] when
j stride >= [ 0 j! ] when
done? not

3
basis/compression/snappy/ffi/ffi.factor
View File

@ -31,5 +31,4 @@ FUNCTION: snappy_status snappy_uncompressed_length ( char* compressed,
size_t* result ) ;
FUNCTION: snappy_status snappy_validate_compressed_buffer ( char* compressed,
size_t compressed_length ) ;
size_t compressed_length ) ;

3
basis/compression/snappy/snappy.factor
View File

@ -27,7 +27,6 @@ PRIVATE>
over
dup length 0 size_t <ref>
[ snappy_uncompressed_length check-snappy ] keep
size_t deref
size_t deref
n>outs
[ snappy_uncompress check-snappy ] 2keep drop >byte-array ;

110
basis/concurrency/combinators/combinators-docs.factor
View File

@ -1,55 +1,55 @@
USING: help.markup help.syntax sequences ;
IN: concurrency.combinators
HELP: parallel-map
{ $values { "seq" sequence } { "quot" { $quotation ( elt -- newelt ) } } { "newseq" sequence } }
{ $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", collecting the results at the end." }
{ $errors "Throws an error if one of the iterations throws an error." } ;
HELP: 2parallel-map
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation ( elt1 elt2 -- newelt ) } } { "newseq" sequence } }
{ $description "Spawns a new thread for applying " { $snippet "quot" } " to pairwise elements of " { $snippet "seq1" } " and " { $snippet "seq2" } ", collecting the results at the end." }
{ $errors "Throws an error if one of the iterations throws an error." } ;
HELP: parallel-each
{ $values { "seq" sequence } { "quot" { $quotation ( elt -- ) } } }
{ $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", blocking until all quotations complete." }
{ $errors "Throws an error if one of the iterations throws an error." } ;
HELP: 2parallel-each
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation ( elt1 elt2 -- ) } } }
{ $description "Spawns a new thread for applying " { $snippet "quot" } " to pairwise elements of " { $snippet "seq1" } " and " { $snippet "seq2" } ", blocking until all quotations complete." }
{ $errors "Throws an error if one of the iterations throws an error." } ;
HELP: parallel-filter
{ $values { "seq" sequence } { "quot" { $quotation ( elt -- ? ) } } { "newseq" sequence } }
{ $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", collecting the elements for which the quotation yielded a true value." }
{ $errors "Throws an error if one of the iterations throws an error." } ;
ARTICLE: "concurrency.combinators" "Concurrent combinators"
"The " { $vocab-link "concurrency.combinators" } " vocabulary provides concurrent variants of various combinators."
$nl
"Concurrent sequence combinators:"
{ $subsections
parallel-each
2parallel-each
parallel-map
2parallel-map
parallel-filter
}
"Concurrent product sequence combinators:"
{ $subsections
parallel-product-each
parallel-cartesian-each
parallel-product-map
parallel-cartesian-map
}
"Concurrent cleave combinators:"
{ $subsections
parallel-cleave
parallel-spread
parallel-napply
}
"The " { $vocab-link "concurrency.semaphores" } " vocabulary can be used in conjunction with the above combinators to limit the maximum number of concurrent operations." ;
ABOUT: "concurrency.combinators"
USING: help.markup help.syntax sequences ;
IN: concurrency.combinators
HELP: parallel-map
{ $values { "seq" sequence } { "quot" { $quotation ( elt -- newelt ) } } { "newseq" sequence } }
{ $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", collecting the results at the end." }
{ $errors "Throws an error if one of the iterations throws an error." } ;
HELP: 2parallel-map
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation ( elt1 elt2 -- newelt ) } } { "newseq" sequence } }
{ $description "Spawns a new thread for applying " { $snippet "quot" } " to pairwise elements of " { $snippet "seq1" } " and " { $snippet "seq2" } ", collecting the results at the end." }
{ $errors "Throws an error if one of the iterations throws an error." } ;
HELP: parallel-each
{ $values { "seq" sequence } { "quot" { $quotation ( elt -- ) } } }
{ $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", blocking until all quotations complete." }
{ $errors "Throws an error if one of the iterations throws an error." } ;
HELP: 2parallel-each
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation ( elt1 elt2 -- ) } } }
{ $description "Spawns a new thread for applying " { $snippet "quot" } " to pairwise elements of " { $snippet "seq1" } " and " { $snippet "seq2" } ", blocking until all quotations complete." }
{ $errors "Throws an error if one of the iterations throws an error." } ;
HELP: parallel-filter
{ $values { "seq" sequence } { "quot" { $quotation ( elt -- ? ) } } { "newseq" sequence } }
{ $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", collecting the elements for which the quotation yielded a true value." }
{ $errors "Throws an error if one of the iterations throws an error." } ;
ARTICLE: "concurrency.combinators" "Concurrent combinators"
"The " { $vocab-link "concurrency.combinators" } " vocabulary provides concurrent variants of various combinators."
$nl
"Concurrent sequence combinators:"
{ $subsections
parallel-each
2parallel-each
parallel-map
2parallel-map
parallel-filter
}
"Concurrent product sequence combinators:"
{ $subsections
parallel-product-each
parallel-cartesian-each
parallel-product-map
parallel-cartesian-map
}
"Concurrent cleave combinators:"
{ $subsections
parallel-cleave
parallel-spread
parallel-napply
}
"The " { $vocab-link "concurrency.semaphores" } " vocabulary can be used in conjunction with the above combinators to limit the maximum number of concurrent operations." ;
ABOUT: "concurrency.combinators"

122
basis/concurrency/combinators/combinators-tests.factor
View File

@ -1,61 +1,61 @@
USING: concurrency.combinators tools.test random kernel math
concurrency.mailboxes threads sequences accessors arrays
math.parser ;
IN: concurrency.combinators.tests
[ [ drop ] parallel-each ] must-infer
{ 2 0 } [ [ 2drop ] 2parallel-each ] must-infer-as
[ [ ] parallel-map ] must-infer
{ 2 1 } [ [ 2array ] 2parallel-map ] must-infer-as
[ [ ] parallel-filter ] must-infer
[ { 1 4 9 } ] [ { 1 2 3 } [ sq ] parallel-map ] unit-test
[ { 1 4 9 } ] [ { 1 2 3 } [ 1000000 random sleep sq ] parallel-map ] unit-test
[ { 1 2 3 } [ dup 2 mod 0 = [ "Even" throw ] when ] parallel-map ]
[ error>> "Even" = ] must-fail-with
[ V{ 0 3 6 9 } ]
[ 10 iota [ 3 mod zero? ] parallel-filter ] unit-test
[ 10 ]
[
V{ } clone
10 iota over [ push ] curry parallel-each
length
] unit-test
[ { 10 20 30 } ] [
{ 1 4 3 } { 10 5 10 } [ * ] 2parallel-map
] unit-test
[ { -9 -1 -7 } ] [
{ 1 4 3 } { 10 5 10 } [ - ] 2parallel-map
] unit-test
[
{ 1 4 3 } { 1 0 1 } [ / drop ] 2parallel-each
] must-fail
[ 20 ]
[
V{ } clone
10 iota 10 iota pick [ [ push ] [ push ] bi ] curry 2parallel-each
length
] unit-test
[ { f } [ "OOPS" throw ] parallel-each ] must-fail
[ "1a" "4b" "3c" ] [
2
{ [ 1 - ] [ sq ] [ 1 + ] } parallel-cleave
[ number>string ] 3 parallel-napply
{ [ "a" append ] [ "b" append ] [ "c" append ] } parallel-spread
] unit-test
{ H{ { 0 4 } { 2 6 } { 4 8 } } } [
H{ { 1 2 } { 3 4 } { 5 6 } } [
[ 1 - ] [ 2 + ] bi*
] parallel-assoc-map
] unit-test
USING: concurrency.combinators tools.test random kernel math
concurrency.mailboxes threads sequences accessors arrays
math.parser ;
IN: concurrency.combinators.tests
[ [ drop ] parallel-each ] must-infer
{ 2 0 } [ [ 2drop ] 2parallel-each ] must-infer-as
[ [ ] parallel-map ] must-infer
{ 2 1 } [ [ 2array ] 2parallel-map ] must-infer-as
[ [ ] parallel-filter ] must-infer
[ { 1 4 9 } ] [ { 1 2 3 } [ sq ] parallel-map ] unit-test
[ { 1 4 9 } ] [ { 1 2 3 } [ 1000000 random sleep sq ] parallel-map ] unit-test
[ { 1 2 3 } [ dup 2 mod 0 = [ "Even" throw ] when ] parallel-map ]
[ error>> "Even" = ] must-fail-with
[ V{ 0 3 6 9 } ]
[ 10 iota [ 3 mod zero? ] parallel-filter ] unit-test
[ 10 ]
[
V{ } clone
10 iota over [ push ] curry parallel-each
length
] unit-test
[ { 10 20 30 } ] [
{ 1 4 3 } { 10 5 10 } [ * ] 2parallel-map
] unit-test
[ { -9 -1 -7 } ] [
{ 1 4 3 } { 10 5 10 } [ - ] 2parallel-map
] unit-test
[
{ 1 4 3 } { 1 0 1 } [ / drop ] 2parallel-each
] must-fail
[ 20 ]
[
V{ } clone
10 iota 10 iota pick [ [ push ] [ push ] bi ] curry 2parallel-each
length
] unit-test
[ { f } [ "OOPS" throw ] parallel-each ] must-fail
[ "1a" "4b" "3c" ] [
2
{ [ 1 - ] [ sq ] [ 1 + ] } parallel-cleave
[ number>string ] 3 parallel-napply
{ [ "a" append ] [ "b" append ] [ "c" append ] } parallel-spread
] unit-test
{ H{ { 0 4 } { 2 6 } { 4 8 } } } [
H{ { 1 2 } { 3 4 } { 5 6 } } [
[ 1 - ] [ 2 + ] bi*
] parallel-assoc-map
] unit-test

68
basis/concurrency/conditions/conditions.factor
View File

@ -1,34 +1,34 @@
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: deques threads kernel arrays sequences timers fry ;
IN: concurrency.conditions
: notify-1 ( deque -- )
dup deque-empty? [ drop ] [ pop-back resume-now ] if ; inline
: notify-all ( deque -- )
[ resume-now ] slurp-deque ; inline
: queue-timeout ( queue timeout -- timer )
#! Add an timer which removes the current thread from the
#! queue, and resumes it, passing it a value of t.
[
[ self swap push-front* ] keep '[
_ _
[ delete-node ] [ drop node-value ] 2bi
t swap resume-with
]
] dip later ;
ERROR: timed-out-error timer ;
: queue ( queue -- )
[ self ] dip push-front ; inline
: wait ( queue timeout status -- )
over [
[ queue-timeout ] dip suspend
[ timed-out-error ] [ stop-timer ] if
] [
[ drop queue ] dip suspend drop
] if ; inline
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: deques threads kernel arrays sequences timers fry ;
IN: concurrency.conditions
: notify-1 ( deque -- )
dup deque-empty? [ drop ] [ pop-back resume-now ] if ; inline
: notify-all ( deque -- )
[ resume-now ] slurp-deque ; inline
: queue-timeout ( queue timeout -- timer )
#! Add an timer which removes the current thread from the
#! queue, and resumes it, passing it a value of t.
[
[ self swap push-front* ] keep '[
_ _
[ delete-node ] [ drop node-value ] 2bi
t swap resume-with
]
] dip later ;
ERROR: timed-out-error timer ;
: queue ( queue -- )
[ self ] dip push-front ; inline
: wait ( queue timeout status -- )
over [
[ queue-timeout ] dip suspend
[ timed-out-error ] [ stop-timer ] if
] [
[ drop queue ] dip suspend drop
] if ; inline

54
basis/concurrency/count-downs/count-downs-docs.factor
View File

@ -1,27 +1,27 @@
USING: help.markup help.syntax sequences ;
IN: concurrency.count-downs
HELP: <count-down>
{ $values { "n" "a non-negative integer" } { "count-down" count-down } }
{ $description "Creates a new count-down latch." }
{ $errors "Throws an error if the count is lower than zero." } ;
HELP: count-down
{ $values { "count-down" count-down } }
{ $description "Decrements a count-down latch. If it reaches zero, all threads blocking on " { $link await } " are notified." }
{ $errors "Throws an error if an attempt is made to decrement the count lower than zero." } ;
HELP: await
{ $values { "count-down" count-down } }
{ $description "Waits until the count-down value reaches zero." } ;
ARTICLE: "concurrency.count-downs" "Count-down latches"
"The " { $vocab-link "concurrency.count-downs" } " vocabulary implements the " { $emphasis "count-down latch" } " data type, which is a wrapper for a non-negative integer value which tends towards zero. A thread can either decrement the value, or wait for it to become zero."
{ $subsections
<count-down>
count-down
await
}
"The vocabulary was modelled after a similar feature in Java's " { $snippet "java.util.concurrent" } " library." ;
ABOUT: "concurrency.count-downs"
USING: help.markup help.syntax sequences ;
IN: concurrency.count-downs
HELP: <count-down>
{ $values { "n" "a non-negative integer" } { "count-down" count-down } }
{ $description "Creates a new count-down latch." }
{ $errors "Throws an error if the count is lower than zero." } ;
HELP: count-down
{ $values { "count-down" count-down } }
{ $description "Decrements a count-down latch. If it reaches zero, all threads blocking on " { $link await } " are notified." }
{ $errors "Throws an error if an attempt is made to decrement the count lower than zero." } ;
HELP: await
{ $values { "count-down" count-down } }
{ $description "Waits until the count-down value reaches zero." } ;
ARTICLE: "concurrency.count-downs" "Count-down latches"
"The " { $vocab-link "concurrency.count-downs" } " vocabulary implements the " { $emphasis "count-down latch" } " data type, which is a wrapper for a non-negative integer value which tends towards zero. A thread can either decrement the value, or wait for it to become zero."
{ $subsections
<count-down>
count-down
await
}
"The vocabulary was modelled after a similar feature in Java's " { $snippet "java.util.concurrent" } " library." ;
ABOUT: "concurrency.count-downs"

32
basis/concurrency/count-downs/count-downs-tests.factor
View File

@ -1,16 +1,16 @@
USING: concurrency.count-downs threads kernel tools.test ;
IN: concurrency.count-downs.tests`
[ ] [ 0 <count-down> await ] unit-test
[ 1 <count-down> dup count-down count-down ] must-fail
[ ] [
1 <count-down>
3 <count-down>
2dup [ await count-down ] 2curry "Master" spawn drop
dup [ count-down ] curry "Slave" spawn drop
dup [ count-down ] curry "Slave" spawn drop
dup [ count-down ] curry "Slave" spawn drop
drop await
] unit-test
USING: concurrency.count-downs threads kernel tools.test ;
IN: concurrency.count-downs.tests`
[ ] [ 0 <count-down> await ] unit-test
[ 1 <count-down> dup count-down count-down ] must-fail
[ ] [
1 <count-down>
3 <count-down>
2dup [ await count-down ] 2curry "Master" spawn drop
dup [ count-down ] curry "Slave" spawn drop
dup [ count-down ] curry "Slave" spawn drop
dup [ count-down ] curry "Slave" spawn drop
drop await
] unit-test

74
basis/concurrency/count-downs/count-downs.factor
View File

@ -1,37 +1,37 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: dlists kernel math concurrency.promises
concurrency.mailboxes accessors fry ;
IN: concurrency.count-downs
! http://java.sun.com/j2se/1.5.0/docs/api/java/util/concurrent/CountDownLatch.html
TUPLE: count-down-tuple n promise ;
: count-down-check ( count-down -- )
dup n>> zero? [ t swap promise>> fulfill ] [ drop ] if ;
ERROR: invalid-count-down-count count ;
: <count-down> ( n -- count-down )
dup 0 < [ invalid-count-down-count ] when
<promise> \ count-down-tuple boa
dup count-down-check ;
ERROR: count-down-already-done ;
: count-down ( count-down -- )
dup n>> dup zero?
[ count-down-already-done ]
[ 1 - >>n count-down-check ] if ;
: await-timeout ( count-down timeout -- )
[ promise>> ] dip ?promise-timeout ?linked t assert= ;
: await ( count-down -- )
f await-timeout ;
: spawn-stage ( quot count-down -- )
[ '[ @ _ count-down ] ] keep
"Count down stage"
swap promise>> mailbox>> spawn-linked-to drop ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: dlists kernel math concurrency.promises
concurrency.mailboxes accessors fry ;
IN: concurrency.count-downs
! http://java.sun.com/j2se/1.5.0/docs/api/java/util/concurrent/CountDownLatch.html
TUPLE: count-down-tuple n promise ;
: count-down-check ( count-down -- )
dup n>> zero? [ t swap promise>> fulfill ] [ drop ] if ;
ERROR: invalid-count-down-count count ;
: <count-down> ( n -- count-down )
dup 0 < [ invalid-count-down-count ] when
<promise> \ count-down-tuple boa
dup count-down-check ;
ERROR: count-down-already-done ;
: count-down ( count-down -- )
dup n>> dup zero?
[ count-down-already-done ]
[ 1 - >>n count-down-check ] if ;
: await-timeout ( count-down timeout -- )
[ promise>> ] dip ?promise-timeout ?linked t assert= ;
: await ( count-down -- )
f await-timeout ;
: spawn-stage ( quot count-down -- )
[ '[ @ _ count-down ] ] keep
"Count down stage"
swap promise>> mailbox>> spawn-linked-to drop ;

52
basis/concurrency/exchangers/exchangers-docs.factor
View File

@ -1,26 +1,26 @@
USING: help.markup help.syntax sequences kernel ;
IN: concurrency.exchangers
HELP: exchanger
{ $class-description "The class of object exchange points." } ;
HELP: <exchanger>
{ $values { "exchanger" exchanger } }
{ $description "Creates a new object exchange point." } ;
HELP: exchange
{ $values { "obj" object } { "exchanger" exchanger } { "newobj" object } }
{ $description "Waits for another thread to call " { $link exchange } " on the same exchanger. The thread's call to " { $link exchange } " returns with " { $snippet "obj" } " on the stack, and the object passed to " { $link exchange } " by the other thread is left on the current's thread stack as " { $snippet "newobj" } "." } ;
ARTICLE: "concurrency.exchangers" "Object exchange points"
"The " { $vocab-link "concurrency.exchangers" } " vocabulary implements " { $emphasis "object exchange points" } ", which are rendezvous points where two threads can exchange objects."
{ $subsections
exchanger
<exchanger>
exchange
}
"One use-case is two threads, where one thread reads data into a buffer and another thread processes the data. The reader thread can begin by reading the data, then passing the buffer through an exchanger, then recursing. The processing thread can begin by creating an empty buffer, and exchanging it through the exchanger. It then processes the result and recurses."
$nl
"The vocabulary was modelled after a similar feature in Java's " { $snippet "java.util.concurrent" } " library." ;
ABOUT: "concurrency.exchangers"
USING: help.markup help.syntax sequences kernel ;
IN: concurrency.exchangers
HELP: exchanger
{ $class-description "The class of object exchange points." } ;
HELP: <exchanger>
{ $values { "exchanger" exchanger } }
{ $description "Creates a new object exchange point." } ;
HELP: exchange
{ $values { "obj" object } { "exchanger" exchanger } { "newobj" object } }
{ $description "Waits for another thread to call " { $link exchange } " on the same exchanger. The thread's call to " { $link exchange } " returns with " { $snippet "obj" } " on the stack, and the object passed to " { $link exchange } " by the other thread is left on the current's thread stack as " { $snippet "newobj" } "." } ;
ARTICLE: "concurrency.exchangers" "Object exchange points"
"The " { $vocab-link "concurrency.exchangers" } " vocabulary implements " { $emphasis "object exchange points" } ", which are rendezvous points where two threads can exchange objects."
{ $subsections
exchanger
<exchanger>
exchange
}
"One use-case is two threads, where one thread reads data into a buffer and another thread processes the data. The reader thread can begin by reading the data, then passing the buffer through an exchanger, then recursing. The processing thread can begin by creating an empty buffer, and exchanging it through the exchanger. It then processes the result and recurses."
$nl
"The vocabulary was modelled after a similar feature in Java's " { $snippet "java.util.concurrent" } " library." ;
ABOUT: "concurrency.exchangers"

58
basis/concurrency/exchangers/exchangers-tests.factor
View File

@ -1,29 +1,29 @@
USING: tools.test concurrency.exchangers
concurrency.count-downs concurrency.promises locals kernel
threads ;
FROM: sequences => 3append ;
IN: concurrency.exchangers.tests
:: exchanger-test ( -- string )
<exchanger> :> ex
2 <count-down> :> c
f :> v1!
f :> v2!
<promise> :> pr
[
c await
v1 ", " v2 3append pr fulfill
] "Awaiter" spawn drop
[
"Goodbye world" ex exchange v1! c count-down
] "Exchanger 1" spawn drop
[
"Hello world" ex exchange v2! c count-down
] "Exchanger 2" spawn drop
pr ?promise ;
[ "Hello world, Goodbye world" ] [ exchanger-test ] unit-test
USING: tools.test concurrency.exchangers
concurrency.count-downs concurrency.promises locals kernel
threads ;
FROM: sequences => 3append ;
IN: concurrency.exchangers.tests
:: exchanger-test ( -- string )
<exchanger> :> ex
2 <count-down> :> c
f :> v1!
f :> v2!
<promise> :> pr
[
c await
v1 ", " v2 3append pr fulfill
] "Awaiter" spawn drop
[
"Goodbye world" ex exchange v1! c count-down
] "Exchanger 1" spawn drop
[
"Hello world" ex exchange v2! c count-down
] "Exchanger 2" spawn drop
pr ?promise ;
[ "Hello world, Goodbye world" ] [ exchanger-test ] unit-test

44
basis/concurrency/exchangers/exchangers.factor
View File

@ -1,22 +1,22 @@
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel threads boxes accessors fry ;
IN: concurrency.exchangers
! Motivated by
! http://java.sun.com/j2se/1.5.0/docs/api/java/util/concurrent/Exchanger.html
TUPLE: exchanger thread object ;
: <exchanger> ( -- exchanger )
<box> <box> exchanger boa ;
: exchange ( obj exchanger -- newobj )
dup thread>> occupied>> [
dup object>> box>
[ thread>> box> resume-with ] dip
] [
[ object>> >box ] keep
[ self ] dip thread>> >box
"exchange" suspend
] if ;
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel threads boxes accessors fry ;
IN: concurrency.exchangers
! Motivated by
! http://java.sun.com/j2se/1.5.0/docs/api/java/util/concurrent/Exchanger.html
TUPLE: exchanger thread object ;
: <exchanger> ( -- exchanger )
<box> <box> exchanger boa ;
: exchange ( obj exchanger -- newobj )
dup thread>> occupied>> [
dup object>> box>
[ thread>> box> resume-with ] dip
] [
[ object>> >box ] keep
[ self ] dip thread>> >box
"exchange" suspend
] if ;

96
basis/concurrency/flags/flags-tests.factor
View File

@ -1,48 +1,48 @@
USING: tools.test concurrency.flags concurrency.combinators
kernel threads locals accessors calendar ;
IN: concurrency.flags.tests
:: flag-test-1 ( -- val )
<flag> :> f
[ f raise-flag ] "Flag test" spawn drop
f lower-flag
f value>> ;
[ f ] [ flag-test-1 ] unit-test
:: flag-test-2 ( -- ? )
<flag> :> f
[ 1 seconds sleep f raise-flag ] "Flag test" spawn drop
f lower-flag
f value>> ;
[ f ] [ flag-test-2 ] unit-test
:: flag-test-3 ( -- val )
<flag> :> f
f raise-flag
f value>> ;
[ t ] [ flag-test-3 ] unit-test
:: flag-test-4 ( -- val )
<flag> :> f
[ f raise-flag ] "Flag test" spawn drop
f wait-for-flag
f value>> ;
[ t ] [ flag-test-4 ] unit-test
:: flag-test-5 ( -- val )
<flag> :> f
[ 1 seconds sleep f raise-flag ] "Flag test" spawn drop
f wait-for-flag
f value>> ;
[ t ] [ flag-test-5 ] unit-test
[ ] [
{ 1 2 } <flag>
[ [ 1 seconds sleep raise-flag ] curry "Flag test" spawn drop ]
[ [ wait-for-flag drop ] curry parallel-each ] bi
] unit-test
USING: tools.test concurrency.flags concurrency.combinators
kernel threads locals accessors calendar ;
IN: concurrency.flags.tests
:: flag-test-1 ( -- val )
<flag> :> f
[ f raise-flag ] "Flag test" spawn drop
f lower-flag
f value>> ;
[ f ] [ flag-test-1 ] unit-test
:: flag-test-2 ( -- ? )
<flag> :> f
[ 1 seconds sleep f raise-flag ] "Flag test" spawn drop
f lower-flag
f value>> ;
[ f ] [ flag-test-2 ] unit-test
:: flag-test-3 ( -- val )
<flag> :> f
f raise-flag
f value>> ;
[ t ] [ flag-test-3 ] unit-test
:: flag-test-4 ( -- val )
<flag> :> f
[ f raise-flag ] "Flag test" spawn drop
f wait-for-flag
f value>> ;
[ t ] [ flag-test-4 ] unit-test
:: flag-test-5 ( -- val )
<flag> :> f
[ 1 seconds sleep f raise-flag ] "Flag test" spawn drop
f wait-for-flag
f value>> ;
[ t ] [ flag-test-5 ] unit-test
[ ] [
{ 1 2 } <flag>
[ [ 1 seconds sleep raise-flag ] curry "Flag test" spawn drop ]
[ [ wait-for-flag drop ] curry parallel-each ] bi
] unit-test

62
basis/concurrency/futures/futures-docs.factor
View File

@ -1,31 +1,31 @@
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: concurrency.promises concurrency.messaging kernel arrays
continuations help.markup help.syntax quotations calendar ;
IN: concurrency.futures
HELP: future
{ $values { "quot" { $quotation ( -- value ) } } { "future" future } }
{ $description "Creates a deferred computation."
$nl
"The quotation begins with an empty data stack, an empty catch stack, and a name stack containing the global namespace only. This means that the only way to pass data to the quotation is to partially apply the data, for example using " { $link curry } " or " { $link compose } "." } ;
HELP: ?future-timeout
{ $values { "future" future } { "timeout" { $maybe duration } } { "value" object } }
{ $description "Waits for a deferred computation to complete, blocking indefinitely if " { $snippet "timeout" } " is " { $link f } ", otherwise waiting up to the " { $snippet "timeout" } " before throwing an error." }
{ $errors "Throws an error if the timeout expires before the computation completes. Also throws an error if the future quotation threw an error." } ;
HELP: ?future
{ $values { "future" future } { "value" object } }
{ $description "Waits for a deferred computation to complete, blocking indefinitely." }
{ $errors "Throws an error if future quotation threw an error." } ;
ARTICLE: "concurrency.futures" "Futures"
"The " { $vocab-link "concurrency.futures" } " vocabulary implements " { $emphasis "futures" } ", which are deferred computations performed in a background thread. A thread may create a future, then proceed to perform other tasks, then later wait for the future to complete."
{ $subsections
future
?future
?future-timeout
} ;
ABOUT: "concurrency.futures"
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: concurrency.promises concurrency.messaging kernel arrays
continuations help.markup help.syntax quotations calendar ;
IN: concurrency.futures
HELP: future
{ $values { "quot" { $quotation ( -- value ) } } { "future" future } }
{ $description "Creates a deferred computation."
$nl
"The quotation begins with an empty data stack, an empty catch stack, and a name stack containing the global namespace only. This means that the only way to pass data to the quotation is to partially apply the data, for example using " { $link curry } " or " { $link compose } "." } ;
HELP: ?future-timeout
{ $values { "future" future } { "timeout" { $maybe duration } } { "value" object } }
{ $description "Waits for a deferred computation to complete, blocking indefinitely if " { $snippet "timeout" } " is " { $link f } ", otherwise waiting up to the " { $snippet "timeout" } " before throwing an error." }
{ $errors "Throws an error if the timeout expires before the computation completes. Also throws an error if the future quotation threw an error." } ;
HELP: ?future
{ $values { "future" future } { "value" object } }
{ $description "Waits for a deferred computation to complete, blocking indefinitely." }
{ $errors "Throws an error if future quotation threw an error." } ;
ARTICLE: "concurrency.futures" "Futures"
"The " { $vocab-link "concurrency.futures" } " vocabulary implements " { $emphasis "futures" } ", which are deferred computations performed in a background thread. A thread may create a future, then proceed to perform other tasks, then later wait for the future to complete."
{ $subsections
future
?future
?future-timeout
} ;
ABOUT: "concurrency.futures"

50
basis/concurrency/futures/futures-tests.factor
View File

@ -1,25 +1,25 @@
USING: concurrency.futures kernel tools.test threads ;
IN: concurrency.futures.tests
[ 50 ] [
[ 50 ] future ?future
] unit-test
[
[ "this should propogate" throw ] future ?future
] must-fail
[ ] [
[ "this should not propogate" throw ] future drop
] unit-test
! Race condition with futures
[ 3 3 ] [
[ 3 ] future
dup ?future swap ?future
] unit-test
! Another race
[ 3 ] [
[ 3 yield ] future ?future
] unit-test
USING: concurrency.futures kernel tools.test threads ;
IN: concurrency.futures.tests
[ 50 ] [
[ 50 ] future ?future
] unit-test
[
[ "this should propogate" throw ] future ?future
] must-fail
[ ] [
[ "this should not propogate" throw ] future drop
] unit-test
! Race condition with futures
[ 3 3 ] [
[ 3 ] future
dup ?future swap ?future
] unit-test
! Another race
[ 3 ] [
[ 3 yield ] future ?future
] unit-test

34
basis/concurrency/futures/futures.factor
View File

@ -1,17 +1,17 @@
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: concurrency.promises concurrency.mailboxes kernel arrays
continuations accessors fry ;
IN: concurrency.futures
: future ( quot -- future )
<promise> [
[ '[ @ _ fulfill ] "Future" ] keep
mailbox>> spawn-linked-to drop
] keep ; inline
: ?future-timeout ( future timeout -- value )
?promise-timeout ?linked ;
: ?future ( future -- value )
?promise ?linked ;
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: concurrency.promises concurrency.mailboxes kernel arrays
continuations accessors fry ;
IN: concurrency.futures
: future ( quot -- future )
<promise> [
[ '[ @ _ fulfill ] "Future" ] keep
mailbox>> spawn-linked-to drop
] keep ; inline
: ?future-timeout ( future timeout -- value )
?promise-timeout ?linked ;
: ?future ( future -- value )
?promise ?linked ;

170
basis/concurrency/locks/locks-docs.factor
View File

@ -1,85 +1,85 @@
USING: help.markup help.syntax sequences kernel quotations
calendar ;
IN: concurrency.locks
HELP: lock
{ $class-description "The class of mutual exclusion locks." } ;
HELP: <lock>
{ $values { "lock" lock } }
{ $description "Creates a non-reentrant lock." } ;
HELP: <reentrant-lock>
{ $values { "lock" lock } }
{ $description "Creates a reentrant lock." } ;
HELP: with-lock-timeout
{ $values { "lock" lock } { "timeout" { $maybe duration } } { "quot" quotation } }
{ $description "Calls the quotation, ensuring that only one thread executes with the lock held at a time. If another thread is holding the lock, blocks until the thread releases the lock." }
{ $errors "Throws an error if the lock could not be acquired before the timeout expires. A timeout value of " { $link f } " means the thread is willing to wait indefinitely." } ;
HELP: with-lock
{ $values { "lock" lock } { "quot" quotation } }
{ $description "Calls the quotation, ensuring that only one thread executes with the lock held at a time. If another thread is holding the lock, blocks until the thread releases the lock." } ;
ARTICLE: "concurrency.locks.mutex" "Mutual-exclusion locks"
"A mutual-exclusion lock ensures that only one thread executes with the lock held at a time. They are used to protect critical sections so that certain operations appear to be atomic to other threads."
$nl
"There are two varieties of locks: non-reentrant and reentrant. The latter may be acquired recursively by the same thread. Attempting to do so with the former will deadlock."
{ $subsections
lock
<lock>
<reentrant-lock>
with-lock
with-lock-timeout
} ;
HELP: rw-lock
{ $class-description "The class of reader/writer locks." } ;
HELP: with-read-lock-timeout
{ $values { "lock" lock } { "timeout" { $maybe duration } } { "quot" quotation } }
{ $description "Calls the quotation, ensuring that no other thread is holding a write lock at the same time. If another thread is holding a write lock, blocks until the thread releases the lock." }
{ $errors "Throws an error if the lock could not be acquired before the timeout expires. A timeout value of " { $link f } " means the thread is willing to wait indefinitely." } ;
HELP: with-read-lock
{ $values { "lock" lock } { "quot" quotation } }
{ $description "Calls the quotation, ensuring that no other thread is holding a write lock at the same time. If another thread is holding a write lock, blocks until the thread releases the lock." } ;
HELP: with-write-lock-timeout
{ $values { "lock" lock } { "timeout" { $maybe duration } } { "quot" quotation } }
{ $description "Calls the quotation, ensuring that no other thread is holding a read or write lock at the same time. If another thread is holding a read or write lock, blocks until the thread releases the lock." }
{ $errors "Throws an error if the lock could not be acquired before the timeout expires. A timeout value of " { $link f } " means the thread is willing to wait indefinitely." } ;
HELP: with-write-lock
{ $values { "lock" lock } { "quot" quotation } }
{ $description "Calls the quotation, ensuring that no other thread is holding a read or write lock at the same time. If another thread is holding a read or write lock, blocks until the thread releases the lock." } ;
ARTICLE: "concurrency.locks.rw" "Read-write locks"
"A read-write lock encapsulates a common pattern in the implementation of concurrent data structures, where one wishes to ensure that a thread is able to see a consistent view of the structure for a period of time, during which no other thread modifies the structure."
$nl
"While this can be achieved with a simple " { $link "concurrency.locks.mutex" } ", performance will suffer, since in fact multiple threads can view the structure at the same time; serialization must only be enforced for writes."
$nl
"Read/write locks allow any number of threads to hold the read lock simultaneously, however attempting to acquire a write lock blocks until all other threads release read locks and write locks."
$nl
"Read/write locks are reentrant. A thread holding a write lock may acquire a read lock or a write lock without blocking. However a thread holding a read lock may not acquire a write lock recursively since that could break invariants assumed by the code executing with the read lock held."
{ $subsections
rw-lock
<rw-lock>
with-read-lock
with-write-lock
}
"Versions of the above that take a timeout duration:"
{ $subsections
with-read-lock-timeout
with-write-lock-timeout
} ;
ARTICLE: "concurrency.locks" "Locks"
"A " { $emphasis "lock" } " is an object protecting a critical region of code, enforcing a particular mutual-exclusion policy. The " { $vocab-link "concurrency.locks" } " vocabulary implements two types of locks:"
{ $subsections
"concurrency.locks.mutex"
"concurrency.locks.rw"
} ;
ABOUT: "concurrency.locks"
USING: help.markup help.syntax sequences kernel quotations
calendar ;
IN: concurrency.locks
HELP: lock
{ $class-description "The class of mutual exclusion locks." } ;
HELP: <lock>
{ $values { "lock" lock } }
{ $description "Creates a non-reentrant lock." } ;
HELP: <reentrant-lock>
{ $values { "lock" lock } }
{ $description "Creates a reentrant lock." } ;
HELP: with-lock-timeout
{ $values { "lock" lock } { "timeout" { $maybe duration } } { "quot" quotation } }
{ $description "Calls the quotation, ensuring that only one thread executes with the lock held at a time. If another thread is holding the lock, blocks until the thread releases the lock." }
{ $errors "Throws an error if the lock could not be acquired before the timeout expires. A timeout value of " { $link f } " means the thread is willing to wait indefinitely." } ;
HELP: with-lock
{ $values { "lock" lock } { "quot" quotation } }
{ $description "Calls the quotation, ensuring that only one thread executes with the lock held at a time. If another thread is holding the lock, blocks until the thread releases the lock." } ;
ARTICLE: "concurrency.locks.mutex" "Mutual-exclusion locks"
"A mutual-exclusion lock ensures that only one thread executes with the lock held at a time. They are used to protect critical sections so that certain operations appear to be atomic to other threads."
$nl
"There are two varieties of locks: non-reentrant and reentrant. The latter may be acquired recursively by the same thread. Attempting to do so with the former will deadlock."
{ $subsections
lock
<lock>
<reentrant-lock>
with-lock
with-lock-timeout
} ;
HELP: rw-lock
{ $class-description "The class of reader/writer locks." } ;
HELP: with-read-lock-timeout
{ $values { "lock" lock } { "timeout" { $maybe duration } } { "quot" quotation } }
{ $description "Calls the quotation, ensuring that no other thread is holding a write lock at the same time. If another thread is holding a write lock, blocks until the thread releases the lock." }
{ $errors "Throws an error if the lock could not be acquired before the timeout expires. A timeout value of " { $link f } " means the thread is willing to wait indefinitely." } ;
HELP: with-read-lock
{ $values { "lock" lock } { "quot" quotation } }
{ $description "Calls the quotation, ensuring that no other thread is holding a write lock at the same time. If another thread is holding a write lock, blocks until the thread releases the lock." } ;
HELP: with-write-lock-timeout
{ $values { "lock" lock } { "timeout" { $maybe duration } } { "quot" quotation } }
{ $description "Calls the quotation, ensuring that no other thread is holding a read or write lock at the same time. If another thread is holding a read or write lock, blocks until the thread releases the lock." }
{ $errors "Throws an error if the lock could not be acquired before the timeout expires. A timeout value of " { $link f } " means the thread is willing to wait indefinitely." } ;
HELP: with-write-lock
{ $values { "lock" lock } { "quot" quotation } }
{ $description "Calls the quotation, ensuring that no other thread is holding a read or write lock at the same time. If another thread is holding a read or write lock, blocks until the thread releases the lock." } ;
ARTICLE: "concurrency.locks.rw" "Read-write locks"
"A read-write lock encapsulates a common pattern in the implementation of concurrent data structures, where one wishes to ensure that a thread is able to see a consistent view of the structure for a period of time, during which no other thread modifies the structure."
$nl
"While this can be achieved with a simple " { $link "concurrency.locks.mutex" } ", performance will suffer, since in fact multiple threads can view the structure at the same time; serialization must only be enforced for writes."
$nl
"Read/write locks allow any number of threads to hold the read lock simultaneously, however attempting to acquire a write lock blocks until all other threads release read locks and write locks."
$nl
"Read/write locks are reentrant. A thread holding a write lock may acquire a read lock or a write lock without blocking. However a thread holding a read lock may not acquire a write lock recursively since that could break invariants assumed by the code executing with the read lock held."
{ $subsections
rw-lock
<rw-lock>
with-read-lock
with-write-lock
}
"Versions of the above that take a timeout duration:"
{ $subsections
with-read-lock-timeout
with-write-lock-timeout
} ;
ARTICLE: "concurrency.locks" "Locks"
"A " { $emphasis "lock" } " is an object protecting a critical region of code, enforcing a particular mutual-exclusion policy. The " { $vocab-link "concurrency.locks" } " vocabulary implements two types of locks:"
{ $subsections
"concurrency.locks.mutex"
"concurrency.locks.rw"
} ;
ABOUT: "concurrency.locks"

392
basis/concurrency/locks/locks-tests.factor
View File

@ -1,196 +1,196 @@
USING: tools.test concurrency.locks concurrency.count-downs
concurrency.messaging concurrency.mailboxes locals kernel
threads sequences calendar accessors ;
IN: concurrency.locks.tests
:: lock-test-0 ( -- v )
V{ } clone :> v
2 <count-down> :> c
[
yield
1 v push
yield
2 v push
c count-down
] "Lock test 1" spawn drop
[
yield
3 v push
yield
4 v push
c count-down
] "Lock test 2" spawn drop
c await
v ;
:: lock-test-1 ( -- v )
V{ } clone :> v
<lock> :> l
2 <count-down> :> c
[
l [
yield
1 v push
yield
2 v push
] with-lock
c count-down
] "Lock test 1" spawn drop
[
l [
yield
3 v push
yield
4 v push
] with-lock
c count-down
] "Lock test 2" spawn drop
c await
v ;
[ V{ 1 3 2 4 } ] [ lock-test-0 ] unit-test
[ V{ 1 2 3 4 } ] [ lock-test-1 ] unit-test
[ 3 ] [
<reentrant-lock> dup [
[
3
] with-lock
] with-lock
] unit-test
[ ] [ <rw-lock> drop ] unit-test
[ ] [ <rw-lock> [ ] with-read-lock ] unit-test
[ ] [ <rw-lock> dup [ [ ] with-read-lock ] with-read-lock ] unit-test
[ ] [ <rw-lock> [ ] with-write-lock ] unit-test
[ ] [ <rw-lock> dup [ [ ] with-write-lock ] with-write-lock ] unit-test
[ ] [ <rw-lock> dup [ [ ] with-read-lock ] with-write-lock ] unit-test
:: rw-lock-test-1 ( -- v )
<rw-lock> :> l
1 <count-down> :> c
1 <count-down> :> c'
4 <count-down> :> c''
V{ } clone :> v
[
l [
1 v push
c count-down
yield
3 v push
] with-read-lock
c'' count-down
] "R/W lock test 1" spawn drop
[
c await
l [
4 v push
1 seconds sleep
5 v push
] with-write-lock
c'' count-down
] "R/W lock test 2" spawn drop
[
c await
l [
2 v push
c' count-down
] with-read-lock
c'' count-down
] "R/W lock test 4" spawn drop
[
c' await
l [
6 v push
] with-write-lock
c'' count-down
] "R/W lock test 5" spawn drop
c'' await
v ;
[ V{ 1 2 3 4 5 6 } ] [ rw-lock-test-1 ] unit-test
:: rw-lock-test-2 ( -- v )
<rw-lock> :> l
1 <count-down> :> c
2 <count-down> :> c'
V{ } clone :> v
[
l [
1 v push
c count-down
1 seconds sleep
2 v push
] with-write-lock
c' count-down
] "R/W lock test 1" spawn drop
[
c await
l [
3 v push
] with-read-lock
c' count-down
] "R/W lock test 2" spawn drop
c' await
v ;
[ V{ 1 2 3 } ] [ rw-lock-test-2 ] unit-test
! Test lock timeouts
:: lock-timeout-test ( -- v )
<lock> :> l
[
l [ 1 seconds sleep ] with-lock
] "Lock holder" spawn drop
[
l 1/10 seconds [ ] with-lock-timeout
] "Lock timeout-er" spawn-linked drop
receive ;
[ lock-timeout-test ] [
thread>> name>> "Lock timeout-er" =
] must-fail-with
[
<rw-lock> dup [
1 seconds [ ] with-write-lock-timeout
] with-read-lock
] must-fail
[
<rw-lock> dup [
dup [
1 seconds [ ] with-write-lock-timeout
] with-read-lock
] with-write-lock
] must-fail
[ ] [
<rw-lock> dup [
dup [
1 seconds [ ] with-read-lock-timeout
] with-read-lock
] with-write-lock
] unit-test
USING: tools.test concurrency.locks concurrency.count-downs
concurrency.messaging concurrency.mailboxes locals kernel
threads sequences calendar accessors ;
IN: concurrency.locks.tests
:: lock-test-0 ( -- v )
V{ } clone :> v
2 <count-down> :> c
[
yield
1 v push
yield
2 v push
c count-down
] "Lock test 1" spawn drop
[
yield
3 v push
yield
4 v push
c count-down
] "Lock test 2" spawn drop
c await
v ;
:: lock-test-1 ( -- v )
V{ } clone :> v
<lock> :> l
2 <count-down> :> c
[
l [
yield
1 v push
yield
2 v push
] with-lock
c count-down
] "Lock test 1" spawn drop
[
l [
yield
3 v push
yield
4 v push
] with-lock
c count-down
] "Lock test 2" spawn drop
c await
v ;
[ V{ 1 3 2 4 } ] [ lock-test-0 ] unit-test
[ V{ 1 2 3 4 } ] [ lock-test-1 ] unit-test
[ 3 ] [
<reentrant-lock> dup [
[
3
] with-lock
] with-lock
] unit-test
[ ] [ <rw-lock> drop ] unit-test
[ ] [ <rw-lock> [ ] with-read-lock ] unit-test
[ ] [ <rw-lock> dup [ [ ] with-read-lock ] with-read-lock ] unit-test
[ ] [ <rw-lock> [ ] with-write-lock ] unit-test
[ ] [ <rw-lock> dup [ [ ] with-write-lock ] with-write-lock ] unit-test
[ ] [ <rw-lock> dup [ [ ] with-read-lock ] with-write-lock ] unit-test
:: rw-lock-test-1 ( -- v )
<rw-lock> :> l
1 <count-down> :> c
1 <count-down> :> c'
4 <count-down> :> c''
V{ } clone :> v
[
l [
1 v push
c count-down
yield
3 v push
] with-read-lock
c'' count-down
] "R/W lock test 1" spawn drop
[
c await
l [
4 v push
1 seconds sleep
5 v push
] with-write-lock
c'' count-down
] "R/W lock test 2" spawn drop
[
c await
l [
2 v push
c' count-down
] with-read-lock
c'' count-down
] "R/W lock test 4" spawn drop
[
c' await
l [
6 v push
] with-write-lock
c'' count-down
] "R/W lock test 5" spawn drop
c'' await
v ;
[ V{ 1 2 3 4 5 6 } ] [ rw-lock-test-1 ] unit-test
:: rw-lock-test-2 ( -- v )
<rw-lock> :> l
1 <count-down> :> c
2 <count-down> :> c'
V{ } clone :> v
[
l [
1 v push
c count-down
1 seconds sleep
2 v push
] with-write-lock
c' count-down
] "R/W lock test 1" spawn drop
[
c await
l [
3 v push
] with-read-lock
c' count-down
] "R/W lock test 2" spawn drop
c' await
v ;
[ V{ 1 2 3 } ] [ rw-lock-test-2 ] unit-test
! Test lock timeouts
:: lock-timeout-test ( -- v )
<lock> :> l
[
l [ 1 seconds sleep ] with-lock
] "Lock holder" spawn drop
[
l 1/10 seconds [ ] with-lock-timeout
] "Lock timeout-er" spawn-linked drop
receive ;
[ lock-timeout-test ] [
thread>> name>> "Lock timeout-er" =
] must-fail-with
[
<rw-lock> dup [
1 seconds [ ] with-write-lock-timeout
] with-read-lock
] must-fail
[
<rw-lock> dup [
dup [
1 seconds [ ] with-write-lock-timeout
] with-read-lock
] with-write-lock
] must-fail
[ ] [
<rw-lock> dup [
dup [
1 seconds [ ] with-read-lock-timeout
] with-read-lock
] with-write-lock
] unit-test

232
basis/concurrency/locks/locks.factor
View File

@ -1,116 +1,116 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: deques dlists kernel threads continuations math
concurrency.conditions combinators.short-circuit accessors
locals ;
IN: concurrency.locks
! Simple critical sections
TUPLE: lock threads owner reentrant? ;
: <lock> ( -- lock )
<dlist> f f lock boa ;
: <reentrant-lock> ( -- lock )
<dlist> f t lock boa ;
<PRIVATE
: acquire-lock ( lock timeout -- )
over owner>>
[ 2dup [ threads>> ] dip "lock" wait ] when drop
self >>owner drop ;
: release-lock ( lock -- )
f >>owner
threads>> notify-1 ;
:: do-lock ( lock timeout quot acquire release -- )
lock timeout acquire call
quot lock release curry [ ] cleanup ; inline
: (with-lock) ( lock timeout quot -- )
[ acquire-lock ] [ release-lock ] do-lock ; inline
PRIVATE>
: with-lock-timeout ( lock timeout quot -- )
pick reentrant?>> [
pick owner>> self eq? [
2nip call
] [
(with-lock)
] if
] [
(with-lock)
] if ; inline
: with-lock ( lock quot -- )
f swap with-lock-timeout ; inline
! Many-reader/single-writer locks
TUPLE: rw-lock readers writers reader# writer ;
: <rw-lock> ( -- lock )
<dlist> <dlist> 0 f rw-lock boa ;
<PRIVATE
: add-reader ( lock -- )
[ 1 + ] change-reader# drop ;
: acquire-read-lock ( lock timeout -- )
over writer>>
[ 2dup [ readers>> ] dip "read lock" wait ] when drop
add-reader ;
: notify-writer ( lock -- )
writers>> notify-1 ;
: remove-reader ( lock -- )
[ 1 - ] change-reader# drop ;
: release-read-lock ( lock -- )
dup remove-reader
dup reader#>> zero? [ notify-writer ] [ drop ] if ;
: acquire-write-lock ( lock timeout -- )
over writer>> pick reader#>> 0 > or
[ 2dup [ writers>> ] dip "write lock" wait ] when drop
self >>writer drop ;
: release-write-lock ( lock -- )
f >>writer
dup readers>> deque-empty?
[ notify-writer ] [ readers>> notify-all ] if ;
: reentrant-read-lock-ok? ( lock -- ? )
#! If we already have a write lock, then we can grab a read
#! lock too.
writer>> self eq? ;
: reentrant-write-lock-ok? ( lock -- ? )
#! The only case where we have a writer and > 1 reader is
#! write -> read re-entrancy, and in this case we prohibit
#! a further write -> read -> write re-entrancy.
{ [ writer>> self eq? ] [ reader#>> zero? ] } 1&& ;
PRIVATE>
: with-read-lock-timeout ( lock timeout quot -- )
pick reentrant-read-lock-ok? [
[ drop add-reader ] [ remove-reader ] do-lock
] [
[ acquire-read-lock ] [ release-read-lock ] do-lock
] if ; inline
: with-read-lock ( lock quot -- )
f swap with-read-lock-timeout ; inline
: with-write-lock-timeout ( lock timeout quot -- )
pick reentrant-write-lock-ok? [ 2nip call ] [
[ acquire-write-lock ] [ release-write-lock ] do-lock
] if ; inline
: with-write-lock ( lock quot -- )
f swap with-write-lock-timeout ; inline
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: deques dlists kernel threads continuations math
concurrency.conditions combinators.short-circuit accessors
locals ;
IN: concurrency.locks
! Simple critical sections
TUPLE: lock threads owner reentrant? ;
: <lock> ( -- lock )
<dlist> f f lock boa ;
: <reentrant-lock> ( -- lock )
<dlist> f t lock boa ;
<PRIVATE
: acquire-lock ( lock timeout -- )
over owner>>
[ 2dup [ threads>> ] dip "lock" wait ] when drop
self >>owner drop ;
: release-lock ( lock -- )
f >>owner
threads>> notify-1 ;
:: do-lock ( lock timeout quot acquire release -- )
lock timeout acquire call
quot lock release curry [ ] cleanup ; inline
: (with-lock) ( lock timeout quot -- )
[ acquire-lock ] [ release-lock ] do-lock ; inline
PRIVATE>
: with-lock-timeout ( lock timeout quot -- )
pick reentrant?>> [
pick owner>> self eq? [
2nip call
] [
(with-lock)
] if
] [
(with-lock)
] if ; inline
: with-lock ( lock quot -- )
f swap with-lock-timeout ; inline
! Many-reader/single-writer locks
TUPLE: rw-lock readers writers reader# writer ;
: <rw-lock> ( -- lock )
<dlist> <dlist> 0 f rw-lock boa ;
<PRIVATE
: add-reader ( lock -- )
[ 1 + ] change-reader# drop ;
: acquire-read-lock ( lock timeout -- )
over writer>>
[ 2dup [ readers>> ] dip "read lock" wait ] when drop
add-reader ;
: notify-writer ( lock -- )
writers>> notify-1 ;
: remove-reader ( lock -- )
[ 1 - ] change-reader# drop ;
: release-read-lock ( lock -- )
dup remove-reader
dup reader#>> zero? [ notify-writer ] [ drop ] if ;
: acquire-write-lock ( lock timeout -- )
over writer>> pick reader#>> 0 > or
[ 2dup [ writers>> ] dip "write lock" wait ] when drop
self >>writer drop ;
: release-write-lock ( lock -- )
f >>writer
dup readers>> deque-empty?
[ notify-writer ] [ readers>> notify-all ] if ;
: reentrant-read-lock-ok? ( lock -- ? )
#! If we already have a write lock, then we can grab a read
#! lock too.
writer>> self eq? ;
: reentrant-write-lock-ok? ( lock -- ? )
#! The only case where we have a writer and > 1 reader is
#! write -> read re-entrancy, and in this case we prohibit
#! a further write -> read -> write re-entrancy.
{ [ writer>> self eq? ] [ reader#>> zero? ] } 1&& ;
PRIVATE>
: with-read-lock-timeout ( lock timeout quot -- )
pick reentrant-read-lock-ok? [
[ drop add-reader ] [ remove-reader ] do-lock
] [
[ acquire-read-lock ] [ release-read-lock ] do-lock
] if ; inline
: with-read-lock ( lock quot -- )
f swap with-read-lock-timeout ; inline
: with-write-lock-timeout ( lock timeout quot -- )
pick reentrant-write-lock-ok? [ 2nip call ] [
[ acquire-write-lock ] [ release-write-lock ] do-lock
] if ; inline
: with-write-lock ( lock quot -- )
f swap with-write-lock-timeout ; inline

162
basis/concurrency/mailboxes/mailboxes-docs.factor
View File

@ -1,81 +1,81 @@
USING: help.markup help.syntax kernel arrays calendar ;
IN: concurrency.mailboxes
HELP: <mailbox>
{ $values { "mailbox" mailbox } }
{ $description "A mailbox is an object that can be used for safe thread communication. Items can be put in the mailbox and retrieved in a FIFO order. If the mailbox is empty when a get operation is performed then the thread will block until another thread places something in the mailbox. If multiple threads are waiting on the same mailbox, only one of the waiting threads will be unblocked to thread the get operation." } ;
HELP: mailbox-empty?
{ $values { "mailbox" mailbox }
{ "bool" boolean }
}
{ $description "Return true if the mailbox is empty." } ;
HELP: mailbox-put
{ $values { "obj" object }
{ "mailbox" mailbox }
}
{ $description "Put the object into the mailbox. Any threads that have a blocking get on the mailbox are resumed. Only one of those threads will successfully get the object, the rest will immediately block waiting for the next item in the mailbox." } ;
HELP: block-unless-pred
{ $values
{ "mailbox" mailbox }
{ "timeout" { $maybe duration } }
{ "pred" { $quotation ( ... message -- ... ? ) } }
}
{ $description "Block the thread if there are no items in the mailbox that return true when the predicate is called with the item on the stack." } ;
HELP: block-if-empty
{ $values { "mailbox" mailbox }
{ "timeout" { $maybe duration } }
}
{ $description "Block the thread if the mailbox is empty." } ;
HELP: mailbox-get
{ $values { "mailbox" mailbox } { "obj" object } }
{ $description "Get the first item put into the mailbox. If it is empty the thread blocks until an item is put into it. The thread then resumes, leaving the item on the stack." } ;
HELP: mailbox-get-all
{ $values { "mailbox" mailbox } { "array" array } }
{ $description "Blocks the thread if the mailbox is empty, otherwise removes all objects in the mailbox and returns an array containing the objects." } ;
HELP: while-mailbox-empty
{ $values { "mailbox" mailbox }
{ "quot" { $quotation ( -- ) } }
}
{ $description "Repeatedly call the quotation while there are no items in the mailbox." } ;
HELP: mailbox-get?
{ $values { "mailbox" mailbox }
{ "pred" { $quotation ( obj -- ? ) } }
{ "obj" object }
}
{ $description "Get the first item in the mailbox which satisfies the predicate. When the predicate returns true that item will be returned. If nothing in the mailbox satisfies the predicate then the thread will block until something does." } ;
ARTICLE: "concurrency.mailboxes" "Mailboxes"
"A " { $emphasis "mailbox" } " is a first-in-first-out queue where the operation of removing an element blocks if the queue is empty. Mailboxes are implemented in the " { $vocab-link "concurrency.mailboxes" } " vocabulary."
{ $subsections
mailbox
<mailbox>
}
"Removing the first element:"
{ $subsections
mailbox-get
mailbox-get-timeout
}
"Removing the first element matching a predicate:"
{ $subsections
mailbox-get?
mailbox-get-timeout?
}
"Emptying out a mailbox:"
{ $subsections mailbox-get-all }
"Adding an element:"
{ $subsections mailbox-put }
"Testing if a mailbox is empty:"
{ $subsections
mailbox-empty?
while-mailbox-empty
} ;
ABOUT: "concurrency.mailboxes"
USING: help.markup help.syntax kernel arrays calendar ;
IN: concurrency.mailboxes
HELP: <mailbox>
{ $values { "mailbox" mailbox } }
{ $description "A mailbox is an object that can be used for safe thread communication. Items can be put in the mailbox and retrieved in a FIFO order. If the mailbox is empty when a get operation is performed then the thread will block until another thread places something in the mailbox. If multiple threads are waiting on the same mailbox, only one of the waiting threads will be unblocked to thread the get operation." } ;
HELP: mailbox-empty?
{ $values { "mailbox" mailbox }
{ "bool" boolean }
}
{ $description "Return true if the mailbox is empty." } ;
HELP: mailbox-put
{ $values { "obj" object }
{ "mailbox" mailbox }
}
{ $description "Put the object into the mailbox. Any threads that have a blocking get on the mailbox are resumed. Only one of those threads will successfully get the object, the rest will immediately block waiting for the next item in the mailbox." } ;
HELP: block-unless-pred
{ $values
{ "mailbox" mailbox }
{ "timeout" { $maybe duration } }
{ "pred" { $quotation ( ... message -- ... ? ) } }
}
{ $description "Block the thread if there are no items in the mailbox that return true when the predicate is called with the item on the stack." } ;
HELP: block-if-empty
{ $values { "mailbox" mailbox }
{ "timeout" { $maybe duration } }
}
{ $description "Block the thread if the mailbox is empty." } ;
HELP: mailbox-get
{ $values { "mailbox" mailbox } { "obj" object } }
{ $description "Get the first item put into the mailbox. If it is empty the thread blocks until an item is put into it. The thread then resumes, leaving the item on the stack." } ;
HELP: mailbox-get-all
{ $values { "mailbox" mailbox } { "array" array } }
{ $description "Blocks the thread if the mailbox is empty, otherwise removes all objects in the mailbox and returns an array containing the objects." } ;
HELP: while-mailbox-empty
{ $values { "mailbox" mailbox }
{ "quot" { $quotation ( -- ) } }
}
{ $description "Repeatedly call the quotation while there are no items in the mailbox." } ;
HELP: mailbox-get?
{ $values { "mailbox" mailbox }
{ "pred" { $quotation ( obj -- ? ) } }
{ "obj" object }
}
{ $description "Get the first item in the mailbox which satisfies the predicate. When the predicate returns true that item will be returned. If nothing in the mailbox satisfies the predicate then the thread will block until something does." } ;
ARTICLE: "concurrency.mailboxes" "Mailboxes"
"A " { $emphasis "mailbox" } " is a first-in-first-out queue where the operation of removing an element blocks if the queue is empty. Mailboxes are implemented in the " { $vocab-link "concurrency.mailboxes" } " vocabulary."
{ $subsections
mailbox
<mailbox>
}
"Removing the first element:"
{ $subsections
mailbox-get
mailbox-get-timeout
}
"Removing the first element matching a predicate:"
{ $subsections
mailbox-get?
mailbox-get-timeout?
}
"Emptying out a mailbox:"
{ $subsections mailbox-get-all }
"Adding an element:"
{ $subsections mailbox-put }
"Testing if a mailbox is empty:"
{ $subsections
mailbox-empty?
while-mailbox-empty
} ;
ABOUT: "concurrency.mailboxes"

144
basis/concurrency/messaging/messaging.factor
View File

@ -1,72 +1,72 @@
! Copyright (C) 2005, 2010 Chris Double, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel kernel.private threads concurrency.mailboxes
continuations namespaces assocs accessors summary fry ;
IN: concurrency.messaging
GENERIC: send ( message thread -- )
GENERIC: mailbox-of ( thread -- mailbox )
M: thread mailbox-of
dup mailbox>>
[ { mailbox } declare ]
[ <mailbox> [ >>mailbox drop ] keep ] ?if ; inline
M: thread send ( message thread -- )
mailbox-of mailbox-put ;
: my-mailbox ( -- mailbox ) self mailbox-of ; inline
: receive ( -- message )
my-mailbox mailbox-get ?linked ;
: receive-timeout ( timeout -- message )
[ my-mailbox ] dip mailbox-get-timeout ?linked ;
: receive-if ( pred -- message )
[ my-mailbox ] dip mailbox-get? ?linked ; inline
: receive-if-timeout ( timeout pred -- message )
[ my-mailbox ] 2dip mailbox-get-timeout? ?linked ; inline
: rethrow-linked ( error process supervisor -- )
[ <linked-error> ] dip send ;
: spawn-linked ( quot name -- thread )
my-mailbox spawn-linked-to ;
TUPLE: synchronous data sender tag ;
: <synchronous> ( data -- sync )
self synchronous counter synchronous boa ;
TUPLE: reply data tag ;
: <reply> ( data synchronous -- reply )
tag>> \ reply boa ;
: synchronous-reply? ( response synchronous -- ? )
over reply? [ [ tag>> ] same? ] [ 2drop f ] if ;
ERROR: cannot-send-synchronous-to-self message thread ;
M: cannot-send-synchronous-to-self summary
drop "Cannot synchronous send to myself" ;
: send-synchronous ( message thread -- reply )
dup self eq? [
cannot-send-synchronous-to-self
] [
[ <synchronous> dup ] dip send
'[ _ synchronous-reply? ] receive-if
data>>
] if ;
: reply-synchronous ( message synchronous -- )
[ <reply> ] keep sender>> send ;
: handle-synchronous ( quot -- )
receive [
data>> swap call
] keep reply-synchronous ; inline
! Copyright (C) 2005, 2010 Chris Double, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel kernel.private threads concurrency.mailboxes
continuations namespaces assocs accessors summary fry ;
IN: concurrency.messaging
GENERIC: send ( message thread -- )
GENERIC: mailbox-of ( thread -- mailbox )
M: thread mailbox-of
dup mailbox>>
[ { mailbox } declare ]
[ <mailbox> [ >>mailbox drop ] keep ] ?if ; inline
M: thread send ( message thread -- )
mailbox-of mailbox-put ;
: my-mailbox ( -- mailbox ) self mailbox-of ; inline
: receive ( -- message )
my-mailbox mailbox-get ?linked ;
: receive-timeout ( timeout -- message )
[ my-mailbox ] dip mailbox-get-timeout ?linked ;
: receive-if ( pred -- message )
[ my-mailbox ] dip mailbox-get? ?linked ; inline
: receive-if-timeout ( timeout pred -- message )
[ my-mailbox ] 2dip mailbox-get-timeout? ?linked ; inline
: rethrow-linked ( error process supervisor -- )
[ <linked-error> ] dip send ;
: spawn-linked ( quot name -- thread )
my-mailbox spawn-linked-to ;
TUPLE: synchronous data sender tag ;
: <synchronous> ( data -- sync )
self synchronous counter synchronous boa ;
TUPLE: reply data tag ;
: <reply> ( data synchronous -- reply )
tag>> \ reply boa ;
: synchronous-reply? ( response synchronous -- ? )
over reply? [ [ tag>> ] same? ] [ 2drop f ] if ;
ERROR: cannot-send-synchronous-to-self message thread ;
M: cannot-send-synchronous-to-self summary
drop "Cannot synchronous send to myself" ;
: send-synchronous ( message thread -- reply )
dup self eq? [
cannot-send-synchronous-to-self
] [
[ <synchronous> dup ] dip send
'[ _ synchronous-reply? ] receive-if
data>>
] if ;
: reply-synchronous ( message synchronous -- )
[ <reply> ] keep sender>> send ;
: handle-synchronous ( quot -- )
receive [
data>> swap call
] keep reply-synchronous ; inline

82
basis/concurrency/promises/promises-docs.factor
View File

@ -1,41 +1,41 @@
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: calendar help.markup help.syntax kernel ;
IN: concurrency.promises
HELP: promise
{ $class-description "The class of write-once promises." } ;
HELP: <promise>
{ $values { "promise" promise } }
{ $description "Creates a new promise which may be fulfilled by calling " { $link fulfill } "." } ;
HELP: promise-fulfilled?
{ $values { "promise" promise } { "?" boolean } }
{ $description "Tests if " { $link fulfill } " has previously been called on the promise, in which case " { $link ?promise } " will return immediately without blocking." } ;
HELP: ?promise-timeout
{ $values { "promise" promise } { "timeout" { $maybe duration } } { "result" object } }
{ $description "Waits for another thread to fulfill a promise, returning immediately if the promise has already been fulfilled. A timeout of " { $link f } " indicates that the thread may block indefinitely, otherwise it will wait up to the " { $snippet "timeout" } " before throwing an error." }
{ $errors "Throws an error if the timeout expires before the promise has been fulfilled." } ;
HELP: ?promise
{ $values { "promise" promise } { "result" object } }
{ $description "Waits for another thread to fulfill a promise, returning immediately if the promise has already been fulfilled." } ;
HELP: fulfill
{ $values { "value" object } { "promise" promise } }
{ $description "Fulfills a promise by writing a value to it. Any threads waiting for the value are notified." }
{ $errors "Throws an error if the promise has already been fulfilled." } ;
ARTICLE: "concurrency.promises" "Promises"
"The " { $vocab-link "concurrency.promises" } " vocabulary implements " { $emphasis "promises" } ", which are thread-safe write-once variables. Once a promise is created, threads may block waiting for it to be " { $emphasis "fulfilled" } "; at some point in the future, another thread may provide a value at which point all waiting threads are notified."
{ $subsections
promise
<promise>
fulfill
?promise
?promise-timeout
} ;
ABOUT: "concurrency.promises"
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: calendar help.markup help.syntax kernel ;
IN: concurrency.promises
HELP: promise
{ $class-description "The class of write-once promises." } ;
HELP: <promise>
{ $values { "promise" promise } }
{ $description "Creates a new promise which may be fulfilled by calling " { $link fulfill } "." } ;
HELP: promise-fulfilled?
{ $values { "promise" promise } { "?" boolean } }
{ $description "Tests if " { $link fulfill } " has previously been called on the promise, in which case " { $link ?promise } " will return immediately without blocking." } ;
HELP: ?promise-timeout
{ $values { "promise" promise } { "timeout" { $maybe duration } } { "result" object } }
{ $description "Waits for another thread to fulfill a promise, returning immediately if the promise has already been fulfilled. A timeout of " { $link f } " indicates that the thread may block indefinitely, otherwise it will wait up to the " { $snippet "timeout" } " before throwing an error." }
{ $errors "Throws an error if the timeout expires before the promise has been fulfilled." } ;
HELP: ?promise
{ $values { "promise" promise } { "result" object } }
{ $description "Waits for another thread to fulfill a promise, returning immediately if the promise has already been fulfilled." } ;
HELP: fulfill
{ $values { "value" object } { "promise" promise } }
{ $description "Fulfills a promise by writing a value to it. Any threads waiting for the value are notified." }
{ $errors "Throws an error if the promise has already been fulfilled." } ;
ARTICLE: "concurrency.promises" "Promises"
"The " { $vocab-link "concurrency.promises" } " vocabulary implements " { $emphasis "promises" } ", which are thread-safe write-once variables. Once a promise is created, threads may block waiting for it to be " { $emphasis "fulfilled" } "; at some point in the future, another thread may provide a value at which point all waiting threads are notified."
{ $subsections
promise
<promise>
fulfill
?promise
?promise-timeout
} ;
ABOUT: "concurrency.promises"

24
basis/concurrency/promises/promises-tests.factor
View File

@ -1,12 +1,12 @@
USING: vectors concurrency.promises kernel threads sequences
tools.test ;
IN: concurrency.promises.tests
[ V{ 50 50 50 } ] [
0 <vector>
<promise>
[ ?promise swap push ] in-thread
[ ?promise swap push ] in-thread
[ ?promise swap push ] in-thread
50 swap fulfill
] unit-test
USING: vectors concurrency.promises kernel threads sequences
tools.test ;
IN: concurrency.promises.tests
[ V{ 50 50 50 } ] [
0 <vector>
<promise>
[ ?promise swap push ] in-thread
[ ?promise swap push ] in-thread
[ ?promise swap push ] in-thread
50 swap fulfill
] unit-test

2
basis/concurrency/promises/promises.factor
View File

@ -14,7 +14,7 @@ TUPLE: promise mailbox ;
ERROR: promise-already-fulfilled promise ;
: fulfill ( value promise -- )
dup promise-fulfilled? [
dup promise-fulfilled? [
promise-already-fulfilled
] [
mailbox>> mailbox-put

160
basis/concurrency/semaphores/semaphores-docs.factor
View File

@ -1,80 +1,80 @@
IN: concurrency.semaphores
USING: help.markup help.syntax kernel quotations calendar ;
HELP: semaphore
{ $class-description "The class of counting semaphores. New instances can be created by calling " { $link <semaphore> } "." } ;
HELP: <semaphore>
{ $values { "n" "a non-negative integer" } { "semaphore" semaphore } }
{ $description "Creates a counting semaphore with the specified initial count." } ;
HELP: acquire-timeout
{ $values { "semaphore" semaphore } { "timeout" { $maybe duration } } }
{ $description "If the semaphore has a non-zero count, decrements it and returns immediately. Otherwise, if the timeout is " { $link f } ", waits indefinitely for the semaphore to be released. If the timeout is not " { $link f } ", waits a certain period of time, and if the semaphore still has not been released, throws an error." }
{ $errors "Throws an error if the timeout expires before the semaphore is released." } ;
HELP: acquire
{ $values { "semaphore" semaphore } }
{ $description "If the semaphore has a non-zero count, decrements it and returns immediately. Otherwise, waits for it to be released." } ;
HELP: release
{ $values { "semaphore" semaphore } }
{ $description "Increments a semaphore's count. If the count was previously zero, any threads waiting on the semaphore are woken up." } ;
HELP: with-semaphore-timeout
{ $values { "semaphore" semaphore } { "timeout" { $maybe duration } } { "quot" quotation } }
{ $description "Calls the quotation with the semaphore held." } ;
HELP: with-semaphore
{ $values { "semaphore" semaphore } { "quot" quotation } }
{ $description "Calls the quotation with the semaphore held." } ;
ARTICLE: "concurrency.semaphores.examples" "Semaphore examples"
"A use-case would be a batch processing server which runs a large number of jobs which perform calculations but then need to fire off expensive external processes or perform heavy network I/O. While for most of the time, the threads can all run in parallel, it might be desired that the expensive operation is not run by more than 10 threads at once, to avoid thrashing swap space or saturating the network. This can be accomplished with a counting semaphore:"
{ $code
"SYMBOL: expensive-section"
"requests"
"10 <semaphore> '["
" ..."
" _ [ do-expensive-stuff ] with-semaphore"
" ..."
"] parallel-map"
}
"Here is a concrete example which fetches content from 5 different web sites, making no more than 3 requests at a time:"
{ $code
"""USING: concurrency.combinators concurrency.semaphores
fry http.client kernel urls ;
{
URL" http://www.apple.com"
URL" http://www.google.com"
URL" http://www.ibm.com"
URL" http://www.hp.com"
URL" http://www.oracle.com"
}
2 <semaphore> '[
_ [ http-get nip ] with-semaphore
] parallel-map"""
} ;
ARTICLE: "concurrency.semaphores" "Counting semaphores"
"Counting semaphores are used to ensure that no more than a fixed number of threads are executing in a critical section at a time; as such, they generalize " { $vocab-link "concurrency.locks" } ", since locks can be thought of as semaphores with an initial count of 1."
{ $subsections "concurrency.semaphores.examples" }
"Creating semaphores:"
{ $subsections
semaphore
<semaphore>
}
"Unlike locks, where acquisition and release are always paired by a combinator, semaphores expose these operations directly and there is no requirement that they be performed in the same thread:"
{ $subsections
acquire
acquire-timeout
release
}
"Combinators which pair acquisition and release:"
{ $subsections
with-semaphore
with-semaphore-timeout
} ;
ABOUT: "concurrency.semaphores"
IN: concurrency.semaphores
USING: help.markup help.syntax kernel quotations calendar ;
HELP: semaphore
{ $class-description "The class of counting semaphores. New instances can be created by calling " { $link <semaphore> } "." } ;
HELP: <semaphore>
{ $values { "n" "a non-negative integer" } { "semaphore" semaphore } }
{ $description "Creates a counting semaphore with the specified initial count." } ;
HELP: acquire-timeout
{ $values { "semaphore" semaphore } { "timeout" { $maybe duration } } }
{ $description "If the semaphore has a non-zero count, decrements it and returns immediately. Otherwise, if the timeout is " { $link f } ", waits indefinitely for the semaphore to be released. If the timeout is not " { $link f } ", waits a certain period of time, and if the semaphore still has not been released, throws an error." }
{ $errors "Throws an error if the timeout expires before the semaphore is released." } ;
HELP: acquire
{ $values { "semaphore" semaphore } }
{ $description "If the semaphore has a non-zero count, decrements it and returns immediately. Otherwise, waits for it to be released." } ;
HELP: release
{ $values { "semaphore" semaphore } }
{ $description "Increments a semaphore's count. If the count was previously zero, any threads waiting on the semaphore are woken up." } ;
HELP: with-semaphore-timeout
{ $values { "semaphore" semaphore } { "timeout" { $maybe duration } } { "quot" quotation } }
{ $description "Calls the quotation with the semaphore held." } ;
HELP: with-semaphore
{ $values { "semaphore" semaphore } { "quot" quotation } }
{ $description "Calls the quotation with the semaphore held." } ;
ARTICLE: "concurrency.semaphores.examples" "Semaphore examples"
"A use-case would be a batch processing server which runs a large number of jobs which perform calculations but then need to fire off expensive external processes or perform heavy network I/O. While for most of the time, the threads can all run in parallel, it might be desired that the expensive operation is not run by more than 10 threads at once, to avoid thrashing swap space or saturating the network. This can be accomplished with a counting semaphore:"
{ $code
"SYMBOL: expensive-section"
"requests"
"10 <semaphore> '["
" ..."
" _ [ do-expensive-stuff ] with-semaphore"
" ..."
"] parallel-map"
}
"Here is a concrete example which fetches content from 5 different web sites, making no more than 3 requests at a time:"
{ $code
"""USING: concurrency.combinators concurrency.semaphores
fry http.client kernel urls ;
{
URL" http://www.apple.com"
URL" http://www.google.com"
URL" http://www.ibm.com"
URL" http://www.hp.com"
URL" http://www.oracle.com"
}
2 <semaphore> '[
_ [ http-get nip ] with-semaphore
] parallel-map"""
} ;
ARTICLE: "concurrency.semaphores" "Counting semaphores"
"Counting semaphores are used to ensure that no more than a fixed number of threads are executing in a critical section at a time; as such, they generalize " { $vocab-link "concurrency.locks" } ", since locks can be thought of as semaphores with an initial count of 1."
{ $subsections "concurrency.semaphores.examples" }
"Creating semaphores:"
{ $subsections
semaphore
<semaphore>
}
"Unlike locks, where acquisition and release are always paired by a combinator, semaphores expose these operations directly and there is no requirement that they be performed in the same thread:"
{ $subsections
acquire
acquire-timeout
release
}
"Combinators which pair acquisition and release:"
{ $subsections
with-semaphore
with-semaphore-timeout
} ;
ABOUT: "concurrency.semaphores"

76
basis/concurrency/semaphores/semaphores.factor
View File

@ -1,38 +1,38 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: dlists kernel threads math concurrency.conditions
continuations accessors summary locals fry ;
IN: concurrency.semaphores
TUPLE: semaphore count threads ;
ERROR: negative-count-semaphore ;
M: negative-count-semaphore summary
drop "Cannot have semaphore with negative count" ;
: <semaphore> ( n -- semaphore )
dup 0 < [ negative-count-semaphore ] when
<dlist> semaphore boa ;
: wait-to-acquire ( semaphore timeout -- )
[ threads>> ] dip "semaphore" wait ;
: acquire-timeout ( semaphore timeout -- )
over count>> zero?
[ dupd wait-to-acquire ] [ drop ] if
[ 1 - ] change-count drop ;
: acquire ( semaphore -- )
f acquire-timeout ;
: release ( semaphore -- )
[ 1 + ] change-count
threads>> notify-1 ;
:: with-semaphore-timeout ( semaphore timeout quot -- )
semaphore timeout acquire-timeout
quot [ semaphore release ] [ ] cleanup ; inline
: with-semaphore ( semaphore quot -- )
swap dup acquire '[ _ release ] [ ] cleanup ; inline
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: dlists kernel threads math concurrency.conditions
continuations accessors summary locals fry ;
IN: concurrency.semaphores
TUPLE: semaphore count threads ;
ERROR: negative-count-semaphore ;
M: negative-count-semaphore summary
drop "Cannot have semaphore with negative count" ;
: <semaphore> ( n -- semaphore )
dup 0 < [ negative-count-semaphore ] when
<dlist> semaphore boa ;
: wait-to-acquire ( semaphore timeout -- )
[ threads>> ] dip "semaphore" wait ;
: acquire-timeout ( semaphore timeout -- )
over count>> zero?
[ dupd wait-to-acquire ] [ drop ] if
[ 1 - ] change-count drop ;
: acquire ( semaphore -- )
f acquire-timeout ;
: release ( semaphore -- )
[ 1 + ] change-count
threads>> notify-1 ;
:: with-semaphore-timeout ( semaphore timeout quot -- )
semaphore timeout acquire-timeout
quot [ semaphore release ] [ ] cleanup ; inline
: with-semaphore ( semaphore quot -- )
swap dup acquire '[ _ release ] [ ] cleanup ; inline

1
basis/core-foundation/core-foundation.factor
View File

@ -41,4 +41,3 @@ FUNCTION: CFTypeRef CFRetain ( CFTypeRef cf ) ;
FUNCTION: void CFRelease ( CFTypeRef cf ) ;
DESTRUCTOR: CFRelease

2
basis/core-foundation/file-descriptors/file-descriptors.factor
View File

@ -19,7 +19,7 @@ FUNCTION: CFFileDescriptorRef CFFileDescriptorCreate (
CFAllocatorRef allocator,
CFFileDescriptorNativeDescriptor fd,
Boolean closeOnInvalidate,
CFFileDescriptorCallBack callout,
CFFileDescriptorCallBack callout,
CFFileDescriptorContext* context
) ;

4
basis/core-foundation/strings/strings.factor
View File

@ -98,7 +98,7 @@ FUNCTION: CFStringRef CFCopyTypeIDDescription ( CFTypeID type_id ) ;
: CFType>description ( cf -- description )
CFGetTypeID [ CFCopyTypeIDDescription &CFRelease CF>string ] with-destructors ;
SYNTAX: CFSTRING:
scan-new-word scan-object
SYNTAX: CFSTRING:
scan-new-word scan-object
[ drop ] [ '[ _ [ _ <CFString> ] initialize-alien ] ] 2bi
( -- alien ) define-declared ;

2
basis/core-foundation/timers/timers.factor
View File

@ -51,5 +51,3 @@ FUNCTION: CFTimeInterval CFRunLoopTimerGetInterval (
FUNCTION: CFAbsoluteTime CFRunLoopTimerGetNextFireDate (
CFRunLoopTimerRef timer
) ;

12
basis/db/db-tests.factor
View File

@ -1,6 +1,6 @@
USING: tools.test db kernel ;
IN: db.tests
{ 1 0 } [ [ drop ] query-each ] must-infer-as
{ 1 1 } [ [ ] query-map ] must-infer-as
{ 1 0 } [ [ ] with-db ] must-infer-as
USING: tools.test db kernel ;
IN: db.tests
{ 1 0 } [ [ drop ] query-each ] must-infer-as
{ 1 1 } [ [ ] query-map ] must-infer-as
{ 1 0 } [ [ ] with-db ] must-infer-as

2
basis/db/db.factor
View File

@ -27,7 +27,7 @@ HOOK: parse-db-error db-connection ( error -- error' )
: dispose-statements ( assoc -- ) values dispose-each ;
M: db-connection dispose ( db-connection -- )
M: db-connection dispose ( db-connection -- )
dup db-connection [
[ dispose-statements H{ } clone ] change-insert-statements
[ dispose-statements H{ } clone ] change-update-statements

16
basis/db/postgresql/ffi/ffi.factor
View File

@ -54,10 +54,10 @@ CONSTANT: PQERRORS_VERBOSE 0x2
CONSTANT: InvalidOid 0
TYPEDEF: int ConnStatusType
TYPEDEF: int ExecStatusType
TYPEDEF: int ExecStatusType
TYPEDEF: int PostgresPollingStatusType
TYPEDEF: int PGTransactionStatusType
TYPEDEF: int PGVerbosity
TYPEDEF: int PGTransactionStatusType
TYPEDEF: int PGVerbosity
C-TYPE: PGconn
C-TYPE: PGresult
@ -237,7 +237,7 @@ FUNCTION: int PQisnonblocking ( PGconn* conn ) ;
! Force the write buffer to be written (or at least try)
FUNCTION: int PQflush ( PGconn* conn ) ;
!
!
! * "Fast path" interface --- not really recommended for application
! * use
!
@ -310,17 +310,17 @@ FUNCTION: void PQprint ( FILE* fout, PGresult* res, PQprintOpt* ps ) ;
! really old printing routines
FUNCTION: void PQdisplayTuples ( PGresult* res,
FILE* fp,
FILE* fp,
int fillAlign,
c-string fieldSep,
int printHeader,
int quiet ) ;
FUNCTION: void PQprintTuples ( PGresult* res,
FILE* fout,
FILE* fout,
int printAttName,
int terseOutput,
int width ) ;
int terseOutput,
int width ) ;
! === in fe-lobj.c ===
! Large-object access routines

6
basis/db/queries/queries.factor
View File

@ -23,7 +23,7 @@ SINGLETON: retryable
[ make-retryable ] when ;
: regenerate-params ( statement -- statement )
dup
dup
[ bind-params>> ] [ in-params>> ] bi
[
dup generator-bind? [
@ -32,13 +32,13 @@ SINGLETON: retryable
drop
] if
] 2map >>bind-params ;
M: retryable execute-statement* ( statement type -- )
drop [ retries>> iota ] [
[
nip
[ query-results dispose t ]
[ ]
[ ]
[ regenerate-params bind-statement* f ] cleanup
] curry
] bi attempt-all drop ;

2
basis/db/sqlite/lib/lib.factor
View File

@ -121,7 +121,7 @@ ERROR: sqlite-sql-error < sql-error n string ;
over [
NULL = [ 2drop NULL NULL ] when
] [
drop NULL
drop NULL
] if* (sqlite-bind-type) ;
: sqlite-finalize ( handle -- ) sqlite3_finalize sqlite-check-result ;

90
basis/debugger/debugger-tests.factor
View File

@ -1,45 +1,45 @@
USING: accessors alien.syntax continuations debugger kernel
namespaces tools.test ;
IN: debugger.tests
[ ] [ [ drop ] [ error. ] recover ] unit-test
[ f ] [ { } vm-error? ] unit-test
[ f ] [ { "A" "B" } vm-error? ] unit-test
[ ] [
T{ test-failure
{ error
{
"kernel-error"
10
{
B{
88 73 110 112 117 116 69 110 97 98 108 101 0
}
B{
88 73 110 112 117 116 69 110 97 98 108 101
64 56 0
}
B{
95 88 73 110 112 117 116 69 110 97 98 108
101 64 56 0
}
B{
64 88 73 110 112 117 116 69 110 97 98 108
101 64 56 0
}
}
DLL" xinput1_3.dll"
}
}
{ asset { "Unit Test" [ ] [ dup ] } }
{ file "resource:basis/game/input/input-tests.factor" }
{ line# 6 }
{ continuation f }
} error.
] unit-test
[ "foo" { 1 2 3 "foo" } ] [
[ 1 2 3 "foo" throw ] [ ] recover error-continuation get data>>
] unit-test
USING: accessors alien.syntax continuations debugger kernel
namespaces tools.test ;
IN: debugger.tests
[ ] [ [ drop ] [ error. ] recover ] unit-test
[ f ] [ { } vm-error? ] unit-test
[ f ] [ { "A" "B" } vm-error? ] unit-test
[ ] [
T{ test-failure
{ error
{
"kernel-error"
10
{
B{
88 73 110 112 117 116 69 110 97 98 108 101 0
}
B{
88 73 110 112 117 116 69 110 97 98 108 101
64 56 0
}
B{
95 88 73 110 112 117 116 69 110 97 98 108
101 64 56 0
}
B{
64 88 73 110 112 117 116 69 110 97 98 108
101 64 56 0
}
}
DLL" xinput1_3.dll"
}
}
{ asset { "Unit Test" [ ] [ dup ] } }
{ file "resource:basis/game/input/input-tests.factor" }
{ line# 6 }
{ continuation f }
} error.
] unit-test
[ "foo" { 1 2 3 "foo" } ] [
[ 1 2 3 "foo" throw ] [ ] recover error-continuation get data>>
] unit-test

1
basis/debugger/windows/windows.factor
View File

@ -52,4 +52,3 @@ M: windows-error error.
"Win32 error 0x" write
dup n>> 0xffff,ffff bitand >hex write ": " write
string>> write ;

4
basis/delegate/delegate.factor
View File

@ -46,9 +46,9 @@ TUPLE: consultation group class quot loc ;
TUPLE: broadcast < consultation ;
: <consultation> ( group class quot -- consultation )
f consultation boa ;
f consultation boa ;
: <broadcast> ( group class quot -- consultation )
[ check-broadcast-group ] 2dip f broadcast boa ;
[ check-broadcast-group ] 2dip f broadcast boa ;
: create-consult-method ( word consultation -- method )
[ class>> swap first create-method dup fake-definition ] keep

1
basis/dlists/prettyprint/prettyprint.factor
View File

@ -7,4 +7,3 @@ M: dlist pprint-delims drop \ DL{ \ } ;
M: dlist >pprint-sequence dlist>sequence ;
M: dlist pprint-narrow? drop f ;
M: dlist pprint* pprint-object ;

1
basis/editors/atom/atom.factor
View File

@ -14,4 +14,3 @@ M: atom-editor editor-command ( file line -- command )
atom-path get [ "atom" ?find-in-path ] unless* ,
number>string ":" glue ,
] { } make ;

2
basis/editors/editors.factor
View File

@ -27,7 +27,7 @@ M: object editor-detached? t ;
: run-and-wait-for-editor ( command -- )
<process>
swap >>command
swap >>command
editor-detached? >>detached
run-process
300 milliseconds sleep

1
basis/editors/editpadpro/editpadpro.factor
View File

@ -18,4 +18,3 @@ M: editpadpro editor-command ( file line -- command )
[
editpadpro-path , number>string "/l" prepend , ,
] { } make ;

1
basis/editors/etexteditor/etexteditor.factor
View File

@ -18,4 +18,3 @@ M: etexteditor editor-command ( file line -- command )
etexteditor-path ,
[ , ] [ "--line" , number>string , ] bi*
] { } make ;

5
basis/farkup/farkup.factor
View File

@ -152,7 +152,7 @@ DEFER: (parse-paragraph)
'[
_ dup ?last ?last CHAR: \\ =
[ [ pop "|" rot 3append ] keep ] when
push
push
] each
] keep ;
@ -197,7 +197,7 @@ DEFER: (parse-paragraph)
{ CHAR: | [ parse-table ] }
{ CHAR: _ [ parse-line ] }
{ CHAR: - [ parse-ul ] }
{ CHAR: # [ parse-ol ] }
{ CHAR: # [ parse-ol ] }
{ CHAR: [ [ parse-code ] }
{ f [ rest-slice f ] }
[ drop unclip-slice make-paragraph ]
@ -290,4 +290,3 @@ M: array (write-farkup) [ (write-farkup) ] map ;
: convert-farkup ( string -- string' )
[ write-farkup ] with-string-writer ;

2
basis/fonts/fonts.factor
View File

@ -65,4 +65,4 @@ TUPLE: metrics width ascent descent height leading cap-height x-height ;
TUPLE: selection string start end color ;
C: <selection> selection
C: <selection> selection

200
basis/fry/fry-docs.factor
View File

@ -1,100 +1,100 @@
USING: help.markup help.syntax quotations kernel ;
IN: fry
HELP: _
{ $description "Fry specifier. Inserts a literal value into the fried quotation." }
{ $examples "See " { $link "fry.examples" } "." } ;
HELP: @
{ $description "Fry specifier. Splices a quotation into the fried quotation." }
{ $examples "See " { $link "fry.examples" } "." } ;
HELP: fry
{ $values { "quot" quotation } { "quot'" quotation } }
{ $description "Outputs a quotation that when called, fries " { $snippet "quot" } " by taking values from the stack and substituting them in." }
{ $notes "This word is used to implement " { $link POSTPONE: '[ } "; the following two lines are equivalent:"
{ $code "[ X ] fry call" "'[ X ]" }
}
{ $examples "See " { $link "fry.examples" } "." } ;
HELP: '[
{ $syntax "'[ code... ]" }
{ $description "Literal fried quotation. Expands into code which takes values from the stack and substitutes them in place of the fry specifiers " { $link _ } " and " { $link @ } "." }
{ $examples "See " { $link "fry.examples" } "." } ;
HELP: >r/r>-in-fry-error
{ $error-description "Thrown by " { $link POSTPONE: '[ } " if the fried quotation contains calls to retain stack manipulation primitives." } ;
ARTICLE: "fry.examples" "Examples of fried quotations"
"The easiest way to understand fried quotations is to look at some examples."
$nl
"If a quotation does not contain any fry specifiers, then " { $link POSTPONE: '[ } " behaves just like " { $link POSTPONE: [ } ":"
{ $code "{ 10 20 30 } '[ . ] each" }
"Occurrences of " { $link _ } " on the left map directly to " { $link curry } ". That is, the following three lines are equivalent:"
{ $code
"{ 10 20 30 } 5 '[ _ + ] map"
"{ 10 20 30 } 5 [ + ] curry map"
"{ 10 20 30 } [ 5 + ] map"
}
"Occurrences of " { $link _ } " in the middle of a quotation map to more complex quotation composition patterns. The following three lines are equivalent:"
{ $code
"{ 10 20 30 } 5 '[ 3 _ / ] map"
"{ 10 20 30 } 5 [ 3 ] swap [ / ] curry compose map"
"{ 10 20 30 } [ 3 5 / ] map"
}
"Occurrences of " { $link @ } " are simply syntax sugar for " { $snippet "_ call" } ". The following four lines are equivalent:"
{ $code
"{ 10 20 30 } [ sq ] '[ @ . ] each"
"{ 10 20 30 } [ sq ] [ call . ] curry each"
"{ 10 20 30 } [ sq ] [ . ] compose each"
"{ 10 20 30 } [ sq . ] each"
}
"The " { $link _ } " and " { $link @ } " specifiers may be freely mixed, and the result is considerably more concise and readable than the version using " { $link curry } " and " { $link compose } " directly:"
{ $code
"{ 8 13 14 27 } [ even? ] 5 '[ @ dup _ ? ] map"
"{ 8 13 14 27 } [ even? ] 5 [ dup ] swap [ ? ] curry compose compose map"
"{ 8 13 14 27 } [ even? dup 5 ? ] map"
}
"The following is a no-op:"
{ $code "'[ @ ]" }
"Here are some built-in combinators rewritten in terms of fried quotations:"
{ $table
{ { $link literalize } { $snippet ": literalize '[ _ ] ;" } }
{ { $link curry } { $snippet ": curry '[ _ @ ] ;" } }
{ { $link compose } { $snippet ": compose '[ @ @ ] ;" } }
} ;
ARTICLE: "fry.philosophy" "Fried quotation philosophy"
"Fried quotations generalize quotation-building words such as " { $link curry } " and " { $link compose } ". They can clean up code with lots of currying and composition, particularly when quotations are nested:"
{ $code
"'[ [ _ key? ] all? ] filter"
"[ [ key? ] curry all? ] curry filter"
}
"There is a mapping from fried quotations to lexical closures as defined in the " { $vocab-link "locals" } " vocabulary. Namely, a fried quotation is equivalent to a " { $snippet "[| | ]" } " form where each local binding is only used once, and bindings are used in the same order in which they are defined. The following two lines are equivalent:"
{ $code
"'[ 3 _ + 4 _ / ]"
"[| a b | 3 a + 4 b / ]"
} ;
ARTICLE: "fry" "Fried quotations"
"The " { $vocab-link "fry" } " vocabulary implements " { $emphasis "fried quotation" } ". Conceptually, fried quotations are quotations with “holes” (more formally, " { $emphasis "fry specifiers" } "), and the holes are filled in when the fried quotation is pushed on the stack."
$nl
"Fried quotations are started by a special parsing word:"
{ $subsections POSTPONE: '[ }
"There are two types of fry specifiers; the first can hold a value, and the second “splices” a quotation, as if it were inserted without surrounding brackets:"
{ $subsections
_
@
}
"The holes are filled in with the top of stack going in the rightmost hole, the second item on the stack going in the second hole from the right, and so on."
{ $subsections
"fry.examples"
"fry.philosophy"
}
"Fry is implemented as a parsing word which reads a quotation and scans for occurrences of " { $link _ } " and " { $link @ } "; these words are not actually executed, and doing so raises an error (this can happen if they're accidentally used outside of a fry)."
$nl
"Fried quotations can also be constructed without using a parsing word; this is useful when meta-programming:"
{ $subsections fry }
"Fried quotations are an abstraction on top of the " { $link "compositional-combinators" } "; their use is encouraged over the combinators, because often the fry form is shorter and clearer than the combinator form." ;
ABOUT: "fry"
USING: help.markup help.syntax quotations kernel ;
IN: fry
HELP: _
{ $description "Fry specifier. Inserts a literal value into the fried quotation." }
{ $examples "See " { $link "fry.examples" } "." } ;
HELP: @
{ $description "Fry specifier. Splices a quotation into the fried quotation." }
{ $examples "See " { $link "fry.examples" } "." } ;
HELP: fry
{ $values { "quot" quotation } { "quot'" quotation } }
{ $description "Outputs a quotation that when called, fries " { $snippet "quot" } " by taking values from the stack and substituting them in." }
{ $notes "This word is used to implement " { $link POSTPONE: '[ } "; the following two lines are equivalent:"
{ $code "[ X ] fry call" "'[ X ]" }
}
{ $examples "See " { $link "fry.examples" } "." } ;
HELP: '[
{ $syntax "'[ code... ]" }
{ $description "Literal fried quotation. Expands into code which takes values from the stack and substitutes them in place of the fry specifiers " { $link _ } " and " { $link @ } "." }
{ $examples "See " { $link "fry.examples" } "." } ;
HELP: >r/r>-in-fry-error
{ $error-description "Thrown by " { $link POSTPONE: '[ } " if the fried quotation contains calls to retain stack manipulation primitives." } ;
ARTICLE: "fry.examples" "Examples of fried quotations"
"The easiest way to understand fried quotations is to look at some examples."
$nl
"If a quotation does not contain any fry specifiers, then " { $link POSTPONE: '[ } " behaves just like " { $link POSTPONE: [ } ":"
{ $code "{ 10 20 30 } '[ . ] each" }
"Occurrences of " { $link _ } " on the left map directly to " { $link curry } ". That is, the following three lines are equivalent:"
{ $code
"{ 10 20 30 } 5 '[ _ + ] map"
"{ 10 20 30 } 5 [ + ] curry map"
"{ 10 20 30 } [ 5 + ] map"
}
"Occurrences of " { $link _ } " in the middle of a quotation map to more complex quotation composition patterns. The following three lines are equivalent:"
{ $code
"{ 10 20 30 } 5 '[ 3 _ / ] map"
"{ 10 20 30 } 5 [ 3 ] swap [ / ] curry compose map"
"{ 10 20 30 } [ 3 5 / ] map"
}
"Occurrences of " { $link @ } " are simply syntax sugar for " { $snippet "_ call" } ". The following four lines are equivalent:"
{ $code
"{ 10 20 30 } [ sq ] '[ @ . ] each"
"{ 10 20 30 } [ sq ] [ call . ] curry each"
"{ 10 20 30 } [ sq ] [ . ] compose each"
"{ 10 20 30 } [ sq . ] each"
}
"The " { $link _ } " and " { $link @ } " specifiers may be freely mixed, and the result is considerably more concise and readable than the version using " { $link curry } " and " { $link compose } " directly:"
{ $code
"{ 8 13 14 27 } [ even? ] 5 '[ @ dup _ ? ] map"
"{ 8 13 14 27 } [ even? ] 5 [ dup ] swap [ ? ] curry compose compose map"
"{ 8 13 14 27 } [ even? dup 5 ? ] map"
}
"The following is a no-op:"
{ $code "'[ @ ]" }
"Here are some built-in combinators rewritten in terms of fried quotations:"
{ $table
{ { $link literalize } { $snippet ": literalize '[ _ ] ;" } }
{ { $link curry } { $snippet ": curry '[ _ @ ] ;" } }
{ { $link compose } { $snippet ": compose '[ @ @ ] ;" } }
} ;
ARTICLE: "fry.philosophy" "Fried quotation philosophy"
"Fried quotations generalize quotation-building words such as " { $link curry } " and " { $link compose } ". They can clean up code with lots of currying and composition, particularly when quotations are nested:"
{ $code
"'[ [ _ key? ] all? ] filter"
"[ [ key? ] curry all? ] curry filter"
}
"There is a mapping from fried quotations to lexical closures as defined in the " { $vocab-link "locals" } " vocabulary. Namely, a fried quotation is equivalent to a " { $snippet "[| | ]" } " form where each local binding is only used once, and bindings are used in the same order in which they are defined. The following two lines are equivalent:"
{ $code
"'[ 3 _ + 4 _ / ]"
"[| a b | 3 a + 4 b / ]"
} ;
ARTICLE: "fry" "Fried quotations"
"The " { $vocab-link "fry" } " vocabulary implements " { $emphasis "fried quotation" } ". Conceptually, fried quotations are quotations with “holes” (more formally, " { $emphasis "fry specifiers" } "), and the holes are filled in when the fried quotation is pushed on the stack."
$nl
"Fried quotations are started by a special parsing word:"
{ $subsections POSTPONE: '[ }
"There are two types of fry specifiers; the first can hold a value, and the second “splices” a quotation, as if it were inserted without surrounding brackets:"
{ $subsections
_
@
}
"The holes are filled in with the top of stack going in the rightmost hole, the second item on the stack going in the second hole from the right, and so on."
{ $subsections
"fry.examples"
"fry.philosophy"
}
"Fry is implemented as a parsing word which reads a quotation and scans for occurrences of " { $link _ } " and " { $link @ } "; these words are not actually executed, and doing so raises an error (this can happen if they're accidentally used outside of a fry)."
$nl
"Fried quotations can also be constructed without using a parsing word; this is useful when meta-programming:"
{ $subsections fry }
"Fried quotations are an abstraction on top of the " { $link "compositional-combinators" } "; their use is encouraged over the combinators, because often the fry form is shorter and clearer than the combinator form." ;
ABOUT: "fry"

2
basis/ftp/server/server.factor
View File

@ -221,7 +221,7 @@ M: ftp-disconnect handle-passive-command ( stream obj -- )
dup can-serve-file? [
<ftp-put> fulfill-client
] [
drop
drop
<ftp-disconnect> fulfill-client
] if ;

240
basis/furnace/actions/actions.factor
View File

@ -1,120 +1,120 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors sequences kernel assocs combinators
validators http hashtables namespaces fry continuations locals
io arrays math boxes splitting urls
xml.entities
http.server
http.server.responses
furnace.utilities
furnace.redirection
furnace.conversations
furnace.chloe-tags
html.forms
html.components
html.templates.chloe
html.templates.chloe.syntax
html.templates.chloe.compiler ;
IN: furnace.actions
SYMBOL: rest
TUPLE: action rest init authorize display validate submit ;
: new-action ( class -- action )
new [ ] >>init [ ] >>validate [ ] >>authorize ; inline
: <action> ( -- action )
action new-action ;
: merge-forms ( form -- )
[ form get ] dip
[ [ errors>> ] bi@ append! drop ]
[ [ values>> ] bi@ assoc-union! drop ]
[ validation-failed>> >>validation-failed drop ]
2tri ;
: set-nested-form ( form name -- )
[
merge-forms
] [
unclip [ set-nested-form ] nest-form
] if-empty ;
: restore-validation-errors ( -- )
form cget [
nested-forms cget set-nested-form
] when* ;
: handle-get ( action -- response )
'[
_ dup display>> [
{
[ init>> call( -- ) ]
[ authorize>> call( -- ) ]
[ drop restore-validation-errors ]
[ display>> call( -- response ) ]
} cleave
] [ drop <400> ] if
] with-exit-continuation ;
CONSTANT: revalidate-url-key "__u"
: revalidate-url ( -- url/f )
revalidate-url-key param
dup [ >url ensure-port [ same-host? ] keep and ] when ;
: validation-failed ( -- * )
post-request? revalidate-url and [
begin-conversation
nested-forms-key param " " split harvest nested-forms cset
form get form cset
<continue-conversation>
] [ <400> ] if*
exit-with ;
: handle-post ( action -- response )
'[
_ dup submit>> [
[ validate>> call( -- ) ]
[ authorize>> call( -- ) ]
[ submit>> call( -- response ) ]
tri
] [ drop <400> ] if
] with-exit-continuation ;
: handle-rest ( path action -- )
rest>> dup [ [ "/" join ] dip set-param ] [ 2drop ] if ;
: init-action ( path action -- )
begin-form
handle-rest ;
M: action call-responder* ( path action -- response )
[ init-action ] keep
request get method>> {
{ "GET" [ handle-get ] }
{ "HEAD" [ handle-get ] }
{ "POST" [ handle-post ] }
} case ;
M: action modify-form
drop url get revalidate-url-key hidden-form-field ;
: check-validation ( -- )
validation-failed? [ validation-failed ] when ;
: validate-params ( validators -- )
params get swap validate-values check-validation ;
: validate-integer-id ( -- )
{ { "id" [ v-number ] } } validate-params ;
TUPLE: page-action < action template ;
: <chloe-content> ( path -- response )
resolve-template-path <chloe> <html-content> ;
: <page-action> ( -- page )
page-action new-action
dup '[ _ template>> <chloe-content> ] >>display ;
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors sequences kernel assocs combinators
validators http hashtables namespaces fry continuations locals
io arrays math boxes splitting urls
xml.entities
http.server
http.server.responses
furnace.utilities
furnace.redirection
furnace.conversations
furnace.chloe-tags
html.forms
html.components
html.templates.chloe
html.templates.chloe.syntax
html.templates.chloe.compiler ;
IN: furnace.actions
SYMBOL: rest
TUPLE: action rest init authorize display validate submit ;
: new-action ( class -- action )
new [ ] >>init [ ] >>validate [ ] >>authorize ; inline
: <action> ( -- action )
action new-action ;
: merge-forms ( form -- )
[ form get ] dip
[ [ errors>> ] bi@ append! drop ]
[ [ values>> ] bi@ assoc-union! drop ]
[ validation-failed>> >>validation-failed drop ]
2tri ;
: set-nested-form ( form name -- )
[
merge-forms
] [
unclip [ set-nested-form ] nest-form
] if-empty ;
: restore-validation-errors ( -- )
form cget [
nested-forms cget set-nested-form
] when* ;
: handle-get ( action -- response )
'[
_ dup display>> [
{
[ init>> call( -- ) ]
[ authorize>> call( -- ) ]
[ drop restore-validation-errors ]
[ display>> call( -- response ) ]
} cleave
] [ drop <400> ] if
] with-exit-continuation ;
CONSTANT: revalidate-url-key "__u"
: revalidate-url ( -- url/f )
revalidate-url-key param
dup [ >url ensure-port [ same-host? ] keep and ] when ;
: validation-failed ( -- * )
post-request? revalidate-url and [
begin-conversation
nested-forms-key param " " split harvest nested-forms cset
form get form cset
<continue-conversation>
] [ <400> ] if*
exit-with ;
: handle-post ( action -- response )
'[
_ dup submit>> [
[ validate>> call( -- ) ]
[ authorize>> call( -- ) ]
[ submit>> call( -- response ) ]
tri
] [ drop <400> ] if
] with-exit-continuation ;
: handle-rest ( path action -- )
rest>> dup [ [ "/" join ] dip set-param ] [ 2drop ] if ;
: init-action ( path action -- )
begin-form
handle-rest ;
M: action call-responder* ( path action -- response )
[ init-action ] keep
request get method>> {
{ "GET" [ handle-get ] }
{ "HEAD" [ handle-get ] }
{ "POST" [ handle-post ] }
} case ;
M: action modify-form
drop url get revalidate-url-key hidden-form-field ;
: check-validation ( -- )
validation-failed? [ validation-failed ] when ;
: validate-params ( validators -- )
params get swap validate-values check-validation ;
: validate-integer-id ( -- )
{ { "id" [ v-number ] } } validate-params ;
TUPLE: page-action < action template ;
: <chloe-content> ( path -- response )
resolve-template-path <chloe> <html-content> ;
: <page-action> ( -- page )
page-action new-action
dup '[ _ template>> <chloe-content> ] >>display ;

344
basis/furnace/auth/auth.factor
View File

@ -1,172 +1,172 @@
! Copyright (c) 2008, 2010 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs namespaces kernel sequences sets
destructors combinators fry logging io.encodings.utf8
io.encodings.string io.binary io.sockets.secure random checksums
checksums.sha urls
html.forms
http.server
http.server.filters
http.server.dispatchers
furnace.actions
furnace.utilities
furnace.redirection
furnace.boilerplate
furnace.auth.providers
furnace.auth.providers.db ;
FROM: assocs => change-at ;
FROM: namespaces => set ;
IN: furnace.auth
SYMBOL: logged-in-user
: logged-in? ( -- ? )
logged-in-user get >boolean ;
: username ( -- string/f )
logged-in-user get dup [ username>> ] when ;
GENERIC: init-user-profile ( responder -- )
M: object init-user-profile drop ;
M: dispatcher init-user-profile
default>> init-user-profile ;
M: filter-responder init-user-profile
responder>> init-user-profile ;
: current-profile ( -- assoc ) logged-in-user get profile>> ;
: user-changed ( -- )
logged-in-user get t >>changed? drop ;
: uget ( key -- value )
current-profile at ;
: uset ( value key -- )
current-profile set-at
user-changed ;
: uchange ( quot key -- )
current-profile swap change-at
user-changed ; inline
SYMBOL: capabilities
V{ } clone capabilities set-global
: define-capability ( word -- ) capabilities get adjoin ;
TUPLE: realm < dispatcher name users checksum secure ;
GENERIC: login-required* ( description capabilities realm -- response )
GENERIC: user-registered ( user realm -- response )
M: object user-registered 2drop URL" $realm" <redirect> ;
GENERIC: init-realm ( realm -- )
GENERIC: logged-in-username ( realm -- username )
: login-required ( description capabilities -- * )
realm get login-required* exit-with ;
: new-realm ( responder name class -- realm )
new-dispatcher
swap >>name
swap >>default
users-in-db >>users
sha-256 >>checksum
ssl-supported? >>secure ; inline
: users ( -- provider )
realm get users>> ;
TUPLE: user-saver user ;
C: <user-saver> user-saver
M: user-saver dispose
user>> dup changed?>> [ users update-user ] [ drop ] if ;
: save-user-after ( user -- )
<user-saver> &dispose drop ;
: init-user ( user -- )
[ [ logged-in-user set ] [ save-user-after ] bi ] when* ;
\ init-user DEBUG add-input-logging
M: realm call-responder* ( path responder -- response )
dup realm set
logged-in? [
dup init-realm
dup logged-in-username
dup [ users get-user ] when
init-user
] unless
call-next-method ;
: encode-password ( string salt -- bytes )
[ utf8 encode ] [ 4 >be ] bi* append
realm get checksum>> checksum-bytes ;
: >>encoded-password ( user string -- user )
32 random-bits [ encode-password ] keep
[ >>password ] [ >>salt ] bi* ; inline
: valid-login? ( password user -- ? )
[ salt>> encode-password ] [ password>> ] bi = ;
: check-login ( password username -- user/f )
users get-user dup [ [ valid-login? ] keep and ] [ 2drop f ] if ;
: if-secure-realm ( quot -- )
realm get secure>> [ if-secure ] [ call ] if ; inline
TUPLE: secure-realm-only < filter-responder ;
C: <secure-realm-only> secure-realm-only
M: secure-realm-only call-responder*
'[ _ _ call-next-method ] if-secure-realm ;
TUPLE: protected < filter-responder description capabilities ;
: <protected> ( responder -- protected )
protected new
swap >>responder ;
: have-capabilities? ( capabilities -- ? )
realm get secure>> secure-connection? not and [ drop f ] [
logged-in-user get {
{ [ dup not ] [ 2drop f ] }
{ [ dup deleted>> 1 = ] [ 2drop f ] }
[ capabilities>> subset? ]
} cond
] if ;
M: protected call-responder* ( path responder -- response )
dup protected set
dup capabilities>> have-capabilities?
[ call-next-method ] [
[ drop ] [ [ description>> ] [ capabilities>> ] bi ] bi*
realm get login-required*
] if ;
: <auth-boilerplate> ( responder -- responder' )
<boilerplate> { realm "boilerplate" } >>template ;
: password-mismatch ( -- * )
"passwords do not match" validation-error
validation-failed ;
: same-password-twice ( -- )
"new-password" value "verify-password" value =
[ password-mismatch ] unless ;
: user-exists ( -- * )
"username taken" validation-error
validation-failed ;
! Copyright (c) 2008, 2010 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs namespaces kernel sequences sets
destructors combinators fry logging io.encodings.utf8
io.encodings.string io.binary io.sockets.secure random checksums
checksums.sha urls
html.forms
http.server
http.server.filters
http.server.dispatchers
furnace.actions
furnace.utilities
furnace.redirection
furnace.boilerplate
furnace.auth.providers
furnace.auth.providers.db ;
FROM: assocs => change-at ;
FROM: namespaces => set ;
IN: furnace.auth
SYMBOL: logged-in-user
: logged-in? ( -- ? )
logged-in-user get >boolean ;
: username ( -- string/f )
logged-in-user get dup [ username>> ] when ;
GENERIC: init-user-profile ( responder -- )
M: object init-user-profile drop ;
M: dispatcher init-user-profile
default>> init-user-profile ;
M: filter-responder init-user-profile
responder>> init-user-profile ;
: current-profile ( -- assoc ) logged-in-user get profile>> ;
: user-changed ( -- )
logged-in-user get t >>changed? drop ;
: uget ( key -- value )
current-profile at ;
: uset ( value key -- )
current-profile set-at
user-changed ;
: uchange ( quot key -- )
current-profile swap change-at
user-changed ; inline
SYMBOL: capabilities
V{ } clone capabilities set-global
: define-capability ( word -- ) capabilities get adjoin ;
TUPLE: realm < dispatcher name users checksum secure ;
GENERIC: login-required* ( description capabilities realm -- response )
GENERIC: user-registered ( user realm -- response )
M: object user-registered 2drop URL" $realm" <redirect> ;
GENERIC: init-realm ( realm -- )
GENERIC: logged-in-username ( realm -- username )
: login-required ( description capabilities -- * )
realm get login-required* exit-with ;
: new-realm ( responder name class -- realm )
new-dispatcher
swap >>name
swap >>default
users-in-db >>users
sha-256 >>checksum
ssl-supported? >>secure ; inline
: users ( -- provider )
realm get users>> ;
TUPLE: user-saver user ;
C: <user-saver> user-saver
M: user-saver dispose
user>> dup changed?>> [ users update-user ] [ drop ] if ;
: save-user-after ( user -- )
<user-saver> &dispose drop ;
: init-user ( user -- )
[ [ logged-in-user set ] [ save-user-after ] bi ] when* ;
\ init-user DEBUG add-input-logging
M: realm call-responder* ( path responder -- response )
dup realm set
logged-in? [
dup init-realm
dup logged-in-username
dup [ users get-user ] when
init-user
] unless
call-next-method ;
: encode-password ( string salt -- bytes )
[ utf8 encode ] [ 4 >be ] bi* append
realm get checksum>> checksum-bytes ;
: >>encoded-password ( user string -- user )
32 random-bits [ encode-password ] keep
[ >>password ] [ >>salt ] bi* ; inline
: valid-login? ( password user -- ? )
[ salt>> encode-password ] [ password>> ] bi = ;
: check-login ( password username -- user/f )
users get-user dup [ [ valid-login? ] keep and ] [ 2drop f ] if ;
: if-secure-realm ( quot -- )
realm get secure>> [ if-secure ] [ call ] if ; inline
TUPLE: secure-realm-only < filter-responder ;
C: <secure-realm-only> secure-realm-only
M: secure-realm-only call-responder*
'[ _ _ call-next-method ] if-secure-realm ;
TUPLE: protected < filter-responder description capabilities ;
: <protected> ( responder -- protected )
protected new
swap >>responder ;
: have-capabilities? ( capabilities -- ? )
realm get secure>> secure-connection? not and [ drop f ] [
logged-in-user get {
{ [ dup not ] [ 2drop f ] }
{ [ dup deleted>> 1 = ] [ 2drop f ] }
[ capabilities>> subset? ]
} cond
] if ;
M: protected call-responder* ( path responder -- response )
dup protected set
dup capabilities>> have-capabilities?
[ call-next-method ] [
[ drop ] [ [ description>> ] [ capabilities>> ] bi ] bi*
realm get login-required*
] if ;
: <auth-boilerplate> ( responder -- responder' )
<boilerplate> { realm "boilerplate" } >>template ;
: password-mismatch ( -- * )
"passwords do not match" validation-error
validation-failed ;
: same-password-twice ( -- )
"new-password" value "verify-password" value =
[ password-mismatch ] unless ;
: user-exists ( -- * )
"username taken" validation-error
validation-failed ;

62
basis/furnace/auth/basic/basic.factor
View File

@ -1,31 +1,31 @@
! Copyright (c) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel splitting base64 namespaces make strings
http http.server.responses furnace.auth ;
IN: furnace.auth.basic
TUPLE: basic-auth-realm < realm ;
: <basic-auth-realm> ( responder name -- realm )
basic-auth-realm new-realm ;
: parse-basic-auth ( header -- username/f password/f )
dup [
" " split1 swap "Basic" = [
base64> >string ":" split1
] [ drop f f ] if
] [ drop f f ] if ;
: <401> ( realm -- response )
401 "Invalid username or password" <trivial-response>
[ "Basic realm=\"" % swap % "\"" % ] "" make "WWW-Authenticate" set-header ;
M: basic-auth-realm login-required* ( description capabilities realm -- response )
2nip name>> <401> ;
M: basic-auth-realm logged-in-username ( realm -- uid )
drop
request get "authorization" header parse-basic-auth
dup [ over check-login swap and ] [ 2drop f ] if ;
M: basic-auth-realm init-realm drop ;
! Copyright (c) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel splitting base64 namespaces make strings
http http.server.responses furnace.auth ;
IN: furnace.auth.basic
TUPLE: basic-auth-realm < realm ;
: <basic-auth-realm> ( responder name -- realm )
basic-auth-realm new-realm ;
: parse-basic-auth ( header -- username/f password/f )
dup [
" " split1 swap "Basic" = [
base64> >string ":" split1
] [ drop f f ] if
] [ drop f f ] if ;
: <401> ( realm -- response )
401 "Invalid username or password" <trivial-response>
[ "Basic realm=\"" % swap % "\"" % ] "" make "WWW-Authenticate" set-header ;
M: basic-auth-realm login-required* ( description capabilities realm -- response )
2nip name>> <401> ;
M: basic-auth-realm logged-in-username ( realm -- uid )
drop
request get "authorization" header parse-basic-auth
dup [ over check-login swap and ] [ 2drop f ] if ;
M: basic-auth-realm init-realm drop ;

2
basis/furnace/auth/features/deactivate-user/deactivate-user.factor
View File

@ -17,7 +17,7 @@ IN: furnace.auth.features.deactivate-user
drop
URL" $realm" end-aside
] >>submit ;
: allow-deactivation ( realm -- realm )
<deactivate-user-action> <protected>
"delete your profile" >>description

2
basis/furnace/auth/features/edit-profile/edit-profile.factor
View File

@ -26,7 +26,7 @@ IN: furnace.auth.features.edit-profile
{ "realname" [ [ v-one-line ] v-optional ] }
{ "password" [ ] }
{ "new-password" [ [ v-password ] v-optional ] }
{ "verify-password" [ [ v-password ] v-optional ] }
{ "verify-password" [ [ v-password ] v-optional ] }
{ "email" [ [ v-email ] v-optional ] }
} validate-params

232
basis/furnace/auth/login/login.factor
View File

@ -1,116 +1,116 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces sequences math.parser
calendar checksums validators urls logging html.forms
http http.server http.server.dispatchers
furnace.auth
furnace.asides
furnace.actions
furnace.sessions
furnace.utilities
furnace.redirection
furnace.conversations
furnace.auth.login.permits ;
IN: furnace.auth.login
SYMBOL: permit-id
: permit-id-key ( realm -- string )
hex-string "__p_" prepend ;
: client-permit-id ( realm -- id/f )
permit-id-key client-state dup [ string>number ] when ;
TUPLE: login-realm < realm timeout domain ;
M: login-realm init-realm
name>> client-permit-id permit-id set ;
M: login-realm logged-in-username
drop permit-id get dup [ get-permit-uid ] when ;
M: login-realm modify-form ( responder -- xml/f )
drop permit-id get realm get name>> permit-id-key hidden-form-field ;
: <permit-cookie> ( -- cookie )
permit-id get realm get name>> permit-id-key <cookie>
"$login-realm" resolve-base-path >>path
realm get
[ domain>> >>domain ]
[ secure>> >>secure ]
bi ;
: put-permit-cookie ( response -- response' )
<permit-cookie> put-cookie ;
\ put-permit-cookie DEBUG add-input-logging
: successful-login ( user -- response )
[ username>> make-permit permit-id set ] [ init-user ] bi
URL" $realm" end-aside
put-permit-cookie ;
\ successful-login DEBUG add-input-logging
: logout ( -- response )
permit-id get [ delete-permit ] when*
URL" $realm" end-aside ;
<PRIVATE
SYMBOL: description
SYMBOL: capabilities
PRIVATE>
CONSTANT: flashed-variables { description capabilities }
: login-failed ( -- * )
"invalid username or password" validation-error
validation-failed ;
: <login-action> ( -- action )
<page-action>
[
description cget "description" set-value
capabilities cget words>strings "capabilities" set-value
] >>init
{ login-realm "login" } >>template
[
{
{ "username" [ v-required ] }
{ "password" [ v-required ] }
} validate-params
"password" value
"username" value check-login
[ successful-login ] [ login-failed ] if*
] >>submit
<auth-boilerplate>
<secure-realm-only> ;
: <logout-action> ( -- action )
<action>
[ logout ] >>submit ;
M: login-realm login-required* ( description capabilities login -- response )
begin-conversation
[ description cset ] [ capabilities cset ] [ secure>> ] tri*
[
url get >secure-url begin-aside
URL" $realm/login" >secure-url <continue-conversation>
] [
url get begin-aside
URL" $realm/login" <continue-conversation>
] if ;
M: login-realm user-registered ( user realm -- response )
drop successful-login ;
: <login-realm> ( responder name -- realm )
login-realm new-realm
<login-action> "login" add-responder
<logout-action> "logout" add-responder
20 minutes >>timeout ;
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces sequences math.parser
calendar checksums validators urls logging html.forms
http http.server http.server.dispatchers
furnace.auth
furnace.asides
furnace.actions
furnace.sessions
furnace.utilities
furnace.redirection
furnace.conversations
furnace.auth.login.permits ;
IN: furnace.auth.login
SYMBOL: permit-id
: permit-id-key ( realm -- string )
hex-string "__p_" prepend ;
: client-permit-id ( realm -- id/f )
permit-id-key client-state dup [ string>number ] when ;
TUPLE: login-realm < realm timeout domain ;
M: login-realm init-realm
name>> client-permit-id permit-id set ;
M: login-realm logged-in-username
drop permit-id get dup [ get-permit-uid ] when ;
M: login-realm modify-form ( responder -- xml/f )
drop permit-id get realm get name>> permit-id-key hidden-form-field ;
: <permit-cookie> ( -- cookie )
permit-id get realm get name>> permit-id-key <cookie>
"$login-realm" resolve-base-path >>path
realm get
[ domain>> >>domain ]
[ secure>> >>secure ]
bi ;
: put-permit-cookie ( response -- response' )
<permit-cookie> put-cookie ;
\ put-permit-cookie DEBUG add-input-logging
: successful-login ( user -- response )
[ username>> make-permit permit-id set ] [ init-user ] bi
URL" $realm" end-aside
put-permit-cookie ;
\ successful-login DEBUG add-input-logging
: logout ( -- response )
permit-id get [ delete-permit ] when*
URL" $realm" end-aside ;
<PRIVATE
SYMBOL: description
SYMBOL: capabilities
PRIVATE>
CONSTANT: flashed-variables { description capabilities }
: login-failed ( -- * )
"invalid username or password" validation-error
validation-failed ;
: <login-action> ( -- action )
<page-action>
[
description cget "description" set-value
capabilities cget words>strings "capabilities" set-value
] >>init
{ login-realm "login" } >>template
[
{
{ "username" [ v-required ] }
{ "password" [ v-required ] }
} validate-params
"password" value
"username" value check-login
[ successful-login ] [ login-failed ] if*
] >>submit
<auth-boilerplate>
<secure-realm-only> ;
: <logout-action> ( -- action )
<action>
[ logout ] >>submit ;
M: login-realm login-required* ( description capabilities login -- response )
begin-conversation
[ description cset ] [ capabilities cset ] [ secure>> ] tri*
[
url get >secure-url begin-aside
URL" $realm/login" >secure-url <continue-conversation>
] [
url get begin-aside
URL" $realm/login" <continue-conversation>
] if ;
M: login-realm user-registered ( user realm -- response )
drop successful-login ;
: <login-realm> ( responder name -- realm )
login-realm new-realm
<login-action> "login" add-responder
<logout-action> "logout" add-responder
20 minutes >>timeout ;

2
basis/furnace/auth/login/permits/permits.factor
View File

@ -24,6 +24,6 @@ permit "PERMITS" {
swap >>uid
session get id>> >>session
[ touch-permit ] [ insert-tuple ] [ id>> ] tri ;
: delete-permit ( id -- )
permit new-server-state delete-tuples ;

70
basis/furnace/auth/providers/assoc/assoc-tests.factor
View File

@ -1,35 +1,35 @@
USING: furnace.actions furnace.auth furnace.auth.providers
furnace.auth.providers.assoc furnace.auth.login
tools.test namespaces accessors kernel ;
IN: furnace.auth.providers.assoc.tests
<action> "Test" <login-realm>
<users-in-memory> >>users
realm set
[ t ] [
"slava" <user>
"foobar" >>encoded-password
"slava@factorcode.org" >>email
H{ } clone >>profile
users new-user
username>> "slava" =
] unit-test
[ f ] [
"slava" <user>
H{ } clone >>profile
users new-user
] unit-test
[ f ] [ "fdasf" "slava" check-login >boolean ] unit-test
[ ] [ "foobar" "slava" check-login "user" set ] unit-test
[ t ] [ "user" get >boolean ] unit-test
[ ] [ "user" get "fdasf" >>encoded-password drop ] unit-test
[ t ] [ "fdasf" "slava" check-login >boolean ] unit-test
[ f ] [ "foobar" "slava" check-login >boolean ] unit-test
USING: furnace.actions furnace.auth furnace.auth.providers
furnace.auth.providers.assoc furnace.auth.login
tools.test namespaces accessors kernel ;
IN: furnace.auth.providers.assoc.tests
<action> "Test" <login-realm>
<users-in-memory> >>users
realm set
[ t ] [
"slava" <user>
"foobar" >>encoded-password
"slava@factorcode.org" >>email
H{ } clone >>profile
users new-user
username>> "slava" =
] unit-test
[ f ] [
"slava" <user>
H{ } clone >>profile
users new-user
] unit-test
[ f ] [ "fdasf" "slava" check-login >boolean ] unit-test
[ ] [ "foobar" "slava" check-login "user" set ] unit-test
[ t ] [ "user" get >boolean ] unit-test
[ ] [ "user" get "fdasf" >>encoded-password drop ] unit-test
[ t ] [ "fdasf" "slava" check-login >boolean ] unit-test
[ f ] [ "foobar" "slava" check-login >boolean ] unit-test

36
basis/furnace/auth/providers/assoc/assoc.factor
View File

@ -1,18 +1,18 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel furnace.auth.providers ;
IN: furnace.auth.providers.assoc
TUPLE: users-in-memory assoc ;
: <users-in-memory> ( -- provider )
H{ } clone users-in-memory boa ;
M: users-in-memory get-user ( username provider -- user/f )
assoc>> at ;
M: users-in-memory update-user ( user provider -- ) 2drop ;
M: users-in-memory new-user ( user provider -- user/f )
[ dup username>> ] dip assoc>>
2dup key? [ 3drop f ] [ pick [ set-at ] dip ] if ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel furnace.auth.providers ;
IN: furnace.auth.providers.assoc
TUPLE: users-in-memory assoc ;
: <users-in-memory> ( -- provider )
H{ } clone users-in-memory boa ;
M: users-in-memory get-user ( username provider -- user/f )
assoc>> at ;
M: users-in-memory update-user ( user provider -- ) 2drop ;
M: users-in-memory new-user ( user provider -- user/f )
[ dup username>> ] dip assoc>>
2dup key? [ 3drop f ] [ pick [ set-at ] dip ] if ;

100
basis/furnace/auth/providers/db/db-tests.factor
View File

@ -1,50 +1,50 @@
USING: furnace.actions
furnace.auth
furnace.auth.login
furnace.auth.providers
furnace.auth.providers.db tools.test
namespaces db db.sqlite db.tuples continuations
io.files io.files.temp io.directories accessors kernel
sequences system ;
IN: furnace.auth.providers.db.tests
<action> "test" <login-realm> realm set
: auth-test-db-name ( -- string )
cpu name>> "auth-test." ".db" surround ;
[ auth-test-db-name temp-file delete-file ] ignore-errors
auth-test-db-name temp-file <sqlite-db> [
user ensure-table
[ t ] [
"slava" <user>
"foobar" >>encoded-password
"slava@factorcode.org" >>email
H{ } clone >>profile
users new-user
username>> "slava" =
] unit-test
[ f ] [
"slava" <user>
H{ } clone >>profile
users new-user
] unit-test
[ f ] [ "fdasf" "slava" check-login >boolean ] unit-test
[ ] [ "foobar" "slava" check-login "user" set ] unit-test
[ t ] [ "user" get >boolean ] unit-test
[ ] [ "user" get "fdasf" >>encoded-password drop ] unit-test
[ ] [ "user" get users update-user ] unit-test
[ t ] [ "fdasf" "slava" check-login >boolean ] unit-test
[ f ] [ "foobar" "slava" check-login >boolean ] unit-test
] with-db
USING: furnace.actions
furnace.auth
furnace.auth.login
furnace.auth.providers
furnace.auth.providers.db tools.test
namespaces db db.sqlite db.tuples continuations
io.files io.files.temp io.directories accessors kernel
sequences system ;
IN: furnace.auth.providers.db.tests
<action> "test" <login-realm> realm set
: auth-test-db-name ( -- string )
cpu name>> "auth-test." ".db" surround ;
[ auth-test-db-name temp-file delete-file ] ignore-errors
auth-test-db-name temp-file <sqlite-db> [
user ensure-table
[ t ] [
"slava" <user>
"foobar" >>encoded-password
"slava@factorcode.org" >>email
H{ } clone >>profile
users new-user
username>> "slava" =
] unit-test
[ f ] [
"slava" <user>
H{ } clone >>profile
users new-user
] unit-test
[ f ] [ "fdasf" "slava" check-login >boolean ] unit-test
[ ] [ "foobar" "slava" check-login "user" set ] unit-test
[ t ] [ "user" get >boolean ] unit-test
[ ] [ "user" get "fdasf" >>encoded-password drop ] unit-test
[ ] [ "user" get users update-user ] unit-test
[ t ] [ "fdasf" "slava" check-login >boolean ] unit-test
[ f ] [ "foobar" "slava" check-login >boolean ] unit-test
] with-db

24
basis/furnace/auth/providers/null/null.factor
View File

@ -1,12 +1,12 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: furnace.auth.providers kernel ;
IN: furnace.auth.providers.null
SINGLETON: no-users
M: no-users get-user 2drop f ;
M: no-users new-user 2drop f ;
M: no-users update-user 2drop ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: furnace.auth.providers kernel ;
IN: furnace.auth.providers.null
SINGLETON: no-users
M: no-users get-user 2drop f ;
M: no-users new-user 2drop f ;
M: no-users update-user 2drop ;

96
basis/furnace/auth/providers/providers.factor
View File

@ -1,48 +1,48 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors random math.parser locals
sequences math ;
IN: furnace.auth.providers
TUPLE: user
username realname
password salt
email ticket capabilities profile deleted changed? ;
: <user> ( username -- user )
user new
swap >>username
0 >>deleted ;
GENERIC: get-user ( username provider -- user/f )
GENERIC: update-user ( user provider -- )
GENERIC: new-user ( user provider -- user/f )
! Password recovery support
:: issue-ticket ( email username provider -- user/f )
username provider get-user :> user
user [
user email>> length 0 > [
user email>> email = [
user
256 random-bits >hex >>ticket
dup provider update-user
] [ f ] if
] [ f ] if
] [ f ] if ;
:: claim-ticket ( ticket username provider -- user/f )
username provider get-user :> user
user [
user ticket>> ticket = [
user f >>ticket dup provider update-user
] [ f ] if
] [ f ] if ;
! For configuration
: add-user ( provider user -- provider )
over new-user [ "User exists" throw ] when ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors random math.parser locals
sequences math ;
IN: furnace.auth.providers
TUPLE: user
username realname
password salt
email ticket capabilities profile deleted changed? ;
: <user> ( username -- user )
user new
swap >>username
0 >>deleted ;
GENERIC: get-user ( username provider -- user/f )
GENERIC: update-user ( user provider -- )
GENERIC: new-user ( user provider -- user/f )
! Password recovery support
:: issue-ticket ( email username provider -- user/f )
username provider get-user :> user
user [
user email>> length 0 > [
user email>> email = [
user
256 random-bits >hex >>ticket
dup provider update-user
] [ f ] if
] [ f ] if
] [ f ] if ;
:: claim-ticket ( ticket username provider -- user/f )
username provider get-user :> user
user [
user ticket>> ticket = [
user f >>ticket dup provider update-user
] [ f ] if
] [ f ] if ;
! For configuration
: add-user ( provider user -- provider )
over new-user [ "User exists" throw ] when ;

38
basis/furnace/db/db.factor
View File

@ -1,19 +1,19 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors continuations namespaces destructors
db db.private db.pools io.pools http.server http.server.filters ;
IN: furnace.db
TUPLE: db-persistence < filter-responder pool disposed ;
: <db-persistence> ( responder db -- responder' )
<db-pool> f db-persistence boa ;
M: db-persistence call-responder*
[
pool>> [ acquire-connection ] keep
[ return-connection-later ] [ drop db-connection set ] 2bi
]
[ call-next-method ] bi ;
M: db-persistence dispose* pool>> dispose ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors continuations namespaces destructors
db db.private db.pools io.pools http.server http.server.filters ;
IN: furnace.db
TUPLE: db-persistence < filter-responder pool disposed ;
: <db-persistence> ( responder db -- responder' )
<db-pool> f db-persistence boa ;
M: db-persistence call-responder*
[
pool>> [ acquire-connection ] keep
[ return-connection-later ] [ drop db-connection set ] 2bi
]
[ call-next-method ] bi ;
M: db-persistence dispose* pool>> dispose ;

308
basis/furnace/sessions/sessions-tests.factor
View File

@ -1,154 +1,154 @@
USING: tools.test http furnace.sessions furnace.actions
http.server http.server.responses math namespaces make kernel
accessors io.sockets io.servers prettyprint
io.streams.string io.files io.files.temp io.directories
splitting destructors sequences db db.tuples db.sqlite
continuations urls math.parser furnace furnace.utilities ;
IN: furnace.sessions.tests
: with-session ( session quot -- )
[
[ [ save-session-after ] [ session set ] bi ] dip call
] with-destructors ; inline
TUPLE: foo ;
C: <foo> foo
M: foo init-session* drop 0 "x" sset ;
M: foo call-responder*
2drop
"x" [ 1 + ] schange
"x" sget number>string <html-content> ;
: url-responder-mock-test ( -- string )
[
<request>
"GET" >>method
dup url>>
"id" get session-id-key set-query-param
"/" >>path drop
init-request
{ } sessions get call-responder
[ write-response-body drop ] with-string-writer
] with-destructors ;
: sessions-mock-test ( -- string )
[
<request>
"GET" >>method
"cookies" get >>cookies
dup url>> "/" >>path drop
init-request
{ } sessions get call-responder
[ write-response-body drop ] with-string-writer
] with-destructors ;
: <exiting-action> ( -- action )
<action>
[ [ ] <text-content> exit-with ] >>display ;
[ "auth-test.db" temp-file delete-file ] ignore-errors
"auth-test.db" temp-file <sqlite-db> [
<request> "GET" >>method init-request
session ensure-table
"127.0.0.1" 1234 <inet4> remote-address set
[ ] [
<foo> <sessions>
sessions set
] unit-test
[
[ ] [
empty-session
123 >>id session set
] unit-test
[ ] [ 3 "x" sset ] unit-test
[ 9 ] [ "x" sget sq ] unit-test
[ ] [ "x" [ 1 - ] schange ] unit-test
[ 4 ] [ "x" sget sq ] unit-test
[ t ] [ session get changed?>> ] unit-test
] with-scope
[ t ] [
begin-session id>>
get-session session?
] unit-test
[ { 5 0 } ] [
[
begin-session
dup [ 5 "a" sset ] with-session
dup [ "a" sget , ] with-session
dup [ "x" sget , ] with-session
drop
] { } make
] unit-test
[ 0 ] [
begin-session id>>
get-session [ "x" sget ] with-session
] unit-test
[ { 5 0 } ] [
[
begin-session id>>
dup get-session [ 5 "a" sset ] with-session
dup get-session [ "a" sget , ] with-session
dup get-session [ "x" sget , ] with-session
drop
] { } make
] unit-test
[ ] [
<foo> <sessions>
sessions set
] unit-test
[
<request>
"GET" >>method
dup url>> "/" >>path drop
request set
{ "etc" } sessions get call-responder response set
[ "1" ] [ [ response get write-response-body drop ] with-string-writer ] unit-test
response get
] with-destructors
response set
[ ] [ response get cookies>> "cookies" set ] unit-test
[ "2" ] [ sessions-mock-test ] unit-test
[ "3" ] [ sessions-mock-test ] unit-test
[ "4" ] [ sessions-mock-test ] unit-test
[
[ ] [
<request>
"GET" >>method
dup url>>
"id" get session-id-key set-query-param
"/" >>path drop
request set
[
{ } <exiting-action> <sessions>
call-responder
] with-destructors response set
] unit-test
[ "text/plain" ] [ response get content-type>> ] unit-test
[ f ] [ response get cookies>> empty? ] unit-test
] with-scope
] with-db
USING: tools.test http furnace.sessions furnace.actions
http.server http.server.responses math namespaces make kernel
accessors io.sockets io.servers prettyprint
io.streams.string io.files io.files.temp io.directories
splitting destructors sequences db db.tuples db.sqlite
continuations urls math.parser furnace furnace.utilities ;
IN: furnace.sessions.tests
: with-session ( session quot -- )
[
[ [ save-session-after ] [ session set ] bi ] dip call
] with-destructors ; inline
TUPLE: foo ;
C: <foo> foo
M: foo init-session* drop 0 "x" sset ;
M: foo call-responder*
2drop
"x" [ 1 + ] schange
"x" sget number>string <html-content> ;
: url-responder-mock-test ( -- string )
[
<request>
"GET" >>method
dup url>>
"id" get session-id-key set-query-param
"/" >>path drop
init-request
{ } sessions get call-responder
[ write-response-body drop ] with-string-writer
] with-destructors ;
: sessions-mock-test ( -- string )
[
<request>
"GET" >>method
"cookies" get >>cookies
dup url>> "/" >>path drop
init-request
{ } sessions get call-responder
[ write-response-body drop ] with-string-writer
] with-destructors ;
: <exiting-action> ( -- action )
<action>
[ [ ] <text-content> exit-with ] >>display ;
[ "auth-test.db" temp-file delete-file ] ignore-errors
"auth-test.db" temp-file <sqlite-db> [
<request> "GET" >>method init-request
session ensure-table
"127.0.0.1" 1234 <inet4> remote-address set
[ ] [
<foo> <sessions>
sessions set
] unit-test
[
[ ] [
empty-session
123 >>id session set
] unit-test
[ ] [ 3 "x" sset ] unit-test
[ 9 ] [ "x" sget sq ] unit-test
[ ] [ "x" [ 1 - ] schange ] unit-test
[ 4 ] [ "x" sget sq ] unit-test
[ t ] [ session get changed?>> ] unit-test
] with-scope
[ t ] [
begin-session id>>
get-session session?
] unit-test
[ { 5 0 } ] [
[
begin-session
dup [ 5 "a" sset ] with-session
dup [ "a" sget , ] with-session
dup [ "x" sget , ] with-session
drop
] { } make
] unit-test
[ 0 ] [
begin-session id>>
get-session [ "x" sget ] with-session
] unit-test
[ { 5 0 } ] [
[
begin-session id>>
dup get-session [ 5 "a" sset ] with-session
dup get-session [ "a" sget , ] with-session
dup get-session [ "x" sget , ] with-session
drop
] { } make
] unit-test
[ ] [
<foo> <sessions>
sessions set
] unit-test
[
<request>
"GET" >>method
dup url>> "/" >>path drop
request set
{ "etc" } sessions get call-responder response set
[ "1" ] [ [ response get write-response-body drop ] with-string-writer ] unit-test
response get
] with-destructors
response set
[ ] [ response get cookies>> "cookies" set ] unit-test
[ "2" ] [ sessions-mock-test ] unit-test
[ "3" ] [ sessions-mock-test ] unit-test
[ "4" ] [ sessions-mock-test ] unit-test
[
[ ] [
<request>
"GET" >>method
dup url>>
"id" get session-id-key set-query-param
"/" >>path drop
request set
[
{ } <exiting-action> <sessions>
call-responder
] with-destructors response set
] unit-test
[ "text/plain" ] [ response get content-type>> ] unit-test
[ f ] [ response get cookies>> empty? ] unit-test
] with-scope
] with-db

1
basis/game/input/dinput/keys-array/keys-array.factor
View File

@ -14,4 +14,3 @@ M: keys-array length length>> ;
M: keys-array nth-unsafe underlying>> nth-unsafe >key ;
INSTANCE: keys-array sequence

70
basis/game/input/gtk/gtk.factor
View File

@ -49,45 +49,45 @@ HOOK: x>hid-bit-order os ( -- x )
M: linux x>hid-bit-order
{
0 0 0 0 0 0 0 0
0 41 30 31 32 33 34 35
36 37 38 39 45 46 42 43
20 26 8 21 23 28 24 12
18 19 47 48 40 224 4 22
7 9 10 11 13 14 15 51
52 53 225 49 29 27 6 25
5 17 16 54 55 56 229 85
226 44 57 58 59 60 61 62
63 64 65 66 67 83 71 95
96 97 86 92 93 94 87 91
90 89 98 99 0 0 0 68
69 0 0 0 0 0 0 0
88 228 84 70 0 0 74 82
75 80 79 77 81 78 73 76
127 129 128 102 103 0 72 0
0 0 0 227 231 0 0 0
0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0
0 41 30 31 32 33 34 35
36 37 38 39 45 46 42 43
20 26 8 21 23 28 24 12
18 19 47 48 40 224 4 22
7 9 10 11 13 14 15 51
52 53 225 49 29 27 6 25
5 17 16 54 55 56 229 85
226 44 57 58 59 60 61 62
63 64 65 66 67 83 71 95
96 97 86 92 93 94 87 91
90 89 98 99 0 0 0 68
69 0 0 0 0 0 0 0
88 228 84 70 0 0 74 82
75 80 79 77 81 78 73 76
127 129 128 102 103 0 72 0
0 0 0 227 231 0 0 0
0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0
} ; inline
: x-bits>hid-bits ( bit-array -- bit-array )
256 iota zip [ first ] filter values
x>hid-bit-order [ nth ] curry map
256 <bit-array> swap [ t swap pick set-nth ] each ;
M: gtk-game-input-backend read-keyboard
get-dpy 256 <bit-array> [ XQueryKeymap drop ] keep
x-bits>hid-bits keyboard-state boa ;
@ -105,7 +105,7 @@ M: gtk-game-input-backend read-mouse
swap 400 - >>dy
swap 400 - >>dx
0 >>scroll-dy 0 >>scroll-dx ;
M: gtk-game-input-backend reset-mouse
get-dpy dup XDefaultRootWindow dup
0 0 0 0 400 400 XWarpPointer drop ;

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