From: Doug Coleman Date: Mon, 29 Jun 2015 23:43:15 +0000 (-0700) Subject: core, basis, extra: Remove DOS line endings from files. X-Git-Tag: unmaintained~2534 X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=352e5de16a2c0981532a7af518bf05a99586aea8 core, basis, extra: Remove DOS line endings from files. Remove whitespace from end of lines. Add a newline to the end of each file. --- diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor index 136c791327..a4a2838043 100644 --- a/basis/alien/arrays/arrays.factor +++ b/basis/alien/arrays/arrays.factor @@ -63,4 +63,3 @@ M: string-type c-type-setter drop [ set-alien-cell ] ; [ { c-string utf8 } c-string typedef ] with-compilation-unit - diff --git a/basis/alien/endian/endian.factor b/basis/alien/endian/endian.factor index a7b1d025cd..a7593c05b7 100644 --- a/basis/alien/endian/endian.factor +++ b/basis/alien/endian/endian.factor @@ -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 ; - diff --git a/basis/alien/libraries/unix/unix.factor b/basis/alien/libraries/unix/unix.factor index 612c656c07..c0fd232caa 100644 --- a/basis/alien/libraries/unix/unix.factor +++ b/basis/alien/libraries/unix/unix.factor @@ -12,4 +12,3 @@ M: unix >deployed-library-path M: macosx >deployed-library-path file-name "@executable_path/../Frameworks" prepend-path ; - diff --git a/basis/alien/prettyprint/prettyprint-tests.factor b/basis/alien/prettyprint/prettyprint-tests.factor index 09d0250788..b3ca2f0e7f 100644 --- a/basis/alien/prettyprint/prettyprint-tests.factor +++ b/basis/alien/prettyprint/prettyprint-tests.factor @@ -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 diff --git a/basis/alien/prettyprint/prettyprint.factor b/basis/alien/prettyprint/prettyprint.factor index bd91d04784..58b128d3c1 100644 --- a/basis/alien/prettyprint/prettyprint.factor +++ b/basis/alien/prettyprint/prettyprint.factor @@ -110,7 +110,7 @@ M: alien-callback-type-word synopsis* [ def>> first first pprint-c-type ] [ pprint-word ] [ - > first second ] [ "callback-effect" word-prop in>> ] bi pprint-function-args ")" text block> diff --git a/basis/ascii/ascii-docs.factor b/basis/ascii/ascii-docs.factor index 9242460718..be49af644c 100644 --- a/basis/ascii/ascii-docs.factor +++ b/basis/ascii/ascii-docs.factor @@ -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" diff --git a/basis/ascii/ascii.factor b/basis/ascii/ascii.factor index cf3f62c7c1..d2e12ac551 100644 --- a/basis/ascii/ascii.factor +++ b/basis/ascii/ascii.factor @@ -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 ] 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 ] 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 ; diff --git a/basis/atk/atk.factor b/basis/atk/atk.factor index a27f470902..c2cba8f922 100644 --- a/basis/atk/atk.factor +++ b/basis/atk/atk.factor @@ -2,4 +2,3 @@ ! See http://factorcode.org/license.txt for BSD license. USING: atk.ffi ; IN: atk - diff --git a/basis/bit-vectors/bit-vectors-docs.factor b/basis/bit-vectors/bit-vectors-docs.factor index 34bc8f5ab3..88ddb0c2a1 100644 --- a/basis/bit-vectors/bit-vectors-docs.factor +++ b/basis/bit-vectors/bit-vectors-docs.factor @@ -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 - -} -"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: -{ $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 + +} +"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: +{ $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 }" } } ; + diff --git a/basis/bit-vectors/bit-vectors-tests.factor b/basis/bit-vectors/bit-vectors-tests.factor index a8a856ffd0..abfbe300b3 100644 --- a/basis/bit-vectors/bit-vectors-tests.factor +++ b/basis/bit-vectors/bit-vectors-tests.factor @@ -1,14 +1,14 @@ -USING: tools.test bit-vectors vectors sequences kernel math ; -IN: bit-vectors.tests - -[ 0 ] [ 123 length ] unit-test - -: do-it ( seq -- ) - 1234 swap [ [ even? ] dip push ] curry each-integer ; - -[ t ] [ - 3 dup do-it - 3 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 length ] unit-test + +: do-it ( seq -- ) + 1234 swap [ [ even? ] dip push ] curry each-integer ; + +[ t ] [ + 3 dup do-it + 3 dup do-it sequence= +] unit-test + +[ t ] [ ?V{ } bit-vector? ] unit-test diff --git a/basis/bit-vectors/bit-vectors.factor b/basis/bit-vectors/bit-vectors.factor index 7febe6fc1b..a9b66ccbcb 100644 --- a/basis/bit-vectors/bit-vectors.factor +++ b/basis/bit-vectors/bit-vectors.factor @@ -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 \ 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 \ 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 ; diff --git a/basis/bootstrap/handbook/handbook.factor b/basis/bootstrap/handbook/handbook.factor index f680c0e328..5e153a38f2 100644 --- a/basis/bootstrap/handbook/handbook.factor +++ b/basis/bootstrap/handbook/handbook.factor @@ -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 diff --git a/basis/bootstrap/unicode/unicode.factor b/basis/bootstrap/unicode/unicode.factor index 3530c9d99f..0be914afc8 100644 --- a/basis/bootstrap/unicode/unicode.factor +++ b/basis/bootstrap/unicode/unicode.factor @@ -1 +1 @@ -USE: unicode \ No newline at end of file +USE: unicode diff --git a/basis/boxes/boxes-docs.factor b/basis/boxes/boxes-docs.factor index 5c0514b213..a72d8e082d 100644 --- a/basis/boxes/boxes-docs.factor +++ b/basis/boxes/boxes-docs.factor @@ -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: -{ $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 } -"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: +{ $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 } +"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" diff --git a/basis/boxes/boxes-tests.factor b/basis/boxes/boxes-tests.factor index 3bcb735217..a89c3f172e 100644 --- a/basis/boxes/boxes-tests.factor +++ b/basis/boxes/boxes-tests.factor @@ -1,24 +1,24 @@ -USING: boxes namespaces tools.test accessors ; -IN: boxes.tests - -[ ] [ "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 + +[ ] [ "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 diff --git a/basis/boxes/boxes.factor b/basis/boxes/boxes.factor index 22b28b8434..25f2b963b4 100644 --- a/basis/boxes/boxes.factor +++ b/basis/boxes/boxes.factor @@ -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 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 - - ( 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 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 + + ( 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 diff --git a/basis/cache/cache-tests.factor b/basis/cache/cache-tests.factor index ea1c22b2cf..241d1f5377 100755 --- a/basis/cache/cache-tests.factor +++ b/basis/cache/cache-tests.factor @@ -1,50 +1,50 @@ -USING: cache tools.test accessors destructors kernel assocs -namespaces ; -IN: cache.tests - -TUPLE: mock-disposable < disposable n ; - -: ( n -- mock-disposable ) - mock-disposable new-disposable swap >>n ; - -M: mock-disposable dispose* drop ; - -[ ] [ "cache" set ] unit-test - -[ 0 ] [ "cache" get assoc-size ] unit-test - -[ ] [ "cache" get 2 >>max-age drop ] unit-test - -[ ] [ 1 dup "a" set 2 "cache" get set-at ] unit-test - -[ 1 ] [ "cache" get assoc-size ] unit-test - -[ ] [ "cache" get purge-cache ] unit-test - -[ ] [ 2 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 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 ; + +: ( n -- mock-disposable ) + mock-disposable new-disposable swap >>n ; + +M: mock-disposable dispose* drop ; + +[ ] [ "cache" set ] unit-test + +[ 0 ] [ "cache" get assoc-size ] unit-test + +[ ] [ "cache" get 2 >>max-age drop ] unit-test + +[ ] [ 1 dup "a" set 2 "cache" get set-at ] unit-test + +[ 1 ] [ "cache" get assoc-size ] unit-test + +[ ] [ "cache" get purge-cache ] unit-test + +[ ] [ 2 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 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 diff --git a/basis/cairo/ffi/ffi.factor b/basis/cairo/ffi/ffi.factor index ff30dae5a0..154e8a6aaa 100644 --- a/basis/cairo/ffi/ffi.factor +++ b/basis/cairo/ffi/ffi.factor @@ -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 diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor index a0c111fb5e..cee2358f67 100644 --- a/basis/calendar/calendar.factor +++ b/basis/calendar/calendar.factor @@ -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" diff --git a/basis/calendar/model/model.factor b/basis/calendar/model/model.factor index 305c31c385..4948c94581 100644 --- a/basis/calendar/model/model.factor +++ b/basis/calendar/model/model.factor @@ -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 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 time set-global + time-thread +] "calendar.model" add-startup-hook diff --git a/basis/channels/examples/examples.factor b/basis/channels/examples/examples.factor index 4b48d7923c..8aec6f5935 100644 --- a/basis/channels/examples/examples.factor +++ b/basis/channels/examples/examples.factor @@ -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 ) - dup [ counter ] curry "Counter" spawn drop + 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 dup [ counter ] curry "Counter" spawn drop (sieve) ; : sieve-test ( -- seq ) dup [ sieve ] curry "Sieve" spawn drop - V{ } clone swap + V{ } clone swap [ from swap push ] 2keep [ from swap push ] 2keep [ from swap push ] 2keep diff --git a/basis/channels/remote/remote.factor b/basis/channels/remote/remote.factor index 4eab29fd81..1b75def6cd 100644 --- a/basis/channels/remote/remote.factor +++ b/basis/channels/remote/remote.factor @@ -21,7 +21,7 @@ PRIVATE> : unpublish ( id -- ) remote-channels delete-at ; - + TUPLE: remote-channel node id ; -C: remote-channel +C: remote-channel > "remote-channels" + node>> "remote-channels" send-synchronous dup no-channel = [ no-channel throw ] when* ; - + PRIVATE> M: remote-channel to ( value remote-channel -- ) diff --git a/basis/checksums/internet/internet.factor b/basis/checksums/internet/internet.factor index b8175a61d4..926e184fe5 100644 --- a/basis/checksums/internet/internet.factor +++ b/basis/checksums/internet/internet.factor @@ -13,4 +13,3 @@ M: internet checksum-bytes drop 2 [ le> ] map-sum [ -16 shift ] [ 0xffff bitand ] bi + [ -16 shift ] keep + bitnot 2 >le ; - diff --git a/basis/checksums/sha/sha.factor b/basis/checksums/sha/sha.factor index b46ff6ec76..6f68255444 100644 --- a/basis/checksums/sha/sha.factor +++ b/basis/checksums/sha/sha.factor @@ -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 } diff --git a/basis/cocoa/runtime/runtime.factor b/basis/cocoa/runtime/runtime.factor index 4fbfa622c3..b0e149e0c1 100644 --- a/basis/cocoa/runtime/runtime.factor +++ b/basis/cocoa/runtime/runtime.factor @@ -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 ) ; diff --git a/basis/combinators/smart/smart.factor b/basis/combinators/smart/smart.factor index e97c65038c..a620fd4cce 100644 --- a/basis/combinators/smart/smart.factor +++ b/basis/combinators/smart/smart.factor @@ -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 diff --git a/basis/command-line/startup/startup.factor b/basis/command-line/startup/startup.factor index 2a77de3692..6c60e05911 100644 --- a/basis/command-line/startup/startup.factor +++ b/basis/command-line/startup/startup.factor @@ -42,4 +42,3 @@ from within Factor for more information. output-stream get [ stream-flush ] when* 0 exit ; - diff --git a/basis/compiler/cfg/comparisons/comparisons.factor b/basis/compiler/cfg/comparisons/comparisons.factor index 019bfd7a74..cc67c194e4 100644 --- a/basis/compiler/cfg/comparisons/comparisons.factor +++ b/basis/compiler/cfg/comparisons/comparisons.factor @@ -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? ; - diff --git a/basis/compiler/cfg/value-numbering/expressions/expressions.factor b/basis/compiler/cfg/value-numbering/expressions/expressions.factor index 8c9ea85016..cff4a232cf 100644 --- a/basis/compiler/cfg/value-numbering/expressions/expressions.factor +++ b/basis/compiler/cfg/value-numbering/expressions/expressions.factor @@ -26,7 +26,7 @@ GENERIC: >expr ( insn -- expr ) : narray-quot ( length -- quot ) [ [ , [ f ] % ] - [ + [ dup iota [ - 1 - , [ swap [ set-array-nth ] keep ] % ] with each diff --git a/basis/compiler/cfg/value-numbering/simd/simd.factor b/basis/compiler/cfg/value-numbering/simd/simd.factor index 4c8df86998..d17e4ce289 100644 --- a/basis/compiler/cfg/value-numbering/simd/simd.factor +++ b/basis/compiler/cfg/value-numbering/simd/simd.factor @@ -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? ] [ { diff --git a/basis/compiler/errors/errors.factor b/basis/compiler/errors/errors.factor index c9ba3c8b77..62c83a4601 100644 --- a/basis/compiler/errors/errors.factor +++ b/basis/compiler/errors/errors.factor @@ -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 - diff --git a/basis/compiler/tests/redefine25.factor b/basis/compiler/tests/redefine25.factor index 804bbcd77c..4cdc387cf7 100644 --- a/basis/compiler/tests/redefine25.factor +++ b/basis/compiler/tests/redefine25.factor @@ -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 diff --git a/basis/compiler/tree/dead-code/dead-code.factor b/basis/compiler/tree/dead-code/dead-code.factor index 38b5317d1c..7946d979ec 100644 --- a/basis/compiler/tree/dead-code/dead-code.factor +++ b/basis/compiler/tree/dead-code/dead-code.factor @@ -11,4 +11,3 @@ IN: compiler.tree.dead-code mark-live-values compute-live-values (remove-dead-code) ; - diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor index faa3642732..a57c2c276c 100644 --- a/basis/compiler/tree/debugger/debugger.factor +++ b/basis/compiler/tree/debugger/debugger.factor @@ -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@ ; @@ -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 -- ? ) diff --git a/basis/compiler/tree/propagation/simple/simple.factor b/basis/compiler/tree/propagation/simple/simple.factor index 67f49b55d6..8425df4719 100644 --- a/basis/compiler/tree/propagation/simple/simple.factor +++ b/basis/compiler/tree/propagation/simple/simple.factor @@ -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 ] diff --git a/basis/compression/huffman/huffman.factor b/basis/compression/huffman/huffman.factor index 7b5582a0b6..03927e5a48 100644 --- a/basis/compression/huffman/huffman.factor +++ b/basis/compression/huffman/huffman.factor @@ -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 - - ( -- 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 -- ... ) -- ... ) - :> 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 :> 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 } ; - -: ( 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 + + ( -- 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 -- ... ) -- ... ) + :> 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 :> 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 } ; + +: ( 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 diff --git a/basis/compression/inflate/inflate.factor b/basis/compression/inflate/inflate.factor index d96946d53d..b4166044a9 100644 --- a/basis/compression/inflate/inflate.factor +++ b/basis/compression/inflate/inflate.factor @@ -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 diff --git a/basis/compression/run-length/run-length.factor b/basis/compression/run-length/run-length.factor index deaed9e947..8faaaffc1e 100644 --- a/basis/compression/run-length/run-length.factor +++ b/basis/compression/run-length/run-length.factor @@ -36,7 +36,7 @@ IN: compression.run-length [ sp next 8hi-lo 2array 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 [ 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 diff --git a/basis/compression/snappy/ffi/ffi.factor b/basis/compression/snappy/ffi/ffi.factor index da213ccbbc..9fd08aa1cb 100644 --- a/basis/compression/snappy/ffi/ffi.factor +++ b/basis/compression/snappy/ffi/ffi.factor @@ -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 ) ; diff --git a/basis/compression/snappy/snappy.factor b/basis/compression/snappy/snappy.factor index 10bd78f8c3..590c9d4b71 100644 --- a/basis/compression/snappy/snappy.factor +++ b/basis/compression/snappy/snappy.factor @@ -27,7 +27,6 @@ PRIVATE> over dup length 0 size_t [ snappy_uncompressed_length check-snappy ] keep - size_t deref + size_t deref n>outs [ snappy_uncompress check-snappy ] 2keep drop >byte-array ; - diff --git a/basis/concurrency/combinators/combinators-docs.factor b/basis/concurrency/combinators/combinators-docs.factor index 28d6d11bd5..8f76b52504 100644 --- a/basis/concurrency/combinators/combinators-docs.factor +++ b/basis/concurrency/combinators/combinators-docs.factor @@ -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" diff --git a/basis/concurrency/combinators/combinators-tests.factor b/basis/concurrency/combinators/combinators-tests.factor index 74363e6af0..dcb64dc878 100644 --- a/basis/concurrency/combinators/combinators-tests.factor +++ b/basis/concurrency/combinators/combinators-tests.factor @@ -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 diff --git a/basis/concurrency/conditions/conditions.factor b/basis/concurrency/conditions/conditions.factor index 652b858a92..48a685efda 100644 --- a/basis/concurrency/conditions/conditions.factor +++ b/basis/concurrency/conditions/conditions.factor @@ -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 diff --git a/basis/concurrency/count-downs/count-downs-docs.factor b/basis/concurrency/count-downs/count-downs-docs.factor index 29c90bcdd5..8d9a64f59d 100644 --- a/basis/concurrency/count-downs/count-downs-docs.factor +++ b/basis/concurrency/count-downs/count-downs-docs.factor @@ -1,27 +1,27 @@ -USING: help.markup help.syntax sequences ; -IN: concurrency.count-downs - -HELP: -{ $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 - 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: +{ $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 + await +} +"The vocabulary was modelled after a similar feature in Java's " { $snippet "java.util.concurrent" } " library." ; + +ABOUT: "concurrency.count-downs" diff --git a/basis/concurrency/count-downs/count-downs-tests.factor b/basis/concurrency/count-downs/count-downs-tests.factor index 649802cd95..153a055685 100644 --- a/basis/concurrency/count-downs/count-downs-tests.factor +++ b/basis/concurrency/count-downs/count-downs-tests.factor @@ -1,16 +1,16 @@ -USING: concurrency.count-downs threads kernel tools.test ; -IN: concurrency.count-downs.tests` - -[ ] [ 0 await ] unit-test - -[ 1 dup count-down count-down ] must-fail - -[ ] [ - 1 - 3 - 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 await ] unit-test + +[ 1 dup count-down count-down ] must-fail + +[ ] [ + 1 + 3 + 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 diff --git a/basis/concurrency/count-downs/count-downs.factor b/basis/concurrency/count-downs/count-downs.factor index 85b0f76f85..c5d1d57985 100755 --- a/basis/concurrency/count-downs/count-downs.factor +++ b/basis/concurrency/count-downs/count-downs.factor @@ -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 ; - -: ( n -- count-down ) - dup 0 < [ invalid-count-down-count ] when - \ 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 ; + +: ( n -- count-down ) + dup 0 < [ invalid-count-down-count ] when + \ 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 ; diff --git a/basis/concurrency/exchangers/exchangers-docs.factor b/basis/concurrency/exchangers/exchangers-docs.factor index 48dd04f4f7..3d5711b50b 100644 --- a/basis/concurrency/exchangers/exchangers-docs.factor +++ b/basis/concurrency/exchangers/exchangers-docs.factor @@ -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: -{ $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 - - 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: +{ $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 + + 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" diff --git a/basis/concurrency/exchangers/exchangers-tests.factor b/basis/concurrency/exchangers/exchangers-tests.factor index c411aaea92..8360d1ffe1 100644 --- a/basis/concurrency/exchangers/exchangers-tests.factor +++ b/basis/concurrency/exchangers/exchangers-tests.factor @@ -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 ) - :> ex - 2 :> c - f :> v1! - f :> v2! - :> 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 ) + :> ex + 2 :> c + f :> v1! + f :> v2! + :> 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 diff --git a/basis/concurrency/exchangers/exchangers.factor b/basis/concurrency/exchangers/exchangers.factor index 7cfe016085..bdc3a9ca80 100644 --- a/basis/concurrency/exchangers/exchangers.factor +++ b/basis/concurrency/exchangers/exchangers.factor @@ -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 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 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 ; diff --git a/basis/concurrency/flags/flags-tests.factor b/basis/concurrency/flags/flags-tests.factor index 8402a56631..4ea2105b35 100644 --- a/basis/concurrency/flags/flags-tests.factor +++ b/basis/concurrency/flags/flags-tests.factor @@ -1,48 +1,48 @@ -USING: tools.test concurrency.flags concurrency.combinators -kernel threads locals accessors calendar ; -IN: concurrency.flags.tests - -:: flag-test-1 ( -- val ) - :> f - [ f raise-flag ] "Flag test" spawn drop - f lower-flag - f value>> ; - -[ f ] [ flag-test-1 ] unit-test - -:: flag-test-2 ( -- ? ) - :> 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 ) - :> f - f raise-flag - f value>> ; - -[ t ] [ flag-test-3 ] unit-test - -:: flag-test-4 ( -- val ) - :> f - [ f raise-flag ] "Flag test" spawn drop - f wait-for-flag - f value>> ; - -[ t ] [ flag-test-4 ] unit-test - -:: flag-test-5 ( -- val ) - :> 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 } - [ [ 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 ) + :> f + [ f raise-flag ] "Flag test" spawn drop + f lower-flag + f value>> ; + +[ f ] [ flag-test-1 ] unit-test + +:: flag-test-2 ( -- ? ) + :> 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 ) + :> f + f raise-flag + f value>> ; + +[ t ] [ flag-test-3 ] unit-test + +:: flag-test-4 ( -- val ) + :> f + [ f raise-flag ] "Flag test" spawn drop + f wait-for-flag + f value>> ; + +[ t ] [ flag-test-4 ] unit-test + +:: flag-test-5 ( -- val ) + :> 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 } + [ [ 1 seconds sleep raise-flag ] curry "Flag test" spawn drop ] + [ [ wait-for-flag drop ] curry parallel-each ] bi +] unit-test diff --git a/basis/concurrency/futures/futures-docs.factor b/basis/concurrency/futures/futures-docs.factor index 56f8c73237..2aae2b4aec 100644 --- a/basis/concurrency/futures/futures-docs.factor +++ b/basis/concurrency/futures/futures-docs.factor @@ -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" diff --git a/basis/concurrency/futures/futures-tests.factor b/basis/concurrency/futures/futures-tests.factor index 07466e5ffd..69fba8474b 100644 --- a/basis/concurrency/futures/futures-tests.factor +++ b/basis/concurrency/futures/futures-tests.factor @@ -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 diff --git a/basis/concurrency/futures/futures.factor b/basis/concurrency/futures/futures.factor index a1f4f57af6..c8c2f582b9 100644 --- a/basis/concurrency/futures/futures.factor +++ b/basis/concurrency/futures/futures.factor @@ -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 ) - [ - [ '[ @ _ 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 ) + [ + [ '[ @ _ fulfill ] "Future" ] keep + mailbox>> spawn-linked-to drop + ] keep ; inline + +: ?future-timeout ( future timeout -- value ) + ?promise-timeout ?linked ; + +: ?future ( future -- value ) + ?promise ?linked ; diff --git a/basis/concurrency/locks/locks-docs.factor b/basis/concurrency/locks/locks-docs.factor index 4a331e8f19..77bed82f76 100644 --- a/basis/concurrency/locks/locks-docs.factor +++ b/basis/concurrency/locks/locks-docs.factor @@ -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: -{ $values { "lock" lock } } -{ $description "Creates a non-reentrant lock." } ; - -HELP: -{ $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 - - - 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 - - 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: +{ $values { "lock" lock } } +{ $description "Creates a non-reentrant lock." } ; + +HELP: +{ $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 + + + 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 + + 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" diff --git a/basis/concurrency/locks/locks-tests.factor b/basis/concurrency/locks/locks-tests.factor index c58d012b3f..84573e7bd3 100644 --- a/basis/concurrency/locks/locks-tests.factor +++ b/basis/concurrency/locks/locks-tests.factor @@ -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 :> 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 - :> l - 2 :> 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 ] [ - dup [ - [ - 3 - ] with-lock - ] with-lock -] unit-test - -[ ] [ drop ] unit-test - -[ ] [ [ ] with-read-lock ] unit-test - -[ ] [ dup [ [ ] with-read-lock ] with-read-lock ] unit-test - -[ ] [ [ ] with-write-lock ] unit-test - -[ ] [ dup [ [ ] with-write-lock ] with-write-lock ] unit-test - -[ ] [ dup [ [ ] with-read-lock ] with-write-lock ] unit-test - -:: rw-lock-test-1 ( -- v ) - :> l - 1 :> c - 1 :> c' - 4 :> 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 ) - :> l - 1 :> c - 2 :> 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 ) - :> 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 - -[ - dup [ - 1 seconds [ ] with-write-lock-timeout - ] with-read-lock -] must-fail - -[ - dup [ - dup [ - 1 seconds [ ] with-write-lock-timeout - ] with-read-lock - ] with-write-lock -] must-fail - -[ ] [ - 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 :> 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 + :> l + 2 :> 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 ] [ + dup [ + [ + 3 + ] with-lock + ] with-lock +] unit-test + +[ ] [ drop ] unit-test + +[ ] [ [ ] with-read-lock ] unit-test + +[ ] [ dup [ [ ] with-read-lock ] with-read-lock ] unit-test + +[ ] [ [ ] with-write-lock ] unit-test + +[ ] [ dup [ [ ] with-write-lock ] with-write-lock ] unit-test + +[ ] [ dup [ [ ] with-read-lock ] with-write-lock ] unit-test + +:: rw-lock-test-1 ( -- v ) + :> l + 1 :> c + 1 :> c' + 4 :> 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 ) + :> l + 1 :> c + 2 :> 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 ) + :> 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 + +[ + dup [ + 1 seconds [ ] with-write-lock-timeout + ] with-read-lock +] must-fail + +[ + dup [ + dup [ + 1 seconds [ ] with-write-lock-timeout + ] with-read-lock + ] with-write-lock +] must-fail + +[ ] [ + dup [ + dup [ + 1 seconds [ ] with-read-lock-timeout + ] with-read-lock + ] with-write-lock +] unit-test diff --git a/basis/concurrency/locks/locks.factor b/basis/concurrency/locks/locks.factor index 18cd86fa53..f1945db084 100644 --- a/basis/concurrency/locks/locks.factor +++ b/basis/concurrency/locks/locks.factor @@ -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 ) - f f lock boa ; - -: ( -- lock ) - f t lock boa ; - -> - [ 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 ; - -: ( -- lock ) - 0 f rw-lock boa ; - -> - [ 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 ) + f f lock boa ; + +: ( -- lock ) + f t lock boa ; + +> + [ 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 ; + +: ( -- lock ) + 0 f rw-lock boa ; + +> + [ 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 diff --git a/basis/concurrency/mailboxes/mailboxes-docs.factor b/basis/concurrency/mailboxes/mailboxes-docs.factor index 0cd23dc1b5..5c15bc85f2 100644 --- a/basis/concurrency/mailboxes/mailboxes-docs.factor +++ b/basis/concurrency/mailboxes/mailboxes-docs.factor @@ -1,81 +1,81 @@ -USING: help.markup help.syntax kernel arrays calendar ; -IN: concurrency.mailboxes - -HELP: -{ $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 - -} -"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: +{ $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 + +} +"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" diff --git a/basis/concurrency/messaging/messaging.factor b/basis/concurrency/messaging/messaging.factor index c5140e7506..dc3e810871 100644 --- a/basis/concurrency/messaging/messaging.factor +++ b/basis/concurrency/messaging/messaging.factor @@ -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 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 -- ) - [ ] dip send ; - -: spawn-linked ( quot name -- thread ) - my-mailbox spawn-linked-to ; - -TUPLE: synchronous data sender tag ; - -: ( data -- sync ) - self synchronous counter synchronous boa ; - -TUPLE: reply data tag ; - -: ( 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 - ] [ - [ dup ] dip send - '[ _ synchronous-reply? ] receive-if - data>> - ] if ; - -: reply-synchronous ( message synchronous -- ) - [ ] 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 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 -- ) + [ ] dip send ; + +: spawn-linked ( quot name -- thread ) + my-mailbox spawn-linked-to ; + +TUPLE: synchronous data sender tag ; + +: ( data -- sync ) + self synchronous counter synchronous boa ; + +TUPLE: reply data tag ; + +: ( 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 + ] [ + [ dup ] dip send + '[ _ synchronous-reply? ] receive-if + data>> + ] if ; + +: reply-synchronous ( message synchronous -- ) + [ ] keep sender>> send ; + +: handle-synchronous ( quot -- ) + receive [ + data>> swap call + ] keep reply-synchronous ; inline diff --git a/basis/concurrency/promises/promises-docs.factor b/basis/concurrency/promises/promises-docs.factor index 9760d842dc..49d7360fe8 100644 --- a/basis/concurrency/promises/promises-docs.factor +++ b/basis/concurrency/promises/promises-docs.factor @@ -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: -{ $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 - - 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: +{ $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 + + fulfill + ?promise + ?promise-timeout +} ; + +ABOUT: "concurrency.promises" diff --git a/basis/concurrency/promises/promises-tests.factor b/basis/concurrency/promises/promises-tests.factor index 353f4a69b7..9115e8644d 100644 --- a/basis/concurrency/promises/promises-tests.factor +++ b/basis/concurrency/promises/promises-tests.factor @@ -1,12 +1,12 @@ -USING: vectors concurrency.promises kernel threads sequences -tools.test ; -IN: concurrency.promises.tests - -[ V{ 50 50 50 } ] [ - 0 - - [ ?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 + + [ ?promise swap push ] in-thread + [ ?promise swap push ] in-thread + [ ?promise swap push ] in-thread + 50 swap fulfill +] unit-test diff --git a/basis/concurrency/promises/promises.factor b/basis/concurrency/promises/promises.factor index 4d6439cf30..f47ee05c75 100644 --- a/basis/concurrency/promises/promises.factor +++ b/basis/concurrency/promises/promises.factor @@ -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 diff --git a/basis/concurrency/semaphores/semaphores-docs.factor b/basis/concurrency/semaphores/semaphores-docs.factor index 06c951f586..c2a7ecfc4a 100644 --- a/basis/concurrency/semaphores/semaphores-docs.factor +++ b/basis/concurrency/semaphores/semaphores-docs.factor @@ -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 } "." } ; - -HELP: -{ $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 '[" - " ..." - " _ [ 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 '[ - _ [ 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 - -} -"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 } "." } ; + +HELP: +{ $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 '[" + " ..." + " _ [ 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 '[ + _ [ 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 + +} +"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" diff --git a/basis/concurrency/semaphores/semaphores.factor b/basis/concurrency/semaphores/semaphores.factor index dcd0ed9a2c..392b7557d6 100644 --- a/basis/concurrency/semaphores/semaphores.factor +++ b/basis/concurrency/semaphores/semaphores.factor @@ -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" ; - -: ( n -- semaphore ) - dup 0 < [ negative-count-semaphore ] when - 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" ; + +: ( n -- semaphore ) + dup 0 < [ negative-count-semaphore ] when + 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 diff --git a/basis/core-foundation/core-foundation.factor b/basis/core-foundation/core-foundation.factor index d02210f0c8..801c5d5413 100644 --- a/basis/core-foundation/core-foundation.factor +++ b/basis/core-foundation/core-foundation.factor @@ -41,4 +41,3 @@ FUNCTION: CFTypeRef CFRetain ( CFTypeRef cf ) ; FUNCTION: void CFRelease ( CFTypeRef cf ) ; DESTRUCTOR: CFRelease - diff --git a/basis/core-foundation/file-descriptors/file-descriptors.factor b/basis/core-foundation/file-descriptors/file-descriptors.factor index 28b8b681f3..78565318af 100644 --- a/basis/core-foundation/file-descriptors/file-descriptors.factor +++ b/basis/core-foundation/file-descriptors/file-descriptors.factor @@ -19,7 +19,7 @@ FUNCTION: CFFileDescriptorRef CFFileDescriptorCreate ( CFAllocatorRef allocator, CFFileDescriptorNativeDescriptor fd, Boolean closeOnInvalidate, - CFFileDescriptorCallBack callout, + CFFileDescriptorCallBack callout, CFFileDescriptorContext* context ) ; diff --git a/basis/core-foundation/strings/strings.factor b/basis/core-foundation/strings/strings.factor index ab81087ab7..944b1a34ce 100644 --- a/basis/core-foundation/strings/strings.factor +++ b/basis/core-foundation/strings/strings.factor @@ -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 ] [ '[ _ [ _ ] initialize-alien ] ] 2bi ( -- alien ) define-declared ; diff --git a/basis/core-foundation/timers/timers.factor b/basis/core-foundation/timers/timers.factor index 95388a620d..e20590e8f4 100644 --- a/basis/core-foundation/timers/timers.factor +++ b/basis/core-foundation/timers/timers.factor @@ -51,5 +51,3 @@ FUNCTION: CFTimeInterval CFRunLoopTimerGetInterval ( FUNCTION: CFAbsoluteTime CFRunLoopTimerGetNextFireDate ( CFRunLoopTimerRef timer ) ; - - diff --git a/basis/db/db-tests.factor b/basis/db/db-tests.factor index 56b6c25a19..3f1bd62f88 100644 --- a/basis/db/db-tests.factor +++ b/basis/db/db-tests.factor @@ -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 diff --git a/basis/db/db.factor b/basis/db/db.factor index f5d73b917b..a9e7bdca24 100644 --- a/basis/db/db.factor +++ b/basis/db/db.factor @@ -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 diff --git a/basis/db/postgresql/ffi/ffi.factor b/basis/db/postgresql/ffi/ffi.factor index 995b361fb5..12876d984a 100644 --- a/basis/db/postgresql/ffi/ffi.factor +++ b/basis/db/postgresql/ffi/ffi.factor @@ -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 diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor index 522a62045e..fb3a7e107a 100644 --- a/basis/db/queries/queries.factor +++ b/basis/db/queries/queries.factor @@ -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 ; diff --git a/basis/db/sqlite/lib/lib.factor b/basis/db/sqlite/lib/lib.factor index 2035137eee..defc730884 100644 --- a/basis/db/sqlite/lib/lib.factor +++ b/basis/db/sqlite/lib/lib.factor @@ -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 ; diff --git a/basis/debugger/debugger-tests.factor b/basis/debugger/debugger-tests.factor index 2858fb43d1..5f96ae9b43 100644 --- a/basis/debugger/debugger-tests.factor +++ b/basis/debugger/debugger-tests.factor @@ -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 diff --git a/basis/debugger/windows/windows.factor b/basis/debugger/windows/windows.factor index 082291eaf4..fbafd5b345 100644 --- a/basis/debugger/windows/windows.factor +++ b/basis/debugger/windows/windows.factor @@ -52,4 +52,3 @@ M: windows-error error. "Win32 error 0x" write dup n>> 0xffff,ffff bitand >hex write ": " write string>> write ; - diff --git a/basis/delegate/delegate.factor b/basis/delegate/delegate.factor index 4bd99357e0..6a18de6c0e 100644 --- a/basis/delegate/delegate.factor +++ b/basis/delegate/delegate.factor @@ -46,9 +46,9 @@ TUPLE: consultation group class quot loc ; TUPLE: broadcast < consultation ; : ( group class quot -- consultation ) - f consultation boa ; + f consultation boa ; : ( 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 diff --git a/basis/dlists/prettyprint/prettyprint.factor b/basis/dlists/prettyprint/prettyprint.factor index 2a1e62630f..c4c8e020b9 100644 --- a/basis/dlists/prettyprint/prettyprint.factor +++ b/basis/dlists/prettyprint/prettyprint.factor @@ -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 ; - diff --git a/basis/editors/atom/atom.factor b/basis/editors/atom/atom.factor index a20f60cf6d..9be37c82b1 100644 --- a/basis/editors/atom/atom.factor +++ b/basis/editors/atom/atom.factor @@ -14,4 +14,3 @@ M: atom-editor editor-command ( file line -- command ) atom-path get [ "atom" ?find-in-path ] unless* , number>string ":" glue , ] { } make ; - diff --git a/basis/editors/editors.factor b/basis/editors/editors.factor index 7b785bac41..fe21dfe4df 100644 --- a/basis/editors/editors.factor +++ b/basis/editors/editors.factor @@ -27,7 +27,7 @@ M: object editor-detached? t ; : run-and-wait-for-editor ( command -- ) - swap >>command + swap >>command editor-detached? >>detached run-process 300 milliseconds sleep diff --git a/basis/editors/editpadpro/editpadpro.factor b/basis/editors/editpadpro/editpadpro.factor index 4fe8fed8a0..e3d930b2f9 100644 --- a/basis/editors/editpadpro/editpadpro.factor +++ b/basis/editors/editpadpro/editpadpro.factor @@ -18,4 +18,3 @@ M: editpadpro editor-command ( file line -- command ) [ editpadpro-path , number>string "/l" prepend , , ] { } make ; - diff --git a/basis/editors/etexteditor/etexteditor.factor b/basis/editors/etexteditor/etexteditor.factor index 5964f04a4a..459f5b8ddb 100644 --- a/basis/editors/etexteditor/etexteditor.factor +++ b/basis/editors/etexteditor/etexteditor.factor @@ -18,4 +18,3 @@ M: etexteditor editor-command ( file line -- command ) etexteditor-path , [ , ] [ "--line" , number>string , ] bi* ] { } make ; - diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor index d54587caf2..da0834861e 100644 --- a/basis/farkup/farkup.factor +++ b/basis/farkup/farkup.factor @@ -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 ; - diff --git a/basis/fonts/fonts.factor b/basis/fonts/fonts.factor index fb89bdbfb0..311715ce44 100644 --- a/basis/fonts/fonts.factor +++ b/basis/fonts/fonts.factor @@ -65,4 +65,4 @@ TUPLE: metrics width ascent descent height leading cap-height x-height ; TUPLE: selection string start end color ; -C: selection \ No newline at end of file +C: selection diff --git a/basis/fry/fry-docs.factor b/basis/fry/fry-docs.factor index b3d2ff296e..eb33f7cd32 100644 --- a/basis/fry/fry-docs.factor +++ b/basis/fry/fry-docs.factor @@ -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" diff --git a/basis/ftp/server/server.factor b/basis/ftp/server/server.factor index 9458d5d3a6..6e9dc01f1c 100644 --- a/basis/ftp/server/server.factor +++ b/basis/ftp/server/server.factor @@ -221,7 +221,7 @@ M: ftp-disconnect handle-passive-command ( stream obj -- ) dup can-serve-file? [ fulfill-client ] [ - drop + drop fulfill-client ] if ; diff --git a/basis/furnace/actions/actions.factor b/basis/furnace/actions/actions.factor index e01fb9e6e7..262a55e343 100644 --- a/basis/furnace/actions/actions.factor +++ b/basis/furnace/actions/actions.factor @@ -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 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 - - ] [ <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 ; - -: ( path -- response ) - resolve-template-path ; - -: ( -- page ) - page-action new-action - dup '[ _ template>> ] >>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 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 + + ] [ <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 ; + +: ( path -- response ) + resolve-template-path ; + +: ( -- page ) + page-action new-action + dup '[ _ template>> ] >>display ; diff --git a/basis/furnace/auth/auth.factor b/basis/furnace/auth/auth.factor index e7b3ab72e6..ee4b2b81c7 100644 --- a/basis/furnace/auth/auth.factor +++ b/basis/furnace/auth/auth.factor @@ -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" ; - -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 - -M: user-saver dispose - user>> dup changed?>> [ users update-user ] [ drop ] if ; - -: save-user-after ( user -- ) - &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 - -M: secure-realm-only call-responder* - '[ _ _ call-next-method ] if-secure-realm ; - -TUPLE: protected < filter-responder description capabilities ; - -: ( 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 ; - -: ( responder -- responder' ) - { 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" ; + +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 + +M: user-saver dispose + user>> dup changed?>> [ users update-user ] [ drop ] if ; + +: save-user-after ( user -- ) + &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 + +M: secure-realm-only call-responder* + '[ _ _ call-next-method ] if-secure-realm ; + +TUPLE: protected < filter-responder description capabilities ; + +: ( 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 ; + +: ( responder -- responder' ) + { 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 ; diff --git a/basis/furnace/auth/basic/basic.factor b/basis/furnace/auth/basic/basic.factor index 802e489e74..af5f34e3e3 100644 --- a/basis/furnace/auth/basic/basic.factor +++ b/basis/furnace/auth/basic/basic.factor @@ -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 ; - -: ( 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" - [ "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 ; + +: ( 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" + [ "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 ; diff --git a/basis/furnace/auth/features/deactivate-user/deactivate-user.factor b/basis/furnace/auth/features/deactivate-user/deactivate-user.factor index 4e80f9188b..110b8afebf 100644 --- a/basis/furnace/auth/features/deactivate-user/deactivate-user.factor +++ b/basis/furnace/auth/features/deactivate-user/deactivate-user.factor @@ -17,7 +17,7 @@ IN: furnace.auth.features.deactivate-user drop URL" $realm" end-aside ] >>submit ; - + : allow-deactivation ( realm -- realm ) "delete your profile" >>description diff --git a/basis/furnace/auth/features/edit-profile/edit-profile.factor b/basis/furnace/auth/features/edit-profile/edit-profile.factor index 08c1a1abfe..76dae1d652 100644 --- a/basis/furnace/auth/features/edit-profile/edit-profile.factor +++ b/basis/furnace/auth/features/edit-profile/edit-profile.factor @@ -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 diff --git a/basis/furnace/auth/login/login.factor b/basis/furnace/auth/login/login.factor index 2295f61ea2..d6160352e2 100644 --- a/basis/furnace/auth/login/login.factor +++ b/basis/furnace/auth/login/login.factor @@ -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 ; - -: ( -- cookie ) - permit-id get realm get name>> permit-id-key - "$login-realm" resolve-base-path >>path - realm get - [ domain>> >>domain ] - [ secure>> >>secure ] - bi ; - -: put-permit-cookie ( response -- response' ) - 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 ; - - - -CONSTANT: flashed-variables { description capabilities } - -: login-failed ( -- * ) - "invalid username or password" validation-error - validation-failed ; - -: ( -- 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 - - ; - -: ( -- 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 - ] [ - url get begin-aside - URL" $realm/login" - ] if ; - -M: login-realm user-registered ( user realm -- response ) - drop successful-login ; - -: ( responder name -- realm ) - login-realm new-realm - "login" add-responder - "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 ; + +: ( -- cookie ) + permit-id get realm get name>> permit-id-key + "$login-realm" resolve-base-path >>path + realm get + [ domain>> >>domain ] + [ secure>> >>secure ] + bi ; + +: put-permit-cookie ( response -- response' ) + 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 ; + + + +CONSTANT: flashed-variables { description capabilities } + +: login-failed ( -- * ) + "invalid username or password" validation-error + validation-failed ; + +: ( -- 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 + + ; + +: ( -- 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 + ] [ + url get begin-aside + URL" $realm/login" + ] if ; + +M: login-realm user-registered ( user realm -- response ) + drop successful-login ; + +: ( responder name -- realm ) + login-realm new-realm + "login" add-responder + "logout" add-responder + 20 minutes >>timeout ; diff --git a/basis/furnace/auth/login/permits/permits.factor b/basis/furnace/auth/login/permits/permits.factor index c6a037cea1..c2f3ecdaef 100644 --- a/basis/furnace/auth/login/permits/permits.factor +++ b/basis/furnace/auth/login/permits/permits.factor @@ -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 ; diff --git a/basis/furnace/auth/providers/assoc/assoc-tests.factor b/basis/furnace/auth/providers/assoc/assoc-tests.factor index 44a20e7ae3..e9e4c0816c 100644 --- a/basis/furnace/auth/providers/assoc/assoc-tests.factor +++ b/basis/furnace/auth/providers/assoc/assoc-tests.factor @@ -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 - - "Test" - >>users -realm set - -[ t ] [ - "slava" - "foobar" >>encoded-password - "slava@factorcode.org" >>email - H{ } clone >>profile - users new-user - username>> "slava" = -] unit-test - -[ f ] [ - "slava" - 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 + + "Test" + >>users +realm set + +[ t ] [ + "slava" + "foobar" >>encoded-password + "slava@factorcode.org" >>email + H{ } clone >>profile + users new-user + username>> "slava" = +] unit-test + +[ f ] [ + "slava" + 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 diff --git a/basis/furnace/auth/providers/assoc/assoc.factor b/basis/furnace/auth/providers/assoc/assoc.factor index a7a48307c9..712ef13e98 100644 --- a/basis/furnace/auth/providers/assoc/assoc.factor +++ b/basis/furnace/auth/providers/assoc/assoc.factor @@ -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 ; - -: ( -- 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 ; + +: ( -- 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 ; diff --git a/basis/furnace/auth/providers/db/db-tests.factor b/basis/furnace/auth/providers/db/db-tests.factor index 18a9a350d2..41c8cfda39 100644 --- a/basis/furnace/auth/providers/db/db-tests.factor +++ b/basis/furnace/auth/providers/db/db-tests.factor @@ -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 - - "test" 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 [ - - user ensure-table - - [ t ] [ - "slava" - "foobar" >>encoded-password - "slava@factorcode.org" >>email - H{ } clone >>profile - users new-user - username>> "slava" = - ] unit-test - - [ f ] [ - "slava" - 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 + + "test" 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 [ + + user ensure-table + + [ t ] [ + "slava" + "foobar" >>encoded-password + "slava@factorcode.org" >>email + H{ } clone >>profile + users new-user + username>> "slava" = + ] unit-test + + [ f ] [ + "slava" + 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 diff --git a/basis/furnace/auth/providers/null/null.factor b/basis/furnace/auth/providers/null/null.factor index 0fab3c5b09..5304cee19b 100644 --- a/basis/furnace/auth/providers/null/null.factor +++ b/basis/furnace/auth/providers/null/null.factor @@ -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 ; diff --git a/basis/furnace/auth/providers/providers.factor b/basis/furnace/auth/providers/providers.factor index 44374fb5a6..75363df2b6 100644 --- a/basis/furnace/auth/providers/providers.factor +++ b/basis/furnace/auth/providers/providers.factor @@ -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? ; - -: ( 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? ; + +: ( 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 ; diff --git a/basis/furnace/db/db.factor b/basis/furnace/db/db.factor index c09be983bb..e185c458a6 100644 --- a/basis/furnace/db/db.factor +++ b/basis/furnace/db/db.factor @@ -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 ; - -: ( responder db -- responder' ) - 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 ; + +: ( responder db -- responder' ) + 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 ; diff --git a/basis/furnace/sessions/sessions-tests.factor b/basis/furnace/sessions/sessions-tests.factor index 5e9e10591f..479a5caa6e 100644 --- a/basis/furnace/sessions/sessions-tests.factor +++ b/basis/furnace/sessions/sessions-tests.factor @@ -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 - -M: foo init-session* drop 0 "x" sset ; - -M: foo call-responder* - 2drop - "x" [ 1 + ] schange - "x" sget number>string ; - -: url-responder-mock-test ( -- string ) - [ - - "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 ) - [ - - "GET" >>method - "cookies" get >>cookies - dup url>> "/" >>path drop - init-request - { } sessions get call-responder - [ write-response-body drop ] with-string-writer - ] with-destructors ; - -: ( -- action ) - - [ [ ] exit-with ] >>display ; - -[ "auth-test.db" temp-file delete-file ] ignore-errors - -"auth-test.db" temp-file [ - - "GET" >>method init-request - session ensure-table - - "127.0.0.1" 1234 remote-address set - - [ ] [ - - 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 - - [ ] [ - - sessions set - ] unit-test - - [ - - "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 - - [ - [ ] [ - - "GET" >>method - dup url>> - "id" get session-id-key set-query-param - "/" >>path drop - request set - - [ - { } - 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 + +M: foo init-session* drop 0 "x" sset ; + +M: foo call-responder* + 2drop + "x" [ 1 + ] schange + "x" sget number>string ; + +: url-responder-mock-test ( -- string ) + [ + + "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 ) + [ + + "GET" >>method + "cookies" get >>cookies + dup url>> "/" >>path drop + init-request + { } sessions get call-responder + [ write-response-body drop ] with-string-writer + ] with-destructors ; + +: ( -- action ) + + [ [ ] exit-with ] >>display ; + +[ "auth-test.db" temp-file delete-file ] ignore-errors + +"auth-test.db" temp-file [ + + "GET" >>method init-request + session ensure-table + + "127.0.0.1" 1234 remote-address set + + [ ] [ + + 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 + + [ ] [ + + sessions set + ] unit-test + + [ + + "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 + + [ + [ ] [ + + "GET" >>method + dup url>> + "id" get session-id-key set-query-param + "/" >>path drop + request set + + [ + { } + 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 diff --git a/basis/game/input/dinput/keys-array/keys-array.factor b/basis/game/input/dinput/keys-array/keys-array.factor index dca6dbe2b5..f7568ce419 100644 --- a/basis/game/input/dinput/keys-array/keys-array.factor +++ b/basis/game/input/dinput/keys-array/keys-array.factor @@ -14,4 +14,3 @@ M: keys-array length length>> ; M: keys-array nth-unsafe underlying>> nth-unsafe >key ; INSTANCE: keys-array sequence - diff --git a/basis/game/input/gtk/gtk.factor b/basis/game/input/gtk/gtk.factor index 57db116c97..da11a72437 100644 --- a/basis/game/input/gtk/gtk.factor +++ b/basis/game/input/gtk/gtk.factor @@ -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 swap [ t swap pick set-nth ] each ; - + M: gtk-game-input-backend read-keyboard get-dpy 256 [ 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 ; diff --git a/basis/game/input/iokit/iokit.factor b/basis/game/input/iokit/iokit.factor index d07b069160..17fdfd508d 100644 --- a/basis/game/input/iokit/iokit.factor +++ b/basis/game/input/iokit/iokit.factor @@ -158,7 +158,7 @@ CONSTANT: pov-values : record-controller ( controller-state value -- ) dup IOHIDValueGetElement { - { [ dup button? ] [ record-button ] } + { [ dup button? ] [ record-button ] } { [ dup axis? ] [ { { [ dup x-axis? ] [ drop axis-value >>x drop ] } { [ dup y-axis? ] [ drop axis-value >>y drop ] } @@ -206,7 +206,7 @@ M: iokit-game-input-backend reset-mouse +mouse-state+ get-global 0 >>dx 0 >>dy - 0 >>scroll-dx + 0 >>scroll-dx 0 >>scroll-dy drop ; @@ -244,7 +244,7 @@ M: iokit-game-input-backend reset-mouse } cleave controller-state boa ; : ?add-mouse-buttons ( device -- ) - button-count +mouse-state+ get-global buttons>> + button-count +mouse-state+ get-global buttons>> 2dup length > [ set-length ] [ 2drop ] if ; @@ -321,7 +321,7 @@ M: iokit-game-input-backend (reset-game-input) M: iokit-game-input-backend (close-game-input) +hid-manager+ get-global [ - +hid-manager+ [ + +hid-manager+ [ [ CFRunLoopGetMain CFRunLoopDefaultMode IOHIDManagerUnscheduleFromRunLoop diff --git a/basis/game/input/x11/x11.factor b/basis/game/input/x11/x11.factor index cc3e4cd531..44e3fda673 100644 --- a/basis/game/input/x11/x11.factor +++ b/basis/game/input/x11/x11.factor @@ -23,19 +23,19 @@ M: x11-game-input-backend get-controllers M: x11-game-input-backend product-string drop "" ; - + M: x11-game-input-backend product-id drop f ; - + M: x11-game-input-backend instance-id drop f ; - + M: x11-game-input-backend read-controller drop controller-state new ; - + M: x11-game-input-backend calibrate-controller drop ; - + M: x11-game-input-backend vibrate-controller 3drop ; @@ -43,45 +43,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 [ 2array ] { } 2map-as [ first ] filter values x>hid-bit-order [ nth ] curry map 256 swap [ t swap pick set-nth ] each ; - + M: x11-game-input-backend read-keyboard dpy get 256 [ XQueryKeymap drop ] keep x-bits>hid-bits keyboard-state boa ; @@ -93,7 +93,7 @@ M: x11-game-input-backend read-keyboard [ 4 ndrop ] 3dip ; SYMBOL: mouse-reset? - + M: x11-game-input-backend read-mouse mouse-reset? get [ reset-mouse ] unless query-pointer @@ -102,7 +102,7 @@ M: x11-game-input-backend read-mouse swap 400 - >>dy swap 400 - >>dx 0 >>scroll-dy 0 >>scroll-dx ; - + M: x11-game-input-backend reset-mouse dpy get dup XDefaultRootWindow dup 0 0 0 0 400 400 XWarpPointer drop t mouse-reset? set-global ; diff --git a/basis/gdk/gdk.factor b/basis/gdk/gdk.factor index fa7c4d1c95..65ab5db478 100644 --- a/basis/gdk/gdk.factor +++ b/basis/gdk/gdk.factor @@ -2,4 +2,3 @@ ! See http://factorcode.org/license.txt for BSD license. USING: gdk.ffi ; IN: gdk - diff --git a/basis/gdk/gl/gl.factor b/basis/gdk/gl/gl.factor index ab64b5f8fa..efd945539b 100644 --- a/basis/gdk/gl/gl.factor +++ b/basis/gdk/gl/gl.factor @@ -2,4 +2,3 @@ ! See http://factorcode.org/license.txt for BSD license. USING: gdk.gl.ffi ; IN: gdk.gl - diff --git a/basis/gdk/pixbuf/pixbuf.factor b/basis/gdk/pixbuf/pixbuf.factor index 35bbe9ae2c..15d242fd19 100644 --- a/basis/gdk/pixbuf/pixbuf.factor +++ b/basis/gdk/pixbuf/pixbuf.factor @@ -2,4 +2,3 @@ ! See http://factorcode.org/license.txt for BSD license. USING: gdk.pixbuf.ffi ; IN: gdk.pixbuf - diff --git a/basis/generalizations/generalizations-docs.factor b/basis/generalizations/generalizations-docs.factor index 7a219522eb..f774f1c96a 100644 --- a/basis/generalizations/generalizations-docs.factor +++ b/basis/generalizations/generalizations-docs.factor @@ -1,319 +1,319 @@ -USING: help.syntax help.markup kernel sequences quotations -math arrays combinators ; -IN: generalizations - -HELP: nsum -{ $values { "n" integer } } -{ $description "Adds the top " { $snippet "n" } " stack values." } ; - -HELP: npick -{ $values { "n" integer } } -{ $description "A generalization of " { $link dup } ", " -{ $link over } " and " { $link pick } " that can work " -"for any stack depth. The nth item down the stack will be copied and " -"placed on the top of the stack." -} -{ $examples - { $example - "USING: kernel generalizations prettyprint" - "sequences.generalizations ;" - "" - "1 2 3 4 4 npick 5 narray ." - "{ 1 2 3 4 1 }" - } - "Some core words expressed in terms of " { $link npick } ":" - { $table - { { $link dup } { $snippet "1 npick" } } - { { $link over } { $snippet "2 npick" } } - { { $link pick } { $snippet "3 npick" } } - } -} ; - -HELP: ndup -{ $values { "n" integer } } -{ $description "A generalization of " { $link dup } ", " -{ $link 2dup } " and " { $link 3dup } " that can work " -"for any number of items. The n topmost items on the stack will be copied and " -"placed on the top of the stack." -} -{ $examples - { $example - "USING: prettyprint generalizations kernel" - "sequences.generalizations ;" - "" - "1 2 3 4 4 ndup 8 narray ." - "{ 1 2 3 4 1 2 3 4 }" - } - "Some core words expressed in terms of " { $link ndup } ":" - { $table - { { $link dup } { $snippet "1 ndup" } } - { { $link 2dup } { $snippet "2 ndup" } } - { { $link 3dup } { $snippet "3 ndup" } } - } -} ; - -HELP: dupn -{ $values { "n" integer } } -{ $description "Calls " { $link dup } " enough times that " { $snippet "n" } " references to the element at the top of the stack before " { $snippet "dupn" } " is called are on the top of the stack." } -{ $notes { $snippet "2 dupn" } " is equivalent to " { $link dup } ". " { $snippet "1 dupn" } " is a no-op. " { $snippet "0 dupn" } " is equivalent to " { $link drop } "." } ; - -HELP: nnip -{ $values { "n" integer } } -{ $description "A generalization of " { $link nip } " and " { $link 2nip } -" that can work " -"for any number of items." -} -{ $examples - { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 3 nnip ." "4" } - "Some core words expressed in terms of " { $link nnip } ":" - { $table - { { $link nip } { $snippet "1 nnip" } } - { { $link 2nip } { $snippet "2 nnip" } } - } -} ; - -HELP: ndrop -{ $values { "n" integer } } -{ $description "A generalization of " { $link drop } -" that can work " -"for any number of items." -} -{ $examples - { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 3 ndrop ." "1" } - "Some core words expressed in terms of " { $link ndrop } ":" - { $table - { { $link drop } { $snippet "1 ndrop" } } - { { $link 2drop } { $snippet "2 ndrop" } } - { { $link 3drop } { $snippet "3 ndrop" } } - } -} ; - -HELP: nrot -{ $values { "n" integer } } -{ $description "A generalization of " { $link rot } " that works for any " -"number of items on the stack. " -} -{ $examples - { $example "USING: arrays generalizations kernel prettyprint ;" "1 2 3 4 4 nrot 4array ." "{ 2 3 4 1 }" } - "Some core words expressed in terms of " { $link nrot } ":" - { $table - { { $link swap } { $snippet "2 nrot" } } - { { $link rot } { $snippet "3 nrot" } } - } -} ; - -HELP: -nrot -{ $values { "n" integer } } -{ $description "A generalization of " { $link -rot } " that works for any " -"number of items on the stack. " -} -{ $examples - { $example "USING: arrays generalizations kernel prettyprint ;" "1 2 3 4 4 -nrot 4array ." "{ 4 1 2 3 }" } - "Some core words expressed in terms of " { $link -nrot } ":" - { $table - { { $link swap } { $snippet "2 -nrot" } } - { { $link -rot } { $snippet "3 -nrot" } } - } -} ; - -HELP: ndip -{ $values { "n" integer } } -{ $description "A generalization of " { $link dip } " that can work " -"for any stack depth. The quotation will be called with a stack that " -"has 'n' items removed first. The 'n' items are then put back on the " -"stack. The quotation can consume and produce any number of items." -} -{ $examples - { $example "USING: arrays generalizations kernel prettyprint ;" "1 2 [ dup ] 1 ndip 3array ." "{ 1 1 2 }" } - { $example "USING: arrays generalizations kernel prettyprint ;" "1 2 3 [ drop ] 2 ndip 2array ." "{ 2 3 }" } - "Some core words expressed in terms of " { $link ndip } ":" - { $table - { { $link dip } { $snippet "1 ndip" } } - { { $link 2dip } { $snippet "2 ndip" } } - { { $link 3dip } { $snippet "3 ndip" } } - } -} ; - -HELP: nkeep -{ $values { "n" integer } } -{ $description "A generalization of " { $link keep } " that can work " -"for any stack depth. The first " { $snippet "n" } " items after the quotation will be " -"saved, the quotation called, and the items restored." -} -{ $examples - { $example - "USING: generalizations kernel prettyprint" - "sequences.generalizations ;" - "" - "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep 6 narray ." - "{ 99 1 2 3 4 5 }" - } - "Some core words expressed in terms of " { $link nkeep } ":" - { $table - { { $link keep } { $snippet "1 nkeep" } } - { { $link 2keep } { $snippet "2 nkeep" } } - { { $link 3keep } { $snippet "3 nkeep" } } - } -} ; - -HELP: ncurry -{ $values { "n" integer } } -{ $description "A generalization of " { $link curry } " that can work for any stack depth." -} -{ $examples - "Some core words expressed in terms of " { $link ncurry } ":" - { $table - { { $link curry } { $snippet "1 ncurry" } } - { { $link 2curry } { $snippet "2 ncurry" } } - { { $link 3curry } { $snippet "3 ncurry" } } - } -} ; - -HELP: nwith -{ $values { "n" integer } } -{ $description "A generalization of " { $link with } " that can work for any stack depth." -} -{ $examples - "Some core words expressed in terms of " { $link nwith } ":" - { $table - { { $link with } { $snippet "1 nwith" } } - } -} ; - -HELP: napply -{ $values { "quot" quotation } { "n" integer } } -{ $description "A generalization of " { $link bi@ } " and " { $link tri@ } " that can work for any stack depth." -} -{ $examples - "Some core words expressed in terms of " { $link napply } ":" - { $table - { { $link call } { $snippet "1 napply" } } - { { $link bi@ } { $snippet "2 napply" } } - { { $link tri@ } { $snippet "3 napply" } } - } -} ; - -HELP: ncleave -{ $values { "quots" "a sequence of quotations" } { "n" integer } } -{ $description "A generalization of " { $link cleave } " and " { $link 2cleave } " that can work for any quotation arity." -} -{ $examples - "Some core words expressed in terms of " { $link ncleave } ":" - { $table - { { $link cleave } { $snippet "1 ncleave" } } - { { $link 2cleave } { $snippet "2 ncleave" } } - } -} ; - -HELP: nspread -{ $values { "quots" "a sequence of quotations" } { "n" integer } } -{ $description "A generalization of " { $link spread } " that can work for any quotation arity." -} ; - -HELP: cleave* -{ $values { "n" integer } } -{ $description "Like " { $link cleave } ", but instead of taking a single array of quotations, cleaves using quotations taken from the top " { $snippet "n" } " elements of the datastack." } -{ $notes "This word can be used with " { $link apply-curry } " to generalize the " { $snippet "bi-curry@ bi" } " or " { $snippet "tri-curry@ tri" } " dataflow patterns." } ; - -HELP: spread* -{ $values { "n" integer } } -{ $description "Like " { $link spread } ", but instead of taking a single array of quotations, spreads using quotations taken from the top " { $snippet "n" } " elements of the datastack." } -{ $notes "This word can be used with " { $link apply-curry } " to generalize the " { $snippet "bi-curry@ bi*" } " or " { $snippet "tri-curry@ tri*" } " dataflow patterns." } ; - -HELP: apply-curry -{ $values { "a..." { $snippet "n" } " values on the datastack" } { "quot" quotation } { "n" integer } } -{ $description "Curries each of the top " { $snippet "n" } " items of the datastack onto " { $snippet "quot" } ", leaving " { $snippet "n" } " quotations on the datastack. A generalization of " { $link bi-curry@ } " and " { $link tri-curry@ } "." } -{ $notes "This word can be used with " { $link cleave* } " and " { $link spread* } " to generalize dataflow patterns such as " { $snippet "bi-curry@ bi" } ", " { $snippet "tri-curry@ tri" } ", " { $snippet "bi-curry@ bi*" } ", and " { $snippet "tri-curry@ tri*" } "." } ; - -HELP: cleave-curry -{ $values { "a" object } { "quot..." { $snippet "n" } " quotations on the datastack" } { "n" integer } } -{ $description "Curries " { $snippet "a" } " onto the " { $snippet "n" } " quotations on the top of the datastack. A generalization of " { $link bi-curry } " and " { $link tri-curry } "." } -{ $notes "This word can be used with " { $link cleave* } " and " { $link spread* } " to generalize dataflow patterns such as " { $snippet "bi-curry bi" } ", " { $snippet "tri-curry tri" } ", " { $snippet "bi-curry bi*" } ", and " { $snippet "tri-curry tri*" } "." } ; - -HELP: spread-curry -{ $values { "a..." { $snippet "n" } " objects on the datastack" } { "quot..." { $snippet "n" } " quotations on the datastack" } { "n" integer } } -{ $description "Curries the " { $snippet "n" } " quotations on the top of the datastack with the " { $snippet "n" } " values just below them. A generalization of " { $link bi-curry* } " and " { $link tri-curry* } "." } -{ $notes "This word can be used with " { $link cleave* } " and " { $link spread* } " to generalize dataflow patterns such as " { $snippet "bi-curry* bi" } ", " { $snippet "tri-curry* tri" } ", " { $snippet "bi-curry* bi*" } ", and " { $snippet "tri-curry* tri*" } "." } ; - -HELP: mnswap -{ $values { "m" integer } { "n" integer } } -{ $description "Swaps the top " { $snippet "m" } " stack elements with the " { $snippet "n" } " elements directly underneath." } -{ $examples - "Some core words expressed in terms of " { $link mnswap } ":" - { $table - { { $link swap } { $snippet "1 1 mnswap" } } - { { $link rot } { $snippet "2 1 mnswap" } } - { { $link -rot } { $snippet "1 2 mnswap" } } - } -} ; - -HELP: nweave -{ $values { "n" integer } } -{ $description "Copies the top " { $snippet "n" } " stack elements underneath each one of the " { $snippet "n" } " elements below." } -{ $examples - { $example - "USING: arrays kernel generalizations prettyprint ;" - "\"e1\" \"e2\" \"o1\" \"o2\" 2 nweave [ 3array ] 3dip 3array 2array ." - "{ { \"e1\" \"o1\" \"o2\" } { \"e2\" \"o1\" \"o2\" } }" - } -} ; - -HELP: n*quot -{ $values - { "n" integer } { "quot" quotation } - { "quotquot" quotation } -} -{ $examples - { $example "USING: generalizations prettyprint math ;" - "3 [ + ] n*quot ." - "[ + + + ]" - } -} -{ $description "Construct a quotation containing the contents of " { $snippet "seq" } " repeated " { $snippet "n"} " times." } ; - -ARTICLE: "shuffle-generalizations" "Generalized shuffle words" -{ $subsections - ndup - dupn - npick - nrot - -nrot - nnip - ndrop - mnswap - nweave -} ; - -ARTICLE: "combinator-generalizations" "Generalized combinators" -{ $subsections - ndip - nkeep - napply - ncleave - nspread - cleave* - spread* - apply-curry - cleave-curry - spread-curry -} ; - -ARTICLE: "other-generalizations" "Additional generalizations" -{ $subsections - ncurry - nwith - nsum -} ; - -ARTICLE: "generalizations" "Generalized shuffle words and combinators" -"The " { $vocab-link "generalizations" } " vocabulary defines a number of stack shuffling words and combinators for use in " -"macros where the arity of the input quotations depends on an " -"input parameter." -{ $subsections - "shuffle-generalizations" - "combinator-generalizations" - "other-generalizations" -} -"Also see the " { $vocab-link "sequences.generalizations" } " vocabulary for generalized sequence operations." ; - -ABOUT: "generalizations" +USING: help.syntax help.markup kernel sequences quotations +math arrays combinators ; +IN: generalizations + +HELP: nsum +{ $values { "n" integer } } +{ $description "Adds the top " { $snippet "n" } " stack values." } ; + +HELP: npick +{ $values { "n" integer } } +{ $description "A generalization of " { $link dup } ", " +{ $link over } " and " { $link pick } " that can work " +"for any stack depth. The nth item down the stack will be copied and " +"placed on the top of the stack." +} +{ $examples + { $example + "USING: kernel generalizations prettyprint" + "sequences.generalizations ;" + "" + "1 2 3 4 4 npick 5 narray ." + "{ 1 2 3 4 1 }" + } + "Some core words expressed in terms of " { $link npick } ":" + { $table + { { $link dup } { $snippet "1 npick" } } + { { $link over } { $snippet "2 npick" } } + { { $link pick } { $snippet "3 npick" } } + } +} ; + +HELP: ndup +{ $values { "n" integer } } +{ $description "A generalization of " { $link dup } ", " +{ $link 2dup } " and " { $link 3dup } " that can work " +"for any number of items. The n topmost items on the stack will be copied and " +"placed on the top of the stack." +} +{ $examples + { $example + "USING: prettyprint generalizations kernel" + "sequences.generalizations ;" + "" + "1 2 3 4 4 ndup 8 narray ." + "{ 1 2 3 4 1 2 3 4 }" + } + "Some core words expressed in terms of " { $link ndup } ":" + { $table + { { $link dup } { $snippet "1 ndup" } } + { { $link 2dup } { $snippet "2 ndup" } } + { { $link 3dup } { $snippet "3 ndup" } } + } +} ; + +HELP: dupn +{ $values { "n" integer } } +{ $description "Calls " { $link dup } " enough times that " { $snippet "n" } " references to the element at the top of the stack before " { $snippet "dupn" } " is called are on the top of the stack." } +{ $notes { $snippet "2 dupn" } " is equivalent to " { $link dup } ". " { $snippet "1 dupn" } " is a no-op. " { $snippet "0 dupn" } " is equivalent to " { $link drop } "." } ; + +HELP: nnip +{ $values { "n" integer } } +{ $description "A generalization of " { $link nip } " and " { $link 2nip } +" that can work " +"for any number of items." +} +{ $examples + { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 3 nnip ." "4" } + "Some core words expressed in terms of " { $link nnip } ":" + { $table + { { $link nip } { $snippet "1 nnip" } } + { { $link 2nip } { $snippet "2 nnip" } } + } +} ; + +HELP: ndrop +{ $values { "n" integer } } +{ $description "A generalization of " { $link drop } +" that can work " +"for any number of items." +} +{ $examples + { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 3 ndrop ." "1" } + "Some core words expressed in terms of " { $link ndrop } ":" + { $table + { { $link drop } { $snippet "1 ndrop" } } + { { $link 2drop } { $snippet "2 ndrop" } } + { { $link 3drop } { $snippet "3 ndrop" } } + } +} ; + +HELP: nrot +{ $values { "n" integer } } +{ $description "A generalization of " { $link rot } " that works for any " +"number of items on the stack. " +} +{ $examples + { $example "USING: arrays generalizations kernel prettyprint ;" "1 2 3 4 4 nrot 4array ." "{ 2 3 4 1 }" } + "Some core words expressed in terms of " { $link nrot } ":" + { $table + { { $link swap } { $snippet "2 nrot" } } + { { $link rot } { $snippet "3 nrot" } } + } +} ; + +HELP: -nrot +{ $values { "n" integer } } +{ $description "A generalization of " { $link -rot } " that works for any " +"number of items on the stack. " +} +{ $examples + { $example "USING: arrays generalizations kernel prettyprint ;" "1 2 3 4 4 -nrot 4array ." "{ 4 1 2 3 }" } + "Some core words expressed in terms of " { $link -nrot } ":" + { $table + { { $link swap } { $snippet "2 -nrot" } } + { { $link -rot } { $snippet "3 -nrot" } } + } +} ; + +HELP: ndip +{ $values { "n" integer } } +{ $description "A generalization of " { $link dip } " that can work " +"for any stack depth. The quotation will be called with a stack that " +"has 'n' items removed first. The 'n' items are then put back on the " +"stack. The quotation can consume and produce any number of items." +} +{ $examples + { $example "USING: arrays generalizations kernel prettyprint ;" "1 2 [ dup ] 1 ndip 3array ." "{ 1 1 2 }" } + { $example "USING: arrays generalizations kernel prettyprint ;" "1 2 3 [ drop ] 2 ndip 2array ." "{ 2 3 }" } + "Some core words expressed in terms of " { $link ndip } ":" + { $table + { { $link dip } { $snippet "1 ndip" } } + { { $link 2dip } { $snippet "2 ndip" } } + { { $link 3dip } { $snippet "3 ndip" } } + } +} ; + +HELP: nkeep +{ $values { "n" integer } } +{ $description "A generalization of " { $link keep } " that can work " +"for any stack depth. The first " { $snippet "n" } " items after the quotation will be " +"saved, the quotation called, and the items restored." +} +{ $examples + { $example + "USING: generalizations kernel prettyprint" + "sequences.generalizations ;" + "" + "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep 6 narray ." + "{ 99 1 2 3 4 5 }" + } + "Some core words expressed in terms of " { $link nkeep } ":" + { $table + { { $link keep } { $snippet "1 nkeep" } } + { { $link 2keep } { $snippet "2 nkeep" } } + { { $link 3keep } { $snippet "3 nkeep" } } + } +} ; + +HELP: ncurry +{ $values { "n" integer } } +{ $description "A generalization of " { $link curry } " that can work for any stack depth." +} +{ $examples + "Some core words expressed in terms of " { $link ncurry } ":" + { $table + { { $link curry } { $snippet "1 ncurry" } } + { { $link 2curry } { $snippet "2 ncurry" } } + { { $link 3curry } { $snippet "3 ncurry" } } + } +} ; + +HELP: nwith +{ $values { "n" integer } } +{ $description "A generalization of " { $link with } " that can work for any stack depth." +} +{ $examples + "Some core words expressed in terms of " { $link nwith } ":" + { $table + { { $link with } { $snippet "1 nwith" } } + } +} ; + +HELP: napply +{ $values { "quot" quotation } { "n" integer } } +{ $description "A generalization of " { $link bi@ } " and " { $link tri@ } " that can work for any stack depth." +} +{ $examples + "Some core words expressed in terms of " { $link napply } ":" + { $table + { { $link call } { $snippet "1 napply" } } + { { $link bi@ } { $snippet "2 napply" } } + { { $link tri@ } { $snippet "3 napply" } } + } +} ; + +HELP: ncleave +{ $values { "quots" "a sequence of quotations" } { "n" integer } } +{ $description "A generalization of " { $link cleave } " and " { $link 2cleave } " that can work for any quotation arity." +} +{ $examples + "Some core words expressed in terms of " { $link ncleave } ":" + { $table + { { $link cleave } { $snippet "1 ncleave" } } + { { $link 2cleave } { $snippet "2 ncleave" } } + } +} ; + +HELP: nspread +{ $values { "quots" "a sequence of quotations" } { "n" integer } } +{ $description "A generalization of " { $link spread } " that can work for any quotation arity." +} ; + +HELP: cleave* +{ $values { "n" integer } } +{ $description "Like " { $link cleave } ", but instead of taking a single array of quotations, cleaves using quotations taken from the top " { $snippet "n" } " elements of the datastack." } +{ $notes "This word can be used with " { $link apply-curry } " to generalize the " { $snippet "bi-curry@ bi" } " or " { $snippet "tri-curry@ tri" } " dataflow patterns." } ; + +HELP: spread* +{ $values { "n" integer } } +{ $description "Like " { $link spread } ", but instead of taking a single array of quotations, spreads using quotations taken from the top " { $snippet "n" } " elements of the datastack." } +{ $notes "This word can be used with " { $link apply-curry } " to generalize the " { $snippet "bi-curry@ bi*" } " or " { $snippet "tri-curry@ tri*" } " dataflow patterns." } ; + +HELP: apply-curry +{ $values { "a..." { $snippet "n" } " values on the datastack" } { "quot" quotation } { "n" integer } } +{ $description "Curries each of the top " { $snippet "n" } " items of the datastack onto " { $snippet "quot" } ", leaving " { $snippet "n" } " quotations on the datastack. A generalization of " { $link bi-curry@ } " and " { $link tri-curry@ } "." } +{ $notes "This word can be used with " { $link cleave* } " and " { $link spread* } " to generalize dataflow patterns such as " { $snippet "bi-curry@ bi" } ", " { $snippet "tri-curry@ tri" } ", " { $snippet "bi-curry@ bi*" } ", and " { $snippet "tri-curry@ tri*" } "." } ; + +HELP: cleave-curry +{ $values { "a" object } { "quot..." { $snippet "n" } " quotations on the datastack" } { "n" integer } } +{ $description "Curries " { $snippet "a" } " onto the " { $snippet "n" } " quotations on the top of the datastack. A generalization of " { $link bi-curry } " and " { $link tri-curry } "." } +{ $notes "This word can be used with " { $link cleave* } " and " { $link spread* } " to generalize dataflow patterns such as " { $snippet "bi-curry bi" } ", " { $snippet "tri-curry tri" } ", " { $snippet "bi-curry bi*" } ", and " { $snippet "tri-curry tri*" } "." } ; + +HELP: spread-curry +{ $values { "a..." { $snippet "n" } " objects on the datastack" } { "quot..." { $snippet "n" } " quotations on the datastack" } { "n" integer } } +{ $description "Curries the " { $snippet "n" } " quotations on the top of the datastack with the " { $snippet "n" } " values just below them. A generalization of " { $link bi-curry* } " and " { $link tri-curry* } "." } +{ $notes "This word can be used with " { $link cleave* } " and " { $link spread* } " to generalize dataflow patterns such as " { $snippet "bi-curry* bi" } ", " { $snippet "tri-curry* tri" } ", " { $snippet "bi-curry* bi*" } ", and " { $snippet "tri-curry* tri*" } "." } ; + +HELP: mnswap +{ $values { "m" integer } { "n" integer } } +{ $description "Swaps the top " { $snippet "m" } " stack elements with the " { $snippet "n" } " elements directly underneath." } +{ $examples + "Some core words expressed in terms of " { $link mnswap } ":" + { $table + { { $link swap } { $snippet "1 1 mnswap" } } + { { $link rot } { $snippet "2 1 mnswap" } } + { { $link -rot } { $snippet "1 2 mnswap" } } + } +} ; + +HELP: nweave +{ $values { "n" integer } } +{ $description "Copies the top " { $snippet "n" } " stack elements underneath each one of the " { $snippet "n" } " elements below." } +{ $examples + { $example + "USING: arrays kernel generalizations prettyprint ;" + "\"e1\" \"e2\" \"o1\" \"o2\" 2 nweave [ 3array ] 3dip 3array 2array ." + "{ { \"e1\" \"o1\" \"o2\" } { \"e2\" \"o1\" \"o2\" } }" + } +} ; + +HELP: n*quot +{ $values + { "n" integer } { "quot" quotation } + { "quotquot" quotation } +} +{ $examples + { $example "USING: generalizations prettyprint math ;" + "3 [ + ] n*quot ." + "[ + + + ]" + } +} +{ $description "Construct a quotation containing the contents of " { $snippet "seq" } " repeated " { $snippet "n"} " times." } ; + +ARTICLE: "shuffle-generalizations" "Generalized shuffle words" +{ $subsections + ndup + dupn + npick + nrot + -nrot + nnip + ndrop + mnswap + nweave +} ; + +ARTICLE: "combinator-generalizations" "Generalized combinators" +{ $subsections + ndip + nkeep + napply + ncleave + nspread + cleave* + spread* + apply-curry + cleave-curry + spread-curry +} ; + +ARTICLE: "other-generalizations" "Additional generalizations" +{ $subsections + ncurry + nwith + nsum +} ; + +ARTICLE: "generalizations" "Generalized shuffle words and combinators" +"The " { $vocab-link "generalizations" } " vocabulary defines a number of stack shuffling words and combinators for use in " +"macros where the arity of the input quotations depends on an " +"input parameter." +{ $subsections + "shuffle-generalizations" + "combinator-generalizations" + "other-generalizations" +} +"Also see the " { $vocab-link "sequences.generalizations" } " vocabulary for generalized sequence operations." ; + +ABOUT: "generalizations" diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index 8b093b86e0..9f9b7001c1 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -100,7 +100,7 @@ MACRO: nspread* ( m n -- ) MACRO: cleave* ( n -- ) [ [ ] ] - [ 1 - [ [ [ keep ] curry ] dip compose ] n*quot [ call ] compose ] + [ 1 - [ [ [ keep ] curry ] dip compose ] n*quot [ call ] compose ] if-zero ; : napply ( quot n -- ) diff --git a/basis/gio/gio.factor b/basis/gio/gio.factor index 6ab6d1ff14..7abbc42f87 100644 --- a/basis/gio/gio.factor +++ b/basis/gio/gio.factor @@ -2,4 +2,3 @@ ! See http://factorcode.org/license.txt for BSD license. USING: gio.ffi ; IN: gio - diff --git a/basis/glib/glib.factor b/basis/glib/glib.factor index 46fa035951..3ef127b5e1 100644 --- a/basis/glib/glib.factor +++ b/basis/glib/glib.factor @@ -2,4 +2,3 @@ ! See http://factorcode.org/license.txt for BSD license. USING: glib.ffi ; IN: glib - diff --git a/basis/gmodule/gmodule.factor b/basis/gmodule/gmodule.factor index 88bae336a5..8fc718b61e 100644 --- a/basis/gmodule/gmodule.factor +++ b/basis/gmodule/gmodule.factor @@ -2,4 +2,3 @@ ! See http://factorcode.org/license.txt for BSD license. USING: gmodule.ffi ; IN: gmodule - diff --git a/basis/gobject-introspection/ffi/ffi.factor b/basis/gobject-introspection/ffi/ffi.factor index 1bd1a953e1..6909285a57 100644 --- a/basis/gobject-introspection/ffi/ffi.factor +++ b/basis/gobject-introspection/ffi/ffi.factor @@ -266,7 +266,7 @@ M: array-type field-type>c-type type>c-type ; user-data-parameter suffix parameter-names&types ] } cleave make-callback-type define-inline ; - + : def-signals ( signals type -- ) [ def-signal ] curry each ; @@ -360,4 +360,3 @@ M: array-type field-type>c-type type>c-type ; : def-ffi-repository ( repository -- ) namespace>> def-namespace ; - diff --git a/basis/gobject-introspection/loader/loader.factor b/basis/gobject-introspection/loader/loader.factor index 8e17fa5973..d73fa19204 100644 --- a/basis/gobject-introspection/loader/loader.factor +++ b/basis/gobject-introspection/loader/loader.factor @@ -60,7 +60,7 @@ CONSTANT: type-tags [ "value" attr >>value ] [ child-type-tag xml>type >>type ] } cleave ; - + : load-type ( type xml -- type ) { [ "name" attr >>name ] @@ -99,7 +99,7 @@ CONSTANT: type-tags [ child-type-tag xml>type >>type ] [ "transfer-ownership" attr >>transfer-ownership ] } cleave ; - + : load-callable ( callable xml -- callable ) [ "return-value" tag-named xml>return >>return ] [ diff --git a/basis/gobject/gobject.factor b/basis/gobject/gobject.factor index 5dc903a605..7298914eac 100644 --- a/basis/gobject/gobject.factor +++ b/basis/gobject/gobject.factor @@ -2,4 +2,3 @@ ! See http://factorcode.org/license.txt for BSD license. USING: gobject.ffi ; IN: gobject - diff --git a/basis/gtk/gl/gl.factor b/basis/gtk/gl/gl.factor index 3a9a104665..ccd755835f 100644 --- a/basis/gtk/gl/gl.factor +++ b/basis/gtk/gl/gl.factor @@ -2,4 +2,3 @@ ! See http://factorcode.org/license.txt for BSD license. USING: gtk.gl.ffi ; IN: gtk.gl - diff --git a/basis/gtk/gtk.factor b/basis/gtk/gtk.factor index d91e1f3bdf..0e7407cd37 100644 --- a/basis/gtk/gtk.factor +++ b/basis/gtk/gtk.factor @@ -2,4 +2,3 @@ ! See http://factorcode.org/license.txt for BSD license. USING: gtk.ffi ; IN: gtk - diff --git a/basis/hash-sets/identity/identity-tests.factor b/basis/hash-sets/identity/identity-tests.factor index a9752b53bd..22405132c3 100644 --- a/basis/hash-sets/identity/identity-tests.factor +++ b/basis/hash-sets/identity/identity-tests.factor @@ -1,27 +1,27 @@ -USING: hash-sets.identity kernel literals sets tools.test ; -IN: hash-sets.identity.tests - -CONSTANT: the-real-slim-shady "marshall mathers" - -CONSTANT: will - IHS{ - $ the-real-slim-shady - "marshall mathers" - } - -: please-stand-up ( set obj -- ? ) - swap in? ; - -[ t ] [ will the-real-slim-shady please-stand-up ] unit-test -[ t ] [ will clone the-real-slim-shady please-stand-up ] unit-test - -[ 2 ] [ will cardinality ] unit-test -[ { "marshall mathers" } ] [ - the-real-slim-shady will clone - [ delete ] [ members ] bi -] unit-test - -CONSTANT: same-as-it-ever-was "same as it ever was" - -{ IHS{ $ same-as-it-ever-was } } -[ HS{ $ same-as-it-ever-was } IHS{ } set-like ] unit-test +USING: hash-sets.identity kernel literals sets tools.test ; +IN: hash-sets.identity.tests + +CONSTANT: the-real-slim-shady "marshall mathers" + +CONSTANT: will + IHS{ + $ the-real-slim-shady + "marshall mathers" + } + +: please-stand-up ( set obj -- ? ) + swap in? ; + +[ t ] [ will the-real-slim-shady please-stand-up ] unit-test +[ t ] [ will clone the-real-slim-shady please-stand-up ] unit-test + +[ 2 ] [ will cardinality ] unit-test +[ { "marshall mathers" } ] [ + the-real-slim-shady will clone + [ delete ] [ members ] bi +] unit-test + +CONSTANT: same-as-it-ever-was "same as it ever was" + +{ IHS{ $ same-as-it-ever-was } } +[ HS{ $ same-as-it-ever-was } IHS{ } set-like ] unit-test diff --git a/basis/hash-sets/identity/identity.factor b/basis/hash-sets/identity/identity.factor index dad416c19d..e933fcdd50 100644 --- a/basis/hash-sets/identity/identity.factor +++ b/basis/hash-sets/identity/identity.factor @@ -1,37 +1,37 @@ -! Copyright (C) 2013 John Benediktsson. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors hash-sets hash-sets.wrapped kernel parser -sequences sets sets.private vocabs.loader ; -IN: hash-sets.identity - -TUPLE: identity-wrapper < wrapped-key identity-hashcode ; - -: ( wrapped-key -- identity-wrapper ) - dup identity-hashcode identity-wrapper boa ; inline - -M: identity-wrapper equal? - over identity-wrapper? - [ [ underlying>> ] bi@ eq? ] - [ 2drop f ] if ; inline - -M: identity-wrapper hashcode* nip identity-hashcode>> ; inline - -TUPLE: identity-hash-set < wrapped-hash-set ; - -: ( n -- ihash-set ) - identity-hash-set boa ; inline - -M: identity-hash-set wrap-key drop ; - -M: identity-hash-set clone - underlying>> clone identity-hash-set boa ; inline - -: >identity-hash-set ( members -- ihash-set ) - [ ] map >hash-set identity-hash-set boa ; inline - -M: identity-hash-set set-like - drop dup identity-hash-set? [ ?members >identity-hash-set ] unless ; inline - -SYNTAX: IHS{ \ } [ >identity-hash-set ] parse-literal ; - -{ "hash-sets.identity" "prettyprint" } "hash-sets.identity.prettyprint" require-when +! Copyright (C) 2013 John Benediktsson. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors hash-sets hash-sets.wrapped kernel parser +sequences sets sets.private vocabs.loader ; +IN: hash-sets.identity + +TUPLE: identity-wrapper < wrapped-key identity-hashcode ; + +: ( wrapped-key -- identity-wrapper ) + dup identity-hashcode identity-wrapper boa ; inline + +M: identity-wrapper equal? + over identity-wrapper? + [ [ underlying>> ] bi@ eq? ] + [ 2drop f ] if ; inline + +M: identity-wrapper hashcode* nip identity-hashcode>> ; inline + +TUPLE: identity-hash-set < wrapped-hash-set ; + +: ( n -- ihash-set ) + identity-hash-set boa ; inline + +M: identity-hash-set wrap-key drop ; + +M: identity-hash-set clone + underlying>> clone identity-hash-set boa ; inline + +: >identity-hash-set ( members -- ihash-set ) + [ ] map >hash-set identity-hash-set boa ; inline + +M: identity-hash-set set-like + drop dup identity-hash-set? [ ?members >identity-hash-set ] unless ; inline + +SYNTAX: IHS{ \ } [ >identity-hash-set ] parse-literal ; + +{ "hash-sets.identity" "prettyprint" } "hash-sets.identity.prettyprint" require-when diff --git a/basis/hash-sets/identity/prettyprint/prettyprint.factor b/basis/hash-sets/identity/prettyprint/prettyprint.factor index d45ac1a623..25baec0234 100644 --- a/basis/hash-sets/identity/prettyprint/prettyprint.factor +++ b/basis/hash-sets/identity/prettyprint/prettyprint.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2013 John Benediktsson. -! See http://factorcode.org/license.txt for BSD license - -USING: hash-sets.identity kernel prettyprint.custom ; - -IN: hash-sets.identity.prettyprint - -M: identity-hash-set pprint-delims drop \ IHS{ \ } ; +! Copyright (C) 2013 John Benediktsson. +! See http://factorcode.org/license.txt for BSD license + +USING: hash-sets.identity kernel prettyprint.custom ; + +IN: hash-sets.identity.prettyprint + +M: identity-hash-set pprint-delims drop \ IHS{ \ } ; diff --git a/basis/hash-sets/wrapped/prettyprint/prettyprint.factor b/basis/hash-sets/wrapped/prettyprint/prettyprint.factor index a8b0bb08ff..265f758580 100644 --- a/basis/hash-sets/wrapped/prettyprint/prettyprint.factor +++ b/basis/hash-sets/wrapped/prettyprint/prettyprint.factor @@ -11,5 +11,3 @@ M: wrapped-hash-set >pprint-sequence members ; M: wrapped-hash-set pprint* nesting-limit inc [ pprint-object ] [ nesting-limit dec ] [ ] cleanup ; - - diff --git a/basis/hashtables/identity/identity-tests.factor b/basis/hashtables/identity/identity-tests.factor index e333d1f7ba..4e773c2413 100644 --- a/basis/hashtables/identity/identity-tests.factor +++ b/basis/hashtables/identity/identity-tests.factor @@ -1,36 +1,36 @@ -! (c)2010 Joe Groff bsd license -USING: assocs hashtables.identity kernel literals tools.test ; -IN: hashtables.identity.tests - -CONSTANT: the-real-slim-shady "marshall mathers" - -CONSTANT: will - IH{ - { $ the-real-slim-shady t } - { "marshall mathers" f } - } - -: please-stand-up ( assoc key -- value ) - of ; - -[ t ] [ will the-real-slim-shady please-stand-up ] unit-test -[ t ] [ will clone the-real-slim-shady please-stand-up ] unit-test - -[ 2 ] [ will assoc-size ] unit-test -[ { { "marshall mathers" f } } ] [ - the-real-slim-shady will clone - [ delete-at ] [ >alist ] bi -] unit-test -[ t ] [ - t the-real-slim-shady identity-associate - t the-real-slim-shady identity-associate = -] unit-test -[ f ] [ - t the-real-slim-shady identity-associate - t "marshall mathers" identity-associate = -] unit-test - -CONSTANT: same-as-it-ever-was "same as it ever was" - -{ IH{ { $ same-as-it-ever-was $ same-as-it-ever-was } } } -[ H{ { $ same-as-it-ever-was $ same-as-it-ever-was } } IH{ } assoc-like ] unit-test +! (c)2010 Joe Groff bsd license +USING: assocs hashtables.identity kernel literals tools.test ; +IN: hashtables.identity.tests + +CONSTANT: the-real-slim-shady "marshall mathers" + +CONSTANT: will + IH{ + { $ the-real-slim-shady t } + { "marshall mathers" f } + } + +: please-stand-up ( assoc key -- value ) + of ; + +[ t ] [ will the-real-slim-shady please-stand-up ] unit-test +[ t ] [ will clone the-real-slim-shady please-stand-up ] unit-test + +[ 2 ] [ will assoc-size ] unit-test +[ { { "marshall mathers" f } } ] [ + the-real-slim-shady will clone + [ delete-at ] [ >alist ] bi +] unit-test +[ t ] [ + t the-real-slim-shady identity-associate + t the-real-slim-shady identity-associate = +] unit-test +[ f ] [ + t the-real-slim-shady identity-associate + t "marshall mathers" identity-associate = +] unit-test + +CONSTANT: same-as-it-ever-was "same as it ever was" + +{ IH{ { $ same-as-it-ever-was $ same-as-it-ever-was } } } +[ H{ { $ same-as-it-ever-was $ same-as-it-ever-was } } IH{ } assoc-like ] unit-test diff --git a/basis/hashtables/identity/identity.factor b/basis/hashtables/identity/identity.factor index c69673ac36..04238f5e27 100644 --- a/basis/hashtables/identity/identity.factor +++ b/basis/hashtables/identity/identity.factor @@ -1,42 +1,42 @@ -! (c)2010 Joe Groff bsd license -USING: accessors assocs hashtables hashtables.wrapped kernel -parser vocabs.loader ; -IN: hashtables.identity - -TUPLE: identity-wrapper < wrapped-key identity-hashcode ; - -: ( wrapped-key -- identity-wrapper ) - dup identity-hashcode identity-wrapper boa ; inline - -M: identity-wrapper equal? - over identity-wrapper? - [ [ underlying>> ] bi@ eq? ] - [ 2drop f ] if ; inline - -M: identity-wrapper hashcode* nip identity-hashcode>> ; inline - -TUPLE: identity-hashtable < wrapped-hashtable ; - -: ( n -- ihashtable ) - identity-hashtable boa ; inline - -M: identity-hashtable wrap-key drop ; - -M: identity-hashtable clone - underlying>> clone identity-hashtable boa ; inline - -: identity-associate ( value key -- ihashtable ) - 2 [ set-at ] keep ; inline - -: >identity-hashtable ( assoc -- ihashtable ) - [ assoc-size ] keep assoc-union! ; - -M: identity-hashtable assoc-like - drop dup identity-hashtable? [ >identity-hashtable ] unless ; inline - -M: identity-hashtable new-assoc drop ; - -SYNTAX: IH{ \ } [ >identity-hashtable ] parse-literal ; - -{ "hashtables.identity" "prettyprint" } "hashtables.identity.prettyprint" require-when -{ "hashtables.identity" "mirrors" } "hashtables.identity.mirrors" require-when +! (c)2010 Joe Groff bsd license +USING: accessors assocs hashtables hashtables.wrapped kernel +parser vocabs.loader ; +IN: hashtables.identity + +TUPLE: identity-wrapper < wrapped-key identity-hashcode ; + +: ( wrapped-key -- identity-wrapper ) + dup identity-hashcode identity-wrapper boa ; inline + +M: identity-wrapper equal? + over identity-wrapper? + [ [ underlying>> ] bi@ eq? ] + [ 2drop f ] if ; inline + +M: identity-wrapper hashcode* nip identity-hashcode>> ; inline + +TUPLE: identity-hashtable < wrapped-hashtable ; + +: ( n -- ihashtable ) + identity-hashtable boa ; inline + +M: identity-hashtable wrap-key drop ; + +M: identity-hashtable clone + underlying>> clone identity-hashtable boa ; inline + +: identity-associate ( value key -- ihashtable ) + 2 [ set-at ] keep ; inline + +: >identity-hashtable ( assoc -- ihashtable ) + [ assoc-size ] keep assoc-union! ; + +M: identity-hashtable assoc-like + drop dup identity-hashtable? [ >identity-hashtable ] unless ; inline + +M: identity-hashtable new-assoc drop ; + +SYNTAX: IH{ \ } [ >identity-hashtable ] parse-literal ; + +{ "hashtables.identity" "prettyprint" } "hashtables.identity.prettyprint" require-when +{ "hashtables.identity" "mirrors" } "hashtables.identity.mirrors" require-when diff --git a/basis/hashtables/identity/mirrors/mirrors.factor b/basis/hashtables/identity/mirrors/mirrors.factor index 1ba891cd85..6ddd80a802 100644 --- a/basis/hashtables/identity/mirrors/mirrors.factor +++ b/basis/hashtables/identity/mirrors/mirrors.factor @@ -1,4 +1,4 @@ -USING: hashtables.identity mirrors ; -IN: hashtables.identity.mirrors - -M: identity-hashtable make-mirror ; +USING: hashtables.identity mirrors ; +IN: hashtables.identity.mirrors + +M: identity-hashtable make-mirror ; diff --git a/basis/hashtables/identity/prettyprint/prettyprint.factor b/basis/hashtables/identity/prettyprint/prettyprint.factor index e2dbd0b972..4e27c5968d 100644 --- a/basis/hashtables/identity/prettyprint/prettyprint.factor +++ b/basis/hashtables/identity/prettyprint/prettyprint.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2010-2011 Joe Groff -! See http://factorcode.org/license.txt for BSD license - -USING: hashtables.identity kernel prettyprint.custom ; - -IN: hashtables.identity.prettyprint - -M: identity-hashtable pprint-delims drop \ IH{ \ } ; +! Copyright (C) 2010-2011 Joe Groff +! See http://factorcode.org/license.txt for BSD license + +USING: hashtables.identity kernel prettyprint.custom ; + +IN: hashtables.identity.prettyprint + +M: identity-hashtable pprint-delims drop \ IH{ \ } ; diff --git a/basis/hashtables/wrapped/prettyprint/prettyprint.factor b/basis/hashtables/wrapped/prettyprint/prettyprint.factor index d59039f149..1abd5cc10a 100644 --- a/basis/hashtables/wrapped/prettyprint/prettyprint.factor +++ b/basis/hashtables/wrapped/prettyprint/prettyprint.factor @@ -11,5 +11,3 @@ M: wrapped-hashtable >pprint-sequence >alist ; M: wrapped-hashtable pprint* nesting-limit inc [ pprint-object ] [ nesting-limit dec ] [ ] cleanup ; - - diff --git a/basis/help/crossref/crossref.factor b/basis/help/crossref/crossref.factor index 36d780c99b..d15b0eb194 100644 --- a/basis/help/crossref/crossref.factor +++ b/basis/help/crossref/crossref.factor @@ -31,4 +31,4 @@ IN: help.crossref : prev-article ( article -- prev ) -1 prev/next-article ; -: next-article ( article -- next ) 1 prev/next-article ; \ No newline at end of file +: next-article ( article -- next ) 1 prev/next-article ; diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor index 6296eb5ab1..b51c2d5459 100644 --- a/basis/help/handbook/handbook.factor +++ b/basis/help/handbook/handbook.factor @@ -35,7 +35,7 @@ ARTICLE: "conventions" "Conventions" { { "vocabulary " { $strong "or" } " vocab" } { "a named set of words. See " { $link "vocabularies" } } } { "vocabulary specifier" { "a " { $link vocab } ", " { $link vocab-link } " or a string naming a vocabulary" } } { "word" { "the basic unit of code, analogous to a function or procedure in other programming languages. See " { $link "words" } } } -} +} { $heading "Documentation conventions" } "Factor documentation consists of two distinct bodies of text. There is a hierarchy of articles, much like this one, and there is word documentation. Help articles reference word documentation, and vice versa, but not every documented word is referenced from some help article." $nl @@ -122,7 +122,7 @@ ARTICLE: "numbers" "Numbers" USE: io.buffers -ARTICLE: "collections" "Collections" +ARTICLE: "collections" "Collections" { $heading "Sequences" } { $subsections "sequences" diff --git a/basis/help/help.factor b/basis/help/help.factor index 77304db86b..d02ce72f7b 100644 --- a/basis/help/help.factor +++ b/basis/help/help.factor @@ -56,7 +56,7 @@ M: word article-name name>> ; M: word article-title dup [ parsing-word? ] [ symbol? ] bi or [ - name>> + name>> ] [ [ unparse ] [ stack-effect [ effect>string " " prepend ] [ "" ] if* ] bi diff --git a/basis/html/html.factor b/basis/html/html.factor index 12cf3549f4..7f1184c2f9 100644 --- a/basis/html/html.factor +++ b/basis/html/html.factor @@ -24,4 +24,4 @@ IN: html url-encode swap [XML ><-> XML] ; : simple-image ( url -- xml ) - url-encode [XML /> XML] ; \ No newline at end of file + url-encode [XML /> XML] ; diff --git a/basis/http/http.factor b/basis/http/http.factor index 8fdf9f0e58..d1b9968640 100644 --- a/basis/http/http.factor +++ b/basis/http/http.factor @@ -222,5 +222,5 @@ TUPLE: post-data data params content-type content-encoding ; : parse-content-type ( content-type -- type encoding ) ";" split1 - parse-content-type-attributes "charset" of + parse-content-type-attributes "charset" of [ dup mime-type-encoding encoding>name ] unless* ; diff --git a/basis/http/parsers/parsers.factor b/basis/http/parsers/parsers.factor index 4d8c8bd568..083e23b2de 100644 --- a/basis/http/parsers/parsers.factor +++ b/basis/http/parsers/parsers.factor @@ -47,7 +47,7 @@ IN: http.parsers ] seq* [ "" concat-as ] action ; : 'full-request' ( -- parser ) - [ + [ 'space' , 'http-method' , 'space' , diff --git a/basis/http/server/cgi/cgi.factor b/basis/http/server/cgi/cgi.factor index 3089694e13..40e512a060 100644 --- a/basis/http/server/cgi/cgi.factor +++ b/basis/http/server/cgi/cgi.factor @@ -1,66 +1,66 @@ -! Copyright (C) 2007, 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: namespaces kernel assocs io.files io.streams.duplex -combinators arrays io.launcher io.encodings io.encodings.binary io -http.server.static http.server http accessors sequences strings -math.parser fry urls urls.encoding calendar make ; -IN: http.server.cgi - -: cgi-variables ( script-path -- assoc ) - #! This needs some work. - [ - "CGI/1.0" "GATEWAY_INTERFACE" ,, - "HTTP/" request get version>> append "SERVER_PROTOCOL" ,, - "Factor" "SERVER_SOFTWARE" ,, - - [ "PATH_TRANSLATED" ,, ] [ "SCRIPT_FILENAME" ,, ] bi - - url get path>> "SCRIPT_NAME" ,, - - url get host>> "SERVER_NAME" ,, - url get port>> number>string "SERVER_PORT" ,, - "" "PATH_INFO" ,, - "" "REMOTE_HOST" ,, - "" "REMOTE_ADDR" ,, - "" "AUTH_TYPE" ,, - "" "REMOTE_USER" ,, - "" "REMOTE_IDENT" ,, - - request get method>> "REQUEST_METHOD" ,, - url get query>> assoc>query "QUERY_STRING" ,, - request get "cookie" header "HTTP_COOKIE" ,, - - request get "user-agent" header "HTTP_USER_AGENT" ,, - request get "accept" header "HTTP_ACCEPT" ,, - - post-request? [ - request get post-data>> data>> - [ "CONTENT_TYPE" ,, ] - [ length number>string "CONTENT_LENGTH" ,, ] - bi - ] when - ] H{ } make ; - -: ( name -- desc ) - - over 1array >>command - swap cgi-variables >>environment - 1 minutes >>timeout ; - -: serve-cgi ( name -- response ) - - 200 >>code - "CGI output follows" >>message - swap '[ - binary encode-output - output-stream get _ binary [ - post-request? [ request get post-data>> data>> write flush ] when - '[ _ stream-write ] each-block - ] with-stream - ] >>body ; - -SLOT: special - -: enable-cgi ( responder -- responder ) - [ serve-cgi ] "application/x-cgi-script" - pick special>> set-at ; +! Copyright (C) 2007, 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces kernel assocs io.files io.streams.duplex +combinators arrays io.launcher io.encodings io.encodings.binary io +http.server.static http.server http accessors sequences strings +math.parser fry urls urls.encoding calendar make ; +IN: http.server.cgi + +: cgi-variables ( script-path -- assoc ) + #! This needs some work. + [ + "CGI/1.0" "GATEWAY_INTERFACE" ,, + "HTTP/" request get version>> append "SERVER_PROTOCOL" ,, + "Factor" "SERVER_SOFTWARE" ,, + + [ "PATH_TRANSLATED" ,, ] [ "SCRIPT_FILENAME" ,, ] bi + + url get path>> "SCRIPT_NAME" ,, + + url get host>> "SERVER_NAME" ,, + url get port>> number>string "SERVER_PORT" ,, + "" "PATH_INFO" ,, + "" "REMOTE_HOST" ,, + "" "REMOTE_ADDR" ,, + "" "AUTH_TYPE" ,, + "" "REMOTE_USER" ,, + "" "REMOTE_IDENT" ,, + + request get method>> "REQUEST_METHOD" ,, + url get query>> assoc>query "QUERY_STRING" ,, + request get "cookie" header "HTTP_COOKIE" ,, + + request get "user-agent" header "HTTP_USER_AGENT" ,, + request get "accept" header "HTTP_ACCEPT" ,, + + post-request? [ + request get post-data>> data>> + [ "CONTENT_TYPE" ,, ] + [ length number>string "CONTENT_LENGTH" ,, ] + bi + ] when + ] H{ } make ; + +: ( name -- desc ) + + over 1array >>command + swap cgi-variables >>environment + 1 minutes >>timeout ; + +: serve-cgi ( name -- response ) + + 200 >>code + "CGI output follows" >>message + swap '[ + binary encode-output + output-stream get _ binary [ + post-request? [ request get post-data>> data>> write flush ] when + '[ _ stream-write ] each-block + ] with-stream + ] >>body ; + +SLOT: special + +: enable-cgi ( responder -- responder ) + [ serve-cgi ] "application/x-cgi-script" + pick special>> set-at ; diff --git a/basis/http/server/static/static.factor b/basis/http/server/static/static.factor index 01b085e1ae..2ec80ec9d5 100644 --- a/basis/http/server/static/static.factor +++ b/basis/http/server/static/static.factor @@ -1,112 +1,112 @@ -! Copyright (C) 2004, 2010 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: calendar kernel math math.order math.parser namespaces -parser sequences strings assocs hashtables debugger mime.types -sorting logging calendar.format accessors splitting io io.files -io.files.info io.directories io.pathnames io.encodings.binary -fry xml.entities destructors urls html xml.syntax -html.templates.fhtml http http.server http.server.responses -http.server.redirection xml.writer ; -FROM: sets => adjoin ; -IN: http.server.static - -TUPLE: file-responder root hook special index-names allow-listings ; - -: modified-since ( request -- date ) - "if-modified-since" header ";" split1 drop - dup [ rfc822>timestamp ] when ; - -: modified-since? ( filename -- ? ) - request get modified-since dup - [ [ file-info modified>> ] dip after? ] [ 2drop t ] if ; - -: ( root hook -- responder ) - file-responder new - swap >>hook - swap >>root - H{ } clone >>special - V{ "index.html" } >>index-names ; - -: (serve-static) ( path mime-type -- response ) - [ - [ binary &dispose ] dip - binary >>content-encoding - ] - [ drop file-info [ size>> ] [ modified>> ] bi ] 2bi - [ "content-length" set-header ] - [ "last-modified" set-header ] bi* ; - -: ( root -- responder ) - [ (serve-static) ] ; - -: serve-static ( filename mime-type -- response ) - over modified-since? - [ file-responder get hook>> call( filename mime-type -- response ) ] - [ 2drop <304> ] - if ; - -: serving-path ( filename -- filename ) - [ file-responder get root>> trim-tail-separators ] dip - [ "/" swap trim-head-separators 3append ] unless-empty ; - -: serve-file ( filename -- response ) - dup mime-type - dup file-responder get special>> at - [ call( filename -- response ) ] [ serve-static ] ?if ; - -\ serve-file NOTICE add-input-logging - -: file>html ( name -- xml ) - dup link-info directory? [ "/" append ] when - dup [XML
  • ><->
    • XML] ; - -: directory>html ( path -- xml ) - [ file-name ] - [ drop f ] - [ - [ file-name ] [ [ [ file>html ] map ] with-directory-files ] bi - [XML

    <->

      <->
    XML] - ] tri - simple-page ; - -: list-directory ( directory -- response ) - file-responder get allow-listings>> [ - directory>html - ] [ - drop <403> - ] if ; - -: find-index ( filename -- path ) - file-responder get index-names>> - [ append-path dup exists? [ drop f ] unless ] with map-find - drop ; - -: serve-directory ( filename -- response ) - url get path>> "/" tail? [ - dup - find-index [ serve-file ] [ list-directory ] ?if - ] [ - drop - url get clone [ "/" append ] change-path - ] if ; - -: serve-object ( filename -- response ) - serving-path dup exists? - [ dup file-info directory? [ serve-directory ] [ serve-file ] if ] - [ drop <404> ] - if ; - -M: file-responder call-responder* ( path responder -- response ) - file-responder set - ".." over member? - [ drop <400> ] [ "/" join serve-object ] if ; - -: add-index ( name responder -- ) - index-names>> adjoin ; - -: serve-fhtml ( path -- response ) - ; - -: enable-fhtml ( responder -- responder ) - [ serve-fhtml ] "application/x-factor-server-page" pick special>> set-at - "index.fhtml" over add-index ; +! Copyright (C) 2004, 2010 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: calendar kernel math math.order math.parser namespaces +parser sequences strings assocs hashtables debugger mime.types +sorting logging calendar.format accessors splitting io io.files +io.files.info io.directories io.pathnames io.encodings.binary +fry xml.entities destructors urls html xml.syntax +html.templates.fhtml http http.server http.server.responses +http.server.redirection xml.writer ; +FROM: sets => adjoin ; +IN: http.server.static + +TUPLE: file-responder root hook special index-names allow-listings ; + +: modified-since ( request -- date ) + "if-modified-since" header ";" split1 drop + dup [ rfc822>timestamp ] when ; + +: modified-since? ( filename -- ? ) + request get modified-since dup + [ [ file-info modified>> ] dip after? ] [ 2drop t ] if ; + +: ( root hook -- responder ) + file-responder new + swap >>hook + swap >>root + H{ } clone >>special + V{ "index.html" } >>index-names ; + +: (serve-static) ( path mime-type -- response ) + [ + [ binary &dispose ] dip + binary >>content-encoding + ] + [ drop file-info [ size>> ] [ modified>> ] bi ] 2bi + [ "content-length" set-header ] + [ "last-modified" set-header ] bi* ; + +: ( root -- responder ) + [ (serve-static) ] ; + +: serve-static ( filename mime-type -- response ) + over modified-since? + [ file-responder get hook>> call( filename mime-type -- response ) ] + [ 2drop <304> ] + if ; + +: serving-path ( filename -- filename ) + [ file-responder get root>> trim-tail-separators ] dip + [ "/" swap trim-head-separators 3append ] unless-empty ; + +: serve-file ( filename -- response ) + dup mime-type + dup file-responder get special>> at + [ call( filename -- response ) ] [ serve-static ] ?if ; + +\ serve-file NOTICE add-input-logging + +: file>html ( name -- xml ) + dup link-info directory? [ "/" append ] when + dup [XML
  • ><->
    • XML] ; + +: directory>html ( path -- xml ) + [ file-name ] + [ drop f ] + [ + [ file-name ] [ [ [ file>html ] map ] with-directory-files ] bi + [XML

    <->

      <->
    XML] + ] tri + simple-page ; + +: list-directory ( directory -- response ) + file-responder get allow-listings>> [ + directory>html + ] [ + drop <403> + ] if ; + +: find-index ( filename -- path ) + file-responder get index-names>> + [ append-path dup exists? [ drop f ] unless ] with map-find + drop ; + +: serve-directory ( filename -- response ) + url get path>> "/" tail? [ + dup + find-index [ serve-file ] [ list-directory ] ?if + ] [ + drop + url get clone [ "/" append ] change-path + ] if ; + +: serve-object ( filename -- response ) + serving-path dup exists? + [ dup file-info directory? [ serve-directory ] [ serve-file ] if ] + [ drop <404> ] + if ; + +M: file-responder call-responder* ( path responder -- response ) + file-responder set + ".." over member? + [ drop <400> ] [ "/" join serve-object ] if ; + +: add-index ( name responder -- ) + index-names>> adjoin ; + +: serve-fhtml ( path -- response ) + ; + +: enable-fhtml ( responder -- responder ) + [ serve-fhtml ] "application/x-factor-server-page" pick special>> set-at + "index.fhtml" over add-index ; diff --git a/basis/images/loader/gdiplus/gdiplus.factor b/basis/images/loader/gdiplus/gdiplus.factor index 25d403c00e..a803a25aff 100644 --- a/basis/images/loader/gdiplus/gdiplus.factor +++ b/basis/images/loader/gdiplus/gdiplus.factor @@ -1,106 +1,106 @@ -! (c)2010 Joe Groff bsd license -USING: accessors alien alien.c-types alien.data alien.enums alien.strings -assocs byte-arrays classes.struct destructors grouping images images.loader -io kernel locals math mime.types namespaces sequences specialized-arrays -windows.com windows.gdiplus windows.streams windows.types ; -FROM: system => os windows? ; -IN: images.loader.gdiplus - -SPECIALIZED-ARRAY: ImageCodecInfo - -SINGLETON: gdi+-image - -os windows? [ - { "png" "tif" "tiff" "gif" "jpg" "jpeg" "bmp" "ico" } - [ gdi+-image register-image-class ] each -] when - - ( x y w h -- rect ) - GpRect ; inline - -: stream>gdi+-bitmap ( stream -- bitmap ) - stream>IStream &com-release - { void* } [ GdipCreateBitmapFromStream check-gdi+-status ] - with-out-parameters &GdipFree ; - -: gdi+-bitmap-width ( bitmap -- w ) - { UINT } [ GdipGetImageWidth check-gdi+-status ] - with-out-parameters ; - -: gdi+-bitmap-height ( bitmap -- h ) - { UINT } [ GdipGetImageHeight check-gdi+-status ] - with-out-parameters ; - -: gdi+-lock-bitmap ( bitmap rect mode format -- data ) - { BitmapData } [ GdipBitmapLockBits check-gdi+-status ] - with-out-parameters ; - -:: gdi+-bitmap>data ( bitmap -- w h pixels ) - bitmap [ gdi+-bitmap-width ] [ gdi+-bitmap-height ] bi :> ( w h ) - bitmap 0 0 w h ImageLockModeRead enum>number - PixelFormat32bppARGB gdi+-lock-bitmap :> bitmap-data - bitmap-data [ Scan0>> ] [ Stride>> ] [ Height>> * ] tri - memory>byte-array :> pixels - bitmap bitmap-data GdipBitmapUnlockBits check-gdi+-status - w h pixels ; - -:: data>image ( w h pixels -- image ) - image new - { w h } >>dim - pixels >>bitmap - BGRA >>component-order - ubyte-components >>component-type - f >>upside-down? ; - -! Only one pixel format supported, but I can't find images in the -! wild, loaded using gdi+, in which the format is different. -ERROR: unsupported-pixel-format component-order ; - -: check-pixel-format ( image -- ) - component-order>> dup BGRA = [ drop ] [ unsupported-pixel-format ] if ; - -: image>gdi+-bitmap ( image -- bitmap ) - dup check-pixel-format - [ dim>> first2 ] [ rowstride PixelFormat32bppARGB ] [ bitmap>> ] tri - { void* } [ - GdipCreateBitmapFromScan0 check-gdi+-status - ] with-out-parameters &GdipFree ; - -: image-encoders-size ( -- num size ) - { UINT UINT } [ - GdipGetImageEncodersSize check-gdi+-status - ] with-out-parameters ; - -: image-encoders ( -- codec-infos ) - image-encoders-size dup 3dup - GdipGetImageEncoders check-gdi+-status - nip swap ImageCodecInfo ; - -: extension>mime-type ( extension -- mime-type ) - ! Crashes if you let this mime through on my machine. - dup mime-types at dup "image/bmp" = [ unknown-image-extension ] when nip ; - -: mime-type>clsid ( mime-type -- clsid ) - image-encoders [ MimeType>> alien>native-string = ] with find nip Clsid>> ; - -: startup-gdi+ ( -- ) - start-gdi+ &stop-gdi+ drop ; - -: write-image-to-stream ( image stream extension -- ) - [ image>gdi+-bitmap ] - [ stream>IStream &com-release ] - [ extension>mime-type mime-type>clsid ] tri* - f GdipSaveImageToStream check-gdi+-status ; - -PRIVATE> - -M: gdi+-image stream>image* - drop startup-gdi+ - stream>gdi+-bitmap - gdi+-bitmap>data - data>image ; - -M: gdi+-image image>stream ( image extension class -- ) - drop startup-gdi+ output-stream get swap write-image-to-stream ; +! (c)2010 Joe Groff bsd license +USING: accessors alien alien.c-types alien.data alien.enums alien.strings +assocs byte-arrays classes.struct destructors grouping images images.loader +io kernel locals math mime.types namespaces sequences specialized-arrays +windows.com windows.gdiplus windows.streams windows.types ; +FROM: system => os windows? ; +IN: images.loader.gdiplus + +SPECIALIZED-ARRAY: ImageCodecInfo + +SINGLETON: gdi+-image + +os windows? [ + { "png" "tif" "tiff" "gif" "jpg" "jpeg" "bmp" "ico" } + [ gdi+-image register-image-class ] each +] when + + ( x y w h -- rect ) + GpRect ; inline + +: stream>gdi+-bitmap ( stream -- bitmap ) + stream>IStream &com-release + { void* } [ GdipCreateBitmapFromStream check-gdi+-status ] + with-out-parameters &GdipFree ; + +: gdi+-bitmap-width ( bitmap -- w ) + { UINT } [ GdipGetImageWidth check-gdi+-status ] + with-out-parameters ; + +: gdi+-bitmap-height ( bitmap -- h ) + { UINT } [ GdipGetImageHeight check-gdi+-status ] + with-out-parameters ; + +: gdi+-lock-bitmap ( bitmap rect mode format -- data ) + { BitmapData } [ GdipBitmapLockBits check-gdi+-status ] + with-out-parameters ; + +:: gdi+-bitmap>data ( bitmap -- w h pixels ) + bitmap [ gdi+-bitmap-width ] [ gdi+-bitmap-height ] bi :> ( w h ) + bitmap 0 0 w h ImageLockModeRead enum>number + PixelFormat32bppARGB gdi+-lock-bitmap :> bitmap-data + bitmap-data [ Scan0>> ] [ Stride>> ] [ Height>> * ] tri + memory>byte-array :> pixels + bitmap bitmap-data GdipBitmapUnlockBits check-gdi+-status + w h pixels ; + +:: data>image ( w h pixels -- image ) + image new + { w h } >>dim + pixels >>bitmap + BGRA >>component-order + ubyte-components >>component-type + f >>upside-down? ; + +! Only one pixel format supported, but I can't find images in the +! wild, loaded using gdi+, in which the format is different. +ERROR: unsupported-pixel-format component-order ; + +: check-pixel-format ( image -- ) + component-order>> dup BGRA = [ drop ] [ unsupported-pixel-format ] if ; + +: image>gdi+-bitmap ( image -- bitmap ) + dup check-pixel-format + [ dim>> first2 ] [ rowstride PixelFormat32bppARGB ] [ bitmap>> ] tri + { void* } [ + GdipCreateBitmapFromScan0 check-gdi+-status + ] with-out-parameters &GdipFree ; + +: image-encoders-size ( -- num size ) + { UINT UINT } [ + GdipGetImageEncodersSize check-gdi+-status + ] with-out-parameters ; + +: image-encoders ( -- codec-infos ) + image-encoders-size dup 3dup + GdipGetImageEncoders check-gdi+-status + nip swap ImageCodecInfo ; + +: extension>mime-type ( extension -- mime-type ) + ! Crashes if you let this mime through on my machine. + dup mime-types at dup "image/bmp" = [ unknown-image-extension ] when nip ; + +: mime-type>clsid ( mime-type -- clsid ) + image-encoders [ MimeType>> alien>native-string = ] with find nip Clsid>> ; + +: startup-gdi+ ( -- ) + start-gdi+ &stop-gdi+ drop ; + +: write-image-to-stream ( image stream extension -- ) + [ image>gdi+-bitmap ] + [ stream>IStream &com-release ] + [ extension>mime-type mime-type>clsid ] tri* + f GdipSaveImageToStream check-gdi+-status ; + +PRIVATE> + +M: gdi+-image stream>image* + drop startup-gdi+ + stream>gdi+-bitmap + gdi+-bitmap>data + data>image ; + +M: gdi+-image image>stream ( image extension class -- ) + drop startup-gdi+ output-stream get swap write-image-to-stream ; diff --git a/basis/images/normalization/normalization.factor b/basis/images/normalization/normalization.factor index f24315d6b2..9abe78236e 100644 --- a/basis/images/normalization/normalization.factor +++ b/basis/images/normalization/normalization.factor @@ -88,4 +88,3 @@ PRIVATE> [ >byte-array ] change-bitmap RGBA reorder-components normalize-scan-line-order ; - diff --git a/basis/images/processing/processing.factor b/basis/images/processing/processing.factor index aa6434743f..4d33f4c260 100644 --- a/basis/images/processing/processing.factor +++ b/basis/images/processing/processing.factor @@ -1,40 +1,40 @@ -! Copyright (C) 2009 Marc Fauconneau. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays byte-arrays combinators grouping images -kernel locals math math.order -math.ranges math.vectors sequences sequences.deep fry ; -IN: images.processing - -: coord-matrix ( dim -- m ) - [ iota ] map first2 cartesian-product ; - -: map^2 ( m quot -- m' ) '[ _ map ] map ; inline -: each^2 ( m quot -- m' ) '[ _ each ] each ; inline - -: matrix-dim ( m -- dim ) [ length ] [ first length ] bi 2array ; - -: matrix>image ( m -- image ) - over matrix-dim >>dim - swap flip flatten - [ 128 * 128 + 0 255 clamp >fixnum ] map - >byte-array >>bitmap L >>component-order ubyte-components >>component-type ; - -:: matrix-zoom ( m f -- m' ) - m matrix-dim f v*n coord-matrix - [ [ f /i ] map first2 swap m nth nth ] map^2 ; - -:: image-offset ( x,y image -- xy ) - image dim>> first - x,y second * x,y first + ; - -:: draw-grey ( value x,y image -- ) - x,y image image-offset 3 * { 0 1 2 } - [ - + value 128 + >fixnum 0 255 clamp swap image bitmap>> set-nth - ] with each ; - -:: draw-color ( value x,y color-id image -- ) - x,y image image-offset 3 * color-id + value >fixnum - swap image bitmap>> set-nth ; - -! : matrix. ( m -- ) 10 matrix-zoom matrix>image image. ; +! Copyright (C) 2009 Marc Fauconneau. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays byte-arrays combinators grouping images +kernel locals math math.order +math.ranges math.vectors sequences sequences.deep fry ; +IN: images.processing + +: coord-matrix ( dim -- m ) + [ iota ] map first2 cartesian-product ; + +: map^2 ( m quot -- m' ) '[ _ map ] map ; inline +: each^2 ( m quot -- m' ) '[ _ each ] each ; inline + +: matrix-dim ( m -- dim ) [ length ] [ first length ] bi 2array ; + +: matrix>image ( m -- image ) + over matrix-dim >>dim + swap flip flatten + [ 128 * 128 + 0 255 clamp >fixnum ] map + >byte-array >>bitmap L >>component-order ubyte-components >>component-type ; + +:: matrix-zoom ( m f -- m' ) + m matrix-dim f v*n coord-matrix + [ [ f /i ] map first2 swap m nth nth ] map^2 ; + +:: image-offset ( x,y image -- xy ) + image dim>> first + x,y second * x,y first + ; + +:: draw-grey ( value x,y image -- ) + x,y image image-offset 3 * { 0 1 2 } + [ + + value 128 + >fixnum 0 255 clamp swap image bitmap>> set-nth + ] with each ; + +:: draw-color ( value x,y color-id image -- ) + x,y image image-offset 3 * color-id + value >fixnum + swap image bitmap>> set-nth ; + +! : matrix. ( m -- ) 10 matrix-zoom matrix>image image. ; diff --git a/basis/interval-maps/interval-maps-docs.factor b/basis/interval-maps/interval-maps-docs.factor index a4603bff03..9eb4a04571 100644 --- a/basis/interval-maps/interval-maps-docs.factor +++ b/basis/interval-maps/interval-maps-docs.factor @@ -1,46 +1,46 @@ -! Copyright (C) 2008, 2009 Daniel Ehrenberg. -! See http://factorcode.org/license.txt for BSD license. -USING: assocs help.markup help.syntax kernel sequences ; -IN: interval-maps - -HELP: interval-at* -{ $values { "key" object } { "map" interval-map } { "value" "the value for the key, or f" } { "?" "whether the key is present" } } -{ $description "Looks up a key in an interval map, returning the corresponding value if the item is in an interval in the map, and a boolean flag. The operation takes O(log n) time." } ; - -HELP: interval-at -{ $values { "key" object } { "map" interval-map } { "value" "the value for the key, or f" } } -{ $description "Looks up a key in an interval map, returning the value of the corresponding interval, or f if the interval is not present in the map." } ; - -HELP: interval-key? -{ $values { "key" object } { "map" interval-map } { "?" boolean } } -{ $description "Tests whether an object is in an interval in the interval map, returning t if the object is present." } ; - -HELP: -{ $values { "specification" assoc } { "map" interval-map } } -{ $description "From a specification, produce an interval tree. The specification is an assoc where the keys are intervals, or pairs of numbers to represent intervals, or individual numbers to represent singleton intervals. The values are the values int he interval map. Construction time is O(n log n)." } ; - -HELP: interval-values -{ $values { "map" interval-map } { "values" sequence } } -{ $description "Constructs a list of all of the values that interval map keys are associated with. This list may contain duplicates." } ; - -HELP: coalesce -{ $values { "alist" "an association list with integer keys" } { "specification" { "array of the format used by " { $link } } } } -{ $description "Finds ranges used in the given alist, coalescing them into a single range." } ; - -ARTICLE: "interval-maps" "Interval maps" -"The " { $vocab-link "interval-maps" } " vocabulary implements a data structure, similar to assocs, where a set of closed intervals of keys are associated with values. As such, interval maps do not conform to the assoc protocol, because intervals of floats, for example, can be used, and it is impossible to get a list of keys in between." -$nl -"The following operations are used to query interval maps:" -{ $subsections - interval-at* - interval-at - interval-key? - interval-values -} -"Use the following to construct interval maps" -{ $subsections - - coalesce -} ; - -ABOUT: "interval-maps" +! Copyright (C) 2008, 2009 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs help.markup help.syntax kernel sequences ; +IN: interval-maps + +HELP: interval-at* +{ $values { "key" object } { "map" interval-map } { "value" "the value for the key, or f" } { "?" "whether the key is present" } } +{ $description "Looks up a key in an interval map, returning the corresponding value if the item is in an interval in the map, and a boolean flag. The operation takes O(log n) time." } ; + +HELP: interval-at +{ $values { "key" object } { "map" interval-map } { "value" "the value for the key, or f" } } +{ $description "Looks up a key in an interval map, returning the value of the corresponding interval, or f if the interval is not present in the map." } ; + +HELP: interval-key? +{ $values { "key" object } { "map" interval-map } { "?" boolean } } +{ $description "Tests whether an object is in an interval in the interval map, returning t if the object is present." } ; + +HELP: +{ $values { "specification" assoc } { "map" interval-map } } +{ $description "From a specification, produce an interval tree. The specification is an assoc where the keys are intervals, or pairs of numbers to represent intervals, or individual numbers to represent singleton intervals. The values are the values int he interval map. Construction time is O(n log n)." } ; + +HELP: interval-values +{ $values { "map" interval-map } { "values" sequence } } +{ $description "Constructs a list of all of the values that interval map keys are associated with. This list may contain duplicates." } ; + +HELP: coalesce +{ $values { "alist" "an association list with integer keys" } { "specification" { "array of the format used by " { $link } } } } +{ $description "Finds ranges used in the given alist, coalescing them into a single range." } ; + +ARTICLE: "interval-maps" "Interval maps" +"The " { $vocab-link "interval-maps" } " vocabulary implements a data structure, similar to assocs, where a set of closed intervals of keys are associated with values. As such, interval maps do not conform to the assoc protocol, because intervals of floats, for example, can be used, and it is impossible to get a list of keys in between." +$nl +"The following operations are used to query interval maps:" +{ $subsections + interval-at* + interval-at + interval-key? + interval-values +} +"Use the following to construct interval maps" +{ $subsections + + coalesce +} ; + +ABOUT: "interval-maps" diff --git a/basis/interval-maps/interval-maps-tests.factor b/basis/interval-maps/interval-maps-tests.factor index 5a4b508939..19c6b64571 100644 --- a/basis/interval-maps/interval-maps-tests.factor +++ b/basis/interval-maps/interval-maps-tests.factor @@ -1,18 +1,18 @@ -USING: kernel namespaces interval-maps tools.test ; -IN: interval-maps.test - -SYMBOL: test - -[ ] [ { { { 4 8 } 3 } { 1 2 } } test set ] unit-test -[ 3 ] [ 5 test get interval-at ] unit-test -[ 3 ] [ 8 test get interval-at ] unit-test -[ 3 ] [ 4 test get interval-at ] unit-test -[ f ] [ 9 test get interval-at ] unit-test -[ 2 ] [ 1 test get interval-at ] unit-test -[ f ] [ 2 test get interval-at ] unit-test -[ f ] [ 0 test get interval-at ] unit-test - -[ { { { 1 4 } 3 } { { 4 8 } 6 } } ] must-fail - -[ { { { 1 3 } 2 } { { 4 5 } 4 } { { 7 8 } 4 } } ] -[ { { 1 2 } { 2 2 } { 3 2 } { 4 4 } { 5 4 } { 7 4 } { 8 4 } } coalesce ] unit-test +USING: kernel namespaces interval-maps tools.test ; +IN: interval-maps.test + +SYMBOL: test + +[ ] [ { { { 4 8 } 3 } { 1 2 } } test set ] unit-test +[ 3 ] [ 5 test get interval-at ] unit-test +[ 3 ] [ 8 test get interval-at ] unit-test +[ 3 ] [ 4 test get interval-at ] unit-test +[ f ] [ 9 test get interval-at ] unit-test +[ 2 ] [ 1 test get interval-at ] unit-test +[ f ] [ 2 test get interval-at ] unit-test +[ f ] [ 0 test get interval-at ] unit-test + +[ { { { 1 4 } 3 } { { 4 8 } 6 } } ] must-fail + +[ { { { 1 3 } 2 } { { 4 5 } 4 } { { 7 8 } 4 } } ] +[ { { 1 2 } { 2 2 } { 3 2 } { 4 4 } { 5 4 } { 7 4 } { 8 4 } } coalesce ] unit-test diff --git a/basis/interval-maps/interval-maps.factor b/basis/interval-maps/interval-maps.factor index 0b63f2815b..a089fa3972 100644 --- a/basis/interval-maps/interval-maps.factor +++ b/basis/interval-maps/interval-maps.factor @@ -1,72 +1,72 @@ -! Copyright (C) 2008 Daniel Ehrenberg. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs binary-search grouping kernel -locals make math math.order sequences sequences.private sorting ; -IN: interval-maps - -TUPLE: interval-map { array array read-only } ; - -> [ start <=> ] with search nip ; inline - -: interval-contains? ( key interval-node -- ? ) - first2-unsafe between? ; inline - -: all-intervals ( sequence -- intervals ) - [ [ dup number? [ dup 2array ] when ] dip ] { } assoc-map-as ; - -: disjoint? ( node1 node2 -- ? ) - [ end ] [ start ] bi* < ; - -: ensure-disjoint ( intervals -- intervals ) - dup [ disjoint? ] monotonic? - [ "Intervals are not disjoint" throw ] unless ; - -: >intervals ( specification -- intervals ) - [ suffix ] { } assoc>map concat 3 group ; - -ERROR: not-an-interval-map obj ; - -: check-interval-map ( map -- map ) - dup interval-map? [ not-an-interval-map ] unless ; inline - -PRIVATE> - -: interval-at* ( key map -- value ? ) - check-interval-map - [ drop ] [ find-interval ] 2bi - [ nip ] [ interval-contains? ] 2bi - [ value t ] [ drop f f ] if ; inline - -: interval-at ( key map -- value ) interval-at* drop ; inline - -: interval-key? ( key map -- ? ) interval-at* nip ; inline - -: interval-values ( map -- values ) - check-interval-map array>> [ value ] map ; - -: ( specification -- map ) - all-intervals [ first-unsafe second-unsafe ] sort-with - >intervals ensure-disjoint interval-map boa ; - -: ( specification -- map ) - dup zip ; - -:: coalesce ( alist -- specification ) - ! Only works with integer keys, because they're discrete - ! Makes 2array keys - [ - alist sort-keys unclip swap [ first2 dupd ] dip - [| oldkey oldval key val | ! Underneath is start - oldkey 1 + key = - oldval val = and - [ oldkey 2array oldval 2array , key ] unless - key val - ] assoc-each [ 2array ] bi@ , - ] { } make ; +! Copyright (C) 2008 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs binary-search grouping kernel +locals make math math.order sequences sequences.private sorting ; +IN: interval-maps + +TUPLE: interval-map { array array read-only } ; + +> [ start <=> ] with search nip ; inline + +: interval-contains? ( key interval-node -- ? ) + first2-unsafe between? ; inline + +: all-intervals ( sequence -- intervals ) + [ [ dup number? [ dup 2array ] when ] dip ] { } assoc-map-as ; + +: disjoint? ( node1 node2 -- ? ) + [ end ] [ start ] bi* < ; + +: ensure-disjoint ( intervals -- intervals ) + dup [ disjoint? ] monotonic? + [ "Intervals are not disjoint" throw ] unless ; + +: >intervals ( specification -- intervals ) + [ suffix ] { } assoc>map concat 3 group ; + +ERROR: not-an-interval-map obj ; + +: check-interval-map ( map -- map ) + dup interval-map? [ not-an-interval-map ] unless ; inline + +PRIVATE> + +: interval-at* ( key map -- value ? ) + check-interval-map + [ drop ] [ find-interval ] 2bi + [ nip ] [ interval-contains? ] 2bi + [ value t ] [ drop f f ] if ; inline + +: interval-at ( key map -- value ) interval-at* drop ; inline + +: interval-key? ( key map -- ? ) interval-at* nip ; inline + +: interval-values ( map -- values ) + check-interval-map array>> [ value ] map ; + +: ( specification -- map ) + all-intervals [ first-unsafe second-unsafe ] sort-with + >intervals ensure-disjoint interval-map boa ; + +: ( specification -- map ) + dup zip ; + +:: coalesce ( alist -- specification ) + ! Only works with integer keys, because they're discrete + ! Makes 2array keys + [ + alist sort-keys unclip swap [ first2 dupd ] dip + [| oldkey oldval key val | ! Underneath is start + oldkey 1 + key = + oldval val = and + [ oldkey 2array oldval 2array , key ] unless + key val + ] assoc-each [ 2array ] bi@ , + ] { } make ; diff --git a/basis/inverse/inverse.factor b/basis/inverse/inverse.factor index 3a2465df21..15b2b33218 100644 --- a/basis/inverse/inverse.factor +++ b/basis/inverse/inverse.factor @@ -79,7 +79,7 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ; if ; : fold ( quot -- folded-quot ) - [ { } [ fold-word ] reduce % ] [ ] make ; + [ { } [ fold-word ] reduce % ] [ ] make ; ERROR: no-recursive-inverse ; @@ -89,7 +89,7 @@ SYMBOL: visited { [ word? ] [ primitive? not ] [ { "inverse" "math-inverse" "pop-inverse" } [ word-prop ] with any? not - ] } 1&& ; + ] } 1&& ; : flatten ( quot -- expanded ) [ diff --git a/basis/io/directories/windows/windows.factor b/basis/io/directories/windows/windows.factor index 2168eeffed..750c349195 100644 --- a/basis/io/directories/windows/windows.factor +++ b/basis/io/directories/windows/windows.factor @@ -84,4 +84,3 @@ M: windows (directory-entries) ( path -- seq ) over name>> "." = [ nip ] [ swap prefix ] if ] ] [ drop '[ _ FindClose win32-error=0/f ] ] 2bi [ ] cleanup ; - diff --git a/basis/io/encodings/8-bit/latin4/latin4.factor b/basis/io/encodings/8-bit/latin4/latin4.factor index 34a68a8810..ab5df96cf5 100644 --- a/basis/io/encodings/8-bit/latin4/latin4.factor +++ b/basis/io/encodings/8-bit/latin4/latin4.factor @@ -4,4 +4,3 @@ USING: io.encodings.8-bit ; IN: io.encodings.8-bit.latin4 8-BIT: latin4 ISO_8859-4:1988 8859-4 - diff --git a/basis/io/encodings/8-bit/latin6/latin6.factor b/basis/io/encodings/8-bit/latin6/latin6.factor index 5e71f75a2c..72f3e723dc 100644 --- a/basis/io/encodings/8-bit/latin6/latin6.factor +++ b/basis/io/encodings/8-bit/latin6/latin6.factor @@ -4,4 +4,3 @@ USING: io.encodings.8-bit ; IN: io.encodings.8-bit.latin6 8-BIT: latin6 ISO-8859-10 8859-10 - diff --git a/basis/io/encodings/big5/big5.factor b/basis/io/encodings/big5/big5.factor index 749815a22d..c53a35987f 100644 --- a/basis/io/encodings/big5/big5.factor +++ b/basis/io/encodings/big5/big5.factor @@ -6,4 +6,3 @@ IN: io.encodings.big5 EUC: big5 "vocab:io/encodings/big5/CP950.TXT" big5 "Big5" register-encoding - diff --git a/basis/io/encodings/gb18030/gb18030.factor b/basis/io/encodings/gb18030/gb18030.factor index 5696733d64..7e9d167857 100644 --- a/basis/io/encodings/gb18030/gb18030.factor +++ b/basis/io/encodings/gb18030/gb18030.factor @@ -51,7 +51,7 @@ TUPLE: range ufirst ulast bfirst blast ; [let H{ } clone :> mapping V{ } clone :> ranges [ - dup contained? [ + dup contained? [ dup name>> main>> { { "range" [ ranges add-range ] } { "a" [ mapping add-mapping ] } diff --git a/basis/io/encodings/johab/johab.factor b/basis/io/encodings/johab/johab.factor index 1e8dac0092..5a5ba3aea0 100644 --- a/basis/io/encodings/johab/johab.factor +++ b/basis/io/encodings/johab/johab.factor @@ -3,5 +3,4 @@ USE: io.encodings.euc IN: io.encodings.johab -EUC: johab "vocab:io/encodings/johab/johab.txt" - +EUC: johab "vocab:io/encodings/johab/johab.txt" diff --git a/basis/io/monitors/monitors-docs.factor b/basis/io/monitors/monitors-docs.factor index 687478a59f..c7e5c42710 100644 --- a/basis/io/monitors/monitors-docs.factor +++ b/basis/io/monitors/monitors-docs.factor @@ -1,123 +1,123 @@ -IN: io.monitors -USING: concurrency.mailboxes destructors help.markup help.syntax -kernel quotations ; - -HELP: with-monitors -{ $values { "quot" quotation } } -{ $description "Calls a quotation in a new dynamic scope where file system monitor operations can be performed." } -{ $errors "Throws an error if the platform does not support file system change monitors." } ; - -HELP: -{ $values { "path" "a pathname string" } { "recursive?" boolean } { "monitor" "a new monitor" } } -{ $contract "Opens a file system change monitor which listens for changes on " { $snippet "path" } ". The boolean indicates whether changes in subdirectories should be reported." } -{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ; - -HELP: (monitor) -{ $values { "path" "a pathname string" } { "recursive?" boolean } { "mailbox" mailbox } { "monitor" "a new monitor" } } -{ $contract "Opens a file system change monitor which listens for changes on " { $snippet "path" } " and posts notifications to " { $snippet "mailbox" } " as triples with shape " { $snippet "{ path changed monitor } " } ". The boolean indicates whether changes in subdirectories should be reported." } -{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ; - -HELP: file-change -{ $class-description "A change notification output by " { $link next-change } ". The " { $snippet "path" } " slot holds a pathname string. The " { $snippet "changed" } " slots holds a sequence of symbols documented in " { $link "io.monitors.descriptors" } "." } ; - -HELP: next-change -{ $values { "monitor" "a monitor" } { "change" file-change } } -{ $contract "Waits for file system changes and outputs a change descriptor for the first changed file." } -{ $errors "Throws an error if the monitor is closed from another thread." } ; - -HELP: with-monitor -{ $values { "path" "a pathname string" } { "recursive?" boolean } { "quot" { $quotation ( monitor -- ) } } } -{ $description "Opens a file system change monitor and passes it to the quotation. Closes the monitor after the quotation returns or throws an error." } -{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ; - -HELP: +add-file+ -{ $description "Indicates that a file has been added to its parent directory." } ; - -HELP: +remove-file+ -{ $description "Indicates that a file has been removed from its parent directory." } ; - -HELP: +modify-file+ -{ $description "Indicates that a file's contents have changed." } ; - -HELP: +rename-file-old+ -{ $description "Indicates that a file has been renamed, and this is the old name." } ; - -HELP: +rename-file-new+ -{ $description "Indicates that a file has been renamed, and this is the new name." } ; - -HELP: +rename-file+ -{ $description "Indicates that a file has been renamed." } ; - -ARTICLE: "io.monitors.descriptors" "File system change descriptors" -"The " { $link next-change } " word outputs instances of a class:" -{ $subsections file-change } -"The " { $slot "changed" } " slot holds a sequence which may contain any of the following symbols:" -{ $subsections - +add-file+ - +remove-file+ - +modify-file+ - +rename-file-old+ - +rename-file-new+ - +rename-file+ -} ; - -ARTICLE: "io.monitors.platforms" "Monitors on different platforms" -"Whether the " { $slot "path" } " slot of a " { $link file-change } " contains an absolute path or a path relative to the path given to " { $link } " is unspecified, and may even vary on the same platform. User code should not assume either case." -$nl -"If the immediate path being monitored was changed, then " { $snippet "path" } " will equal " { $snippet "\"\"" } "; however this condition is not reported on all platforms. See below." -{ $heading "Mac OS X" } -"Factor uses " { $snippet "FSEventStream" } "s to implement monitors on Mac OS X. This requires Mac OS X 10.5 or later." -$nl -{ $snippet "FSEventStream" } "s always monitor directory hierarchies recursively, and the " { $snippet "recursive?" } " parameter to " { $link } " has no effect." -$nl -"The " { $snippet "changed" } " slot of the " { $link file-change } " word tuple always contains " { $link +modify-file+ } " and the " { $snippet "path" } " slot is always the directory containing the file that changed. Unlike other platforms, fine-grained information is not available." -$nl -"Only directories may be monitored, not individual files. Changes to the directory itself (permissions, modification time, and so on) are not reported; only changes to children are reported." -{ $heading "Windows" } -"Factor uses " { $snippet "ReadDirectoryChanges" } " to implement monitors on Windows." -$nl -"Both recursive and non-recursive monitors are directly supported by the operating system." -$nl -"Only directories may be monitored, not individual files. Changes to the directory itself (permissions, modification time, and so on) are not reported; only changes to children are reported." -{ $heading "Linux" } -"Factor uses " { $snippet "inotify" } " to implement monitors on Linux. This requires Linux kernel version 2.6.16 or later." -$nl -"Factor simulates recursive monitors by creating a hierarchy of monitors for every subdirectory, since " { $snippet "inotify" } " can only monitor a single directory. This is transparent to user code." -$nl -"Inside a single " { $link with-monitors } " scope, only one monitor may be created for any given directory." -$nl -"Both directories and files may be monitored. Unlike Mac OS X and Windows, changes to the immediate directory being monitored (permissions, modification time, and so on) are reported." -; - -ARTICLE: "io.monitors" "File system change monitors" -"File system change monitors listen for changes to file names, attributes and contents under a specified directory. They can optionally be recursive, in which case subdirectories are also monitored." -$nl -"Monitoring operations must be wrapped in a combinator:" -{ $subsections with-monitors } -"Creating a file system change monitor and listening for changes:" -{ $subsections - - next-change -} -"An alternative programming style is where instead of having a thread listen for changes on a monitor, change notifications are posted to a mailbox:" -{ $subsections - (monitor) - "io.monitors.descriptors" - "io.monitors.platforms" -} -"Monitors are closed by calling " { $link dispose } " or " { $link with-disposal } ". An easy way to pair construction with disposal is to use a combinator:" -{ $subsections with-monitor } -"Monitors support the " { $link "io.timeouts" } "." -$nl -"An example which watches a directory for changes:" -{ $code - "USE: io.monitors" - "" - ": watch-loop ( monitor -- )" - " dup next-change path>> print flush watch-loop ;" - "" - ": watch-directory ( path -- )" - " [ t [ watch-loop ] with-monitor ] with-monitors ;" -} ; - -ABOUT: "io.monitors" +IN: io.monitors +USING: concurrency.mailboxes destructors help.markup help.syntax +kernel quotations ; + +HELP: with-monitors +{ $values { "quot" quotation } } +{ $description "Calls a quotation in a new dynamic scope where file system monitor operations can be performed." } +{ $errors "Throws an error if the platform does not support file system change monitors." } ; + +HELP: +{ $values { "path" "a pathname string" } { "recursive?" boolean } { "monitor" "a new monitor" } } +{ $contract "Opens a file system change monitor which listens for changes on " { $snippet "path" } ". The boolean indicates whether changes in subdirectories should be reported." } +{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ; + +HELP: (monitor) +{ $values { "path" "a pathname string" } { "recursive?" boolean } { "mailbox" mailbox } { "monitor" "a new monitor" } } +{ $contract "Opens a file system change monitor which listens for changes on " { $snippet "path" } " and posts notifications to " { $snippet "mailbox" } " as triples with shape " { $snippet "{ path changed monitor } " } ". The boolean indicates whether changes in subdirectories should be reported." } +{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ; + +HELP: file-change +{ $class-description "A change notification output by " { $link next-change } ". The " { $snippet "path" } " slot holds a pathname string. The " { $snippet "changed" } " slots holds a sequence of symbols documented in " { $link "io.monitors.descriptors" } "." } ; + +HELP: next-change +{ $values { "monitor" "a monitor" } { "change" file-change } } +{ $contract "Waits for file system changes and outputs a change descriptor for the first changed file." } +{ $errors "Throws an error if the monitor is closed from another thread." } ; + +HELP: with-monitor +{ $values { "path" "a pathname string" } { "recursive?" boolean } { "quot" { $quotation ( monitor -- ) } } } +{ $description "Opens a file system change monitor and passes it to the quotation. Closes the monitor after the quotation returns or throws an error." } +{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ; + +HELP: +add-file+ +{ $description "Indicates that a file has been added to its parent directory." } ; + +HELP: +remove-file+ +{ $description "Indicates that a file has been removed from its parent directory." } ; + +HELP: +modify-file+ +{ $description "Indicates that a file's contents have changed." } ; + +HELP: +rename-file-old+ +{ $description "Indicates that a file has been renamed, and this is the old name." } ; + +HELP: +rename-file-new+ +{ $description "Indicates that a file has been renamed, and this is the new name." } ; + +HELP: +rename-file+ +{ $description "Indicates that a file has been renamed." } ; + +ARTICLE: "io.monitors.descriptors" "File system change descriptors" +"The " { $link next-change } " word outputs instances of a class:" +{ $subsections file-change } +"The " { $slot "changed" } " slot holds a sequence which may contain any of the following symbols:" +{ $subsections + +add-file+ + +remove-file+ + +modify-file+ + +rename-file-old+ + +rename-file-new+ + +rename-file+ +} ; + +ARTICLE: "io.monitors.platforms" "Monitors on different platforms" +"Whether the " { $slot "path" } " slot of a " { $link file-change } " contains an absolute path or a path relative to the path given to " { $link } " is unspecified, and may even vary on the same platform. User code should not assume either case." +$nl +"If the immediate path being monitored was changed, then " { $snippet "path" } " will equal " { $snippet "\"\"" } "; however this condition is not reported on all platforms. See below." +{ $heading "Mac OS X" } +"Factor uses " { $snippet "FSEventStream" } "s to implement monitors on Mac OS X. This requires Mac OS X 10.5 or later." +$nl +{ $snippet "FSEventStream" } "s always monitor directory hierarchies recursively, and the " { $snippet "recursive?" } " parameter to " { $link } " has no effect." +$nl +"The " { $snippet "changed" } " slot of the " { $link file-change } " word tuple always contains " { $link +modify-file+ } " and the " { $snippet "path" } " slot is always the directory containing the file that changed. Unlike other platforms, fine-grained information is not available." +$nl +"Only directories may be monitored, not individual files. Changes to the directory itself (permissions, modification time, and so on) are not reported; only changes to children are reported." +{ $heading "Windows" } +"Factor uses " { $snippet "ReadDirectoryChanges" } " to implement monitors on Windows." +$nl +"Both recursive and non-recursive monitors are directly supported by the operating system." +$nl +"Only directories may be monitored, not individual files. Changes to the directory itself (permissions, modification time, and so on) are not reported; only changes to children are reported." +{ $heading "Linux" } +"Factor uses " { $snippet "inotify" } " to implement monitors on Linux. This requires Linux kernel version 2.6.16 or later." +$nl +"Factor simulates recursive monitors by creating a hierarchy of monitors for every subdirectory, since " { $snippet "inotify" } " can only monitor a single directory. This is transparent to user code." +$nl +"Inside a single " { $link with-monitors } " scope, only one monitor may be created for any given directory." +$nl +"Both directories and files may be monitored. Unlike Mac OS X and Windows, changes to the immediate directory being monitored (permissions, modification time, and so on) are reported." +; + +ARTICLE: "io.monitors" "File system change monitors" +"File system change monitors listen for changes to file names, attributes and contents under a specified directory. They can optionally be recursive, in which case subdirectories are also monitored." +$nl +"Monitoring operations must be wrapped in a combinator:" +{ $subsections with-monitors } +"Creating a file system change monitor and listening for changes:" +{ $subsections + + next-change +} +"An alternative programming style is where instead of having a thread listen for changes on a monitor, change notifications are posted to a mailbox:" +{ $subsections + (monitor) + "io.monitors.descriptors" + "io.monitors.platforms" +} +"Monitors are closed by calling " { $link dispose } " or " { $link with-disposal } ". An easy way to pair construction with disposal is to use a combinator:" +{ $subsections with-monitor } +"Monitors support the " { $link "io.timeouts" } "." +$nl +"An example which watches a directory for changes:" +{ $code + "USE: io.monitors" + "" + ": watch-loop ( monitor -- )" + " dup next-change path>> print flush watch-loop ;" + "" + ": watch-directory ( path -- )" + " [ t [ watch-loop ] with-monitor ] with-monitors ;" +} ; + +ABOUT: "io.monitors" diff --git a/basis/io/servers/servers.factor b/basis/io/servers/servers.factor index 8f7ce10c85..ef8703eaf2 100755 --- a/basis/io/servers/servers.factor +++ b/basis/io/servers/servers.factor @@ -244,7 +244,7 @@ PRIVATE> : insecure-addr ( -- addrspec ) server-addrs [ secure? ] reject random ; - + : server. ( threaded-server -- ) [ [ "=== " write name>> ] [ ] bi write-object nl ] [ servers>> [ addr>> present print ] each ] bi ; @@ -254,7 +254,7 @@ PRIVATE> : get-servers-named ( string -- sequence ) [ all-servers ] dip '[ name>> _ = ] filter ; - + : servers. ( -- ) all-servers [ server. ] each ; diff --git a/basis/io/sockets/unix/linux/linux.factor b/basis/io/sockets/unix/linux/linux.factor index a2c4d96633..1811dce317 100644 --- a/basis/io/sockets/unix/linux/linux.factor +++ b/basis/io/sockets/unix/linux/linux.factor @@ -6,4 +6,3 @@ IN: io.sockets.unix.linux ! Linux seems to use the same port-space for ipv4 and ipv6. M: linux resolve-localhost { T{ ipv4 f "0.0.0.0" } } ; - diff --git a/basis/io/sockets/windows/windows.factor b/basis/io/sockets/windows/windows.factor index 7eaf2c2713..82eb08a83e 100755 --- a/basis/io/sockets/windows/windows.factor +++ b/basis/io/sockets/windows/windows.factor @@ -1,320 +1,320 @@ -! Copyright (C) 2007, 2009 Slava Pestov, Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien alien.c-types alien.data classes.struct -combinators destructors io.backend io.files.windows io.ports -io.sockets io.sockets.icmp io.sockets.private kernel libc locals -math sequences system windows.errors windows.handles -windows.kernel32 windows.types windows.winsock ; -FROM: namespaces => get ; -IN: io.sockets.windows - -: set-socket-option ( handle level opt -- ) - [ handle>> ] 2dip 1 int dup byte-length setsockopt socket-error ; - -: set-ioctl-socket ( handle cmd arg -- ) - [ handle>> ] 2dip ulong ioctlsocket socket-error ; - -M: windows addrinfo-error-string ( n -- string ) - n>win32-error-string ; - -M: windows sockaddr-of-family ( alien af -- addrspec ) - { - { AF_INET [ sockaddr-in memory>struct ] } - { AF_INET6 [ sockaddr-in6 memory>struct ] } - [ 2drop f ] - } case ; - -M: windows addrspec-of-family ( af -- addrspec ) - { - { AF_INET [ T{ ipv4 } ] } - { AF_INET6 [ T{ ipv6 } ] } - [ drop f ] - } case ; - -HOOK: WSASocket-flags io-backend ( -- DWORD ) - -TUPLE: win32-socket < win32-file ; - -: ( handle -- win32-socket ) - win32-socket new-win32-handle ; - -M: win32-socket dispose* ( stream -- ) - handle>> closesocket socket-error* ; - -: unspecific-sockaddr/size ( addrspec -- sockaddr len ) - [ empty-sockaddr/size ] [ protocol-family ] bi pick family<< ; - -: opened-socket ( handle -- win32-socket ) - |dispose add-completion ; - -: open-socket ( addrspec type -- win32-socket ) - [ drop protocol-family ] [ swap protocol ] 2bi - f 0 WSASocket-flags WSASocket - dup socket-error - opened-socket ; - -M: object (get-local-address) ( socket addrspec -- sockaddr ) - [ handle>> ] dip empty-sockaddr/size int - [ getsockname socket-error ] 2keep drop ; - -M: object (get-remote-address) ( socket addrspec -- sockaddr ) - [ handle>> ] dip empty-sockaddr/size int - [ getpeername socket-error ] 2keep drop ; - -: bind-socket ( win32-socket sockaddr len -- ) - [ handle>> ] 2dip bind socket-error ; - -M: object ((client)) ( addrspec -- handle ) - [ SOCK_STREAM open-socket ] keep - [ - bind-local-address get - [ nip make-sockaddr/size ] - [ unspecific-sockaddr/size ] if* bind-socket - ] [ drop ] 2bi ; - -: server-socket ( addrspec type -- fd ) - [ open-socket ] [ drop ] 2bi - [ make-sockaddr/size bind-socket ] [ drop ] 2bi ; - -! http://support.microsoft.com/kb/127144 -! NOTE: Possibly tweak this because of SYN flood attacks -: listen-backlog ( -- n ) 0x7fffffff ; inline - -M: object (server) ( addrspec -- handle ) - [ - SOCK_STREAM server-socket - dup handle>> listen-backlog listen winsock-return-check - ] with-destructors ; - -M: windows (datagram) ( addrspec -- handle ) - [ SOCK_DGRAM server-socket ] with-destructors ; - -M: windows (raw) ( addrspec -- handle ) - [ SOCK_RAW server-socket ] with-destructors ; - -M: windows (broadcast) ( datagram -- datagram ) - dup handle>> SOL_SOCKET SO_BROADCAST set-socket-option ; - -: malloc-int ( n -- alien ) - int malloc-byte-array ; inline - -M: windows WSASocket-flags ( -- DWORD ) - WSA_FLAG_OVERLAPPED ; inline - -: get-ConnectEx-ptr ( socket -- void* ) - SIO_GET_EXTENSION_FUNCTION_POINTER - WSAID_CONNECTEX - GUID heap-size - { void* } - [ - void* heap-size - 0 DWORD - f - f - WSAIoctl SOCKET_ERROR = [ - maybe-winsock-exception throw - ] when - ] with-out-parameters ; - -TUPLE: ConnectEx-args port - s name namelen lpSendBuffer dwSendDataLength - lpdwBytesSent lpOverlapped ptr ; - -: wait-for-socket ( args -- count ) - [ lpOverlapped>> ] [ port>> ] bi twiddle-thumbs ; inline - -: ( sockaddr size -- ConnectEx ) - ConnectEx-args new - swap >>namelen - swap >>name - f >>lpSendBuffer - 0 >>dwSendDataLength - f >>lpdwBytesSent - (make-overlapped) >>lpOverlapped ; inline - -: call-ConnectEx ( ConnectEx -- ) - { - [ s>> ] - [ name>> ] - [ namelen>> ] - [ lpSendBuffer>> ] - [ dwSendDataLength>> ] - [ lpdwBytesSent>> ] - [ lpOverlapped>> ] - [ ptr>> ] - } cleave - int - { SOCKET void* int PVOID DWORD LPDWORD void* } - stdcall alien-indirect drop - winsock-error ; inline - -M: object establish-connection ( client-out remote -- ) - make-sockaddr/size - swap >>port - dup port>> handle>> handle>> >>s - dup s>> get-ConnectEx-ptr >>ptr - dup call-ConnectEx - wait-for-socket drop ; - -TUPLE: AcceptEx-args port - sListenSocket sAcceptSocket lpOutputBuffer dwReceiveDataLength - dwLocalAddressLength dwRemoteAddressLength lpdwBytesReceived lpOverlapped ; - -: init-accept-buffer ( addr AcceptEx -- ) - swap sockaddr-size 16 + - [ >>dwLocalAddressLength ] [ >>dwRemoteAddressLength ] bi - dup dwLocalAddressLength>> 2 * malloc &free >>lpOutputBuffer - drop ; inline - -: ( server addr -- AcceptEx ) - AcceptEx-args new - 2dup init-accept-buffer - swap SOCK_STREAM open-socket |dispose handle>> >>sAcceptSocket - over handle>> handle>> >>sListenSocket - swap >>port - 0 >>dwReceiveDataLength - f >>lpdwBytesReceived - (make-overlapped) >>lpOverlapped ; inline - -! AcceptEx return value is useless -: call-AcceptEx ( AcceptEx -- ) - { - [ sListenSocket>> ] - [ sAcceptSocket>> ] - [ lpOutputBuffer>> ] - [ dwReceiveDataLength>> ] - [ dwLocalAddressLength>> ] - [ dwRemoteAddressLength>> ] - [ lpdwBytesReceived>> ] - [ lpOverlapped>> ] - } cleave AcceptEx drop winsock-error ; inline - -: (extract-remote-address) ( lpOutputBuffer dwReceiveDataLength dwLocalAddressLength dwRemoteAddressLength -- sockaddr ) - f void* 0 int f void* - [ 0 int GetAcceptExSockaddrs ] keep void* deref ; - -: extract-remote-address ( AcceptEx -- sockaddr ) - [ - { - [ lpOutputBuffer>> ] - [ dwReceiveDataLength>> ] - [ dwLocalAddressLength>> ] - [ dwRemoteAddressLength>> ] - } cleave - (extract-remote-address) - ] [ port>> addr>> protocol-family ] bi - sockaddr-of-family ; inline - -M: object (accept) ( server addr -- handle sockaddr ) - [ - - { - [ call-AcceptEx ] - [ wait-for-socket drop ] - [ sAcceptSocket>> ] - [ extract-remote-address ] - } cleave - ] with-destructors ; - -TUPLE: WSARecvFrom-args port - s lpBuffers dwBufferCount lpNumberOfBytesRecvd - lpFlags lpFrom lpFromLen lpOverlapped lpCompletionRoutine ; - -:: make-receive-buffer ( n buf -- buf' WSABUF ) - buf >c-ptr pinned-alien? - [ buf ] [ n malloc &free [ buf n memcpy ] keep ] if :> buf' - buf' - WSABUF malloc-struct &free - n >>len - buf' >>buf ; inline - -:: ( n buf datagram -- buf buf' WSARecvFrom ) - n buf make-receive-buffer :> ( buf' wsaBuf ) - buf buf' - WSARecvFrom-args new - datagram >>port - datagram handle>> handle>> >>s - datagram addr>> sockaddr-size - [ malloc &free >>lpFrom ] - [ malloc-int &free >>lpFromLen ] bi - wsaBuf >>lpBuffers - 1 >>dwBufferCount - 0 malloc-int &free >>lpFlags - 0 malloc-int &free >>lpNumberOfBytesRecvd - (make-overlapped) >>lpOverlapped ; inline - -: call-WSARecvFrom ( WSARecvFrom -- ) - { - [ s>> ] - [ lpBuffers>> ] - [ dwBufferCount>> ] - [ lpNumberOfBytesRecvd>> ] - [ lpFlags>> ] - [ lpFrom>> ] - [ lpFromLen>> ] - [ lpOverlapped>> ] - [ lpCompletionRoutine>> ] - } cleave WSARecvFrom socket-error* ; inline - -:: finalize-buf ( buf buf' count -- ) - buf buf' eq? [ buf buf' count memcpy ] unless ; inline - -:: parse-WSARecvFrom ( buf buf' count wsaRecvFrom -- count sockaddr ) - buf buf' count finalize-buf - count wsaRecvFrom - [ port>> addr>> empty-sockaddr dup ] - [ lpFrom>> ] - [ lpFromLen>> int deref ] - tri memcpy ; inline - -M: windows (receive-unsafe) ( n buf datagram -- count addrspec ) - [ - - [ call-WSARecvFrom ] - [ wait-for-socket ] - [ parse-WSARecvFrom ] - tri - ] with-destructors ; - -TUPLE: WSASendTo-args port - s lpBuffers dwBufferCount lpNumberOfBytesSent - dwFlags lpTo iToLen lpOverlapped lpCompletionRoutine ; - -: make-send-buffer ( packet -- WSABUF ) - [ WSABUF malloc-struct &free ] dip - [ malloc-byte-array &free >>buf ] - [ length >>len ] bi ; inline - -: ( packet addrspec datagram -- WSASendTo ) - WSASendTo-args new - swap >>port - dup port>> handle>> handle>> >>s - swap make-sockaddr/size - [ malloc-byte-array &free ] dip - [ >>lpTo ] [ >>iToLen ] bi* - swap make-send-buffer >>lpBuffers - 1 >>dwBufferCount - 0 >>dwFlags - 0 uint >>lpNumberOfBytesSent - (make-overlapped) >>lpOverlapped ; inline - -: call-WSASendTo ( WSASendTo -- ) - { - [ s>> ] - [ lpBuffers>> ] - [ dwBufferCount>> ] - [ lpNumberOfBytesSent>> ] - [ dwFlags>> ] - [ lpTo>> ] - [ iToLen>> ] - [ lpOverlapped>> ] - [ lpCompletionRoutine>> ] - } cleave WSASendTo socket-error* ; inline - -M: windows (send) ( packet addrspec datagram -- ) - [ - - [ call-WSASendTo ] - [ wait-for-socket drop ] - bi - ] with-destructors ; +! Copyright (C) 2007, 2009 Slava Pestov, Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien alien.c-types alien.data classes.struct +combinators destructors io.backend io.files.windows io.ports +io.sockets io.sockets.icmp io.sockets.private kernel libc locals +math sequences system windows.errors windows.handles +windows.kernel32 windows.types windows.winsock ; +FROM: namespaces => get ; +IN: io.sockets.windows + +: set-socket-option ( handle level opt -- ) + [ handle>> ] 2dip 1 int dup byte-length setsockopt socket-error ; + +: set-ioctl-socket ( handle cmd arg -- ) + [ handle>> ] 2dip ulong ioctlsocket socket-error ; + +M: windows addrinfo-error-string ( n -- string ) + n>win32-error-string ; + +M: windows sockaddr-of-family ( alien af -- addrspec ) + { + { AF_INET [ sockaddr-in memory>struct ] } + { AF_INET6 [ sockaddr-in6 memory>struct ] } + [ 2drop f ] + } case ; + +M: windows addrspec-of-family ( af -- addrspec ) + { + { AF_INET [ T{ ipv4 } ] } + { AF_INET6 [ T{ ipv6 } ] } + [ drop f ] + } case ; + +HOOK: WSASocket-flags io-backend ( -- DWORD ) + +TUPLE: win32-socket < win32-file ; + +: ( handle -- win32-socket ) + win32-socket new-win32-handle ; + +M: win32-socket dispose* ( stream -- ) + handle>> closesocket socket-error* ; + +: unspecific-sockaddr/size ( addrspec -- sockaddr len ) + [ empty-sockaddr/size ] [ protocol-family ] bi pick family<< ; + +: opened-socket ( handle -- win32-socket ) + |dispose add-completion ; + +: open-socket ( addrspec type -- win32-socket ) + [ drop protocol-family ] [ swap protocol ] 2bi + f 0 WSASocket-flags WSASocket + dup socket-error + opened-socket ; + +M: object (get-local-address) ( socket addrspec -- sockaddr ) + [ handle>> ] dip empty-sockaddr/size int + [ getsockname socket-error ] 2keep drop ; + +M: object (get-remote-address) ( socket addrspec -- sockaddr ) + [ handle>> ] dip empty-sockaddr/size int + [ getpeername socket-error ] 2keep drop ; + +: bind-socket ( win32-socket sockaddr len -- ) + [ handle>> ] 2dip bind socket-error ; + +M: object ((client)) ( addrspec -- handle ) + [ SOCK_STREAM open-socket ] keep + [ + bind-local-address get + [ nip make-sockaddr/size ] + [ unspecific-sockaddr/size ] if* bind-socket + ] [ drop ] 2bi ; + +: server-socket ( addrspec type -- fd ) + [ open-socket ] [ drop ] 2bi + [ make-sockaddr/size bind-socket ] [ drop ] 2bi ; + +! http://support.microsoft.com/kb/127144 +! NOTE: Possibly tweak this because of SYN flood attacks +: listen-backlog ( -- n ) 0x7fffffff ; inline + +M: object (server) ( addrspec -- handle ) + [ + SOCK_STREAM server-socket + dup handle>> listen-backlog listen winsock-return-check + ] with-destructors ; + +M: windows (datagram) ( addrspec -- handle ) + [ SOCK_DGRAM server-socket ] with-destructors ; + +M: windows (raw) ( addrspec -- handle ) + [ SOCK_RAW server-socket ] with-destructors ; + +M: windows (broadcast) ( datagram -- datagram ) + dup handle>> SOL_SOCKET SO_BROADCAST set-socket-option ; + +: malloc-int ( n -- alien ) + int malloc-byte-array ; inline + +M: windows WSASocket-flags ( -- DWORD ) + WSA_FLAG_OVERLAPPED ; inline + +: get-ConnectEx-ptr ( socket -- void* ) + SIO_GET_EXTENSION_FUNCTION_POINTER + WSAID_CONNECTEX + GUID heap-size + { void* } + [ + void* heap-size + 0 DWORD + f + f + WSAIoctl SOCKET_ERROR = [ + maybe-winsock-exception throw + ] when + ] with-out-parameters ; + +TUPLE: ConnectEx-args port + s name namelen lpSendBuffer dwSendDataLength + lpdwBytesSent lpOverlapped ptr ; + +: wait-for-socket ( args -- count ) + [ lpOverlapped>> ] [ port>> ] bi twiddle-thumbs ; inline + +: ( sockaddr size -- ConnectEx ) + ConnectEx-args new + swap >>namelen + swap >>name + f >>lpSendBuffer + 0 >>dwSendDataLength + f >>lpdwBytesSent + (make-overlapped) >>lpOverlapped ; inline + +: call-ConnectEx ( ConnectEx -- ) + { + [ s>> ] + [ name>> ] + [ namelen>> ] + [ lpSendBuffer>> ] + [ dwSendDataLength>> ] + [ lpdwBytesSent>> ] + [ lpOverlapped>> ] + [ ptr>> ] + } cleave + int + { SOCKET void* int PVOID DWORD LPDWORD void* } + stdcall alien-indirect drop + winsock-error ; inline + +M: object establish-connection ( client-out remote -- ) + make-sockaddr/size + swap >>port + dup port>> handle>> handle>> >>s + dup s>> get-ConnectEx-ptr >>ptr + dup call-ConnectEx + wait-for-socket drop ; + +TUPLE: AcceptEx-args port + sListenSocket sAcceptSocket lpOutputBuffer dwReceiveDataLength + dwLocalAddressLength dwRemoteAddressLength lpdwBytesReceived lpOverlapped ; + +: init-accept-buffer ( addr AcceptEx -- ) + swap sockaddr-size 16 + + [ >>dwLocalAddressLength ] [ >>dwRemoteAddressLength ] bi + dup dwLocalAddressLength>> 2 * malloc &free >>lpOutputBuffer + drop ; inline + +: ( server addr -- AcceptEx ) + AcceptEx-args new + 2dup init-accept-buffer + swap SOCK_STREAM open-socket |dispose handle>> >>sAcceptSocket + over handle>> handle>> >>sListenSocket + swap >>port + 0 >>dwReceiveDataLength + f >>lpdwBytesReceived + (make-overlapped) >>lpOverlapped ; inline + +! AcceptEx return value is useless +: call-AcceptEx ( AcceptEx -- ) + { + [ sListenSocket>> ] + [ sAcceptSocket>> ] + [ lpOutputBuffer>> ] + [ dwReceiveDataLength>> ] + [ dwLocalAddressLength>> ] + [ dwRemoteAddressLength>> ] + [ lpdwBytesReceived>> ] + [ lpOverlapped>> ] + } cleave AcceptEx drop winsock-error ; inline + +: (extract-remote-address) ( lpOutputBuffer dwReceiveDataLength dwLocalAddressLength dwRemoteAddressLength -- sockaddr ) + f void* 0 int f void* + [ 0 int GetAcceptExSockaddrs ] keep void* deref ; + +: extract-remote-address ( AcceptEx -- sockaddr ) + [ + { + [ lpOutputBuffer>> ] + [ dwReceiveDataLength>> ] + [ dwLocalAddressLength>> ] + [ dwRemoteAddressLength>> ] + } cleave + (extract-remote-address) + ] [ port>> addr>> protocol-family ] bi + sockaddr-of-family ; inline + +M: object (accept) ( server addr -- handle sockaddr ) + [ + + { + [ call-AcceptEx ] + [ wait-for-socket drop ] + [ sAcceptSocket>> ] + [ extract-remote-address ] + } cleave + ] with-destructors ; + +TUPLE: WSARecvFrom-args port + s lpBuffers dwBufferCount lpNumberOfBytesRecvd + lpFlags lpFrom lpFromLen lpOverlapped lpCompletionRoutine ; + +:: make-receive-buffer ( n buf -- buf' WSABUF ) + buf >c-ptr pinned-alien? + [ buf ] [ n malloc &free [ buf n memcpy ] keep ] if :> buf' + buf' + WSABUF malloc-struct &free + n >>len + buf' >>buf ; inline + +:: ( n buf datagram -- buf buf' WSARecvFrom ) + n buf make-receive-buffer :> ( buf' wsaBuf ) + buf buf' + WSARecvFrom-args new + datagram >>port + datagram handle>> handle>> >>s + datagram addr>> sockaddr-size + [ malloc &free >>lpFrom ] + [ malloc-int &free >>lpFromLen ] bi + wsaBuf >>lpBuffers + 1 >>dwBufferCount + 0 malloc-int &free >>lpFlags + 0 malloc-int &free >>lpNumberOfBytesRecvd + (make-overlapped) >>lpOverlapped ; inline + +: call-WSARecvFrom ( WSARecvFrom -- ) + { + [ s>> ] + [ lpBuffers>> ] + [ dwBufferCount>> ] + [ lpNumberOfBytesRecvd>> ] + [ lpFlags>> ] + [ lpFrom>> ] + [ lpFromLen>> ] + [ lpOverlapped>> ] + [ lpCompletionRoutine>> ] + } cleave WSARecvFrom socket-error* ; inline + +:: finalize-buf ( buf buf' count -- ) + buf buf' eq? [ buf buf' count memcpy ] unless ; inline + +:: parse-WSARecvFrom ( buf buf' count wsaRecvFrom -- count sockaddr ) + buf buf' count finalize-buf + count wsaRecvFrom + [ port>> addr>> empty-sockaddr dup ] + [ lpFrom>> ] + [ lpFromLen>> int deref ] + tri memcpy ; inline + +M: windows (receive-unsafe) ( n buf datagram -- count addrspec ) + [ + + [ call-WSARecvFrom ] + [ wait-for-socket ] + [ parse-WSARecvFrom ] + tri + ] with-destructors ; + +TUPLE: WSASendTo-args port + s lpBuffers dwBufferCount lpNumberOfBytesSent + dwFlags lpTo iToLen lpOverlapped lpCompletionRoutine ; + +: make-send-buffer ( packet -- WSABUF ) + [ WSABUF malloc-struct &free ] dip + [ malloc-byte-array &free >>buf ] + [ length >>len ] bi ; inline + +: ( packet addrspec datagram -- WSASendTo ) + WSASendTo-args new + swap >>port + dup port>> handle>> handle>> >>s + swap make-sockaddr/size + [ malloc-byte-array &free ] dip + [ >>lpTo ] [ >>iToLen ] bi* + swap make-send-buffer >>lpBuffers + 1 >>dwBufferCount + 0 >>dwFlags + 0 uint >>lpNumberOfBytesSent + (make-overlapped) >>lpOverlapped ; inline + +: call-WSASendTo ( WSASendTo -- ) + { + [ s>> ] + [ lpBuffers>> ] + [ dwBufferCount>> ] + [ lpNumberOfBytesSent>> ] + [ dwFlags>> ] + [ lpTo>> ] + [ iToLen>> ] + [ lpOverlapped>> ] + [ lpCompletionRoutine>> ] + } cleave WSASendTo socket-error* ; inline + +M: windows (send) ( packet addrspec datagram -- ) + [ + + [ call-WSASendTo ] + [ wait-for-socket drop ] + bi + ] with-destructors ; diff --git a/basis/io/standard-paths/standard-paths.factor b/basis/io/standard-paths/standard-paths.factor index d552af0657..288ff53db2 100644 --- a/basis/io/standard-paths/standard-paths.factor +++ b/basis/io/standard-paths/standard-paths.factor @@ -35,4 +35,3 @@ M: object find-in-standard-login-path* { [ os macosx? ] [ "io.standard-paths.macosx" ] } { [ os unix? ] [ "io.standard-paths.unix" ] } } cond require - diff --git a/basis/io/standard-paths/windows/windows.factor b/basis/io/standard-paths/windows/windows.factor index d82bcdbd6a..799f6d816c 100644 --- a/basis/io/standard-paths/windows/windows.factor +++ b/basis/io/standard-paths/windows/windows.factor @@ -11,4 +11,3 @@ M: windows find-in-applications M: windows find-in-path* [ "PATH" os-env ";" split ] dip '[ _ append-path exists? ] find nip ; - diff --git a/basis/io/streams/limited/limited.factor b/basis/io/streams/limited/limited.factor index b025ec4eca..1455c8fa8c 100644 --- a/basis/io/streams/limited/limited.factor +++ b/basis/io/streams/limited/limited.factor @@ -86,7 +86,7 @@ ERROR: limit-exceeded n stream ; PRIVATE> M: limited-stream stream-read1 - 1 swap + 1 swap [ nip stream-read1 ] maybe-read ; M: limited-stream stream-read-unsafe diff --git a/basis/io/timeouts/timeouts-docs.factor b/basis/io/timeouts/timeouts-docs.factor index 626f0c24c0..26ce1043c4 100644 --- a/basis/io/timeouts/timeouts-docs.factor +++ b/basis/io/timeouts/timeouts-docs.factor @@ -1,40 +1,40 @@ -IN: io.timeouts -USING: help.markup help.syntax math kernel calendar ; - -HELP: timeout -{ $values { "obj" object } { "dt/f" { $maybe duration } } } -{ $contract "Outputs an object's timeout." } ; - -HELP: set-timeout -{ $values { "dt/f" { $maybe duration } } { "obj" object } } -{ $contract "Sets an object's timeout." } -{ $examples "Waits five seconds for a process that sleeps for ten seconds:" - { $unchecked-example - "USING: calendar io.launcher io.timeouts kernel ;" - "\"sleep 10\" >process 5 seconds over set-timeout run-process" - "Process was killed as a result of a call to" - "kill-process, or a timeout" - } -} ; - -HELP: cancel-operation -{ $values { "obj" object } } -{ $contract "Handles a timeout, usually by waking up all threads waiting on the object." } ; - -HELP: with-timeout -{ $values { "obj" object } { "quot" { $quotation ( obj -- ) } } } -{ $description "Applies the quotation to the object. If the object's timeout expires before the quotation returns, " { $link cancel-operation } " is called on the object." } ; - -ARTICLE: "io.timeouts" "I/O timeout protocol" -"Streams, processes and monitors support optional timeouts, which impose an upper bound on the length of time for which an operation on these objects can block. Timeouts are used in network servers to prevent malicious clients from holding onto connections forever, and to ensure that runaway processes get killed." -{ $subsections - timeout - set-timeout -} -"The I/O timeout protocol can be implemented by any class wishing to support timeouts on blocking operations." -{ $subsections cancel-operation } -"A combinator to be used in operations which can time out:" -{ $subsections with-timeout } -{ $see-also "stream-protocol" "io.launcher" "io.monitors" } ; - -ABOUT: "io.timeouts" +IN: io.timeouts +USING: help.markup help.syntax math kernel calendar ; + +HELP: timeout +{ $values { "obj" object } { "dt/f" { $maybe duration } } } +{ $contract "Outputs an object's timeout." } ; + +HELP: set-timeout +{ $values { "dt/f" { $maybe duration } } { "obj" object } } +{ $contract "Sets an object's timeout." } +{ $examples "Waits five seconds for a process that sleeps for ten seconds:" + { $unchecked-example + "USING: calendar io.launcher io.timeouts kernel ;" + "\"sleep 10\" >process 5 seconds over set-timeout run-process" + "Process was killed as a result of a call to" + "kill-process, or a timeout" + } +} ; + +HELP: cancel-operation +{ $values { "obj" object } } +{ $contract "Handles a timeout, usually by waking up all threads waiting on the object." } ; + +HELP: with-timeout +{ $values { "obj" object } { "quot" { $quotation ( obj -- ) } } } +{ $description "Applies the quotation to the object. If the object's timeout expires before the quotation returns, " { $link cancel-operation } " is called on the object." } ; + +ARTICLE: "io.timeouts" "I/O timeout protocol" +"Streams, processes and monitors support optional timeouts, which impose an upper bound on the length of time for which an operation on these objects can block. Timeouts are used in network servers to prevent malicious clients from holding onto connections forever, and to ensure that runaway processes get killed." +{ $subsections + timeout + set-timeout +} +"The I/O timeout protocol can be implemented by any class wishing to support timeouts on blocking operations." +{ $subsections cancel-operation } +"A combinator to be used in operations which can time out:" +{ $subsections with-timeout } +{ $see-also "stream-protocol" "io.launcher" "io.monitors" } ; + +ABOUT: "io.timeouts" diff --git a/basis/io/timeouts/timeouts.factor b/basis/io/timeouts/timeouts.factor index 2190b4009d..42238b6526 100644 --- a/basis/io/timeouts/timeouts.factor +++ b/basis/io/timeouts/timeouts.factor @@ -1,31 +1,31 @@ -! Copyright (C) 2008 Slava Pestov, Doug Coleman -! See http://factorcode.org/license.txt for BSD license. -USING: accessors fry io io.encodings io.streams.null kernel -namespaces timers ; -IN: io.timeouts - -GENERIC: timeout ( obj -- dt/f ) -GENERIC: set-timeout ( dt/f obj -- ) - -M: decoder set-timeout stream>> set-timeout ; - -M: encoder set-timeout stream>> set-timeout ; - -GENERIC: cancel-operation ( obj -- ) - -: queue-timeout ( obj timeout -- timer ) - [ '[ _ cancel-operation ] ] dip later ; - -: with-timeout* ( obj timeout quot -- ) - 2over queue-timeout [ nip call ] dip stop-timer ; - inline - -: with-timeout ( obj quot -- ) - over timeout [ [ dup timeout ] dip with-timeout* ] [ call ] if ; - inline - -: timeouts ( dt -- ) - [ input-stream get set-timeout ] - [ output-stream get set-timeout ] bi ; - -M: null-stream set-timeout 2drop ; +! Copyright (C) 2008 Slava Pestov, Doug Coleman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors fry io io.encodings io.streams.null kernel +namespaces timers ; +IN: io.timeouts + +GENERIC: timeout ( obj -- dt/f ) +GENERIC: set-timeout ( dt/f obj -- ) + +M: decoder set-timeout stream>> set-timeout ; + +M: encoder set-timeout stream>> set-timeout ; + +GENERIC: cancel-operation ( obj -- ) + +: queue-timeout ( obj timeout -- timer ) + [ '[ _ cancel-operation ] ] dip later ; + +: with-timeout* ( obj timeout quot -- ) + 2over queue-timeout [ nip call ] dip stop-timer ; + inline + +: with-timeout ( obj quot -- ) + over timeout [ [ dup timeout ] dip with-timeout* ] [ call ] if ; + inline + +: timeouts ( dt -- ) + [ input-stream get set-timeout ] + [ output-stream get set-timeout ] bi ; + +M: null-stream set-timeout 2drop ; diff --git a/basis/iokit/iokit.factor b/basis/iokit/iokit.factor index 5e2f11f9de..8114c8f49c 100644 --- a/basis/iokit/iokit.factor +++ b/basis/iokit/iokit.factor @@ -11,7 +11,7 @@ IN: iokit CONSTANT: kIOKitBuildVersionKey "IOKitBuildVersion" CONSTANT: kIOKitDiagnosticsKey "IOKitDiagnostics" - + CONSTANT: kIORegistryPlanesKey "IORegistryPlanes" CONSTANT: kIOCatalogueKey "IOCatalogue" @@ -84,16 +84,16 @@ CONSTANT: kIOBundleResourceFileKey "IOBundleResourceFile" CONSTANT: kIOBusBadgeKey "IOBusBadge" CONSTANT: kIODeviceIconKey "IODeviceIcon" -CONSTANT: kIOPlatformSerialNumberKey "IOPlatformSerialNumber" +CONSTANT: kIOPlatformSerialNumberKey "IOPlatformSerialNumber" -CONSTANT: kIOPlatformUUIDKey "IOPlatformUUID" +CONSTANT: kIOPlatformUUIDKey "IOPlatformUUID" CONSTANT: kIONVRAMDeletePropertyKey "IONVRAM-DELETE-PROPERTY" CONSTANT: kIODTNVRAMPanicInfoKey "aapl,panic-info" -CONSTANT: kIOBootDeviceKey "IOBootDevice" -CONSTANT: kIOBootDevicePathKey "IOBootDevicePath" -CONSTANT: kIOBootDeviceSizeKey "IOBootDeviceSize" +CONSTANT: kIOBootDeviceKey "IOBootDevice" +CONSTANT: kIOBootDevicePathKey "IOBootDevicePath" +CONSTANT: kIOBootDeviceSizeKey "IOBootDeviceSize" CONSTANT: kOSBuildVersionKey "OS Build Version" @@ -154,11 +154,10 @@ TUPLE: mach-error-state error-code error-string ; : io-objects-from-iterator ( i -- array ) io-objects-from-iterator* [ release-io-object ] dip ; - + : properties-from-io-object ( o -- o nsdictionary ) dup f void* [ kCFAllocatorDefault kNilOptions IORegistryEntryCreateCFProperties mach-error ] keep void* deref ; - diff --git a/basis/lcs/lcs-docs.factor b/basis/lcs/lcs-docs.factor index ad81a7b346..b37ad67929 100644 --- a/basis/lcs/lcs-docs.factor +++ b/basis/lcs/lcs-docs.factor @@ -1,39 +1,39 @@ -USING: help.syntax help.markup sequences ; -IN: lcs - -HELP: levenshtein -{ $values { "old" sequence } { "new" sequence } { "n" "the Levenshtein distance" } } -{ $description "Calculates the Levenshtein distance between old and new, that is, the minimal number of changes from the old sequence to the new one, in terms of deleting, inserting and replacing characters." } ; - -HELP: lcs -{ $values { "seq1" sequence } { "seq2" sequence } { "lcs" "a longest common subsequence" } } -{ $description "Given two sequences, calculates a longest common subsequence between them. Note two things: this is only one of the many possible LCSs, and the LCS may not be contiguous." } ; - -HELP: lcs-diff -{ $values { "old" sequence } { "new" sequence } { "diff" "an edit script" } } -{ $description "Given two sequences, find a minimal edit script from the old to the new. There may be more than one minimal edit script, and this chooses one arbitrarily. This script is in the form of an array of the tuples of the classes " { $link retain } ", " { $link delete } " and " { $link insert } " which have their information stored in the 'item' slot." } ; - -HELP: retain -{ $class-description "Represents an action in an edit script where an item is kept, going from the initial sequence to the final sequence. This has one slot, called item, containing the thing which is retained" } ; - -HELP: delete -{ $class-description "Represents an action in an edit script where an item is deleted, going from the initial sequence to the final sequence. This has one slot, called item, containing the thing which is deleted" } ; - -HELP: insert -{ $class-description "Represents an action in an edit script where an item is added, going from the initial sequence to the final sequence. This has one slot, called item, containing the thing which is inserted" } ; - -ARTICLE: "lcs" "LCS, diffing and distance" -"This vocabulary provides words for three apparently unrelated but in fact very similar problems: finding a longest common subsequence between two sequences, getting a minimal edit script (diff) between two sequences, and calculating the Levenshtein distance between two sequences. The implementations of these algorithms are very closely related, and all running times are O(nm), where n and m are the lengths of the input sequences." -{ $subsections - lcs - lcs-diff - levenshtein -} -"The " { $link lcs-diff } " word returns a sequence of tuples of the following classes. They all hold their contents in the 'item' slot." -{ $subsections - insert - delete - retain -} ; - -ABOUT: "lcs" +USING: help.syntax help.markup sequences ; +IN: lcs + +HELP: levenshtein +{ $values { "old" sequence } { "new" sequence } { "n" "the Levenshtein distance" } } +{ $description "Calculates the Levenshtein distance between old and new, that is, the minimal number of changes from the old sequence to the new one, in terms of deleting, inserting and replacing characters." } ; + +HELP: lcs +{ $values { "seq1" sequence } { "seq2" sequence } { "lcs" "a longest common subsequence" } } +{ $description "Given two sequences, calculates a longest common subsequence between them. Note two things: this is only one of the many possible LCSs, and the LCS may not be contiguous." } ; + +HELP: lcs-diff +{ $values { "old" sequence } { "new" sequence } { "diff" "an edit script" } } +{ $description "Given two sequences, find a minimal edit script from the old to the new. There may be more than one minimal edit script, and this chooses one arbitrarily. This script is in the form of an array of the tuples of the classes " { $link retain } ", " { $link delete } " and " { $link insert } " which have their information stored in the 'item' slot." } ; + +HELP: retain +{ $class-description "Represents an action in an edit script where an item is kept, going from the initial sequence to the final sequence. This has one slot, called item, containing the thing which is retained" } ; + +HELP: delete +{ $class-description "Represents an action in an edit script where an item is deleted, going from the initial sequence to the final sequence. This has one slot, called item, containing the thing which is deleted" } ; + +HELP: insert +{ $class-description "Represents an action in an edit script where an item is added, going from the initial sequence to the final sequence. This has one slot, called item, containing the thing which is inserted" } ; + +ARTICLE: "lcs" "LCS, diffing and distance" +"This vocabulary provides words for three apparently unrelated but in fact very similar problems: finding a longest common subsequence between two sequences, getting a minimal edit script (diff) between two sequences, and calculating the Levenshtein distance between two sequences. The implementations of these algorithms are very closely related, and all running times are O(nm), where n and m are the lengths of the input sequences." +{ $subsections + lcs + lcs-diff + levenshtein +} +"The " { $link lcs-diff } " word returns a sequence of tuples of the following classes. They all hold their contents in the 'item' slot." +{ $subsections + insert + delete + retain +} ; + +ABOUT: "lcs" diff --git a/basis/lcs/lcs.factor b/basis/lcs/lcs.factor index e0ec97e6bd..7c0b62224c 100644 --- a/basis/lcs/lcs.factor +++ b/basis/lcs/lcs.factor @@ -1,106 +1,106 @@ -USING: accessors arrays combinators combinators.short-circuit -kernel locals make math math.order sequences sequences.private -typed ; -IN: lcs - - ] with map ; - -: levenshtein-initialize ( |str1| |str2| -- matrix ) - [ iota ] bi@ [ [ + ] curry map ] with map ; - -:: run-lcs ( old new init step -- matrix ) - old length 1 + new length 1 + init call :> matrix - old length iota [| i | - new length iota [| j | - i j matrix old new step loop-step - ] each - ] each matrix ; inline - -PRIVATE> - -: levenshtein ( old new -- n ) - [ levenshtein-initialize ] [ levenshtein-step ] - run-lcs last last ; - -TUPLE: retain item ; -TUPLE: delete item ; -TUPLE: insert item ; - -> 1 - ] [ old>> ] bi nth-unsafe ; - -: new-nth ( state -- elt ) - [ j>> 1 - ] [ new>> ] bi nth-unsafe ; - -: top-beats-side? ( state -- ? ) - [ [ i>> ] [ j>> 1 - ] [ table>> ] tri nth-unsafe nth-unsafe ] - [ [ i>> 1 - ] [ j>> ] [ table>> ] tri nth-unsafe nth-unsafe ] bi > ; - -: retained? ( state -- ? ) - { - [ i>> 0 > ] [ j>> 0 > ] - [ [ old-nth ] [ new-nth ] bi = ] - } 1&& ; - -: do-retain ( state -- state ) - dup old-nth retain boa , - [ 1 - ] change-i [ 1 - ] change-j ; - -: inserted? ( state -- ? ) - { - [ j>> 0 > ] - [ { [ i>> zero? ] [ top-beats-side? ] } 1|| ] - } 1&& ; - -: do-insert ( state -- state ) - dup new-nth insert boa , [ 1 - ] change-j ; - -: deleted? ( state -- ? ) - { - [ i>> 0 > ] - [ { [ j>> zero? ] [ top-beats-side? not ] } 1|| ] - } 1&& ; - -: do-delete ( state -- state ) - dup old-nth delete boa , [ 1 - ] change-i ; - -: (trace-diff) ( state -- ) - { - { [ dup retained? ] [ do-retain (trace-diff) ] } - { [ dup inserted? ] [ do-insert (trace-diff) ] } - { [ dup deleted? ] [ do-delete (trace-diff) ] } - [ drop ] ! i=j=0 - } cond ; - -: trace-diff ( old new table -- diff ) - [ ] [ first length 1 - ] [ length 1 - ] tri trace-state boa - [ (trace-diff) ] { } make reverse! ; - -PRIVATE> - -: lcs-diff ( old new -- diff ) - 2dup [ lcs-initialize ] [ lcs-step ] run-lcs trace-diff ; - -: lcs ( seq1 seq2 -- lcs ) - [ lcs-diff [ retain? ] filter ] keep [ item>> ] swap map-as ; +USING: accessors arrays combinators combinators.short-circuit +kernel locals make math math.order sequences sequences.private +typed ; +IN: lcs + + ] with map ; + +: levenshtein-initialize ( |str1| |str2| -- matrix ) + [ iota ] bi@ [ [ + ] curry map ] with map ; + +:: run-lcs ( old new init step -- matrix ) + old length 1 + new length 1 + init call :> matrix + old length iota [| i | + new length iota [| j | + i j matrix old new step loop-step + ] each + ] each matrix ; inline + +PRIVATE> + +: levenshtein ( old new -- n ) + [ levenshtein-initialize ] [ levenshtein-step ] + run-lcs last last ; + +TUPLE: retain item ; +TUPLE: delete item ; +TUPLE: insert item ; + +> 1 - ] [ old>> ] bi nth-unsafe ; + +: new-nth ( state -- elt ) + [ j>> 1 - ] [ new>> ] bi nth-unsafe ; + +: top-beats-side? ( state -- ? ) + [ [ i>> ] [ j>> 1 - ] [ table>> ] tri nth-unsafe nth-unsafe ] + [ [ i>> 1 - ] [ j>> ] [ table>> ] tri nth-unsafe nth-unsafe ] bi > ; + +: retained? ( state -- ? ) + { + [ i>> 0 > ] [ j>> 0 > ] + [ [ old-nth ] [ new-nth ] bi = ] + } 1&& ; + +: do-retain ( state -- state ) + dup old-nth retain boa , + [ 1 - ] change-i [ 1 - ] change-j ; + +: inserted? ( state -- ? ) + { + [ j>> 0 > ] + [ { [ i>> zero? ] [ top-beats-side? ] } 1|| ] + } 1&& ; + +: do-insert ( state -- state ) + dup new-nth insert boa , [ 1 - ] change-j ; + +: deleted? ( state -- ? ) + { + [ i>> 0 > ] + [ { [ j>> zero? ] [ top-beats-side? not ] } 1|| ] + } 1&& ; + +: do-delete ( state -- state ) + dup old-nth delete boa , [ 1 - ] change-i ; + +: (trace-diff) ( state -- ) + { + { [ dup retained? ] [ do-retain (trace-diff) ] } + { [ dup inserted? ] [ do-insert (trace-diff) ] } + { [ dup deleted? ] [ do-delete (trace-diff) ] } + [ drop ] ! i=j=0 + } cond ; + +: trace-diff ( old new table -- diff ) + [ ] [ first length 1 - ] [ length 1 - ] tri trace-state boa + [ (trace-diff) ] { } make reverse! ; + +PRIVATE> + +: lcs-diff ( old new -- diff ) + 2dup [ lcs-initialize ] [ lcs-step ] run-lcs trace-diff ; + +: lcs ( seq1 seq2 -- lcs ) + [ lcs-diff [ retain? ] filter ] keep [ item>> ] swap map-as ; diff --git a/basis/listener/listener.factor b/basis/listener/listener.factor index bdfb86ea2a..96404dc2da 100644 --- a/basis/listener/listener.factor +++ b/basis/listener/listener.factor @@ -11,7 +11,7 @@ GENERIC: stream-read-quot ( stream -- quot/f ) GENERIC# prompt. 1 ( stream prompt -- ) : prompt ( -- str ) - manifest get current-vocab>> [ name>> "IN: " prepend ] [ "" ] if* + manifest get current-vocab>> [ name>> "IN: " prepend ] [ "" ] if* auto-use? get [ " auto-use" append ] when ; M: object prompt. diff --git a/basis/logging/analysis/analysis.factor b/basis/logging/analysis/analysis.factor index b58001100d..da1df05b33 100644 --- a/basis/logging/analysis/analysis.factor +++ b/basis/logging/analysis/analysis.factor @@ -1,74 +1,74 @@ -! Copyright (C) 2008, 2010 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences namespaces words assocs logging sorting -prettyprint io io.styles io.files io.encodings.utf8 -strings combinators accessors arrays math -logging.server logging.parser calendar.format ; -IN: logging.analysis - -SYMBOL: word-names -SYMBOL: errors -SYMBOL: word-histogram -SYMBOL: message-histogram - -: analyze-entry ( entry -- ) - dup level>> { ERROR CRITICAL } member-eq? [ dup errors get push ] when - dup word-name>> word-histogram get inc-at - dup word-name>> word-names get member? [ - dup [ level>> ] [ word-name>> ] [ message>> ] tri 3array - message-histogram get inc-at - ] when - drop ; - -: recent-histogram ( assoc n -- alist ) - [ sort-values ] dip short head ; - -: analyze-entries ( entries word-names -- errors word-histogram message-histogram ) - [ - word-names set - V{ } clone errors set - H{ } clone word-histogram set - H{ } clone message-histogram set - - [ analyze-entry ] each - - errors get - word-histogram get 10 recent-histogram - message-histogram get 10 recent-histogram - ] with-scope ; - -: histogram. ( assoc quot -- ) - standard-table-style [ - [ - [ swapd with-cell pprint-cell ] with-row - ] curry assoc-each - ] tabular-output ; inline - -: 10-most-recent ( errors -- errors ) - 10 tail* "Only showing 10 most recent errors" print nl ; - -: errors. ( errors -- ) - dup length 10 >= [ 10-most-recent ] when - log-entries. ; - -: analysis. ( errors word-histogram message-histogram -- ) - nl "==== FREQUENT MESSAGES:" print nl - "Total: " write dup values sum . nl - [ - [ first name>> write bl ] - [ second write ": " write ] - [ third "\n" join write ] - tri - ] histogram. - nl nl - "==== FREQUENT WORDS:" print nl - [ write ] histogram. - nl nl - "==== ERRORS:" print nl - errors. ; - -: analyze-log ( lines word-names -- ) - [ parse-log ] dip analyze-entries analysis. ; - -: analyze-log-file ( service word-names -- ) - [ parse-log-file ] dip analyze-entries analysis. ; +! Copyright (C) 2008, 2010 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences namespaces words assocs logging sorting +prettyprint io io.styles io.files io.encodings.utf8 +strings combinators accessors arrays math +logging.server logging.parser calendar.format ; +IN: logging.analysis + +SYMBOL: word-names +SYMBOL: errors +SYMBOL: word-histogram +SYMBOL: message-histogram + +: analyze-entry ( entry -- ) + dup level>> { ERROR CRITICAL } member-eq? [ dup errors get push ] when + dup word-name>> word-histogram get inc-at + dup word-name>> word-names get member? [ + dup [ level>> ] [ word-name>> ] [ message>> ] tri 3array + message-histogram get inc-at + ] when + drop ; + +: recent-histogram ( assoc n -- alist ) + [ sort-values ] dip short head ; + +: analyze-entries ( entries word-names -- errors word-histogram message-histogram ) + [ + word-names set + V{ } clone errors set + H{ } clone word-histogram set + H{ } clone message-histogram set + + [ analyze-entry ] each + + errors get + word-histogram get 10 recent-histogram + message-histogram get 10 recent-histogram + ] with-scope ; + +: histogram. ( assoc quot -- ) + standard-table-style [ + [ + [ swapd with-cell pprint-cell ] with-row + ] curry assoc-each + ] tabular-output ; inline + +: 10-most-recent ( errors -- errors ) + 10 tail* "Only showing 10 most recent errors" print nl ; + +: errors. ( errors -- ) + dup length 10 >= [ 10-most-recent ] when + log-entries. ; + +: analysis. ( errors word-histogram message-histogram -- ) + nl "==== FREQUENT MESSAGES:" print nl + "Total: " write dup values sum . nl + [ + [ first name>> write bl ] + [ second write ": " write ] + [ third "\n" join write ] + tri + ] histogram. + nl nl + "==== FREQUENT WORDS:" print nl + [ write ] histogram. + nl nl + "==== ERRORS:" print nl + errors. ; + +: analyze-log ( lines word-names -- ) + [ parse-log ] dip analyze-entries analysis. ; + +: analyze-log-file ( service word-names -- ) + [ parse-log-file ] dip analyze-entries analysis. ; diff --git a/basis/logging/insomniac/insomniac.factor b/basis/logging/insomniac/insomniac.factor index 5f323d7ada..786752f01b 100644 --- a/basis/logging/insomniac/insomniac.factor +++ b/basis/logging/insomniac/insomniac.factor @@ -1,32 +1,32 @@ -! Copyright (C) 2008, 2010 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: logging.analysis logging.server logging smtp kernel -io.files io.streams.string namespaces make timers assocs -io.encodings.utf8 accessors calendar sequences locals ; -QUALIFIED: io.sockets -IN: logging.insomniac - -SYMBOL: insomniac-sender -SYMBOL: insomniac-recipients - -: email-subject ( service -- string ) - [ - "Log analysis for " % % " on " % io.sockets:host-name % - ] "" make ; - -:: (email-log-report) ( service word-names -- ) - - [ service word-names analyze-log-file ] with-string-writer >>body - insomniac-recipients get >>to - insomniac-sender get >>from - service email-subject >>subject - send-email ; - -\ (email-log-report) NOTICE add-error-logging - -: email-log-report ( service word-names -- ) - "logging.insomniac" [ (email-log-report) ] with-logging ; - -: schedule-insomniac ( service word-names -- ) - [ email-log-report rotate-logs ] 2curry - 1 days every drop ; +! Copyright (C) 2008, 2010 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: logging.analysis logging.server logging smtp kernel +io.files io.streams.string namespaces make timers assocs +io.encodings.utf8 accessors calendar sequences locals ; +QUALIFIED: io.sockets +IN: logging.insomniac + +SYMBOL: insomniac-sender +SYMBOL: insomniac-recipients + +: email-subject ( service -- string ) + [ + "Log analysis for " % % " on " % io.sockets:host-name % + ] "" make ; + +:: (email-log-report) ( service word-names -- ) + + [ service word-names analyze-log-file ] with-string-writer >>body + insomniac-recipients get >>to + insomniac-sender get >>from + service email-subject >>subject + send-email ; + +\ (email-log-report) NOTICE add-error-logging + +: email-log-report ( service word-names -- ) + "logging.insomniac" [ (email-log-report) ] with-logging ; + +: schedule-insomniac ( service word-names -- ) + [ email-log-report rotate-logs ] 2curry + 1 days every drop ; diff --git a/basis/logging/logging.factor b/basis/logging/logging.factor index ab35bc5006..7b2d8205ca 100644 --- a/basis/logging/logging.factor +++ b/basis/logging/logging.factor @@ -1,148 +1,148 @@ -! Copyright (C) 2003, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: logging.server sequences namespaces concurrency.messaging -words kernel arrays shuffle tools.annotations -prettyprint.config prettyprint debugger io.streams.string -splitting continuations effects generalizations parser strings -quotations fry accessors math assocs math.order -sequences.generalizations ; -IN: logging - -SYMBOLS: DEBUG NOTICE WARNING ERROR CRITICAL ; - -SYMBOL: log-level - -log-level [ DEBUG ] initialize - -: log-levels ( -- assoc ) - H{ - { DEBUG 0 } - { NOTICE 10 } - { WARNING 20 } - { ERROR 30 } - { CRITICAL 40 } - } ; inline - -ERROR: undefined-log-level ; - -: log-level<=> ( log-level log-level -- <=> ) - [ log-levels at* [ undefined-log-level ] unless ] compare ; - -: log? ( log-level -- ? ) - log-level get log-level<=> +lt+ = not ; - -: send-to-log-server ( array string -- ) - prefix "log-server" get send ; - -SYMBOL: log-service - -ERROR: bad-log-message-parameters msg word level ; - -: check-log-message ( msg word level -- msg word level ) - 3dup [ string? ] [ word? ] [ word? ] tri* and and - [ bad-log-message-parameters ] unless ; inline - -: log-message ( msg word level -- ) - check-log-message - log-service get - 2dup [ log? ] [ ] bi* and [ - [ [ string-lines ] [ name>> ] [ name>> ] tri* ] dip - 4array "log-message" send-to-log-server - ] [ - 4drop - ] if ; - -: rotate-logs ( -- ) - { } "rotate-logs" send-to-log-server ; - -: close-logs ( -- ) - { } "close-logs" send-to-log-server ; - -: with-logging ( service quot -- ) - [ log-service ] dip with-variable ; inline - -! Aspect-oriented programming idioms - -message ( obj -- inputs>message ) - dup array? [ dup length 1 = [ first ] when ] when - dup string? [ - [ - boa-tuples? on - string-limit? off - 1 line-limit set - 3 nesting-limit set - 0 margin set - unparse - ] with-scope - ] unless ; - -PRIVATE> - -: (define-logging) ( word level quot -- ) - [ dup ] 2dip 2curry annotate ; inline - -: call-logging-quot ( quot word level -- quot' ) - [ "called" ] 2dip [ log-message ] 3curry prepose ; - -: add-logging ( word level -- ) - [ call-logging-quot ] (define-logging) ; - -: log-stack ( n word level -- ) - log-service get [ - [ [ ndup ] keep narray stack>message ] 2dip log-message - ] [ - 3drop - ] if ; inline - -: input# ( word -- n ) stack-effect in>> length ; - -: input-logging-quot ( quot word level -- quot' ) - rot [ [ input# ] keep ] 2dip '[ _ _ _ log-stack @ ] ; - -: add-input-logging ( word level -- ) - [ input-logging-quot ] (define-logging) ; - -: output# ( word -- n ) stack-effect out>> length ; - -: output-logging-quot ( quot word level -- quot' ) - [ [ output# ] keep ] dip '[ @ _ _ _ log-stack ] ; - -: add-output-logging ( word level -- ) - [ output-logging-quot ] (define-logging) ; - -: (log-error) ( object word level -- ) - log-service get [ - [ [ print-error ] with-string-writer ] 2dip log-message - ] [ - 2drop rethrow - ] if ; - -: log-error ( error word -- ) ERROR (log-error) ; - -: log-critical ( error word -- ) CRITICAL (log-error) ; - -: stack-balancer ( effect -- quot ) - [ in>> length [ ndrop ] curry ] - [ out>> length f >quotation ] - bi append ; - -: error-logging-quot ( quot word -- quot' ) - dup stack-effect stack-balancer - '[ _ [ _ log-error @ ] recover ] ; - -: add-error-logging ( word level -- ) - [ [ input-logging-quot ] 2keep drop error-logging-quot ] - (define-logging) ; - -SYNTAX: LOG: - #! Syntax: name level - scan-new-word dup scan-word - '[ 1array stack>message _ _ log-message ] - ( message -- ) define-declared ; - -USE: vocabs - -"logging.parser" require -"logging.analysis" require +! Copyright (C) 2003, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: logging.server sequences namespaces concurrency.messaging +words kernel arrays shuffle tools.annotations +prettyprint.config prettyprint debugger io.streams.string +splitting continuations effects generalizations parser strings +quotations fry accessors math assocs math.order +sequences.generalizations ; +IN: logging + +SYMBOLS: DEBUG NOTICE WARNING ERROR CRITICAL ; + +SYMBOL: log-level + +log-level [ DEBUG ] initialize + +: log-levels ( -- assoc ) + H{ + { DEBUG 0 } + { NOTICE 10 } + { WARNING 20 } + { ERROR 30 } + { CRITICAL 40 } + } ; inline + +ERROR: undefined-log-level ; + +: log-level<=> ( log-level log-level -- <=> ) + [ log-levels at* [ undefined-log-level ] unless ] compare ; + +: log? ( log-level -- ? ) + log-level get log-level<=> +lt+ = not ; + +: send-to-log-server ( array string -- ) + prefix "log-server" get send ; + +SYMBOL: log-service + +ERROR: bad-log-message-parameters msg word level ; + +: check-log-message ( msg word level -- msg word level ) + 3dup [ string? ] [ word? ] [ word? ] tri* and and + [ bad-log-message-parameters ] unless ; inline + +: log-message ( msg word level -- ) + check-log-message + log-service get + 2dup [ log? ] [ ] bi* and [ + [ [ string-lines ] [ name>> ] [ name>> ] tri* ] dip + 4array "log-message" send-to-log-server + ] [ + 4drop + ] if ; + +: rotate-logs ( -- ) + { } "rotate-logs" send-to-log-server ; + +: close-logs ( -- ) + { } "close-logs" send-to-log-server ; + +: with-logging ( service quot -- ) + [ log-service ] dip with-variable ; inline + +! Aspect-oriented programming idioms + +message ( obj -- inputs>message ) + dup array? [ dup length 1 = [ first ] when ] when + dup string? [ + [ + boa-tuples? on + string-limit? off + 1 line-limit set + 3 nesting-limit set + 0 margin set + unparse + ] with-scope + ] unless ; + +PRIVATE> + +: (define-logging) ( word level quot -- ) + [ dup ] 2dip 2curry annotate ; inline + +: call-logging-quot ( quot word level -- quot' ) + [ "called" ] 2dip [ log-message ] 3curry prepose ; + +: add-logging ( word level -- ) + [ call-logging-quot ] (define-logging) ; + +: log-stack ( n word level -- ) + log-service get [ + [ [ ndup ] keep narray stack>message ] 2dip log-message + ] [ + 3drop + ] if ; inline + +: input# ( word -- n ) stack-effect in>> length ; + +: input-logging-quot ( quot word level -- quot' ) + rot [ [ input# ] keep ] 2dip '[ _ _ _ log-stack @ ] ; + +: add-input-logging ( word level -- ) + [ input-logging-quot ] (define-logging) ; + +: output# ( word -- n ) stack-effect out>> length ; + +: output-logging-quot ( quot word level -- quot' ) + [ [ output# ] keep ] dip '[ @ _ _ _ log-stack ] ; + +: add-output-logging ( word level -- ) + [ output-logging-quot ] (define-logging) ; + +: (log-error) ( object word level -- ) + log-service get [ + [ [ print-error ] with-string-writer ] 2dip log-message + ] [ + 2drop rethrow + ] if ; + +: log-error ( error word -- ) ERROR (log-error) ; + +: log-critical ( error word -- ) CRITICAL (log-error) ; + +: stack-balancer ( effect -- quot ) + [ in>> length [ ndrop ] curry ] + [ out>> length f >quotation ] + bi append ; + +: error-logging-quot ( quot word -- quot' ) + dup stack-effect stack-balancer + '[ _ [ _ log-error @ ] recover ] ; + +: add-error-logging ( word level -- ) + [ [ input-logging-quot ] 2keep drop error-logging-quot ] + (define-logging) ; + +SYNTAX: LOG: + #! Syntax: name level + scan-new-word dup scan-word + '[ 1array stack>message _ _ log-message ] + ( message -- ) define-declared ; + +USE: vocabs + +"logging.parser" require +"logging.analysis" require diff --git a/basis/logging/parser/parser.factor b/basis/logging/parser/parser.factor index a359c9a254..7e0520d86f 100644 --- a/basis/logging/parser/parser.factor +++ b/basis/logging/parser/parser.factor @@ -1,102 +1,102 @@ -! Copyright (C) 2008, 2010 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors peg peg.parsers memoize kernel sequences -logging arrays words strings vectors io io.files -io.encodings.utf8 namespaces make combinators logging.server -calendar calendar.format assocs prettyprint ; -IN: logging.parser - -TUPLE: log-entry date level word-name message ; - -: string-of ( quot -- parser ) - satisfy repeat0 [ >string ] action ; inline - -SYMBOL: multiline - -: 'date' ( -- parser ) - [ "]" member? not ] string-of [ - dup multiline-header = - [ drop multiline ] [ rfc3339>timestamp ] if - ] action - "[" "]" surrounded-by ; - -: 'log-level' ( -- parser ) - log-levels keys [ - [ name>> token ] keep [ nip ] curry action - ] map choice ; - -: 'word-name' ( -- parser ) - [ " :" member? not ] string-of ; - -SYMBOL: malformed - -: 'malformed-line' ( -- parser ) - [ drop t ] string-of - [ log-entry new swap >>message malformed >>level ] action ; - -: 'log-message' ( -- parser ) - [ drop t ] string-of - [ 1vector ] action ; - -: 'log-line' ( -- parser ) - [ - 'date' , - " " token hide , - 'log-level' , - " " token hide , - 'word-name' , - ": " token hide , - 'log-message' , - ] seq* [ first4 log-entry boa ] action - 'malformed-line' 2choice ; - -PEG: parse-log-line ( string -- entry ) 'log-line' ; - -: malformed? ( line -- ? ) - level>> malformed eq? ; - -: multiline? ( line -- ? ) - level>> multiline eq? ; - -: malformed-line ( line -- ) - "Warning: malformed log line:" print - message>> print ; - -: add-multiline ( line -- ) - building get empty? [ - "Warning: log begins with multiline entry" print drop - ] [ - message>> first building get last message>> push - ] if ; - -: parse-log ( lines -- entries ) - [ - [ - parse-log-line { - { [ dup malformed? ] [ malformed-line ] } - { [ dup multiline? ] [ add-multiline ] } - [ , ] - } cond - ] each - ] { } make ; - -: parse-log-file ( service -- entries ) - log-path 1 log# dup exists? - [ utf8 file-lines parse-log ] [ drop f ] if ; - -GENERIC: log-timestamp. ( date -- ) - -M: timestamp log-timestamp. (timestamp>string) ; -M: word log-timestamp. drop "multiline" write ; - -: log-entry. ( entry -- ) - "====== " write - { - [ date>> log-timestamp. bl ] - [ level>> pprint bl ] - [ word-name>> write nl ] - [ message>> "\n" join print ] - } cleave ; - -: log-entries. ( errors -- ) - [ log-entry. ] each ; +! Copyright (C) 2008, 2010 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors peg peg.parsers memoize kernel sequences +logging arrays words strings vectors io io.files +io.encodings.utf8 namespaces make combinators logging.server +calendar calendar.format assocs prettyprint ; +IN: logging.parser + +TUPLE: log-entry date level word-name message ; + +: string-of ( quot -- parser ) + satisfy repeat0 [ >string ] action ; inline + +SYMBOL: multiline + +: 'date' ( -- parser ) + [ "]" member? not ] string-of [ + dup multiline-header = + [ drop multiline ] [ rfc3339>timestamp ] if + ] action + "[" "]" surrounded-by ; + +: 'log-level' ( -- parser ) + log-levels keys [ + [ name>> token ] keep [ nip ] curry action + ] map choice ; + +: 'word-name' ( -- parser ) + [ " :" member? not ] string-of ; + +SYMBOL: malformed + +: 'malformed-line' ( -- parser ) + [ drop t ] string-of + [ log-entry new swap >>message malformed >>level ] action ; + +: 'log-message' ( -- parser ) + [ drop t ] string-of + [ 1vector ] action ; + +: 'log-line' ( -- parser ) + [ + 'date' , + " " token hide , + 'log-level' , + " " token hide , + 'word-name' , + ": " token hide , + 'log-message' , + ] seq* [ first4 log-entry boa ] action + 'malformed-line' 2choice ; + +PEG: parse-log-line ( string -- entry ) 'log-line' ; + +: malformed? ( line -- ? ) + level>> malformed eq? ; + +: multiline? ( line -- ? ) + level>> multiline eq? ; + +: malformed-line ( line -- ) + "Warning: malformed log line:" print + message>> print ; + +: add-multiline ( line -- ) + building get empty? [ + "Warning: log begins with multiline entry" print drop + ] [ + message>> first building get last message>> push + ] if ; + +: parse-log ( lines -- entries ) + [ + [ + parse-log-line { + { [ dup malformed? ] [ malformed-line ] } + { [ dup multiline? ] [ add-multiline ] } + [ , ] + } cond + ] each + ] { } make ; + +: parse-log-file ( service -- entries ) + log-path 1 log# dup exists? + [ utf8 file-lines parse-log ] [ drop f ] if ; + +GENERIC: log-timestamp. ( date -- ) + +M: timestamp log-timestamp. (timestamp>string) ; +M: word log-timestamp. drop "multiline" write ; + +: log-entry. ( entry -- ) + "====== " write + { + [ date>> log-timestamp. bl ] + [ level>> pprint bl ] + [ word-name>> write nl ] + [ message>> "\n" join print ] + } cleave ; + +: log-entries. ( errors -- ) + [ log-entry. ] each ; diff --git a/basis/logging/server/server.factor b/basis/logging/server/server.factor index 984d440c05..4497b85dbb 100644 --- a/basis/logging/server/server.factor +++ b/basis/logging/server/server.factor @@ -1,115 +1,115 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: assocs calendar calendar.format combinators -concurrency.messaging continuations debugger destructors init io -io.directories io.encodings.utf8 io.files io.pathnames kernel -locals math math.parser math.ranges namespaces sequences -strings threads ; -IN: logging.server - -: log-root ( -- string ) - \ log-root get-global [ "logs" resource-path ] unless* ; - -: log-path ( service -- path ) - log-root prepend-path ; - -: log# ( path n -- path' ) - number>string ".log" append append-path ; - -SYMBOL: log-files - -: open-log-stream ( service -- stream ) - log-path - [ make-directories ] - [ 1 log# utf8 ] bi ; - -: log-stream ( service -- stream ) - log-files get [ open-log-stream ] cache ; - -: close-log-streams ( -- ) - log-files get [ values dispose-each ] [ clear-assoc ] bi ; - -:: with-log-root ( path quot -- ) - [ close-log-streams path \ log-root set-global quot call ] - \ log-root get-global - [ \ log-root set-global close-log-streams ] curry - [ ] cleanup ; inline - -: timestamp-header. ( -- ) - "[" write now (timestamp>rfc3339) "] " write ; - -: multiline-header ( -- str ) 20 CHAR: - ; foldable - -: multiline-header. ( -- ) - "[" write multiline-header write "] " write ; - -:: write-message ( msg word-name level -- ) - msg harvest [ - timestamp-header. - [ multiline-header. ] - [ level write bl word-name write ": " write print ] - interleave - ] unless-empty ; - -: (log-message) ( msg -- ) - #! msg: { msg word-name level service } - first4 log-stream [ write-message flush ] with-output-stream* ; - -: try-dispose ( obj -- ) - [ dispose ] curry [ error. ] recover ; - -: close-log ( service -- ) - log-files get delete-at* - [ try-dispose ] [ drop ] if ; - -: (close-logs) ( -- ) - log-files get - [ values [ try-dispose ] each ] [ clear-assoc ] bi ; - -CONSTANT: keep-logs 10 - -: ?delete-file ( path -- ) - dup exists? [ delete-file ] [ drop ] if ; - -: delete-oldest ( service -- ) - keep-logs log# ?delete-file ; - -: ?move-file ( old new -- ) - over exists? [ move-file ] [ 2drop ] if ; - -: advance-log ( path n -- ) - [ 1 - log# ] 2keep log# ?move-file ; - -: rotate-log ( service -- ) - [ close-log ] - [ - log-path - [ delete-oldest ] - [ keep-logs 1 [a,b] [ advance-log ] with each ] bi - ] bi ; - -: (rotate-logs) ( -- ) - (close-logs) - log-root directory-files [ rotate-log ] each ; - -: log-server-loop ( -- ) - receive unclip { - { "log-message" [ (log-message) ] } - { "rotate-logs" [ drop (rotate-logs) ] } - { "close-logs" [ drop (close-logs) ] } - } case log-server-loop ; - -: log-server ( -- ) - [ - init-namespaces - [ log-server-loop ] - [ error. (close-logs) ] - recover t - ] - "Log server" spawn-server - "log-server" set-global ; - -[ - H{ } clone log-files set-global - log-server -] "logging" add-startup-hook +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs calendar calendar.format combinators +concurrency.messaging continuations debugger destructors init io +io.directories io.encodings.utf8 io.files io.pathnames kernel +locals math math.parser math.ranges namespaces sequences +strings threads ; +IN: logging.server + +: log-root ( -- string ) + \ log-root get-global [ "logs" resource-path ] unless* ; + +: log-path ( service -- path ) + log-root prepend-path ; + +: log# ( path n -- path' ) + number>string ".log" append append-path ; + +SYMBOL: log-files + +: open-log-stream ( service -- stream ) + log-path + [ make-directories ] + [ 1 log# utf8 ] bi ; + +: log-stream ( service -- stream ) + log-files get [ open-log-stream ] cache ; + +: close-log-streams ( -- ) + log-files get [ values dispose-each ] [ clear-assoc ] bi ; + +:: with-log-root ( path quot -- ) + [ close-log-streams path \ log-root set-global quot call ] + \ log-root get-global + [ \ log-root set-global close-log-streams ] curry + [ ] cleanup ; inline + +: timestamp-header. ( -- ) + "[" write now (timestamp>rfc3339) "] " write ; + +: multiline-header ( -- str ) 20 CHAR: - ; foldable + +: multiline-header. ( -- ) + "[" write multiline-header write "] " write ; + +:: write-message ( msg word-name level -- ) + msg harvest [ + timestamp-header. + [ multiline-header. ] + [ level write bl word-name write ": " write print ] + interleave + ] unless-empty ; + +: (log-message) ( msg -- ) + #! msg: { msg word-name level service } + first4 log-stream [ write-message flush ] with-output-stream* ; + +: try-dispose ( obj -- ) + [ dispose ] curry [ error. ] recover ; + +: close-log ( service -- ) + log-files get delete-at* + [ try-dispose ] [ drop ] if ; + +: (close-logs) ( -- ) + log-files get + [ values [ try-dispose ] each ] [ clear-assoc ] bi ; + +CONSTANT: keep-logs 10 + +: ?delete-file ( path -- ) + dup exists? [ delete-file ] [ drop ] if ; + +: delete-oldest ( service -- ) + keep-logs log# ?delete-file ; + +: ?move-file ( old new -- ) + over exists? [ move-file ] [ 2drop ] if ; + +: advance-log ( path n -- ) + [ 1 - log# ] 2keep log# ?move-file ; + +: rotate-log ( service -- ) + [ close-log ] + [ + log-path + [ delete-oldest ] + [ keep-logs 1 [a,b] [ advance-log ] with each ] bi + ] bi ; + +: (rotate-logs) ( -- ) + (close-logs) + log-root directory-files [ rotate-log ] each ; + +: log-server-loop ( -- ) + receive unclip { + { "log-message" [ (log-message) ] } + { "rotate-logs" [ drop (rotate-logs) ] } + { "close-logs" [ drop (close-logs) ] } + } case log-server-loop ; + +: log-server ( -- ) + [ + init-namespaces + [ log-server-loop ] + [ error. (close-logs) ] + recover t + ] + "Log server" spawn-server + "log-server" set-global ; + +[ + H{ } clone log-files set-global + log-server +] "logging" add-startup-hook diff --git a/basis/math/floats/env/env.factor b/basis/math/floats/env/env.factor index d3034b2adf..5016ef5d16 100644 --- a/basis/math/floats/env/env.factor +++ b/basis/math/floats/env/env.factor @@ -159,4 +159,3 @@ PRIVATE> { [ cpu ppc? ] [ "math.floats.env.ppc" require ] } [ "CPU architecture unsupported by math.floats.env" throw ] } cond >> - diff --git a/basis/math/floats/env/ppc/ppc.factor b/basis/math/floats/env/ppc/ppc.factor index eef8ae5365..a78a565204 100644 --- a/basis/math/floats/env/ppc/ppc.factor +++ b/basis/math/floats/env/ppc/ppc.factor @@ -146,4 +146,3 @@ M: ppc-vmx-env (set-denormal-mode) ( register mode -- register ) { +denormal-flush+ [ vmx-denormal-mode-bits bitor ] } } case ] curry change-vscr ; inline - diff --git a/basis/math/floats/half/half.factor b/basis/math/floats/half/half.factor index 711c69c517..d9c280a4e4 100644 --- a/basis/math/floats/half/half.factor +++ b/basis/math/floats/half/half.factor @@ -23,7 +23,7 @@ IN: math.floats.half dup zero? [ dup 0x7c00 >= [ 13 shift 0x7f800000 bitor ] [ 13 shift - 112 23 shift + + 112 23 shift + ] if ] unless ] bi bitor bits>float ; diff --git a/basis/math/polynomials/polynomials.factor b/basis/math/polynomials/polynomials.factor index cb0ef80130..9ce47d942a 100644 --- a/basis/math/polynomials/polynomials.factor +++ b/basis/math/polynomials/polynomials.factor @@ -99,4 +99,3 @@ MACRO: polyval* ( p -- ) [ rest [ \ * swap \ + [ ] 3sequence ] map ] [ first \ drop swap [ ] 2sequence ] bi prefix \ cleave [ ] 2sequence ; - diff --git a/basis/math/statistics/statistics.factor b/basis/math/statistics/statistics.factor index bf1abf7017..76e7373ca9 100644 --- a/basis/math/statistics/statistics.factor +++ b/basis/math/statistics/statistics.factor @@ -133,7 +133,7 @@ PRIVATE> } case ] each ; -: lower-median-index ( seq -- n ) +: lower-median-index ( seq -- n ) [ midpoint@ ] [ length odd? [ 1 - ] unless ] bi ; diff --git a/basis/math/vectors/conversion/conversion.factor b/basis/math/vectors/conversion/conversion.factor index 9d60dd03d4..2cc6bdb2b9 100644 --- a/basis/math/vectors/conversion/conversion.factor +++ b/basis/math/vectors/conversion/conversion.factor @@ -88,7 +88,7 @@ ERROR: bad-vconvert-input value expected-type ; :: [vunpack] ( from-element to-element from-size to-size from-type to-type -- quot ) to-size from-size /i log2 :> steps from-element to-element from-type to-type steps check-vunpack - from-type to-type [[vunpack]] ; + from-type to-type [[vunpack]] ; PRIVATE> @@ -96,7 +96,7 @@ MACRO:: vconvert ( from-type to-type -- ) from-type new [ simd-element-type ] [ byte-length ] bi :> ( from-element from-length ) to-type new [ simd-element-type ] [ byte-length ] bi :> ( to-element to-length ) from-element heap-size :> from-size - to-element heap-size :> to-size + to-element heap-size :> to-size from-length to-length = [ from-type to-type bad-vconvert ] unless @@ -105,4 +105,3 @@ MACRO:: vconvert ( from-type to-type -- ) { [ from-size to-size = ] [ [vconvert] ] } { [ from-size to-size > ] [ [vpack] ] } } cond ; - diff --git a/basis/math/vectors/simd/cords/cords-tests.factor b/basis/math/vectors/simd/cords/cords-tests.factor index eee11b396a..09725bd575 100644 --- a/basis/math/vectors/simd/cords/cords-tests.factor +++ b/basis/math/vectors/simd/cords/cords-tests.factor @@ -1,4 +1,4 @@ -USING: math.vectors.simd math.vectors.simd.cords tools.test ; -IN: math.vectors.simd.cords.tests - -[ float-4{ 1.0 2.0 3.0 4.0 } ] [ double-4{ 1.0 2.0 3.0 4.0 } >float-4 ] unit-test +USING: math.vectors.simd math.vectors.simd.cords tools.test ; +IN: math.vectors.simd.cords.tests + +[ float-4{ 1.0 2.0 3.0 4.0 } ] [ double-4{ 1.0 2.0 3.0 4.0 } >float-4 ] unit-test diff --git a/basis/memoize/syntax/syntax.factor b/basis/memoize/syntax/syntax.factor index 943f2c4f63..d95a2f79c7 100644 --- a/basis/memoize/syntax/syntax.factor +++ b/basis/memoize/syntax/syntax.factor @@ -3,4 +3,3 @@ USING: kernel memoize parser sequences stack-checker ; IN: memoize.syntax SYNTAX: MEMO[ parse-quotation dup infer memoize-quot suffix! ; - diff --git a/basis/mime/types/types.factor b/basis/mime/types/types.factor index 94398fbc0e..a9a6447019 100644 --- a/basis/mime/types/types.factor +++ b/basis/mime/types/types.factor @@ -47,4 +47,3 @@ MEMO: mime-types ( -- assoc ) : mime-type-encoding ( mime-type -- encoding ) "text/" head? utf8 binary ? ; - diff --git a/basis/models/arrow/arrow-docs.factor b/basis/models/arrow/arrow-docs.factor index 2dbcda036f..5acb7c6b58 100644 --- a/basis/models/arrow/arrow-docs.factor +++ b/basis/models/arrow/arrow-docs.factor @@ -1,29 +1,29 @@ -USING: help.syntax help.markup kernel math classes classes.tuple -calendar models ; -IN: models.arrow - -HELP: arrow -{ $class-description "Arrow model values are computed by applying a quotation to the value of another model. Arrows are automatically updated when the underlying model changes. Arrows are constructed by " { $link } "." } -{ $examples - "The following code displays a label showing the result of applying " { $link sq } " to the value 5:" - { $code - "USING: models ui.gadgets.labels ui.gadgets.panes ;" - "5 [ sq ] [ number>string ] " - " gadget." - } - "An exercise for the reader is to keep the original model around on the stack, and change its value to 6, observing that the label will immediately display 36." -} ; - -HELP: -{ $values { "model" model } { "quot" { $quotation ( obj -- newobj ) } } { "arrow" "a new " { $link arrow } } } -{ $description "Creates a new instance of " { $link arrow } ". The value of the new arrow model is computed by applying the quotation to the value." } -{ $examples "See the example in the documentation for " { $link arrow } "." } ; - -ARTICLE: "models.arrow" "Arrow models" -"Arrow model values are computed by applying a quotation to the value of another model." -{ $subsections - arrow - -} ; - -ABOUT: "models.arrow" +USING: help.syntax help.markup kernel math classes classes.tuple +calendar models ; +IN: models.arrow + +HELP: arrow +{ $class-description "Arrow model values are computed by applying a quotation to the value of another model. Arrows are automatically updated when the underlying model changes. Arrows are constructed by " { $link } "." } +{ $examples + "The following code displays a label showing the result of applying " { $link sq } " to the value 5:" + { $code + "USING: models ui.gadgets.labels ui.gadgets.panes ;" + "5 [ sq ] [ number>string ] " + " gadget." + } + "An exercise for the reader is to keep the original model around on the stack, and change its value to 6, observing that the label will immediately display 36." +} ; + +HELP: +{ $values { "model" model } { "quot" { $quotation ( obj -- newobj ) } } { "arrow" "a new " { $link arrow } } } +{ $description "Creates a new instance of " { $link arrow } ". The value of the new arrow model is computed by applying the quotation to the value." } +{ $examples "See the example in the documentation for " { $link arrow } "." } ; + +ARTICLE: "models.arrow" "Arrow models" +"Arrow model values are computed by applying a quotation to the value of another model." +{ $subsections + arrow + +} ; + +ABOUT: "models.arrow" diff --git a/basis/models/arrow/arrow-tests.factor b/basis/models/arrow/arrow-tests.factor index 6bd6395ac0..2cb9b6ee5a 100644 --- a/basis/models/arrow/arrow-tests.factor +++ b/basis/models/arrow/arrow-tests.factor @@ -1,23 +1,23 @@ -USING: arrays generic kernel math models namespaces sequences assocs -tools.test models.arrow accessors ; -IN: models.arrow.tests - -3 "x" set -"x" get [ 2 * ] dup "z" set -[ 1 + ] "y" set -[ ] [ "y" get activate-model ] unit-test -[ t ] [ "z" get "x" get connections>> member-eq? ] unit-test -[ 7 ] [ "y" get value>> ] unit-test -[ ] [ 4 "x" get set-model ] unit-test -[ 9 ] [ "y" get value>> ] unit-test -[ ] [ "y" get deactivate-model ] unit-test -[ f ] [ "z" get "x" get connections>> member-eq? ] unit-test - -3 "x" set -"x" get [ sq ] "y" set - -4 "x" get set-model - -"y" get activate-model -[ 16 ] [ "y" get value>> ] unit-test -"y" get deactivate-model +USING: arrays generic kernel math models namespaces sequences assocs +tools.test models.arrow accessors ; +IN: models.arrow.tests + +3 "x" set +"x" get [ 2 * ] dup "z" set +[ 1 + ] "y" set +[ ] [ "y" get activate-model ] unit-test +[ t ] [ "z" get "x" get connections>> member-eq? ] unit-test +[ 7 ] [ "y" get value>> ] unit-test +[ ] [ 4 "x" get set-model ] unit-test +[ 9 ] [ "y" get value>> ] unit-test +[ ] [ "y" get deactivate-model ] unit-test +[ f ] [ "z" get "x" get connections>> member-eq? ] unit-test + +3 "x" set +"x" get [ sq ] "y" set + +4 "x" get set-model + +"y" get activate-model +[ 16 ] [ "y" get value>> ] unit-test +"y" get deactivate-model diff --git a/basis/models/arrow/arrow.factor b/basis/models/arrow/arrow.factor index 2ed0e9fea0..24797a1cbf 100644 --- a/basis/models/arrow/arrow.factor +++ b/basis/models/arrow/arrow.factor @@ -1,18 +1,18 @@ -! Copyright (C) 2008, 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel models sequences ; -IN: models.arrow - -TUPLE: arrow < model quot ; - -: ( model quot -- arrow ) - f arrow new-model - swap >>quot - [ add-dependency ] keep ; - -M: arrow model-changed - [ [ value>> ] [ quot>> ] bi* call( old -- new ) ] - [ set-model ] bi ; - -M: arrow model-activated - [ dependencies>> ] keep [ model-changed ] curry each ; +! Copyright (C) 2008, 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel models sequences ; +IN: models.arrow + +TUPLE: arrow < model quot ; + +: ( model quot -- arrow ) + f arrow new-model + swap >>quot + [ add-dependency ] keep ; + +M: arrow model-changed + [ [ value>> ] [ quot>> ] bi* call( old -- new ) ] + [ set-model ] bi ; + +M: arrow model-activated + [ dependencies>> ] keep [ model-changed ] curry each ; diff --git a/basis/models/arrow/smart/smart.factor b/basis/models/arrow/smart/smart.factor index 3398183edb..c14d2039db 100644 --- a/basis/models/arrow/smart/smart.factor +++ b/basis/models/arrow/smart/smart.factor @@ -7,4 +7,4 @@ IN: models.arrow.smart MACRO: ( quot -- quot' ) [ inputs dup ] keep - '[ _ narray [ _ firstn @ ] ] ; \ No newline at end of file + '[ _ narray [ _ firstn @ ] ] ; diff --git a/basis/models/delay/delay-docs.factor b/basis/models/delay/delay-docs.factor index d8be7560ab..0e2d94be31 100644 --- a/basis/models/delay/delay-docs.factor +++ b/basis/models/delay/delay-docs.factor @@ -1,38 +1,38 @@ -USING: help.syntax help.markup kernel math classes classes.tuple -calendar models ; -IN: models.delay - -HELP: delay -{ $class-description "Delay models have the same value as their underlying model, however the value only changes after a timer expires. If the underlying model's value changes again before the timer expires, the timer restarts. Delay models are constructed by " { $link } "." } -{ $examples - "The following code displays a sliders and a label which is updated half a second after the slider stops changing:" - { $code - "USING: models models.delay models.arrow models.range" - "ui ui.gadgets ui.gadgets.labels ui.gadgets.sliders" - "ui.gadgets.panes math.parser calendar ;" - "" - "" - "0 10 0 100 1 " - "[ horizontal add-gadget ]" - "[" - " 1/2 seconds " - " [ unparse ] " - " add-gadget" - "] bi" - "\"Test\" open-window" - } -} ; - -HELP: -{ $values { "model" model } { "timeout" duration } { "delay" delay } } -{ $description "Creates a new instance of " { $link delay } ". The timeout must elapse from the time the underlying model last changed to when the delay model value is changed and its connections are notified." } -{ $examples "See the example in the documentation for " { $link delay } "." } ; - -ARTICLE: "models-delay" "Delay models" -"Delay models are used to implement delayed updating of gadgets in response to user input." -{ $subsections - delay - -} ; - -ABOUT: "models-delay" +USING: help.syntax help.markup kernel math classes classes.tuple +calendar models ; +IN: models.delay + +HELP: delay +{ $class-description "Delay models have the same value as their underlying model, however the value only changes after a timer expires. If the underlying model's value changes again before the timer expires, the timer restarts. Delay models are constructed by " { $link } "." } +{ $examples + "The following code displays a sliders and a label which is updated half a second after the slider stops changing:" + { $code + "USING: models models.delay models.arrow models.range" + "ui ui.gadgets ui.gadgets.labels ui.gadgets.sliders" + "ui.gadgets.panes math.parser calendar ;" + "" + "" + "0 10 0 100 1 " + "[ horizontal add-gadget ]" + "[" + " 1/2 seconds " + " [ unparse ] " + " add-gadget" + "] bi" + "\"Test\" open-window" + } +} ; + +HELP: +{ $values { "model" model } { "timeout" duration } { "delay" delay } } +{ $description "Creates a new instance of " { $link delay } ". The timeout must elapse from the time the underlying model last changed to when the delay model value is changed and its connections are notified." } +{ $examples "See the example in the documentation for " { $link delay } "." } ; + +ARTICLE: "models-delay" "Delay models" +"Delay models are used to implement delayed updating of gadgets in response to user input." +{ $subsections + delay + +} ; + +ABOUT: "models-delay" diff --git a/basis/models/delay/delay.factor b/basis/models/delay/delay.factor index b7c9e7e8ed..bb5dc24a5c 100644 --- a/basis/models/delay/delay.factor +++ b/basis/models/delay/delay.factor @@ -1,27 +1,27 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors fry kernel models timers ; -IN: models.delay - -TUPLE: delay < model model timeout timer ; - -: update-delay-model ( delay -- ) - [ model>> value>> ] keep set-model ; - -: ( model timeout -- delay ) - f delay new-model - swap >>timeout - over >>model - [ add-dependency ] keep ; - -: stop-delay ( delay -- ) - timer>> [ stop-timer ] when* ; - -: start-delay ( delay -- ) - [ '[ _ f >>timer update-delay-model ] ] - [ timeout>> later ] - [ timer<< ] tri ; - -M: delay model-changed nip dup stop-delay start-delay ; - -M: delay model-activated update-delay-model ; +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors fry kernel models timers ; +IN: models.delay + +TUPLE: delay < model model timeout timer ; + +: update-delay-model ( delay -- ) + [ model>> value>> ] keep set-model ; + +: ( model timeout -- delay ) + f delay new-model + swap >>timeout + over >>model + [ add-dependency ] keep ; + +: stop-delay ( delay -- ) + timer>> [ stop-timer ] when* ; + +: start-delay ( delay -- ) + [ '[ _ f >>timer update-delay-model ] ] + [ timeout>> later ] + [ timer<< ] tri ; + +M: delay model-changed nip dup stop-delay start-delay ; + +M: delay model-activated update-delay-model ; diff --git a/basis/models/mapping/mapping-tests.factor b/basis/models/mapping/mapping-tests.factor index eeae10ae2a..710ff4e086 100644 --- a/basis/models/mapping/mapping-tests.factor +++ b/basis/models/mapping/mapping-tests.factor @@ -1,34 +1,34 @@ -USING: arrays generic kernel math models namespaces sequences assocs -tools.test models.mapping accessors make ; -IN: models.mapping.tests - -! Test mapping -[ ] [ - [ - 1 "one" ,, - 2 "two" ,, - ] H{ } make - "m" set -] unit-test - -[ ] [ "m" get activate-model ] unit-test - -[ H{ { "one" 1 } { "two" 2 } } ] [ - "m" get value>> -] unit-test - -[ ] [ - H{ { "one" 3 } { "two" 4 } } - "m" get set-model -] unit-test - -[ H{ { "one" 3 } { "two" 4 } } ] [ - "m" get value>> -] unit-test - -[ H{ { "one" 5 } { "two" 4 } } ] [ - 5 "one" "m" get assoc>> at set-model - "m" get value>> -] unit-test - -[ ] [ "m" get deactivate-model ] unit-test +USING: arrays generic kernel math models namespaces sequences assocs +tools.test models.mapping accessors make ; +IN: models.mapping.tests + +! Test mapping +[ ] [ + [ + 1 "one" ,, + 2 "two" ,, + ] H{ } make + "m" set +] unit-test + +[ ] [ "m" get activate-model ] unit-test + +[ H{ { "one" 1 } { "two" 2 } } ] [ + "m" get value>> +] unit-test + +[ ] [ + H{ { "one" 3 } { "two" 4 } } + "m" get set-model +] unit-test + +[ H{ { "one" 3 } { "two" 4 } } ] [ + "m" get value>> +] unit-test + +[ H{ { "one" 5 } { "two" 4 } } ] [ + 5 "one" "m" get assoc>> at set-model + "m" get value>> +] unit-test + +[ ] [ "m" get deactivate-model ] unit-test diff --git a/basis/models/mapping/mapping.factor b/basis/models/mapping/mapping.factor index c401714dd4..0afa9c66de 100644 --- a/basis/models/mapping/mapping.factor +++ b/basis/models/mapping/mapping.factor @@ -1,21 +1,21 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors models kernel assocs ; -IN: models.mapping - -TUPLE: mapping < model assoc ; - -: ( models -- mapping ) - f mapping new-model - over values >>dependencies - swap >>assoc ; - -M: mapping model-changed - nip [ assoc>> [ value>> ] assoc-map ] keep set-model ; - -M: mapping model-activated - dup model-changed ; - -M: mapping update-model - [ value>> ] [ assoc>> ] bi - [ swapd at set-model ] curry assoc-each ; +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors models kernel assocs ; +IN: models.mapping + +TUPLE: mapping < model assoc ; + +: ( models -- mapping ) + f mapping new-model + over values >>dependencies + swap >>assoc ; + +M: mapping model-changed + nip [ assoc>> [ value>> ] assoc-map ] keep set-model ; + +M: mapping model-activated + dup model-changed ; + +M: mapping update-model + [ value>> ] [ assoc>> ] bi + [ swapd at set-model ] curry assoc-each ; diff --git a/basis/models/models.factor b/basis/models/models.factor index 149a97ff59..2f051a1a5d 100644 --- a/basis/models/models.factor +++ b/basis/models/models.factor @@ -120,4 +120,3 @@ GENERIC: set-range-max-value ( value model -- ) : pop-model ( model -- value ) [ pop ] change-model* ; - diff --git a/basis/models/product/product-docs.factor b/basis/models/product/product-docs.factor index 29b26159a7..18a4bc5092 100644 --- a/basis/models/product/product-docs.factor +++ b/basis/models/product/product-docs.factor @@ -1,38 +1,38 @@ -USING: help.syntax help.markup kernel math classes classes.tuple -calendar models ; -IN: models.product - -HELP: product -{ $class-description "Product model values are computed by collecting the values from a sequence of underlying models into a new sequence. Product models are automatically updated when underlying models change. Product models are constructed by " { $link } "." -$nl -"A product model whose children are all " { $link "models-range" } " conforms to the " { $link "range-model-protocol" } " and represents a point in n-dimensional space which is bounded by a rectangle." } -{ $examples - "The following code displays a pair of sliders, and an updating label showing their current values:" - { $code - "USING: models models.product models.range ui.gadgets" - "ui.gadgets.labels ui.gadgets.packs ui.gadgets.panes" - "ui.gadgets.sliders ;" - "" - ": ( -- model ) 0 10 0 100 1 ;" - ": ( model -- slider ) horizontal ;" - "" - " 2array" - "[ [ horizontal add-gadget ] reduce gadget. ]" - "[ [ unparse ] gadget. ]" - "bi" - } -} ; - -HELP: -{ $values { "models" "a sequence of models" } { "product" "a new " { $link product } } } -{ $description "Creates a new instance of " { $link product } ". The value of the new product model is obtained by mapping the " { $snippet "value" } " slot accessor over the given sequence of models." } -{ $examples "See the example in the documentation for " { $link product } "." } ; - -ARTICLE: "models.product" "Product models" -"Product model values are computed by collecting the values from a sequence of underlying models into a new sequence." -{ $subsections - product - -} ; - -ABOUT: "models.product" +USING: help.syntax help.markup kernel math classes classes.tuple +calendar models ; +IN: models.product + +HELP: product +{ $class-description "Product model values are computed by collecting the values from a sequence of underlying models into a new sequence. Product models are automatically updated when underlying models change. Product models are constructed by " { $link } "." +$nl +"A product model whose children are all " { $link "models-range" } " conforms to the " { $link "range-model-protocol" } " and represents a point in n-dimensional space which is bounded by a rectangle." } +{ $examples + "The following code displays a pair of sliders, and an updating label showing their current values:" + { $code + "USING: models models.product models.range ui.gadgets" + "ui.gadgets.labels ui.gadgets.packs ui.gadgets.panes" + "ui.gadgets.sliders ;" + "" + ": ( -- model ) 0 10 0 100 1 ;" + ": ( model -- slider ) horizontal ;" + "" + " 2array" + "[ [ horizontal add-gadget ] reduce gadget. ]" + "[ [ unparse ] gadget. ]" + "bi" + } +} ; + +HELP: +{ $values { "models" "a sequence of models" } { "product" "a new " { $link product } } } +{ $description "Creates a new instance of " { $link product } ". The value of the new product model is obtained by mapping the " { $snippet "value" } " slot accessor over the given sequence of models." } +{ $examples "See the example in the documentation for " { $link product } "." } ; + +ARTICLE: "models.product" "Product models" +"Product model values are computed by collecting the values from a sequence of underlying models into a new sequence." +{ $subsections + product + +} ; + +ABOUT: "models.product" diff --git a/basis/models/product/product-tests.factor b/basis/models/product/product-tests.factor index c26866e83b..29ee202350 100644 --- a/basis/models/product/product-tests.factor +++ b/basis/models/product/product-tests.factor @@ -1,46 +1,46 @@ -USING: arrays generic kernel math models namespaces sequences assocs -tools.test models.product accessors locals ; -IN: models.product.tests - -[ ] [ - 1 "a" set - 2 "b" set - "a" get "b" get 2array "c" set -] unit-test - -[ ] [ "c" get activate-model ] unit-test - -[ { 1 2 } ] [ "c" get value>> ] unit-test - -[ ] [ 3 "b" get set-model ] unit-test - -[ { 1 3 } ] [ "c" get value>> ] unit-test - -[ ] [ { 4 5 } "c" get set-model ] unit-test - -[ { 4 5 } ] [ "c" get value>> ] unit-test - -[ ] [ "c" get deactivate-model ] unit-test - -TUPLE: an-observer { i integer } ; - -M: an-observer model-changed nip [ 1 + ] change-i drop ; - -[ 1 0 ] [ - [let - 1 :> m1 - 2 :> m2 - { m1 m2 } :> c - an-observer new :> o1 - an-observer new :> o2 - - o1 m1 add-connection - o2 m2 add-connection - - c activate-model - - "OH HAI" m1 set-model - o1 i>> - o2 i>> - ] -] unit-test +USING: arrays generic kernel math models namespaces sequences assocs +tools.test models.product accessors locals ; +IN: models.product.tests + +[ ] [ + 1 "a" set + 2 "b" set + "a" get "b" get 2array "c" set +] unit-test + +[ ] [ "c" get activate-model ] unit-test + +[ { 1 2 } ] [ "c" get value>> ] unit-test + +[ ] [ 3 "b" get set-model ] unit-test + +[ { 1 3 } ] [ "c" get value>> ] unit-test + +[ ] [ { 4 5 } "c" get set-model ] unit-test + +[ { 4 5 } ] [ "c" get value>> ] unit-test + +[ ] [ "c" get deactivate-model ] unit-test + +TUPLE: an-observer { i integer } ; + +M: an-observer model-changed nip [ 1 + ] change-i drop ; + +[ 1 0 ] [ + [let + 1 :> m1 + 2 :> m2 + { m1 m2 } :> c + an-observer new :> o1 + an-observer new :> o2 + + o1 m1 add-connection + o2 m2 add-connection + + c activate-model + + "OH HAI" m1 set-model + o1 i>> + o2 i>> + ] +] unit-test diff --git a/basis/models/product/product.factor b/basis/models/product/product.factor index 04e06cb55a..34be54368b 100644 --- a/basis/models/product/product.factor +++ b/basis/models/product/product.factor @@ -1,57 +1,57 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel models sequences ; -IN: models.product - -TUPLE: product < model ; - -: new-product ( models class -- product ) - f swap new-model - swap clone >>dependencies ; inline - -: ( models -- product ) - product new-product ; - -: product-value ( model quot -- seq ) - [ dependencies>> ] dip map ; inline - -: set-product-value ( seq model quot -- ) - [ dependencies>> ] dip 2each ; inline - -M: product model-changed - nip - dup [ value>> ] product-value >>value - notify-connections ; - -M: product model-activated dup model-changed ; - -M: product update-model - [ value>> ] keep [ set-model ] set-product-value ; - -M: product range-value - [ range-value ] product-value ; - -M: product range-page-value - [ range-page-value ] product-value ; - -M: product range-min-value - [ range-min-value ] product-value ; - -M: product range-max-value - [ range-max-value ] product-value ; - -M: product range-max-value* - [ range-max-value* ] product-value ; - -M: product set-range-value - [ clamp-value ] keep - [ set-range-value ] set-product-value ; - -M: product set-range-page-value - [ set-range-page-value ] set-product-value ; - -M: product set-range-min-value - [ set-range-min-value ] set-product-value ; - -M: product set-range-max-value - [ set-range-max-value ] set-product-value ; +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel models sequences ; +IN: models.product + +TUPLE: product < model ; + +: new-product ( models class -- product ) + f swap new-model + swap clone >>dependencies ; inline + +: ( models -- product ) + product new-product ; + +: product-value ( model quot -- seq ) + [ dependencies>> ] dip map ; inline + +: set-product-value ( seq model quot -- ) + [ dependencies>> ] dip 2each ; inline + +M: product model-changed + nip + dup [ value>> ] product-value >>value + notify-connections ; + +M: product model-activated dup model-changed ; + +M: product update-model + [ value>> ] keep [ set-model ] set-product-value ; + +M: product range-value + [ range-value ] product-value ; + +M: product range-page-value + [ range-page-value ] product-value ; + +M: product range-min-value + [ range-min-value ] product-value ; + +M: product range-max-value + [ range-max-value ] product-value ; + +M: product range-max-value* + [ range-max-value* ] product-value ; + +M: product set-range-value + [ clamp-value ] keep + [ set-range-value ] set-product-value ; + +M: product set-range-page-value + [ set-range-page-value ] set-product-value ; + +M: product set-range-min-value + [ set-range-min-value ] set-product-value ; + +M: product set-range-max-value + [ set-range-max-value ] set-product-value ; diff --git a/basis/models/range/range-docs.factor b/basis/models/range/range-docs.factor index 7e205157f2..dc3cc35e87 100644 --- a/basis/models/range/range-docs.factor +++ b/basis/models/range/range-docs.factor @@ -1,66 +1,66 @@ -USING: help.syntax help.markup kernel math classes classes.tuple -calendar models ; -IN: models.range - -HELP: range -{ $class-description "Range models implement the " { $link "range-model-protocol" } " with real numbers as the minimum, current, maximum, and page size. Range models are created with " { $link } "." } -{ $notes { $link "ui.gadgets.sliders" } " use range models." } ; - -HELP: -{ $values { "value" real } { "page" real } { "min" real } { "max" real } { "step" real } { "range" range } } -{ $description "Creates a new " { $link range } " model." } ; - -HELP: range-model -{ $values { "range" range } { "model" model } } -{ $description "Outputs a model holding a range model's current value." } -{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ; - -HELP: range-min -{ $values { "range" range } { "model" model } } -{ $description "Outputs a model holding a range model's minimum value." } -{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ; - -HELP: range-max -{ $values { "range" range } { "model" model } } -{ $description "Outputs a model holding a range model's maximum value." } -{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ; - -HELP: range-page -{ $values { "range" range } { "model" model } } -{ $description "Outputs a model holding a range model's page size." } -{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ; - -HELP: move-by -{ $values { "amount" real } { "range" range } } -{ $description "Adds a number to a range model's current value." } -{ $side-effects "range" } ; - -HELP: move-by-page -{ $values { "amount" real } { "range" range } } -{ $description "Adds a multiple of the page size to a range model's current value." } -{ $side-effects "range" } ; - -ARTICLE: "models-range" "Range models" -"Range models ensure their value is a real number within a fixed range." -{ $subsections - range - -} -"Range models conform to a protocol for getting and setting the current value, as well as the endpoints of the range." -{ $subsections "range-model-protocol" } ; - -ARTICLE: "range-model-protocol" "Range model protocol" -"The range model protocol is implemented by the " { $link range } " and " { $link compose } " classes. User-defined models may implement it too." -{ $subsections - range-value - range-page-value - range-min-value - range-max-value - range-max-value* - set-range-value - set-range-page-value - set-range-min-value - set-range-max-value -} ; - -ABOUT: "models-range" +USING: help.syntax help.markup kernel math classes classes.tuple +calendar models ; +IN: models.range + +HELP: range +{ $class-description "Range models implement the " { $link "range-model-protocol" } " with real numbers as the minimum, current, maximum, and page size. Range models are created with " { $link } "." } +{ $notes { $link "ui.gadgets.sliders" } " use range models." } ; + +HELP: +{ $values { "value" real } { "page" real } { "min" real } { "max" real } { "step" real } { "range" range } } +{ $description "Creates a new " { $link range } " model." } ; + +HELP: range-model +{ $values { "range" range } { "model" model } } +{ $description "Outputs a model holding a range model's current value." } +{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ; + +HELP: range-min +{ $values { "range" range } { "model" model } } +{ $description "Outputs a model holding a range model's minimum value." } +{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ; + +HELP: range-max +{ $values { "range" range } { "model" model } } +{ $description "Outputs a model holding a range model's maximum value." } +{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ; + +HELP: range-page +{ $values { "range" range } { "model" model } } +{ $description "Outputs a model holding a range model's page size." } +{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ; + +HELP: move-by +{ $values { "amount" real } { "range" range } } +{ $description "Adds a number to a range model's current value." } +{ $side-effects "range" } ; + +HELP: move-by-page +{ $values { "amount" real } { "range" range } } +{ $description "Adds a multiple of the page size to a range model's current value." } +{ $side-effects "range" } ; + +ARTICLE: "models-range" "Range models" +"Range models ensure their value is a real number within a fixed range." +{ $subsections + range + +} +"Range models conform to a protocol for getting and setting the current value, as well as the endpoints of the range." +{ $subsections "range-model-protocol" } ; + +ARTICLE: "range-model-protocol" "Range model protocol" +"The range model protocol is implemented by the " { $link range } " and " { $link compose } " classes. User-defined models may implement it too." +{ $subsections + range-value + range-page-value + range-min-value + range-max-value + range-max-value* + set-range-value + set-range-page-value + set-range-min-value + set-range-max-value +} ; + +ABOUT: "models-range" diff --git a/basis/models/range/range-tests.factor b/basis/models/range/range-tests.factor index 51f8b06ef5..16a6b8f9bd 100644 --- a/basis/models/range/range-tests.factor +++ b/basis/models/range/range-tests.factor @@ -1,40 +1,40 @@ -IN: models.range.tests -USING: arrays generic kernel math models namespaces sequences assocs -tools.test models.range ; - -! Test -: setup-range ( -- range ) 0 0 0 255 1 ; -: setup-stepped-range ( -- range ) 0 0 0 255 2 ; - -! clamp-value should not go past range ends -[ 0 ] [ -10 setup-range clamp-value ] unit-test -[ 255 ] [ 2000 setup-range clamp-value ] unit-test -[ 14 ] [ 14 setup-range clamp-value ] unit-test - -! step-value -[ 14 ] [ 15 setup-stepped-range step-value ] unit-test - -! range min/max/page values should be correct -[ 0 ] [ setup-range range-page-value ] unit-test -[ 0 ] [ setup-range range-min-value ] unit-test -[ 255 ] [ setup-range range-max-value ] unit-test - -! should be able to set the value within the range and get back -[ 15 ] [ setup-range 15 over set-range-value range-value ] unit-test -[ 0 ] [ setup-range -15 over set-range-value range-value ] unit-test -[ 255 ] [ setup-range 4000 over set-range-value range-value ] unit-test - -! should be able to change the range min/max/page value -[ 1 ] [ setup-range 1 over set-range-page-value range-page-value ] unit-test -[ 50 ] [ setup-range 50 over set-range-min-value range-min-value ] unit-test -[ 4000 ] [ setup-range 4000 over set-range-max-value range-max-value ] unit-test - -! should be able to move by positive and negative values -[ 30 ] [ setup-range 30 over move-by range-value ] unit-test -[ 0 ] [ setup-range 30 over move-by -30 over move-by range-value ] unit-test - -! should be able to move by a page of 10 -[ 10 ] [ - setup-range 10 over set-range-page-value - 1 over move-by-page range-value -] unit-test +IN: models.range.tests +USING: arrays generic kernel math models namespaces sequences assocs +tools.test models.range ; + +! Test +: setup-range ( -- range ) 0 0 0 255 1 ; +: setup-stepped-range ( -- range ) 0 0 0 255 2 ; + +! clamp-value should not go past range ends +[ 0 ] [ -10 setup-range clamp-value ] unit-test +[ 255 ] [ 2000 setup-range clamp-value ] unit-test +[ 14 ] [ 14 setup-range clamp-value ] unit-test + +! step-value +[ 14 ] [ 15 setup-stepped-range step-value ] unit-test + +! range min/max/page values should be correct +[ 0 ] [ setup-range range-page-value ] unit-test +[ 0 ] [ setup-range range-min-value ] unit-test +[ 255 ] [ setup-range range-max-value ] unit-test + +! should be able to set the value within the range and get back +[ 15 ] [ setup-range 15 over set-range-value range-value ] unit-test +[ 0 ] [ setup-range -15 over set-range-value range-value ] unit-test +[ 255 ] [ setup-range 4000 over set-range-value range-value ] unit-test + +! should be able to change the range min/max/page value +[ 1 ] [ setup-range 1 over set-range-page-value range-page-value ] unit-test +[ 50 ] [ setup-range 50 over set-range-min-value range-min-value ] unit-test +[ 4000 ] [ setup-range 4000 over set-range-max-value range-max-value ] unit-test + +! should be able to move by positive and negative values +[ 30 ] [ setup-range 30 over move-by range-value ] unit-test +[ 0 ] [ setup-range 30 over move-by -30 over move-by range-value ] unit-test + +! should be able to move by a page of 10 +[ 10 ] [ + setup-range 10 over set-range-page-value + 1 over move-by-page range-value +] unit-test diff --git a/basis/models/range/range.factor b/basis/models/range/range.factor index 9a4584a9a2..4039124c40 100644 --- a/basis/models/range/range.factor +++ b/basis/models/range/range.factor @@ -1,48 +1,48 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel models arrays sequences math math.order -models.product generalizations sequences.generalizations -math.functions ; -FROM: models.product => product ; -IN: models.range - -TUPLE: range < product ; - -: ( value page min max step -- range ) - 5 narray [ ] map range new-product ; - -: range-model ( range -- model ) dependencies>> first ; -: range-page ( range -- model ) dependencies>> second ; -: range-min ( range -- model ) dependencies>> third ; -: range-max ( range -- model ) dependencies>> fourth ; -: range-step ( range -- model ) dependencies>> 4 swap nth ; - -: step-value ( value range -- value' ) - range-step value>> floor-to ; - -M: range range-value - [ range-model value>> ] [ clamp-value ] [ step-value ] tri ; - -M: range range-page-value range-page value>> ; - -M: range range-min-value range-min value>> ; - -M: range range-max-value range-max value>> ; - -M: range range-max-value* - [ range-max-value ] [ range-page-value ] bi [-] ; - -M: range set-range-value - [ clamp-value ] [ range-model ] bi set-model ; - -M: range set-range-page-value range-page set-model ; - -M: range set-range-min-value range-min set-model ; - -M: range set-range-max-value range-max set-model ; - -: move-by ( amount range -- ) - [ range-value + ] keep set-range-value ; - -: move-by-page ( amount range -- ) - [ range-page-value * ] keep move-by ; +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel models arrays sequences math math.order +models.product generalizations sequences.generalizations +math.functions ; +FROM: models.product => product ; +IN: models.range + +TUPLE: range < product ; + +: ( value page min max step -- range ) + 5 narray [ ] map range new-product ; + +: range-model ( range -- model ) dependencies>> first ; +: range-page ( range -- model ) dependencies>> second ; +: range-min ( range -- model ) dependencies>> third ; +: range-max ( range -- model ) dependencies>> fourth ; +: range-step ( range -- model ) dependencies>> 4 swap nth ; + +: step-value ( value range -- value' ) + range-step value>> floor-to ; + +M: range range-value + [ range-model value>> ] [ clamp-value ] [ step-value ] tri ; + +M: range range-page-value range-page value>> ; + +M: range range-min-value range-min value>> ; + +M: range range-max-value range-max value>> ; + +M: range range-max-value* + [ range-max-value ] [ range-page-value ] bi [-] ; + +M: range set-range-value + [ clamp-value ] [ range-model ] bi set-model ; + +M: range set-range-page-value range-page set-model ; + +M: range set-range-min-value range-min set-model ; + +M: range set-range-max-value range-max set-model ; + +: move-by ( amount range -- ) + [ range-value + ] keep set-range-value ; + +: move-by-page ( amount range -- ) + [ range-page-value * ] keep move-by ; diff --git a/basis/models/sort/sort.factor b/basis/models/sort/sort.factor index efd2e4927b..5eeeae7c4c 100644 --- a/basis/models/sort/sort.factor +++ b/basis/models/sort/sort.factor @@ -4,4 +4,4 @@ USING: sorting models.arrow.smart fry ; IN: models.sort : ( values sort -- model ) - [ '[ _ call( obj1 obj2 -- <=> ) ] sort ] ; inline \ No newline at end of file + [ '[ _ call( obj1 obj2 -- <=> ) ] sort ] ; inline diff --git a/basis/opengl/debug/debug.factor b/basis/opengl/debug/debug.factor index 0662a9c08a..945a8b8106 100644 --- a/basis/opengl/debug/debug.factor +++ b/basis/opengl/debug/debug.factor @@ -20,4 +20,3 @@ SYMBOL: G-world SYNTAX: GB \ gl-break suffix! ; - diff --git a/basis/opengl/framebuffers/framebuffers.factor b/basis/opengl/framebuffers/framebuffers.factor index 5d28d1852c..3eb3705d0c 100644 --- a/basis/opengl/framebuffers/framebuffers.factor +++ b/basis/opengl/framebuffers/framebuffers.factor @@ -19,7 +19,7 @@ IN: opengl.framebuffers dup GL_FRAMEBUFFER_COMPLETE = f rot ? ; : framebuffer-error ( status -- * ) - { + { { GL_FRAMEBUFFER_COMPLETE [ "framebuffer complete" ] } { GL_FRAMEBUFFER_UNSUPPORTED [ "framebuffer configuration unsupported" ] } { GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT [ "framebuffer incomplete (incomplete attachment)" ] } @@ -44,7 +44,7 @@ IN: opengl.framebuffers [ GL_DRAW_FRAMEBUFFER swap glBindFramebuffer ] [ GL_READ_FRAMEBUFFER swap glBindFramebuffer ] bi* ] dip - [ + [ GL_DRAW_FRAMEBUFFER 0 glBindFramebuffer GL_READ_FRAMEBUFFER 0 glBindFramebuffer ] [ ] cleanup ; inline diff --git a/basis/opengl/gl/extensions/extensions.factor b/basis/opengl/gl/extensions/extensions.factor index f4165d7e20..180344de31 100644 --- a/basis/opengl/gl/extensions/extensions.factor +++ b/basis/opengl/gl/extensions/extensions.factor @@ -18,7 +18,7 @@ SYMBOL: +gl-function-pointers+ 0 +gl-function-counter+ set-global ; : reset-gl-function-pointers ( -- ) 100 +gl-function-pointers+ set-global ; - + [ reset-gl-function-pointers ] "opengl.gl" add-startup-hook reset-gl-function-pointers reset-gl-function-number-counter diff --git a/basis/opengl/gl/gl.factor b/basis/opengl/gl/gl.factor index 4ceb0ebc98..b59280e7cd 100644 --- a/basis/opengl/gl/gl.factor +++ b/basis/opengl/gl/gl.factor @@ -663,7 +663,7 @@ FUNCTION: void glReadBuffer ( GLenum mode ) ; FUNCTION: void glEnable ( GLenum cap ) ; FUNCTION: void glDisable ( GLenum cap ) ; FUNCTION: GLboolean glIsEnabled ( GLenum cap ) ; - + FUNCTION: void glEnableClientState ( GLenum cap ) ; FUNCTION: void glDisableClientState ( GLenum cap ) ; FUNCTION: void glGetBooleanv ( GLenum pname, GLboolean* params ) ; @@ -693,9 +693,9 @@ FUNCTION: void glClearAccum ( GLfloat red, GLfloat green, GLfloat blue, GLfloat FUNCTION: void glAccum ( GLenum op, GLfloat value ) ; FUNCTION: void glMatrixMode ( GLenum mode ) ; -FUNCTION: void glOrtho ( GLdouble left, GLdouble right, GLdouble bottom, GLdouble top, +FUNCTION: void glOrtho ( GLdouble left, GLdouble right, GLdouble bottom, GLdouble top, GLdouble near_val, GLdouble far_val ) ; -FUNCTION: void glFrustum ( GLdouble left, GLdouble right, GLdouble bottom, GLdouble top, +FUNCTION: void glFrustum ( GLdouble left, GLdouble right, GLdouble bottom, GLdouble top, GLdouble near_val, GLdouble far_val ) ; FUNCTION: void glViewport ( GLint x, GLint y, GLsizei width, GLsizei height ) ; FUNCTION: void glPushMatrix ( ) ; @@ -963,13 +963,13 @@ FUNCTION: void glGetPixelMapfv ( GLenum map, GLfloat* values ) ; FUNCTION: void glGetPixelMapuiv ( GLenum map, GLuint* values ) ; FUNCTION: void glGetPixelMapusv ( GLenum map, GLushort* values ) ; -FUNCTION: void glBitmap ( GLsizei width, GLsizei height, GLfloat xorig, GLfloat yorig, +FUNCTION: void glBitmap ( GLsizei width, GLsizei height, GLfloat xorig, GLfloat yorig, GLfloat xmove, GLfloat ymove, GLubyte* bitmap ) ; -FUNCTION: void glReadPixels ( GLint x, GLint y, GLsizei width, GLsizei height, +FUNCTION: void glReadPixels ( GLint x, GLint y, GLsizei width, GLsizei height, GLenum format, GLenum type, GLvoid* pixels ) ; -FUNCTION: void glDrawPixels ( GLsizei width, GLsizei height, GLenum format, +FUNCTION: void glDrawPixels ( GLsizei width, GLsizei height, GLenum format, GLenum type, GLvoid* pixels ) ; FUNCTION: void glCopyPixels ( GLint x, GLint y, GLsizei width, GLsizei height, GLenum type ) ; @@ -1011,7 +1011,7 @@ FUNCTION: void glTexParameteriv ( GLenum target, GLenum pname, GLint* params ) ; FUNCTION: void glGetTexParameterfv ( GLenum target, GLenum pname, GLfloat* params ) ; FUNCTION: void glGetTexParameteriv ( GLenum target, GLenum pname, GLint* params ) ; -FUNCTION: void glGetTexLevelParameterfv ( GLenum target, GLint level, +FUNCTION: void glGetTexLevelParameterfv ( GLenum target, GLint level, GLenum pname, GLfloat* params ) ; FUNCTION: void glGetTexLevelParameteriv ( GLenum target, GLint level, GLenum pname, GLint* params ) ; @@ -1019,11 +1019,11 @@ FUNCTION: void glGetTexLevelParameteriv ( GLenum target, GLint level, FUNCTION: void glTexImage1D ( GLenum target, GLint level, GLint internalFormat, GLsizei width, GLint border, GLenum format, GLenum type, GLvoid* pixels ) ; -FUNCTION: void glTexImage2D ( GLenum target, GLint level, GLint internalFormat, - GLsizei width, GLsizei height, GLint border, +FUNCTION: void glTexImage2D ( GLenum target, GLint level, GLint internalFormat, + GLsizei width, GLsizei height, GLint border, GLenum format, GLenum type, GLvoid* pixels ) ; -FUNCTION: void glGetTexImage ( GLenum target, GLint level, GLenum format, +FUNCTION: void glGetTexImage ( GLenum target, GLint level, GLenum format, GLenum type, GLvoid* pixels ) ; @@ -1045,17 +1045,17 @@ FUNCTION: void glTexSubImage1D ( GLenum target, GLint level, GLint xoffset, GLsi GLenum format, GLenum type, GLvoid* pixels ) ; FUNCTION: void glTexSubImage2D ( GLenum target, GLint level, GLint xoffset, GLint yoffset, - GLsizei width, GLsizei height, GLenum format, + GLsizei width, GLsizei height, GLenum format, GLenum type, GLvoid* pixels ) ; -FUNCTION: void glCopyTexImage1D ( GLenum target, GLint level, GLenum internalformat, +FUNCTION: void glCopyTexImage1D ( GLenum target, GLint level, GLenum internalformat, GLint x, GLint y, GLsizei width, GLint border ) ; -FUNCTION: void glCopyTexImage2D ( GLenum target, GLint level, GLenum internalformat, +FUNCTION: void glCopyTexImage2D ( GLenum target, GLint level, GLenum internalformat, GLint x, GLint y, GLsizei width, GLsizei height, GLint border ) ; -FUNCTION: void glCopyTexSubImage1D ( GLenum target, GLint level, GLint xoffset, +FUNCTION: void glCopyTexSubImage1D ( GLenum target, GLint level, GLint xoffset, GLint x, GLint y, GLsizei width ) ; FUNCTION: void glCopyTexSubImage2D ( GLenum target, GLint level, GLint xoffset, GLint yoffset, @@ -2023,7 +2023,7 @@ GL-FUNCTION: void glFramebufferTexture1D { glFramebufferTexture1DEXT } ( GLenum GL-FUNCTION: void glFramebufferTexture2D { glFramebufferTexture2DEXT } ( GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level ) ; GL-FUNCTION: void glFramebufferTexture3D { glFramebufferTexture3DEXT } ( GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level, GLint zoffset ) ; GL-FUNCTION: void glFramebufferTextureLayer { glFramebufferTextureLayerEXT } - ( GLenum target, GLenum attachment, + ( GLenum target, GLenum attachment, GLuint texture, GLint level, GLint layer ) ; GL-FUNCTION: void glGenFramebuffers { glGenFramebuffersEXT } ( GLsizei n, GLuint* framebuffers ) ; GL-FUNCTION: void glGenRenderbuffers { glGenRenderbuffersEXT } ( GLsizei n, GLuint* renderbuffers ) ; @@ -2072,7 +2072,7 @@ GL-FUNCTION: void glEndTransformFeedback { glEndTransformFeedbackEXT } ( ) ; GL-FUNCTION: void glTransformFeedbackVaryings { glTransformFeedbackVaryingsEXT } ( GLuint program, GLsizei count, GLstring* varyings, GLenum bufferMode ) ; GL-FUNCTION: void glGetTransformFeedbackVarying { glGetTransformFeedbackVaryingEXT } ( GLuint program, GLuint index, - GLsizei bufSize, GLsizei* length, + GLsizei bufSize, GLsizei* length, GLsizei* size, GLenum* type, GLstring name ) ; GL-FUNCTION: void glClearBufferiv { } ( GLenum buffer, GLint drawbuffer, GLint* value ) ; @@ -2570,4 +2570,3 @@ CONSTANT: GL_COMPRESSED_LUMINANCE_LATC1_EXT 0x8C70 CONSTANT: GL_COMPRESSED_SIGNED_LUMINANCE_LATC1_EXT 0x8C71 CONSTANT: GL_COMPRESSED_LUMINANCE_ALPHA_LATC2_EXT 0x8C72 CONSTANT: GL_COMPRESSED_SIGNED_LUMINANCE_ALPHA_LATC2_EXT 0x8C73 - diff --git a/basis/opengl/gl/gtk/gtk.factor b/basis/opengl/gl/gtk/gtk.factor index 0521d2fa07..c5fbdeebb3 100644 --- a/basis/opengl/gl/gtk/gtk.factor +++ b/basis/opengl/gl/gtk/gtk.factor @@ -11,4 +11,3 @@ IN: opengl.gl.gtk ascii string>alien gdk_gl_get_proc_address ; inline : gl-function-calling-convention ( -- str ) cdecl ; inline - diff --git a/basis/opengl/shaders/shaders.factor b/basis/opengl/shaders/shaders.factor index fd2deb4ff1..231011c521 100644 --- a/basis/opengl/shaders/shaders.factor +++ b/basis/opengl/shaders/shaders.factor @@ -63,7 +63,7 @@ PREDICATE: fragment-shader < gl-shader (fragment-shader?) ; ! Programs : (gl-program) ( shaders quot: ( gl-program -- ) -- program ) - glCreateProgram + glCreateProgram [ [ swap [ glAttachShader ] with each ] [ swap call ] bi-curry bi* @@ -74,7 +74,7 @@ PREDICATE: fragment-shader < gl-shader (fragment-shader?) ; : ( shaders -- program ) [ drop ] (gl-program) ; - + : (gl-program?) ( object -- ? ) dup integer? [ glIsProgram c-bool> ] [ drop f ] if ; @@ -131,4 +131,3 @@ PREDICATE: gl-program < integer (gl-program?) ; [ check-gl-shader ] [ check-gl-shader ] bi* 2array check-gl-program ; - diff --git a/basis/pack/pack.factor b/basis/pack/pack.factor index 5f15373790..c1aca45922 100644 --- a/basis/pack/pack.factor +++ b/basis/pack/pack.factor @@ -102,7 +102,7 @@ MACRO: pack ( str -- quot ) : packed-length ( str -- n ) [ ch>packed-length ] map-sum ; - + : pack-native ( seq str -- seq ) '[ _ _ pack ] with-native-endian ; inline diff --git a/basis/pango/cairo/cairo.factor b/basis/pango/cairo/cairo.factor index 38307ed347..1efc783417 100644 --- a/basis/pango/cairo/cairo.factor +++ b/basis/pango/cairo/cairo.factor @@ -2,4 +2,3 @@ ! See http://factorcode.org/license.txt for BSD license. USING: pango.cairo.ffi ; IN: pango.cairo - diff --git a/basis/pango/pango.factor b/basis/pango/pango.factor index 221308f257..078f9c8b7c 100644 --- a/basis/pango/pango.factor +++ b/basis/pango/pango.factor @@ -2,4 +2,3 @@ ! See http://factorcode.org/license.txt for BSD license. USING: pango.ffi ; IN: pango - diff --git a/basis/peg/ebnf/ebnf.factor b/basis/peg/ebnf/ebnf.factor index ca3d9ee915..8baaa033ab 100644 --- a/basis/peg/ebnf/ebnf.factor +++ b/basis/peg/ebnf/ebnf.factor @@ -567,7 +567,7 @@ SYNTAX: [EBNF suffix! \ call suffix! reset-tokenizer ; SYNTAX: EBNF: - reset-tokenizer scan-new-word dup ";EBNF" parse-multiline-string + reset-tokenizer scan-new-word dup ";EBNF" parse-multiline-string ebnf>quot swapd ( input -- ast ) define-declared "ebnf-parser" set-word-prop reset-tokenizer ; diff --git a/basis/peg/peg-docs.factor b/basis/peg/peg-docs.factor index c90b9cc258..c892715e91 100644 --- a/basis/peg/peg-docs.factor +++ b/basis/peg/peg-docs.factor @@ -1,180 +1,180 @@ -! Copyright (C) 2007 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax kernel quotations strings words ; -IN: peg - -HELP: parse -{ $values - { "input" string } - { "parser" parser } - { "ast" object } -} -{ $description - "Given the input string, parse it using the given parser. The result is the abstract " - "syntax tree returned by the parser." } -{ $see-also compile } ; - -HELP: compile -{ $values - { "parser" parser } - { "word" word } -} -{ $description - "Compile the parser to a word. The word will have stack effect ( -- ast )." -} -{ $see-also parse } ; - -HELP: token -{ $values - { "string" string } - { "parser" parser } -} -{ $description - "Returns a parser that matches the given string." } ; - -HELP: satisfy -{ $values - { "quot" quotation } - { "parser" parser } -} -{ $description - "Returns a parser that calls the quotation on the first character of the input string, " - "succeeding if that quotation returns true. The AST is the character from the string." } ; - -HELP: range -{ $values - { "min" "a character" } - { "max" "a character" } - { "parser" parser } -} -{ $description - "Returns a parser that matches a single character that lies within the range of characters given, inclusive." } -{ $examples { $code ": digit ( -- parser ) CHAR: 0 CHAR: 9 range ;" } } ; - -HELP: seq -{ $values - { "seq" "a sequence of parsers" } - { "parser" parser } -} -{ $description - "Returns a parser that calls all parsers in the given sequence, in order. The parser succeeds if " - "all the parsers succeed, otherwise it fails. The AST produced is a sequence of the AST produced by " - "the individual parsers." } ; - -HELP: choice -{ $values - { "seq" "a sequence of parsers" } - { "parser" parser } -} -{ $description - "Returns a parser that will try all the parsers in the sequence, in order, until one succeeds. " - "The resulting AST is that produced by the successful parser." } ; - -HELP: repeat0 -{ $values - { "parser" parser } -} -{ $description - "Returns a parser that parses 0 or more instances of the 'p1' parser. The AST produced is " - "an array of the AST produced by the 'p1' parser. An empty array indicates 0 instances were " - "parsed." } ; - -HELP: repeat1 -{ $values - { "parser" parser } -} -{ $description - "Returns a parser that parses 1 or more instances of the 'p1' parser. The AST produced is " - "an array of the AST produced by the 'p1' parser." } ; - -HELP: optional -{ $values - { "parser" parser } -} -{ $description - "Returns a parser that parses 0 or 1 instances of the 'p1' parser. The AST produced is " - "'f' if 0 instances are parsed the AST produced is 'f', otherwise it is the AST produced by 'p1'." } ; - -HELP: semantic -{ $values - { "parser" parser } - { "quot" { $quotation ( object -- ? ) } } -} -{ $description - "Returns a parser that succeeds if the 'p1' parser succeeds and the quotation called with " - "the AST produced by 'p1' on the stack returns true." } -{ $examples - { $example "USING: kernel math peg prettyprint ;" "\"C\" [ drop t ] satisfy [ 66 > ] semantic parse ." "67" } -} ; - -HELP: ensure -{ $values - { "parser" parser } -} -{ $description - "Returns a parser that succeeds if the 'p1' parser succeeds but does not add anything to the " - "AST and does not move the location in the input string. This can be used for lookahead and " - "disambiguation, along with the " { $link ensure-not } " word." } -{ $examples { $code "\"0\" token ensure octal-parser" } } ; - -HELP: ensure-not -{ $values - { "parser" parser } -} -{ $description - "Returns a parser that succeeds if the 'p1' parser fails but does not add anything to the " - "AST and does not move the location in the input string. This can be used for lookahead and " - "disambiguation, along with the " { $link ensure } " word." } -{ $code "\"+\" token \"=\" token ensure-not \"+=\" token 3array seq" } ; - -HELP: action -{ $values - { "parser" parser } - { "quot" { $quotation ( ast -- ast ) } } -} -{ $description - "Returns a parser that calls the 'p1' parser and applies the quotation to the AST resulting " - "from that parse. The result of the quotation is then used as the final AST. This can be used " - "for manipulating the parse tree to produce a AST better suited for the task at hand rather than " - "the default AST. If the quotation returns " { $link fail } " then the parser fails." } -{ $code "CHAR: 0 CHAR: 9 range [ to-digit ] action" } ; - -HELP: sp -{ $values - { "parser" parser } -} -{ $description - "Returns a parser that calls the original parser 'p1' after stripping any whitespace " - " from the left of the input string." } ; - -HELP: hide -{ $values - { "parser" parser } -} -{ $description - "Returns a parser that succeeds if the original parser succeeds, but does not " - "put any result in the AST. Useful for ignoring 'syntax' in the AST." } -{ $code "\"[\" token hide number \"]\" token hide 3array seq" } ; - -HELP: delay -{ $values - { "quot" quotation } - { "parser" parser } -} -{ $description - "Delays the construction of a parser until it is actually required to parse. This " - "allows for calling a parser that results in a recursive call to itself. The quotation " - "should return the constructed parser and is called the first time the parser is run. " - "The compiled result is memoized for future runs. See " { $link box } " for a word " - "that calls the quotation at compile time." } ; - -HELP: box -{ $values - { "quot" quotation } - { "parser" parser } -} -{ $description - "Delays the construction of a parser until the parser is compiled. The quotation " - "should return the constructed parser and is called when the parser is compiled. " - "The compiled result is memoized for future runs. See " { $link delay } " for a word " - "that calls the quotation at runtime." } ; +! Copyright (C) 2007 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax kernel quotations strings words ; +IN: peg + +HELP: parse +{ $values + { "input" string } + { "parser" parser } + { "ast" object } +} +{ $description + "Given the input string, parse it using the given parser. The result is the abstract " + "syntax tree returned by the parser." } +{ $see-also compile } ; + +HELP: compile +{ $values + { "parser" parser } + { "word" word } +} +{ $description + "Compile the parser to a word. The word will have stack effect ( -- ast )." +} +{ $see-also parse } ; + +HELP: token +{ $values + { "string" string } + { "parser" parser } +} +{ $description + "Returns a parser that matches the given string." } ; + +HELP: satisfy +{ $values + { "quot" quotation } + { "parser" parser } +} +{ $description + "Returns a parser that calls the quotation on the first character of the input string, " + "succeeding if that quotation returns true. The AST is the character from the string." } ; + +HELP: range +{ $values + { "min" "a character" } + { "max" "a character" } + { "parser" parser } +} +{ $description + "Returns a parser that matches a single character that lies within the range of characters given, inclusive." } +{ $examples { $code ": digit ( -- parser ) CHAR: 0 CHAR: 9 range ;" } } ; + +HELP: seq +{ $values + { "seq" "a sequence of parsers" } + { "parser" parser } +} +{ $description + "Returns a parser that calls all parsers in the given sequence, in order. The parser succeeds if " + "all the parsers succeed, otherwise it fails. The AST produced is a sequence of the AST produced by " + "the individual parsers." } ; + +HELP: choice +{ $values + { "seq" "a sequence of parsers" } + { "parser" parser } +} +{ $description + "Returns a parser that will try all the parsers in the sequence, in order, until one succeeds. " + "The resulting AST is that produced by the successful parser." } ; + +HELP: repeat0 +{ $values + { "parser" parser } +} +{ $description + "Returns a parser that parses 0 or more instances of the 'p1' parser. The AST produced is " + "an array of the AST produced by the 'p1' parser. An empty array indicates 0 instances were " + "parsed." } ; + +HELP: repeat1 +{ $values + { "parser" parser } +} +{ $description + "Returns a parser that parses 1 or more instances of the 'p1' parser. The AST produced is " + "an array of the AST produced by the 'p1' parser." } ; + +HELP: optional +{ $values + { "parser" parser } +} +{ $description + "Returns a parser that parses 0 or 1 instances of the 'p1' parser. The AST produced is " + "'f' if 0 instances are parsed the AST produced is 'f', otherwise it is the AST produced by 'p1'." } ; + +HELP: semantic +{ $values + { "parser" parser } + { "quot" { $quotation ( object -- ? ) } } +} +{ $description + "Returns a parser that succeeds if the 'p1' parser succeeds and the quotation called with " + "the AST produced by 'p1' on the stack returns true." } +{ $examples + { $example "USING: kernel math peg prettyprint ;" "\"C\" [ drop t ] satisfy [ 66 > ] semantic parse ." "67" } +} ; + +HELP: ensure +{ $values + { "parser" parser } +} +{ $description + "Returns a parser that succeeds if the 'p1' parser succeeds but does not add anything to the " + "AST and does not move the location in the input string. This can be used for lookahead and " + "disambiguation, along with the " { $link ensure-not } " word." } +{ $examples { $code "\"0\" token ensure octal-parser" } } ; + +HELP: ensure-not +{ $values + { "parser" parser } +} +{ $description + "Returns a parser that succeeds if the 'p1' parser fails but does not add anything to the " + "AST and does not move the location in the input string. This can be used for lookahead and " + "disambiguation, along with the " { $link ensure } " word." } +{ $code "\"+\" token \"=\" token ensure-not \"+=\" token 3array seq" } ; + +HELP: action +{ $values + { "parser" parser } + { "quot" { $quotation ( ast -- ast ) } } +} +{ $description + "Returns a parser that calls the 'p1' parser and applies the quotation to the AST resulting " + "from that parse. The result of the quotation is then used as the final AST. This can be used " + "for manipulating the parse tree to produce a AST better suited for the task at hand rather than " + "the default AST. If the quotation returns " { $link fail } " then the parser fails." } +{ $code "CHAR: 0 CHAR: 9 range [ to-digit ] action" } ; + +HELP: sp +{ $values + { "parser" parser } +} +{ $description + "Returns a parser that calls the original parser 'p1' after stripping any whitespace " + " from the left of the input string." } ; + +HELP: hide +{ $values + { "parser" parser } +} +{ $description + "Returns a parser that succeeds if the original parser succeeds, but does not " + "put any result in the AST. Useful for ignoring 'syntax' in the AST." } +{ $code "\"[\" token hide number \"]\" token hide 3array seq" } ; + +HELP: delay +{ $values + { "quot" quotation } + { "parser" parser } +} +{ $description + "Delays the construction of a parser until it is actually required to parse. This " + "allows for calling a parser that results in a recursive call to itself. The quotation " + "should return the constructed parser and is called the first time the parser is run. " + "The compiled result is memoized for future runs. See " { $link box } " for a word " + "that calls the quotation at compile time." } ; + +HELP: box +{ $values + { "quot" quotation } + { "parser" parser } +} +{ $description + "Delays the construction of a parser until the parser is compiled. The quotation " + "should return the constructed parser and is called when the parser is compiled. " + "The compiled result is memoized for future runs. See " { $link delay } " for a word " + "that calls the quotation at runtime." } ; diff --git a/basis/persistent/heaps/heaps.factor b/basis/persistent/heaps/heaps.factor index e836a4afc6..7d39053379 100644 --- a/basis/persistent/heaps/heaps.factor +++ b/basis/persistent/heaps/heaps.factor @@ -42,7 +42,7 @@ GENERIC: sift-down ( value prio left right -- heap ) ] if ; -M: empty-heap sift-down +M: empty-heap sift-down over singleton-heap? [ singleton-sift-down ] [ ] if ; :: reroot-left ( value prio left right -- heap ) diff --git a/basis/quoted-printable/quoted-printable.factor b/basis/quoted-printable/quoted-printable.factor index 53af3a5178..bffe4f53d7 100644 --- a/basis/quoted-printable/quoted-printable.factor +++ b/basis/quoted-printable/quoted-printable.factor @@ -23,7 +23,7 @@ IN: quoted-printable : char>quoted ( ch -- str ) dup printable? [ 1string ] [ assure-small >hex >upper - 2 CHAR: 0 pad-head + 2 CHAR: 0 pad-head CHAR: = prefix ] if ; diff --git a/basis/random/mersenne-twister/mersenne-twister.factor b/basis/random/mersenne-twister/mersenne-twister.factor index 3b4e029778..c6e949a663 100644 --- a/basis/random/mersenne-twister/mersenne-twister.factor +++ b/basis/random/mersenne-twister/mersenne-twister.factor @@ -79,4 +79,3 @@ M: mersenne-twister random-32* [ default-mersenne-twister random-generator set-global ] "bootstrap.random" add-startup-hook - diff --git a/basis/random/windows/windows.factor b/basis/random/windows/windows.factor index 29f46dd51d..bda828a7b5 100755 --- a/basis/random/windows/windows.factor +++ b/basis/random/windows/windows.factor @@ -42,7 +42,7 @@ ERROR: acquire-crypto-context-failed provider type error ; swap >>provider initialize-crypto-context ; inline -M: windows-crypto-context random-bytes* ( n windows-crypto-context -- bytes ) +M: windows-crypto-context random-bytes* ( n windows-crypto-context -- bytes ) handle>> swap [ ] [ ] bi [ CryptGenRandom win32-error=0/f ] keep ; diff --git a/basis/regexp/classes/classes.factor b/basis/regexp/classes/classes.factor index 7ad452a0b0..60dc6638d6 100644 --- a/basis/regexp/classes/classes.factor +++ b/basis/regexp/classes/classes.factor @@ -328,7 +328,7 @@ M: object class>questions 1array ; ! input table is state => class >alist dup table>questions make-condition ; -: condition-map ( condition quot: ( obj -- obj' ) -- new-condition ) +: condition-map ( condition quot: ( obj -- obj' ) -- new-condition ) over condition? [ [ [ question>> ] [ yes>> ] [ no>> ] tri ] dip '[ _ condition-map ] bi@ diff --git a/basis/regexp/compiler/compiler.factor b/basis/regexp/compiler/compiler.factor index a8b3c9168b..45e17306de 100644 --- a/basis/regexp/compiler/compiler.factor +++ b/basis/regexp/compiler/compiler.factor @@ -120,7 +120,7 @@ C: box dup transitions>> keys [ gensym ] H{ } map>assoc [ transitions-at ] [ values ] - bi swap ; + bi swap ; : dfa>main-word ( dfa -- word ) states>words [ states>code ] keep start-state>> ; diff --git a/basis/regexp/disambiguate/disambiguate.factor b/basis/regexp/disambiguate/disambiguate.factor index 767e341073..2f8725cd18 100644 --- a/basis/regexp/disambiguate/disambiguate.factor +++ b/basis/regexp/disambiguate/disambiguate.factor @@ -44,7 +44,7 @@ TUPLE: parts in out ; :: class-partitions ( classes -- assoc ) classes [ integer? ] partition :> ( integers classes ) - + classes powerset-partition classes integers add-integers [ [ partition>class ] keep 2array ] map [ first ] filter integers [ classes singleton-partition ] map append ; @@ -61,12 +61,12 @@ TUPLE: parts in out ; [ [ drop tagged-epsilon? ] assoc-filter ] bi assoc-union H{ } assoc-like ; inline -: disambiguate ( nfa -- nfa ) +: disambiguate ( nfa -- nfa ) expand-ors [ dup new-transitions '[ [ _ swap '[ _ get-transitions ] assoc-map - [ nip empty? ] assoc-reject + [ nip empty? ] assoc-reject ] preserving-epsilon ] assoc-map ] change-transitions ; diff --git a/basis/regexp/negation/negation.factor b/basis/regexp/negation/negation.factor index 86e4de2b54..81ac83da0b 100644 --- a/basis/regexp/negation/negation.factor +++ b/basis/regexp/negation/negation.factor @@ -41,7 +41,7 @@ CONSTANT: fail-state -1 HS{ -2 } clone >>final-states ; : adjoin-dfa ( transition-table -- start end ) - unify-final-state renumber-states box-transitions + unify-final-state renumber-states box-transitions [ start-state>> ] [ final-states>> members first ] [ nfa-table get [ transitions>> ] bi@ swap assoc-union! drop ] tri ; diff --git a/basis/regexp/nfa/nfa.factor b/basis/regexp/nfa/nfa.factor index a28921f4a0..45fc35a7c0 100644 --- a/basis/regexp/nfa/nfa.factor +++ b/basis/regexp/nfa/nfa.factor @@ -146,7 +146,7 @@ M: range-class modify-class dup cased-range? [ [ from>> ] [ to>> ] bi [ [ ch>lower ] bi@ ] - [ [ ch>upper ] bi@ ] 2bi + [ [ ch>upper ] bi@ ] 2bi 2array ] when ] when ; diff --git a/basis/regexp/parser/parser.factor b/basis/regexp/parser/parser.factor index 5aeb9aa708..01cff98901 100644 --- a/basis/regexp/parser/parser.factor +++ b/basis/regexp/parser/parser.factor @@ -116,7 +116,7 @@ ERROR: nonexistent-option name ; : string>options ( string -- options ) "-" split1 parse-options ; - + : options>string ( options -- string ) [ on>> ] [ off>> ] bi [ [ option>ch ] map ] bi@ diff --git a/basis/regexp/prettyprint/prettyprint.factor b/basis/regexp/prettyprint/prettyprint.factor index 7af762a34e..176714be69 100644 --- a/basis/regexp/prettyprint/prettyprint.factor +++ b/basis/regexp/prettyprint/prettyprint.factor @@ -10,4 +10,4 @@ M: regexp pprint* [ raw>> dup find-regexp-syntax swap % swap % % ] [ options>> options>string % ] bi ] "" make - ] keep present-text ; \ No newline at end of file + ] keep present-text ; diff --git a/basis/see/see.factor b/basis/see/see.factor index b43b53de23..e543ca46bb 100644 --- a/basis/see/see.factor +++ b/basis/see/see.factor @@ -55,7 +55,7 @@ M: word print-stack-effect? drop t ; [ seeing-word ] [ definer. ] [ pprint-word ] - [ stack-effect. ] + [ stack-effect. ] } cleave ; M: word synopsis* word-synopsis ; diff --git a/basis/sequences/unrolled/unrolled.factor b/basis/sequences/unrolled/unrolled.factor index 83da65e6db..da802cd88e 100644 --- a/basis/sequences/unrolled/unrolled.factor +++ b/basis/sequences/unrolled/unrolled.factor @@ -96,4 +96,3 @@ PRIVATE> : unrolled-map-index ( seq len quot: ( x i -- newx ) -- newseq ) [ dup length iota ] 2dip unrolled-2map ; inline - diff --git a/basis/serialize/serialize.factor b/basis/serialize/serialize.factor index 0b7c4df97a..0bc26cb2a1 100644 --- a/basis/serialize/serialize.factor +++ b/basis/serialize/serialize.factor @@ -41,7 +41,7 @@ SYMBOL: serialized dup 0x7e <= [ 0x80 bitor write1 ] [ - dup log2 8 /i 1 + + dup log2 8 /i 1 + dup 0x7f >= [ 0xff write1 dup serialize-cell diff --git a/basis/smtp/server/server.factor b/basis/smtp/server/server.factor index ad27a1a9fc..b810c26dfb 100644 --- a/basis/smtp/server/server.factor +++ b/basis/smtp/server/server.factor @@ -54,7 +54,7 @@ SYMBOL: data-mode { [ dup "DATA" = ] [ - data-mode on + data-mode on "354 Enter message, ending with \".\" on a line by itself\r\n" write flush t ] diff --git a/basis/specialized-arrays/prettyprint/prettyprint.factor b/basis/specialized-arrays/prettyprint/prettyprint.factor index 3dcc092e5f..ac7c705c8a 100644 --- a/basis/specialized-arrays/prettyprint/prettyprint.factor +++ b/basis/specialized-arrays/prettyprint/prettyprint.factor @@ -13,4 +13,3 @@ IN: specialized-arrays.prettyprint M: specialized-array pprint* [ pprint-object ] [ pprint-direct-array ] pprint-c-object ; - diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index d7f8269e20..1191b8493a 100644 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -185,4 +185,3 @@ M: object apply-object push-literal ; word effect variables branches n declare-effect-d ] when* ] each-index ; - diff --git a/basis/suffix-arrays/suffix-arrays.factor b/basis/suffix-arrays/suffix-arrays.factor index 62ba8a9638..d4695554e9 100644 --- a/basis/suffix-arrays/suffix-arrays.factor +++ b/basis/suffix-arrays/suffix-arrays.factor @@ -11,7 +11,7 @@ IN: suffix-arrays : prefix<=> ( begin seq -- <=> ) [ <=> ] [ swap head? ] 2bi [ drop +eq+ ] when ; - + : find-index ( begin suffix-array -- index/f ) [ prefix<=> ] with search drop ; diff --git a/basis/suffix-arrays/words/words.factor b/basis/suffix-arrays/words/words.factor index 74e2fc2f97..5089986d5d 100644 --- a/basis/suffix-arrays/words/words.factor +++ b/basis/suffix-arrays/words/words.factor @@ -1,19 +1,19 @@ -! Copyright (C) 2008 Marc Fauconneau. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel arrays math accessors sequences math.vectors -math.order sorting binary-search sets assocs fry suffix-arrays ; -IN: suffix-arrays.words - -! to search on word names - -: new-word-sa ( words -- sa ) - [ name>> ] map >suffix-array ; - -: name>word-map ( words -- map ) - dup [ name>> V{ } clone ] H{ } map>assoc - [ '[ dup name>> _ at push ] each ] keep ; - -: query-word-sa ( map begin sa -- matches ) query '[ _ at ] map concat ; - -! usage example : -! clear all-words 100 head dup name>word-map "test" rot new-word-sa query . +! Copyright (C) 2008 Marc Fauconneau. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel arrays math accessors sequences math.vectors +math.order sorting binary-search sets assocs fry suffix-arrays ; +IN: suffix-arrays.words + +! to search on word names + +: new-word-sa ( words -- sa ) + [ name>> ] map >suffix-array ; + +: name>word-map ( words -- map ) + dup [ name>> V{ } clone ] H{ } map>assoc + [ '[ dup name>> _ at push ] each ] keep ; + +: query-word-sa ( map begin sa -- matches ) query '[ _ at ] map concat ; + +! usage example : +! clear all-words 100 head dup name>word-map "test" rot new-word-sa query . diff --git a/basis/system-info/system-info.factor b/basis/system-info/system-info.factor index aff6951134..156d20ed8e 100644 --- a/basis/system-info/system-info.factor +++ b/basis/system-info/system-info.factor @@ -4,7 +4,7 @@ USING: accessors io kernel math math.parser sequences system vocabs ; IN: system-info -HOOK: os-version os ( -- version ) +HOOK: os-version os ( -- version ) HOOK: cpus os ( -- n ) HOOK: cpu-mhz os ( -- n ) HOOK: memory-load os ( -- n ) diff --git a/basis/system-info/windows/windows.factor b/basis/system-info/windows/windows.factor index 7bd5a8b8fd..67fd38211e 100644 --- a/basis/system-info/windows/windows.factor +++ b/basis/system-info/windows/windows.factor @@ -35,7 +35,7 @@ IN: system-info.windows M: windows os-version ( -- obj ) os-version-struct [ dwMajorVersion>> ] [ dwMinorVersion>> ] bi 2array ; - + : windows-build# ( -- n ) os-version-struct dwBuildNumber>> ; @@ -100,7 +100,7 @@ M: windows available-virtual-mem ( -- n ) MAX_COMPUTERNAME_LENGTH 1 + [ dup ] keep uint GetComputerName win32-error=0/f alien>native-string ; - + : username ( -- string ) UNLEN 1 + [ dup ] keep uint diff --git a/basis/timers/timers-docs.factor b/basis/timers/timers-docs.factor index 9a9b29cbf3..aaa6277125 100644 --- a/basis/timers/timers-docs.factor +++ b/basis/timers/timers-docs.factor @@ -1,71 +1,71 @@ -USING: help.markup help.syntax calendar quotations system ; -IN: timers - -HELP: timer -{ $class-description "A timer. Can be passed to " { $link stop-timer } "." } ; - -HELP: start-timer -{ $values { "timer" timer } } -{ $description "Starts a timer." } ; - -HELP: restart-timer -{ $values { "timer" timer } } -{ $description "Starts or restarts a timer. Restarting a timer causes the a sleep of initial delay nanoseconds before looping. An timer's parameters may be modified and restarted with this word." } ; - -HELP: stop-timer -{ $values { "timer" timer } } -{ $description "Prevents a timer from calling its quotation again. Has no effect on timers that are not currently running." } ; - -HELP: every -{ $values - { "quot" quotation } { "interval-duration" duration } - { "timer" timer } } -{ $description "Creates a timer that calls the quotation repeatedly, using " { $snippet "duration" } " as the frequency. The first call of " { $snippet "quot" } " will happen immediately. If the quotation throws an exception, the timer will stop." } -{ $examples - { $code - "USING: timers io calendar ;" - """[ "Hi Buddy." print flush ] 10 seconds every drop""" - } -} ; - -HELP: later -{ $values { "quot" quotation } { "delay-duration" duration } { "timer" timer } } -{ $description "Sleeps for " { $snippet "duration" } " and then calls a " { $snippet "quot" } ". The user may cancel the timer before " { $snippet "quot" } " runs. This timer is not repeated." } -{ $examples - { $code - "USING: timers io calendar ;" - """[ "Break's over!" print flush ] 15 minutes later drop""" - } -} ; - -HELP: delayed-every -{ $values - { "quot" quotation } { "duration" duration } - { "timer" timer } } -{ $description "Creates a timer that calls " { $snippet "quot" } " repeatedly, waiting " { $snippet "duration" } " before calling " { $snippet "quot" } " the first time and then waiting " { $snippet "duration" } " between further calls. If the quotation throws an exception, the timer will stop." } -{ $examples - { $code - "USING: timers io calendar ;" - """[ "Hi Buddy." print flush ] 10 seconds every drop""" - } -} ; - -ARTICLE: "timers" "Timers" -"The " { $vocab-link "timers" } " vocabulary provides a lightweight way to schedule one-time and recurring tasks. Timers run in a single green thread per timer and consist of a quotation, a delay duration, and an interval duration. After starting a timer, the timer thread sleeps for the delay duration and calls the quotation. Then it waits out the interval duration and calls the quotation again until something stops the timer. If a recurring timer's quotation would be scheduled to run again before the previous quotation has finished processing, the timer will be run again immediately afterwards. This may result in the timer falling behind indefinitely, in which case the it will run as often as possible while still allowing other green threads to run. Recurring timers that execute 'on time' or 'catch up' will always be scheduled for an exact multiple of the interval from the original starting time to prevent the timer from drifting over time. Timers use " { $link nano-count } " as the timing primitive, so they will continue to work across system clock changes." $nl -"The timer class:" -{ $subsections timer } -"Create a timer before starting it:" -{ $subsections } -"Starting a timer:" -{ $subsections start-timer restart-timer } -"Stopping a timer:" -{ $subsections stop-timer } - -"A recurring timer without an initial delay:" -{ $subsections every } -"A one-time timer with an initial delay:" -{ $subsections later } -"A recurring timer with an initial delay:" -{ $subsections delayed-every } ; - -ABOUT: "timers" +USING: help.markup help.syntax calendar quotations system ; +IN: timers + +HELP: timer +{ $class-description "A timer. Can be passed to " { $link stop-timer } "." } ; + +HELP: start-timer +{ $values { "timer" timer } } +{ $description "Starts a timer." } ; + +HELP: restart-timer +{ $values { "timer" timer } } +{ $description "Starts or restarts a timer. Restarting a timer causes the a sleep of initial delay nanoseconds before looping. An timer's parameters may be modified and restarted with this word." } ; + +HELP: stop-timer +{ $values { "timer" timer } } +{ $description "Prevents a timer from calling its quotation again. Has no effect on timers that are not currently running." } ; + +HELP: every +{ $values + { "quot" quotation } { "interval-duration" duration } + { "timer" timer } } +{ $description "Creates a timer that calls the quotation repeatedly, using " { $snippet "duration" } " as the frequency. The first call of " { $snippet "quot" } " will happen immediately. If the quotation throws an exception, the timer will stop." } +{ $examples + { $code + "USING: timers io calendar ;" + """[ "Hi Buddy." print flush ] 10 seconds every drop""" + } +} ; + +HELP: later +{ $values { "quot" quotation } { "delay-duration" duration } { "timer" timer } } +{ $description "Sleeps for " { $snippet "duration" } " and then calls a " { $snippet "quot" } ". The user may cancel the timer before " { $snippet "quot" } " runs. This timer is not repeated." } +{ $examples + { $code + "USING: timers io calendar ;" + """[ "Break's over!" print flush ] 15 minutes later drop""" + } +} ; + +HELP: delayed-every +{ $values + { "quot" quotation } { "duration" duration } + { "timer" timer } } +{ $description "Creates a timer that calls " { $snippet "quot" } " repeatedly, waiting " { $snippet "duration" } " before calling " { $snippet "quot" } " the first time and then waiting " { $snippet "duration" } " between further calls. If the quotation throws an exception, the timer will stop." } +{ $examples + { $code + "USING: timers io calendar ;" + """[ "Hi Buddy." print flush ] 10 seconds every drop""" + } +} ; + +ARTICLE: "timers" "Timers" +"The " { $vocab-link "timers" } " vocabulary provides a lightweight way to schedule one-time and recurring tasks. Timers run in a single green thread per timer and consist of a quotation, a delay duration, and an interval duration. After starting a timer, the timer thread sleeps for the delay duration and calls the quotation. Then it waits out the interval duration and calls the quotation again until something stops the timer. If a recurring timer's quotation would be scheduled to run again before the previous quotation has finished processing, the timer will be run again immediately afterwards. This may result in the timer falling behind indefinitely, in which case the it will run as often as possible while still allowing other green threads to run. Recurring timers that execute 'on time' or 'catch up' will always be scheduled for an exact multiple of the interval from the original starting time to prevent the timer from drifting over time. Timers use " { $link nano-count } " as the timing primitive, so they will continue to work across system clock changes." $nl +"The timer class:" +{ $subsections timer } +"Create a timer before starting it:" +{ $subsections } +"Starting a timer:" +{ $subsections start-timer restart-timer } +"Stopping a timer:" +{ $subsections stop-timer } + +"A recurring timer without an initial delay:" +{ $subsections every } +"A one-time timer with an initial delay:" +{ $subsections later } +"A recurring timer with an initial delay:" +{ $subsections delayed-every } ; + +ABOUT: "timers" diff --git a/basis/timers/timers-tests.factor b/basis/timers/timers-tests.factor index 82274aff45..e299e29cad 100644 --- a/basis/timers/timers-tests.factor +++ b/basis/timers/timers-tests.factor @@ -1,67 +1,67 @@ -USING: timers timers.private calendar concurrency.count-downs -concurrency.promises fry kernel math math.order sequences -threads tools.test tools.time ; -IN: timers.tests - -[ ] [ - 1 - { f } clone 2dup - [ first stop-timer count-down ] 2curry 1 seconds later - swap set-first - await -] unit-test - -[ ] [ - self [ resume ] curry instant later drop - "test" suspend drop -] unit-test - -[ t ] [ - [ - - [ '[ t _ fulfill ] 2 seconds later drop ] - [ 5 seconds ?promise-timeout drop ] bi - ] benchmark 1,500,000,000 2,500,000,000 between? -] unit-test - -[ { 3 } ] [ - { 3 } dup - '[ 4 _ set-first ] 2 seconds later - 1/2 seconds sleep - stop-timer -] unit-test - -[ { 1 } ] [ - { 0 } - dup '[ 0 _ [ 1 + ] change-nth ] 3 seconds later - [ stop-timer ] [ start-timer ] bi - 4 seconds sleep -] unit-test - -[ { 0 } ] [ - { 0 } - dup '[ 3 seconds sleep 1 _ set-first ] 1 seconds later - 2 seconds sleep stop-timer - 1/2 seconds sleep -] unit-test - -[ { 0 } ] [ - { 0 } - dup '[ 1 _ set-first ] 300 milliseconds later - 150 milliseconds sleep - [ restart-timer ] [ 200 milliseconds sleep stop-timer ] bi -] unit-test - -[ { 1 } ] [ - { 0 } - dup '[ 0 _ [ 1 + ] change-nth ] 200 milliseconds later - 100 milliseconds sleep restart-timer 300 milliseconds sleep -] unit-test - -[ { 4 } ] [ - { 0 } - dup '[ 0 _ [ 1 + ] change-nth ] 300 milliseconds 300 milliseconds - dup start-timer - 700 milliseconds sleep dup restart-timer - 700 milliseconds sleep stop-timer 500 milliseconds sleep -] unit-test +USING: timers timers.private calendar concurrency.count-downs +concurrency.promises fry kernel math math.order sequences +threads tools.test tools.time ; +IN: timers.tests + +[ ] [ + 1 + { f } clone 2dup + [ first stop-timer count-down ] 2curry 1 seconds later + swap set-first + await +] unit-test + +[ ] [ + self [ resume ] curry instant later drop + "test" suspend drop +] unit-test + +[ t ] [ + [ + + [ '[ t _ fulfill ] 2 seconds later drop ] + [ 5 seconds ?promise-timeout drop ] bi + ] benchmark 1,500,000,000 2,500,000,000 between? +] unit-test + +[ { 3 } ] [ + { 3 } dup + '[ 4 _ set-first ] 2 seconds later + 1/2 seconds sleep + stop-timer +] unit-test + +[ { 1 } ] [ + { 0 } + dup '[ 0 _ [ 1 + ] change-nth ] 3 seconds later + [ stop-timer ] [ start-timer ] bi + 4 seconds sleep +] unit-test + +[ { 0 } ] [ + { 0 } + dup '[ 3 seconds sleep 1 _ set-first ] 1 seconds later + 2 seconds sleep stop-timer + 1/2 seconds sleep +] unit-test + +[ { 0 } ] [ + { 0 } + dup '[ 1 _ set-first ] 300 milliseconds later + 150 milliseconds sleep + [ restart-timer ] [ 200 milliseconds sleep stop-timer ] bi +] unit-test + +[ { 1 } ] [ + { 0 } + dup '[ 0 _ [ 1 + ] change-nth ] 200 milliseconds later + 100 milliseconds sleep restart-timer 300 milliseconds sleep +] unit-test + +[ { 4 } ] [ + { 0 } + dup '[ 0 _ [ 1 + ] change-nth ] 300 milliseconds 300 milliseconds + dup start-timer + 700 milliseconds sleep dup restart-timer + 700 milliseconds sleep stop-timer 500 milliseconds sleep +] unit-test diff --git a/basis/timers/timers.factor b/basis/timers/timers.factor index 730383c518..cbe9870573 100644 --- a/basis/timers/timers.factor +++ b/basis/timers/timers.factor @@ -6,7 +6,7 @@ IN: timers TUPLE: timer { quot callable initial: [ ] } - start-nanos + start-nanos delay-nanos interval-nanos iteration-start-nanos diff --git a/basis/tools/continuations/continuations.factor b/basis/tools/continuations/continuations.factor index a83124fabb..2760afe83e 100644 --- a/basis/tools/continuations/continuations.factor +++ b/basis/tools/continuations/continuations.factor @@ -99,7 +99,7 @@ PRIVATE> [ 2dup length = [ nip [ break ] append ] [ 2dup nth \ break = [ nip ] [ - swap 1 + cut [ break ] glue + swap 1 + cut [ break ] glue ] if ] if ] change-frame ; diff --git a/basis/tools/coverage/coverage.factor b/basis/tools/coverage/coverage.factor index e33e5396a0..5854deeee6 100644 --- a/basis/tools/coverage/coverage.factor +++ b/basis/tools/coverage/coverage.factor @@ -63,7 +63,7 @@ M: string add-coverage M: string remove-coverage [ remove-coverage ] each-word ; -M: word add-coverage +M: word add-coverage H{ } clone [ "coverage" set-word-prop ] 2keep '[ \ coverage-state new [ _ set-at ] 2keep diff --git a/basis/tools/deploy/deploy.factor b/basis/tools/deploy/deploy.factor index a90f63f28c..515d69d741 100644 --- a/basis/tools/deploy/deploy.factor +++ b/basis/tools/deploy/deploy.factor @@ -12,7 +12,7 @@ ERROR: no-vocab-main vocab ; : deploy ( vocab -- ) dup find-vocab-root [ check-vocab-main deploy* ] [ no-vocab ] if ; -: deploy-image-only ( vocab image -- ) +: deploy-image-only ( vocab image -- ) [ vm ] 2dip swap dup deploy-config make-deploy-image drop ; diff --git a/basis/tools/deploy/libraries/libraries.factor b/basis/tools/deploy/libraries/libraries.factor index d87f820412..176fbc2296 100644 --- a/basis/tools/deploy/libraries/libraries.factor +++ b/basis/tools/deploy/libraries/libraries.factor @@ -8,4 +8,3 @@ HOOK: find-library-file os ( file -- path ) os windows? "tools.deploy.libraries.windows" "tools.deploy.libraries.unix" ? require - diff --git a/basis/tools/deploy/libraries/unix/unix.factor b/basis/tools/deploy/libraries/unix/unix.factor index db3e9fa134..aa474a81fe 100644 --- a/basis/tools/deploy/libraries/unix/unix.factor +++ b/basis/tools/deploy/libraries/unix/unix.factor @@ -13,4 +13,3 @@ M: unix find-library-file { "/lib" "/usr/lib" "/usr/local/lib" "/opt/local/lib" "resource:" } [ prepend-path ?exists ] with map-find drop ] if ; - diff --git a/basis/tools/deploy/libraries/windows/windows.factor b/basis/tools/deploy/libraries/windows/windows.factor index 4d56b48418..5e29e62348 100644 --- a/basis/tools/deploy/libraries/windows/windows.factor +++ b/basis/tools/deploy/libraries/windows/windows.factor @@ -13,4 +13,3 @@ M: windows find-library-file alien>native-string ] [ FreeLibrary drop ] bi ] [ f ] if* ; - diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index e5831b54fe..a4763d6d90 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -212,7 +212,7 @@ IN: tools.deploy.shaker "writing" } % ] when - + strip-prettyprint? [ { "delimiter" @@ -226,7 +226,7 @@ IN: tools.deploy.shaker "word-style" } % ] when - + deploy-c-types? get [ { "c-type" "struct-slots" "struct-align" } % ] unless @@ -564,7 +564,7 @@ SYMBOL: deploy-vocab [ path>> >deployed-library-path ] [ abi>> ] bi make-library ] change-at ] each - + [ "deploy-libraries" "alien.libraries" lookup-word forget "deploy-library" "alien.libraries" lookup-word forget diff --git a/basis/tools/deploy/test/1/1.factor b/basis/tools/deploy/test/1/1.factor index 63b382e2f6..514487f3f4 100644 --- a/basis/tools/deploy/test/1/1.factor +++ b/basis/tools/deploy/test/1/1.factor @@ -1,6 +1,6 @@ -IN: tools.deploy.test.1 -USING: threads ; - -: deploy-test-1 ( -- ) 1000000 sleep ; - -MAIN: deploy-test-1 +IN: tools.deploy.test.1 +USING: threads ; + +: deploy-test-1 ( -- ) 1000000 sleep ; + +MAIN: deploy-test-1 diff --git a/basis/tools/deploy/test/10/10.factor b/basis/tools/deploy/test/10/10.factor index 95329ff7f2..b0e35e4e5c 100644 --- a/basis/tools/deploy/test/10/10.factor +++ b/basis/tools/deploy/test/10/10.factor @@ -5,4 +5,4 @@ IN: tools.deploy.test.10 : main ( -- ) C{ 0 1 } pprint ; -MAIN: main \ No newline at end of file +MAIN: main diff --git a/basis/tools/deploy/test/11/11.factor b/basis/tools/deploy/test/11/11.factor index 3310686f05..288cd0b8a4 100644 --- a/basis/tools/deploy/test/11/11.factor +++ b/basis/tools/deploy/test/11/11.factor @@ -5,4 +5,4 @@ IN: tools.deploy.test.11 : foo ( -- ) "USING: math prettyprint ; 2 2 + ." eval( -- ) ; -MAIN: foo \ No newline at end of file +MAIN: foo diff --git a/basis/tools/deploy/test/12/12.factor b/basis/tools/deploy/test/12/12.factor index 3bc2af3da4..8247353455 100644 --- a/basis/tools/deploy/test/12/12.factor +++ b/basis/tools/deploy/test/12/12.factor @@ -9,4 +9,4 @@ IN: tools.deploy.test.12 : foo ( -- ) 1 2 \ + execute-test 4 [ * ] call-test number>string print ; -MAIN: foo \ No newline at end of file +MAIN: foo diff --git a/basis/tools/deploy/test/13/13.factor b/basis/tools/deploy/test/13/13.factor index af7cb4e6d5..646740b966 100644 --- a/basis/tools/deploy/test/13/13.factor +++ b/basis/tools/deploy/test/13/13.factor @@ -7,4 +7,4 @@ IN: tools.deploy.test.13 : main ( -- ) "x.z" regexp-test "X" "Y" ? print ; -MAIN: main \ No newline at end of file +MAIN: main diff --git a/basis/tools/deploy/test/17/17.factor b/basis/tools/deploy/test/17/17.factor index a7cb0d25f2..3fd1408f0b 100644 --- a/basis/tools/deploy/test/17/17.factor +++ b/basis/tools/deploy/test/17/17.factor @@ -14,7 +14,7 @@ person "PEOPLE" { : db-deploy-test ( -- ) "test.db" temp-file [ person recreate-table - + person new "Stephen Hawking" >>name timestamp new 8 >>day 0 >>month 1942 >>year >>birthday diff --git a/basis/tools/deploy/test/2/2.factor b/basis/tools/deploy/test/2/2.factor index afd83f510e..f6371e80ba 100644 --- a/basis/tools/deploy/test/2/2.factor +++ b/basis/tools/deploy/test/2/2.factor @@ -1,6 +1,6 @@ -IN: tools.deploy.test.2 -USING: calendar calendar.format ; - -: deploy-test-2 ( -- ) now (timestamp>string) ; - -MAIN: deploy-test-2 +IN: tools.deploy.test.2 +USING: calendar calendar.format ; + +: deploy-test-2 ( -- ) now (timestamp>string) ; + +MAIN: deploy-test-2 diff --git a/basis/tools/deploy/test/3/3.factor b/basis/tools/deploy/test/3/3.factor index 5919fa15db..4494902897 100644 --- a/basis/tools/deploy/test/3/3.factor +++ b/basis/tools/deploy/test/3/3.factor @@ -1,7 +1,7 @@ -IN: tools.deploy.test.3 -USING: io.encodings.ascii io.encodings.string system kernel ; - -: deploy-test-3 ( -- ) - "xyzthg" ascii encode drop ; - -MAIN: deploy-test-3 +IN: tools.deploy.test.3 +USING: io.encodings.ascii io.encodings.string system kernel ; + +: deploy-test-3 ( -- ) + "xyzthg" ascii encode drop ; + +MAIN: deploy-test-3 diff --git a/basis/tools/deploy/windows/ico/ico.factor b/basis/tools/deploy/windows/ico/ico.factor index fb950d25cc..4bb751a13a 100755 --- a/basis/tools/deploy/windows/ico/ico.factor +++ b/basis/tools/deploy/windows/ico/ico.factor @@ -79,4 +79,3 @@ PRIVATE> hUpdate 0 EndUpdateResource drop ] when ; - diff --git a/basis/tools/deploy/windows/windows-tests.factor b/basis/tools/deploy/windows/windows-tests.factor index deaf7338aa..2064e639dd 100644 --- a/basis/tools/deploy/windows/windows-tests.factor +++ b/basis/tools/deploy/windows/windows-tests.factor @@ -1,7 +1,7 @@ -IN: tools.deploy.windows.tests -USING: io.files.temp tools.deploy.windows tools.test sequences ; - -[ t ] [ - "foo" "test-copy-files" temp-file create-exe-dir - ".exe" tail? -] unit-test +IN: tools.deploy.windows.tests +USING: io.files.temp tools.deploy.windows tools.test sequences ; + +[ t ] [ + "foo" "test-copy-files" temp-file create-exe-dir + ".exe" tail? +] unit-test diff --git a/basis/tools/deploy/windows/windows.factor b/basis/tools/deploy/windows/windows.factor index 0a9cd8d105..2827a69bb9 100755 --- a/basis/tools/deploy/windows/windows.factor +++ b/basis/tools/deploy/windows/windows.factor @@ -39,6 +39,6 @@ M: windows deploy* [ drop namespace make-deploy-image-executable ] [ nip "" [ copy-resources ] [ copy-libraries ] 3bi ] [ nip open-in-explorer ] - } 2cleave + } 2cleave ] with-variables ] with-directory ; diff --git a/basis/tools/deprecation/deprecation.factor b/basis/tools/deprecation/deprecation.factor index 4f58ae1038..19c08b5c35 100644 --- a/basis/tools/deprecation/deprecation.factor +++ b/basis/tools/deprecation/deprecation.factor @@ -73,7 +73,7 @@ M: deprecation-observer definitions-changed [ [ check-deprecations ] each ] [ drop initialize-deprecation-notes ] if ; -[ \ deprecation-observer add-definition-observer ] +[ \ deprecation-observer add-definition-observer ] "tools.deprecation" add-startup-hook initialize-deprecation-notes diff --git a/basis/tools/disassembler/disassembler-docs.factor b/basis/tools/disassembler/disassembler-docs.factor index 22507b2cc3..e89e1f1d8e 100644 --- a/basis/tools/disassembler/disassembler-docs.factor +++ b/basis/tools/disassembler/disassembler-docs.factor @@ -1,16 +1,16 @@ -IN: tools.disassembler -USING: help.markup help.syntax sequences.private ; - -HELP: disassemble -{ $values { "obj" "a word or a pair of addresses" } } -{ $description "Disassembles either a compiled word definition or an arbitrary memory range (in the case " { $snippet "obj" } " is a pair of integers)." } -{ $notes "In some cases the Factor compiler emits data inline with code, which can confuse the disassembler. This occurs in words which call " { $link dispatch } ", where the jump table addresses are compiled inline." } ; - -ARTICLE: "tools.disassembler" "Disassembling words" -"The " { $vocab-link "tools.disassembler" } " vocabulary provides support for disassembling compiled word definitions. It uses the " { $snippet "libudis86" } " library on x86-32 and x86-64, and " { $snippet "gdb" } " on PowerPC." -$nl -"See also " { $vocab-link "compiler.tree.debugger" } " and " { $vocab-link "compiler.cfg.debugger" } "." -$nl -{ $subsections disassemble } ; - -ABOUT: "tools.disassembler" +IN: tools.disassembler +USING: help.markup help.syntax sequences.private ; + +HELP: disassemble +{ $values { "obj" "a word or a pair of addresses" } } +{ $description "Disassembles either a compiled word definition or an arbitrary memory range (in the case " { $snippet "obj" } " is a pair of integers)." } +{ $notes "In some cases the Factor compiler emits data inline with code, which can confuse the disassembler. This occurs in words which call " { $link dispatch } ", where the jump table addresses are compiled inline." } ; + +ARTICLE: "tools.disassembler" "Disassembling words" +"The " { $vocab-link "tools.disassembler" } " vocabulary provides support for disassembling compiled word definitions. It uses the " { $snippet "libudis86" } " library on x86-32 and x86-64, and " { $snippet "gdb" } " on PowerPC." +$nl +"See also " { $vocab-link "compiler.tree.debugger" } " and " { $vocab-link "compiler.cfg.debugger" } "." +$nl +{ $subsections disassemble } ; + +ABOUT: "tools.disassembler" diff --git a/basis/tools/disassembler/disassembler-tests.factor b/basis/tools/disassembler/disassembler-tests.factor index a762e36d3f..447ad131b0 100644 --- a/basis/tools/disassembler/disassembler-tests.factor +++ b/basis/tools/disassembler/disassembler-tests.factor @@ -1,6 +1,6 @@ -IN: tools.disassembler.tests -USING: kernel fry vocabs tools.disassembler tools.test sequences ; - -"math" vocab-words [ - [ { } ] dip '[ _ disassemble ] unit-test -] each +IN: tools.disassembler.tests +USING: kernel fry vocabs tools.disassembler tools.test sequences ; + +"math" vocab-words [ + [ { } ] dip '[ _ disassemble ] unit-test +] each diff --git a/basis/tools/disassembler/disassembler.factor b/basis/tools/disassembler/disassembler.factor index ddc1aa6f3f..0f864ff874 100644 --- a/basis/tools/disassembler/disassembler.factor +++ b/basis/tools/disassembler/disassembler.factor @@ -22,7 +22,7 @@ M: alien (>address) alien-address ; PRIVATE> -M: byte-array disassemble +M: byte-array disassemble [ [ malloc-byte-array &free alien-address dup ] [ length + ] bi diff --git a/basis/tools/files/files.factor b/basis/tools/files/files.factor index 5abea4af88..185791883f 100644 --- a/basis/tools/files/files.factor +++ b/basis/tools/files/files.factor @@ -79,7 +79,7 @@ M: object file-spec>string ( file-listing spec -- string ) [ _ [ file-spec>string ] with map ] map ] with-directory-entries ; inline -: list-files ( listing-tool -- array ) +: list-files ( listing-tool -- array ) dup list-slow? [ list-files-slow ] [ list-files-fast ] if ; inline HOOK: (directory.) os ( path -- lines ) diff --git a/basis/tools/threads/threads.factor b/basis/tools/threads/threads.factor index 1b862562c5..77202a79d1 100644 --- a/basis/tools/threads/threads.factor +++ b/basis/tools/threads/threads.factor @@ -1,33 +1,33 @@ -! Copyright (C) 2008, 2010 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs io io.styles kernel math.order -math.parser prettyprint sequences sorting system threads ; -IN: tools.threads - -: thread. ( thread -- ) - dup id>> pprint-cell - dup name>> [ - over write-object - ] with-cell - dup state>> [ - [ dup self eq? "running" "yield" ? ] unless* - write - ] with-cell - [ - sleep-entry>> [ - key>> nano-count [-] number>string write - " nanos" write - ] when* - ] with-cell ; - -: threads. ( -- ) - standard-table-style [ - [ - { "ID:" "Name:" "Waiting on:" "Remaining sleep:" } - [ [ write ] with-cell ] each - ] with-row - - threads sort-keys values [ - [ thread. ] with-row - ] each - ] tabular-output nl ; +! Copyright (C) 2008, 2010 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs io io.styles kernel math.order +math.parser prettyprint sequences sorting system threads ; +IN: tools.threads + +: thread. ( thread -- ) + dup id>> pprint-cell + dup name>> [ + over write-object + ] with-cell + dup state>> [ + [ dup self eq? "running" "yield" ? ] unless* + write + ] with-cell + [ + sleep-entry>> [ + key>> nano-count [-] number>string write + " nanos" write + ] when* + ] with-cell ; + +: threads. ( -- ) + standard-table-style [ + [ + { "ID:" "Name:" "Waiting on:" "Remaining sleep:" } + [ [ write ] with-cell ] each + ] with-row + + threads sort-keys values [ + [ thread. ] with-row + ] each + ] tabular-output nl ; diff --git a/basis/tools/walker/debug/debug.factor b/basis/tools/walker/debug/debug.factor index b776a2c574..a777a28422 100644 --- a/basis/tools/walker/debug/debug.factor +++ b/basis/tools/walker/debug/debug.factor @@ -26,5 +26,5 @@ IN: tools.walker.debug send-synchronous drop p ?promise - variables>> walker-continuation of + variables>> walker-continuation of value>> data>> ; diff --git a/basis/tools/walker/walker.factor b/basis/tools/walker/walker.factor index f2516e18d8..205f9f6703 100644 --- a/basis/tools/walker/walker.factor +++ b/basis/tools/walker/walker.factor @@ -118,7 +118,7 @@ SYMBOL: +stopped+ } case f ] handle-synchronous ] while ; - + : walker-loop ( -- ) +running+ set-status [ status +stopped+ eq? ] [ diff --git a/basis/typed/namespaces/namespaces.factor b/basis/typed/namespaces/namespaces.factor index bca92ff089..f86ad952a3 100644 --- a/basis/typed/namespaces/namespaces.factor +++ b/basis/typed/namespaces/namespaces.factor @@ -37,4 +37,3 @@ PRIVATE> : typed-set-global ( value name type -- ) [ set-global ] (typed-set) ; inline - diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor index 019faeb5d6..11f3c2a963 100644 --- a/basis/ui/backend/cocoa/cocoa.factor +++ b/basis/ui/backend/cocoa/cocoa.factor @@ -103,7 +103,7 @@ M: cocoa-ui-backend set-title ( string world -- ) : exit-fullscreen ( world -- ) handle>> - [ view>> f -> exitFullScreenModeWithOptions: ] + [ view>> f -> exitFullScreenModeWithOptions: ] [ [ window>> ] [ view>> ] bi -> makeFirstResponder: drop ] bi ; M: cocoa-ui-backend (set-fullscreen) ( world ? -- ) @@ -263,4 +263,3 @@ cocoa-ui-backend ui-backend set-global M: cocoa-ui-backend ui-backend-available? running.app? ; - diff --git a/basis/ui/backend/gtk/io/io.factor b/basis/ui/backend/gtk/io/io.factor index c2284a3d13..04a69690da 100644 --- a/basis/ui/backend/gtk/io/io.factor +++ b/basis/ui/backend/gtk/io/io.factor @@ -5,4 +5,4 @@ IN: ui.backend.gtk.io HOOK: with-event-loop io-backend ( quot -- ) -M: object with-event-loop call( -- ) ; \ No newline at end of file +M: object with-event-loop call( -- ) ; diff --git a/basis/ui/baseline-alignment/baseline-alignment.factor b/basis/ui/baseline-alignment/baseline-alignment.factor index 2527b52295..46729877d8 100644 --- a/basis/ui/baseline-alignment/baseline-alignment.factor +++ b/basis/ui/baseline-alignment/baseline-alignment.factor @@ -61,7 +61,7 @@ TUPLE: gadget-metrics height ascent descent cap-height ; :: combine-metrics ( graphics-height ascent descent cap-height -- ascent' descent' ) ascent [ - cap-height 2 / :> mid-line + cap-height 2 / :> mid-line graphics-height 2 / [ ascent mid-line - max mid-line + floor >integer ] [ descent mid-line + max mid-line - ceiling >integer ] bi diff --git a/basis/ui/commands/commands.factor b/basis/ui/commands/commands.factor index 5ff99e658d..9fdec5bf5a 100644 --- a/basis/ui/commands/commands.factor +++ b/basis/ui/commands/commands.factor @@ -55,7 +55,7 @@ TR: convert-command-name "-" " " ; convert-command-name >title ; M: word command-name ( word -- str ) - name>> + name>> "com-" ?head drop "." ?tail drop dup first Letter? [ rest ] unless (command-name) ; diff --git a/basis/ui/debugger/debugger.factor b/basis/ui/debugger/debugger.factor index e0abfe05be..ec4534a3dc 100644 --- a/basis/ui/debugger/debugger.factor +++ b/basis/ui/debugger/debugger.factor @@ -1,23 +1,23 @@ -! Copyright (C) 2006, 2011 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors continuations debugger io io.streams.string -kernel namespaces prettyprint ui ui.gadgets.worlds ; -IN: ui.debugger - -: error-alert ( error -- ) - [ "Error" ] dip [ print-error ] with-string-writer - system-alert ; - -! ( error -- ) -[ error-alert ] ui-error-hook set-global - -! ( error -- ) -[ - ui-running? [ dup error-alert ] [ dup print-error ] if die -] callback-error-hook set-global - -M: world-error error. - "An error occurred while drawing the world " write - dup world>> pprint-short "." print - "This world has been deactivated to prevent cascading errors." print - error>> error. ; +! Copyright (C) 2006, 2011 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors continuations debugger io io.streams.string +kernel namespaces prettyprint ui ui.gadgets.worlds ; +IN: ui.debugger + +: error-alert ( error -- ) + [ "Error" ] dip [ print-error ] with-string-writer + system-alert ; + +! ( error -- ) +[ error-alert ] ui-error-hook set-global + +! ( error -- ) +[ + ui-running? [ dup error-alert ] [ dup print-error ] if die +] callback-error-hook set-global + +M: world-error error. + "An error occurred while drawing the world " write + dup world>> pprint-short "." print + "This world has been deactivated to prevent cascading errors." print + error>> error. ; diff --git a/basis/ui/gadgets/canvas/canvas-tests.factor b/basis/ui/gadgets/canvas/canvas-tests.factor index bc87064c92..d87a4d76f3 100644 --- a/basis/ui/gadgets/canvas/canvas-tests.factor +++ b/basis/ui/gadgets/canvas/canvas-tests.factor @@ -1,4 +1,4 @@ -IN: ui.gadgets.canvas.tests -USING: ui.gadgets.canvas tools.test kernel ; - -{ 1 0 } [ [ drop ] draw-canvas ] must-infer-as +IN: ui.gadgets.canvas.tests +USING: ui.gadgets.canvas tools.test kernel ; + +{ 1 0 } [ [ drop ] draw-canvas ] must-infer-as diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor index f3e109f16b..df81156981 100644 --- a/basis/ui/gadgets/editors/editors.factor +++ b/basis/ui/gadgets/editors/editors.factor @@ -341,22 +341,22 @@ M: editor gadget-text* editor-string % ; [ drop dup extend-selection dup mark>> click-loc ] [ select-elt ] if ; -: delete-previous-character ( editor -- ) +: delete-previous-character ( editor -- ) char-elt editor-backspace ; -: delete-next-character ( editor -- ) +: delete-next-character ( editor -- ) char-elt editor-delete ; -: delete-previous-word ( editor -- ) +: delete-previous-word ( editor -- ) word-elt editor-backspace ; -: delete-next-word ( editor -- ) +: delete-next-word ( editor -- ) word-elt editor-delete ; -: delete-to-start-of-line ( editor -- ) +: delete-to-start-of-line ( editor -- ) one-line-elt editor-backspace ; -: delete-to-end-of-line ( editor -- ) +: delete-to-end-of-line ( editor -- ) one-line-elt editor-delete ; : delete-to-start-of-document ( editor -- ) @@ -445,28 +445,28 @@ editor "caret-motion" f { [ dup select-word ] unless gadget-selection ; -: select-previous-character ( editor -- ) +: select-previous-character ( editor -- ) char-elt editor-select-prev ; -: select-next-character ( editor -- ) +: select-next-character ( editor -- ) char-elt editor-select-next ; -: select-previous-word ( editor -- ) +: select-previous-word ( editor -- ) word-elt editor-select-prev ; -: select-next-word ( editor -- ) +: select-next-word ( editor -- ) word-elt editor-select-next ; -: select-start-of-line ( editor -- ) +: select-start-of-line ( editor -- ) one-line-elt editor-select-prev ; -: select-end-of-line ( editor -- ) +: select-end-of-line ( editor -- ) one-line-elt editor-select-next ; -: select-start-of-document ( editor -- ) +: select-start-of-document ( editor -- ) doc-elt editor-select-prev ; -: select-end-of-document ( editor -- ) +: select-end-of-document ( editor -- ) doc-elt editor-select-next ; editor "selection" f { diff --git a/basis/ui/gadgets/panes/panes.factor b/basis/ui/gadgets/panes/panes.factor index 2f2929fa5c..b0ba2e9aae 100644 --- a/basis/ui/gadgets/panes/panes.factor +++ b/basis/ui/gadgets/panes/panes.factor @@ -444,4 +444,3 @@ M: string content-gadget '[ _ write ] make-pane { 450 100 } >>pref-dim ; - diff --git a/basis/ui/gadgets/prettyprint/prettyprint.factor b/basis/ui/gadgets/prettyprint/prettyprint.factor index 82a89eda11..45b540994e 100644 --- a/basis/ui/gadgets/prettyprint/prettyprint.factor +++ b/basis/ui/gadgets/prettyprint/prettyprint.factor @@ -4,4 +4,4 @@ USING: ui.gadgets prettyprint.backend prettyprint.custom ; IN: ui.gadgets.prettyprint ! Don't print gadgets with RECT: syntax -M: gadget pprint* pprint-tuple ; \ No newline at end of file +M: gadget pprint* pprint-tuple ; diff --git a/basis/ui/gadgets/scrollers/scrollers.factor b/basis/ui/gadgets/scrollers/scrollers.factor index a02c6deb2a..4cbd0441a8 100644 --- a/basis/ui/gadgets/scrollers/scrollers.factor +++ b/basis/ui/gadgets/scrollers/scrollers.factor @@ -99,7 +99,7 @@ M: scroller layout* [ call-next-method ] [ dup follows>> [ update-scroller ] [ >>follows drop ] 2bi - ] bi ; + ] bi ; M: scroller focusable-child* viewport>> ; diff --git a/basis/ui/gadgets/sliders/sliders.factor b/basis/ui/gadgets/sliders/sliders.factor index 95e34cc0ff..19b8a43885 100644 --- a/basis/ui/gadgets/sliders/sliders.factor +++ b/basis/ui/gadgets/sliders/sliders.factor @@ -242,4 +242,3 @@ PRIVATE> [ f track-add ] [ drop { 1 1 } >>dim f track-add ] } cleave ; - diff --git a/basis/ui/gadgets/slots/slots.factor b/basis/ui/gadgets/slots/slots.factor index f09b2e53b3..6bc255bfc2 100644 --- a/basis/ui/gadgets/slots/slots.factor +++ b/basis/ui/gadgets/slots/slots.factor @@ -69,7 +69,7 @@ TUPLE: slot-editor < track ref close-hook update-hook text ; >>text dup text>> 1 track-add dup revert ; - + M: slot-editor pref-dim* call-next-method { 600 200 } vmin ; M: slot-editor focusable-child* text>> ; diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index 72eaba9647..51e95ac4cc 100644 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -74,7 +74,7 @@ TUPLE: world-attributes f >>grab-input? dup focused?>> [ handle>> (ungrab-input) ] [ drop ] if ] [ drop ] if ; - + : show-status ( string/f gadget -- ) dup find-world dup [ dup status>> [ diff --git a/basis/ui/pens/image/image.factor b/basis/ui/pens/image/image.factor index b67669f212..e3e30b9812 100644 --- a/basis/ui/pens/image/image.factor +++ b/basis/ui/pens/image/image.factor @@ -17,4 +17,3 @@ M: image-pen draw-interior ] if ; M: image-pen pen-pref-dim nip image>> image-dim ; - diff --git a/basis/ui/pens/pens.factor b/basis/ui/pens/pens.factor index 9a1717f534..97952f5ae8 100644 --- a/basis/ui/pens/pens.factor +++ b/basis/ui/pens/pens.factor @@ -17,4 +17,4 @@ M: object pen-foreground 2drop f ; GENERIC: pen-pref-dim ( gadget pen -- dim ) -M: object pen-pref-dim 2drop { 0 0 } ; \ No newline at end of file +M: object pen-pref-dim 2drop { 0 0 } ; diff --git a/basis/ui/pens/solid/solid.factor b/basis/ui/pens/solid/solid.factor index fe44a8f341..0cfc48edc1 100644 --- a/basis/ui/pens/solid/solid.factor +++ b/basis/ui/pens/solid/solid.factor @@ -29,4 +29,4 @@ M: solid draw-boundary (gl-rect) ; M: solid pen-background - nip color>> dup alpha>> 1 number= [ drop transparent ] unless ; \ No newline at end of file + nip color>> dup alpha>> 1 number= [ drop transparent ] unless ; diff --git a/basis/ui/pens/tile/tile.factor b/basis/ui/pens/tile/tile.factor index 7f26e928aa..72f9c44421 100644 --- a/basis/ui/pens/tile/tile.factor +++ b/basis/ui/pens/tile/tile.factor @@ -49,4 +49,4 @@ M: tile-pen draw-interior ( gadget pen -- ) M: tile-pen pen-background nip background>> ; -M: tile-pen pen-foreground nip foreground>> ; \ No newline at end of file +M: tile-pen pen-foreground nip foreground>> ; diff --git a/basis/ui/text/uniscribe/uniscribe.factor b/basis/ui/text/uniscribe/uniscribe.factor index b06ec10506..df6fdf26c2 100644 --- a/basis/ui/text/uniscribe/uniscribe.factor +++ b/basis/ui/text/uniscribe/uniscribe.factor @@ -1,35 +1,35 @@ -! Copyright (C) 2009, 2010 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs cache kernel math math.vectors sequences -fonts namespaces ui.text ui.text.private windows.uniscribe ; -IN: ui.text.uniscribe - -SINGLETON: uniscribe-renderer - -M: uniscribe-renderer string-dim - [ " " string-dim { 0 1 } v* ] - [ cached-script-string size>> ] if-empty ; - -M: uniscribe-renderer flush-layout-cache - cached-script-strings get-global purge-cache ; - -M: uniscribe-renderer string>image ( font string -- image loc ) - cached-script-string script-string>image { 0 0 } ; - -M: uniscribe-renderer x>offset ( x font string -- n ) - [ 2drop 0 ] [ - cached-script-string x>line-offset 0 = [ 1 + ] unless - ] if-empty ; - -M: uniscribe-renderer offset>x ( n font string -- x ) - [ 2drop 0 ] [ cached-script-string line-offset>x ] if-empty ; - -M: uniscribe-renderer font-metrics ( font -- metrics ) - " " cached-script-string metrics>> clone f >>width ; - -M: uniscribe-renderer line-metrics ( font string -- metrics ) - [ " " line-metrics clone 0 >>width ] - [ cached-script-string metrics>> 50 >>width 10 >>cap-height 10 >>x-height ] - if-empty ; - -uniscribe-renderer font-renderer set-global +! Copyright (C) 2009, 2010 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs cache kernel math math.vectors sequences +fonts namespaces ui.text ui.text.private windows.uniscribe ; +IN: ui.text.uniscribe + +SINGLETON: uniscribe-renderer + +M: uniscribe-renderer string-dim + [ " " string-dim { 0 1 } v* ] + [ cached-script-string size>> ] if-empty ; + +M: uniscribe-renderer flush-layout-cache + cached-script-strings get-global purge-cache ; + +M: uniscribe-renderer string>image ( font string -- image loc ) + cached-script-string script-string>image { 0 0 } ; + +M: uniscribe-renderer x>offset ( x font string -- n ) + [ 2drop 0 ] [ + cached-script-string x>line-offset 0 = [ 1 + ] unless + ] if-empty ; + +M: uniscribe-renderer offset>x ( n font string -- x ) + [ 2drop 0 ] [ cached-script-string line-offset>x ] if-empty ; + +M: uniscribe-renderer font-metrics ( font -- metrics ) + " " cached-script-string metrics>> clone f >>width ; + +M: uniscribe-renderer line-metrics ( font string -- metrics ) + [ " " line-metrics clone 0 >>width ] + [ cached-script-string metrics>> 50 >>width 10 >>cap-height 10 >>x-height ] + if-empty ; + +uniscribe-renderer font-renderer set-global diff --git a/basis/ui/tools/browser/history/history.factor b/basis/ui/tools/browser/history/history.factor index f80189c783..f8fcf09b2e 100644 --- a/basis/ui/tools/browser/history/history.factor +++ b/basis/ui/tools/browser/history/history.factor @@ -29,4 +29,4 @@ GENERIC: set-history-value ( value object -- ) : add-history ( history -- ) dup forward>> delete-all - dup back>> (add-history) ; \ No newline at end of file + dup back>> (add-history) ; diff --git a/basis/ui/tools/deploy/deploy.factor b/basis/ui/tools/deploy/deploy.factor index 557a87b944..22e0df58f3 100644 --- a/basis/ui/tools/deploy/deploy.factor +++ b/basis/ui/tools/deploy/deploy.factor @@ -108,7 +108,7 @@ deploy-gadget "toolbar" f { dup { 10 10 } >>gap add-gadget deploy-settings-theme dup com-revert ; - + : deploy-tool ( vocab -- ) vocab-name [ { 10 10 } ] diff --git a/basis/ui/tools/error-list/error-list.factor b/basis/ui/tools/error-list/error-list.factor index f9ca9ceeee..cbefaed0b1 100644 --- a/basis/ui/tools/error-list/error-list.factor +++ b/basis/ui/tools/error-list/error-list.factor @@ -156,7 +156,7 @@ error-display "toolbar" f { :: ( model -- gadget ) vertical \ error-list-gadget new-track [ >>error-toggle ] [ >>visible-errors ] bi* - dup visible-errors>> model >>model + dup visible-errors>> model >>model f >>source-file f >>error dup >>source-file-table diff --git a/basis/ui/tools/listener/popups/popups.factor b/basis/ui/tools/listener/popups/popups.factor index 9329c0ebe8..f4be066459 100644 --- a/basis/ui/tools/listener/popups/popups.factor +++ b/basis/ui/tools/listener/popups/popups.factor @@ -15,4 +15,4 @@ IN: ui.tools.listener.popups [ caret-loc ] [ drop caret-dim { 0 1 } v+ ] 2bi ; : show-listener-popup ( interactor element popup -- ) - [ [ drop ] [ relevant-rect ] 2bi ] dip swap show-popup ; \ No newline at end of file + [ [ drop ] [ relevant-rect ] 2bi ] dip swap show-popup ; diff --git a/basis/ui/tools/walker/walker-docs.factor b/basis/ui/tools/walker/walker-docs.factor index 81dfdf9cad..a100783acd 100644 --- a/basis/ui/tools/walker/walker-docs.factor +++ b/basis/ui/tools/walker/walker-docs.factor @@ -1,37 +1,37 @@ -IN: ui.tools.walker -USING: help.markup help.syntax ui.commands ui.operations -ui.render tools.walker sequences tools.continuations ; - -ARTICLE: "ui-walker-step" "Stepping through code" -"If the current position points to a word, the various stepping commands behave as follows:" -{ $list - { { $link com-step } " executes the word and moves the current position one word further." } - { { $link com-into } " enters the word's definition, unless it is a primitive, in which case it behaves like " { $link com-step } "." } - { { $link com-out } " executes until the end of the current quotation." } -} -"If the current position points to a literal, the various stepping commands behave as follows:" -{ $list - { { $link com-step } " pushes the literal on the data stack." } - { { $link com-into } " pushes the literal. If it is a quotation, a breakpoint is inserted at the beginning of the quotation, and if it is an array of quotations, a breakpoint is inserted at the beginning of each quotation element." } - { { $link com-out } " executes until the end of the current quotation." } -} -"The behavior of the " { $link com-into } " command is useful when debugging code using combinators. Instead of stepping into the definition of a combinator, which may be quite complex, you can set a breakpoint on the quotation and continue. For example, suppose the following quotation is being walked:" -{ $code "{ 10 20 30 } [ 3 + . ] each" } -"If the current position is on the quotation and " { $link com-into } " is invoked, the following quotation is pushed on the stack:" -{ $code "[ break 3 + . ]" } -"Invoking " { $link com-continue } " will continue execution until the breakpoint is hit, which in this case happens immediately. The stack can then be inspected to verify that the first element of the array, 10, was pushed. Invoking " { $link com-continue } " proceeds until the breakpoint is hit on the second iteration, at which time the top of the stack will contain the value 20. Invoking " { $link com-continue } " a third time will proceed on to the final iteration where 30 is at the top of the stack. Invoking " { $link com-continue } " again will end the walk of this code snippet, since no more iterations remain the quotation will never be called again and the breakpoint will not be hit." -$nl -"The " { $link com-back } " command travels backwards through time, and restore stacks. This does not undo side effects (modifying array entries, writing to files, formatting the hard drive, etc) and therefore can only be used reliably on referentially transparent code." ; - -ARTICLE: "ui-walker" "UI walker" -"The walker single-steps through quotations. To use the walker, enter a piece of code in the listener's input area and press " { $operation walk } "." -$nl -"Walkers are instances of " { $link walker-gadget } "." -{ $subsections - "ui-walker-step" - "breakpoints" -} -{ $command-map walker-gadget "toolbar" } -{ $command-map walker-gadget "multitouch" } ; - -ABOUT: "ui-walker" +IN: ui.tools.walker +USING: help.markup help.syntax ui.commands ui.operations +ui.render tools.walker sequences tools.continuations ; + +ARTICLE: "ui-walker-step" "Stepping through code" +"If the current position points to a word, the various stepping commands behave as follows:" +{ $list + { { $link com-step } " executes the word and moves the current position one word further." } + { { $link com-into } " enters the word's definition, unless it is a primitive, in which case it behaves like " { $link com-step } "." } + { { $link com-out } " executes until the end of the current quotation." } +} +"If the current position points to a literal, the various stepping commands behave as follows:" +{ $list + { { $link com-step } " pushes the literal on the data stack." } + { { $link com-into } " pushes the literal. If it is a quotation, a breakpoint is inserted at the beginning of the quotation, and if it is an array of quotations, a breakpoint is inserted at the beginning of each quotation element." } + { { $link com-out } " executes until the end of the current quotation." } +} +"The behavior of the " { $link com-into } " command is useful when debugging code using combinators. Instead of stepping into the definition of a combinator, which may be quite complex, you can set a breakpoint on the quotation and continue. For example, suppose the following quotation is being walked:" +{ $code "{ 10 20 30 } [ 3 + . ] each" } +"If the current position is on the quotation and " { $link com-into } " is invoked, the following quotation is pushed on the stack:" +{ $code "[ break 3 + . ]" } +"Invoking " { $link com-continue } " will continue execution until the breakpoint is hit, which in this case happens immediately. The stack can then be inspected to verify that the first element of the array, 10, was pushed. Invoking " { $link com-continue } " proceeds until the breakpoint is hit on the second iteration, at which time the top of the stack will contain the value 20. Invoking " { $link com-continue } " a third time will proceed on to the final iteration where 30 is at the top of the stack. Invoking " { $link com-continue } " again will end the walk of this code snippet, since no more iterations remain the quotation will never be called again and the breakpoint will not be hit." +$nl +"The " { $link com-back } " command travels backwards through time, and restore stacks. This does not undo side effects (modifying array entries, writing to files, formatting the hard drive, etc) and therefore can only be used reliably on referentially transparent code." ; + +ARTICLE: "ui-walker" "UI walker" +"The walker single-steps through quotations. To use the walker, enter a piece of code in the listener's input area and press " { $operation walk } "." +$nl +"Walkers are instances of " { $link walker-gadget } "." +{ $subsections + "ui-walker-step" + "breakpoints" +} +{ $command-map walker-gadget "toolbar" } +{ $command-map walker-gadget "multitouch" } ; + +ABOUT: "ui-walker" diff --git a/basis/ui/tools/walker/walker.factor b/basis/ui/tools/walker/walker.factor index 6728fb8338..2fda954e4e 100644 --- a/basis/ui/tools/walker/walker.factor +++ b/basis/ui/tools/walker/walker.factor @@ -65,7 +65,7 @@ M: walker-gadget focusable-child* add-toolbar dup status>> self f track-add dup traceback>> 1 track-add ; - + : walker-help ( -- ) "ui-walker" com-browse ; \ walker-help H{ { +nullary+ t } } define-command diff --git a/basis/unicode/collation/collation-tests.factor b/basis/unicode/collation/collation-tests.factor index add0cbe677..f76e93d066 100644 --- a/basis/unicode/collation/collation-tests.factor +++ b/basis/unicode/collation/collation-tests.factor @@ -1,29 +1,29 @@ -USING: io io.files splitting grouping unicode.collation -sequences kernel io.encodings.utf8 math.parser math.order -tools.test assocs words ; -IN: unicode.collation.tests - -: parse-test ( -- strings ) - "vocab:unicode/collation/CollationTest_SHIFTED.txt" - utf8 file-lines 5 tail - [ ";" split1 drop " " split [ hex> ] "" map-as ] map ; - -: test-two ( str1 str2 -- ) - [ +lt+ ] -rot [ string<=> ] 2curry unit-test ; - -: test-equality ( str1 str2 -- ? ? ? ? ) - { primary= secondary= tertiary= quaternary= } - [ execute( a b -- ? ) ] 2with map - first4 ; - -[ f f f f ] [ "hello" "hi" test-equality ] unit-test -[ t f f f ] [ "hello" "h\u0000e9llo" test-equality ] unit-test -[ t t f f ] [ "hello" "HELLO" test-equality ] unit-test -[ t t t f ] [ "hello" "h e l l o." test-equality ] unit-test -[ t t t t ] [ "hello" "\0hello\0" test-equality ] unit-test -[ { "good bye" "goodbye" "hello" "HELLO" } ] -[ { "HELLO" "goodbye" "good bye" "hello" } sort-strings ] -unit-test - -parse-test 2 -[ test-two ] assoc-each +USING: io io.files splitting grouping unicode.collation +sequences kernel io.encodings.utf8 math.parser math.order +tools.test assocs words ; +IN: unicode.collation.tests + +: parse-test ( -- strings ) + "vocab:unicode/collation/CollationTest_SHIFTED.txt" + utf8 file-lines 5 tail + [ ";" split1 drop " " split [ hex> ] "" map-as ] map ; + +: test-two ( str1 str2 -- ) + [ +lt+ ] -rot [ string<=> ] 2curry unit-test ; + +: test-equality ( str1 str2 -- ? ? ? ? ) + { primary= secondary= tertiary= quaternary= } + [ execute( a b -- ? ) ] 2with map + first4 ; + +[ f f f f ] [ "hello" "hi" test-equality ] unit-test +[ t f f f ] [ "hello" "h\u0000e9llo" test-equality ] unit-test +[ t t f f ] [ "hello" "HELLO" test-equality ] unit-test +[ t t t f ] [ "hello" "h e l l o." test-equality ] unit-test +[ t t t t ] [ "hello" "\0hello\0" test-equality ] unit-test +[ { "good bye" "goodbye" "hello" "HELLO" } ] +[ { "HELLO" "goodbye" "good bye" "hello" } sort-strings ] +unit-test + +parse-test 2 +[ test-two ] assoc-each diff --git a/basis/unicode/collation/collation.factor b/basis/unicode/collation/collation.factor index 65d3887fc9..02d813afce 100644 --- a/basis/unicode/collation/collation.factor +++ b/basis/unicode/collation/collation.factor @@ -1,159 +1,159 @@ -! Copyright (C) 2008 Daniel Ehrenberg. -! See http://factorcode.org/license.txt for BSD license. -USING: sequences io.files io.encodings.ascii kernel splitting -accessors math.parser ascii io assocs strings math namespaces make -sorting combinators math.order arrays unicode.normalize unicode.data -locals macros sequences.deep words unicode.breaks quotations -combinators.short-circuit simple-flat-file ; -IN: unicode.collation - ->ignorable? - swap "." split first3 [ hex> ] tri@ - [ >>primary ] [ >>secondary ] [ >>tertiary ] tri* - ] map ; - -: parse-keys ( string -- chars ) - " " split [ hex> ] "" map-as ; - -: parse-ducet ( file -- ducet ) - data [ [ parse-keys ] [ parse-weight ] bi* ] H{ } assoc-map-as ; - -"vocab:unicode/collation/allkeys.txt" parse-ducet ducet set-global - -! Fix up table for long contractions -: help-one ( assoc key -- ) - ! Need to be more general? Not for DUCET, apparently - 2 head 2dup swap key? [ 2drop ] [ - [ [ 1string of ] with { } map-as concat ] - [ swap set-at ] 2bi - ] if ; - -: insert-helpers ( assoc -- ) - dup keys [ length 3 >= ] filter - [ help-one ] with each ; - -ducet get-global insert-helpers - -: base ( char -- base ) - { - { [ dup 0x3400 0x4DB5 between? ] [ drop 0xFB80 ] } ! Extension A - { [ dup 0x20000 0x2A6D6 between? ] [ drop 0xFB80 ] } ! Extension B - { [ dup 0x4E00 0x9FC3 between? ] [ drop 0xFB40 ] } ! CJK - [ drop 0xFBC0 ] ! Other - } cond ; - -: AAAA ( char -- weight ) - [ base ] [ -15 shift ] bi + 0x20 2 f weight boa ; - -: BBBB ( char -- weight ) - 0x7FFF bitand 0x8000 bitor 0 0 f weight boa ; - -: illegal? ( char -- ? ) - { [ "Noncharacter_Code_Point" property? ] [ category "Cs" = ] } 1|| ; - -: derive-weight ( char -- weights ) - first dup illegal? - [ drop { } ] - [ [ AAAA ] [ BBBB ] bi 2array ] if ; - -: building-last ( -- char ) - building get empty? [ 0 ] [ building get last last ] if ; - -: blocked? ( char -- ? ) - combining-class dup { 0 f } member? - [ drop building-last non-starter? ] - [ building-last combining-class = ] if ; - -: possible-bases ( -- slice-of-building ) - building get dup [ first non-starter? not ] find-last - drop [ 0 ] unless* tail-slice ; - -:: ?combine ( char slice i -- ? ) - i slice nth char suffix :> str - str ducet get-global key? dup - [ str i slice set-nth ] when ; - -: add ( char -- ) - dup blocked? [ 1string , ] [ - dup possible-bases dup length iota - [ ?combine ] 2with any? - [ drop ] [ 1string , ] if - ] if ; - -: string>graphemes ( string -- graphemes ) - [ [ add ] each ] { } make ; - -: graphemes>weights ( graphemes -- weights ) - [ - dup weight? [ 1array ] ! From tailoring - [ dup ducet get-global at [ ] [ derive-weight ] ?if ] if - ] { } map-as concat ; - -: append-weights ( weights quot -- ) - [ [ ignorable?>> ] reject ] dip - map [ zero? ] reject % 0 , ; inline - -: variable-weight ( weight -- ) - dup ignorable?>> [ primary>> ] [ drop 0xFFFF ] if , ; - -: weights>bytes ( weights -- byte-array ) - [ - { - [ [ primary>> ] append-weights ] - [ [ secondary>> ] append-weights ] - [ [ tertiary>> ] append-weights ] - [ [ variable-weight ] each ] - } cleave - ] { } make ; -PRIVATE> - -: completely-ignorable? ( weight -- ? ) - [ primary>> ] [ secondary>> ] [ tertiary>> ] tri - [ zero? ] tri@ and and ; - -: filter-ignorable ( weights -- weights' ) - f swap [ - [ nip ] [ primary>> zero? and ] 2bi - [ swap ignorable?>> or ] - [ swap completely-ignorable? or not ] 2bi - ] filter nip ; - -: collation-key ( string -- key ) - nfd string>graphemes graphemes>weights - filter-ignorable weights>bytes ; - - - -: primary= ( str1 str2 -- ? ) - 3 insensitive= ; - -: secondary= ( str1 str2 -- ? ) - 2 insensitive= ; - -: tertiary= ( str1 str2 -- ? ) - 1 insensitive= ; - -: quaternary= ( str1 str2 -- ? ) - 0 insensitive= ; - -: w/collation-key ( str -- {str,key} ) - [ collation-key ] keep 2array ; - -: sort-strings ( strings -- sorted ) - [ w/collation-key ] map natural-sort values ; - -: string<=> ( str1 str2 -- <=> ) - [ w/collation-key ] compare ; +! Copyright (C) 2008 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: sequences io.files io.encodings.ascii kernel splitting +accessors math.parser ascii io assocs strings math namespaces make +sorting combinators math.order arrays unicode.normalize unicode.data +locals macros sequences.deep words unicode.breaks quotations +combinators.short-circuit simple-flat-file ; +IN: unicode.collation + +>ignorable? + swap "." split first3 [ hex> ] tri@ + [ >>primary ] [ >>secondary ] [ >>tertiary ] tri* + ] map ; + +: parse-keys ( string -- chars ) + " " split [ hex> ] "" map-as ; + +: parse-ducet ( file -- ducet ) + data [ [ parse-keys ] [ parse-weight ] bi* ] H{ } assoc-map-as ; + +"vocab:unicode/collation/allkeys.txt" parse-ducet ducet set-global + +! Fix up table for long contractions +: help-one ( assoc key -- ) + ! Need to be more general? Not for DUCET, apparently + 2 head 2dup swap key? [ 2drop ] [ + [ [ 1string of ] with { } map-as concat ] + [ swap set-at ] 2bi + ] if ; + +: insert-helpers ( assoc -- ) + dup keys [ length 3 >= ] filter + [ help-one ] with each ; + +ducet get-global insert-helpers + +: base ( char -- base ) + { + { [ dup 0x3400 0x4DB5 between? ] [ drop 0xFB80 ] } ! Extension A + { [ dup 0x20000 0x2A6D6 between? ] [ drop 0xFB80 ] } ! Extension B + { [ dup 0x4E00 0x9FC3 between? ] [ drop 0xFB40 ] } ! CJK + [ drop 0xFBC0 ] ! Other + } cond ; + +: AAAA ( char -- weight ) + [ base ] [ -15 shift ] bi + 0x20 2 f weight boa ; + +: BBBB ( char -- weight ) + 0x7FFF bitand 0x8000 bitor 0 0 f weight boa ; + +: illegal? ( char -- ? ) + { [ "Noncharacter_Code_Point" property? ] [ category "Cs" = ] } 1|| ; + +: derive-weight ( char -- weights ) + first dup illegal? + [ drop { } ] + [ [ AAAA ] [ BBBB ] bi 2array ] if ; + +: building-last ( -- char ) + building get empty? [ 0 ] [ building get last last ] if ; + +: blocked? ( char -- ? ) + combining-class dup { 0 f } member? + [ drop building-last non-starter? ] + [ building-last combining-class = ] if ; + +: possible-bases ( -- slice-of-building ) + building get dup [ first non-starter? not ] find-last + drop [ 0 ] unless* tail-slice ; + +:: ?combine ( char slice i -- ? ) + i slice nth char suffix :> str + str ducet get-global key? dup + [ str i slice set-nth ] when ; + +: add ( char -- ) + dup blocked? [ 1string , ] [ + dup possible-bases dup length iota + [ ?combine ] 2with any? + [ drop ] [ 1string , ] if + ] if ; + +: string>graphemes ( string -- graphemes ) + [ [ add ] each ] { } make ; + +: graphemes>weights ( graphemes -- weights ) + [ + dup weight? [ 1array ] ! From tailoring + [ dup ducet get-global at [ ] [ derive-weight ] ?if ] if + ] { } map-as concat ; + +: append-weights ( weights quot -- ) + [ [ ignorable?>> ] reject ] dip + map [ zero? ] reject % 0 , ; inline + +: variable-weight ( weight -- ) + dup ignorable?>> [ primary>> ] [ drop 0xFFFF ] if , ; + +: weights>bytes ( weights -- byte-array ) + [ + { + [ [ primary>> ] append-weights ] + [ [ secondary>> ] append-weights ] + [ [ tertiary>> ] append-weights ] + [ [ variable-weight ] each ] + } cleave + ] { } make ; +PRIVATE> + +: completely-ignorable? ( weight -- ? ) + [ primary>> ] [ secondary>> ] [ tertiary>> ] tri + [ zero? ] tri@ and and ; + +: filter-ignorable ( weights -- weights' ) + f swap [ + [ nip ] [ primary>> zero? and ] 2bi + [ swap ignorable?>> or ] + [ swap completely-ignorable? or not ] 2bi + ] filter nip ; + +: collation-key ( string -- key ) + nfd string>graphemes graphemes>weights + filter-ignorable weights>bytes ; + + + +: primary= ( str1 str2 -- ? ) + 3 insensitive= ; + +: secondary= ( str1 str2 -- ? ) + 2 insensitive= ; + +: tertiary= ( str1 str2 -- ? ) + 1 insensitive= ; + +: quaternary= ( str1 str2 -- ? ) + 0 insensitive= ; + +: w/collation-key ( str -- {str,key} ) + [ collation-key ] keep 2array ; + +: sort-strings ( strings -- sorted ) + [ w/collation-key ] map natural-sort values ; + +: string<=> ( str1 str2 -- <=> ) + [ w/collation-key ] compare ; diff --git a/basis/unicode/script/script-docs.factor b/basis/unicode/script/script-docs.factor index 266f32144b..ed255cc803 100644 --- a/basis/unicode/script/script-docs.factor +++ b/basis/unicode/script/script-docs.factor @@ -1,14 +1,14 @@ -! Copyright (C) 2009 Daniel Ehrenberg -! See http://factorcode.org/license.txt for BSD license. -USING: help.syntax help.markup strings ; -IN: unicode.script - -ABOUT: "unicode.script" - -ARTICLE: "unicode.script" "Unicode script properties" -"The unicode standard gives every character a script. Note that this is different from a language, and that it is non-trivial to detect language from a string. To get the script of a character, use" -{ $subsections script-of } ; - -HELP: script-of -{ $values { "char" "a code point" } { "script" string } } -{ $description "Finds the script of the given Unicode code point, represented as a string." } ; +! Copyright (C) 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: help.syntax help.markup strings ; +IN: unicode.script + +ABOUT: "unicode.script" + +ARTICLE: "unicode.script" "Unicode script properties" +"The unicode standard gives every character a script. Note that this is different from a language, and that it is non-trivial to detect language from a string. To get the script of a character, use" +{ $subsections script-of } ; + +HELP: script-of +{ $values { "char" "a code point" } { "script" string } } +{ $description "Finds the script of the given Unicode code point, represented as a string." } ; diff --git a/basis/unicode/script/script-tests.factor b/basis/unicode/script/script-tests.factor index 3088eea765..9a2467354a 100644 --- a/basis/unicode/script/script-tests.factor +++ b/basis/unicode/script/script-tests.factor @@ -1,4 +1,4 @@ -USING: unicode.script tools.test ; - -[ "Latin" ] [ CHAR: a script-of ] unit-test -[ "Common" ] [ 0 script-of ] unit-test +USING: unicode.script tools.test ; + +[ "Latin" ] [ CHAR: a script-of ] unit-test +[ "Common" ] [ 0 script-of ] unit-test diff --git a/basis/unix/groups/groups.factor b/basis/unix/groups/groups.factor index cfd37b0e56..e51ccc40c4 100644 --- a/basis/unix/groups/groups.factor +++ b/basis/unix/groups/groups.factor @@ -79,15 +79,15 @@ ERROR: no-group string ; ] if* ; PRIVATE> - + GENERIC: user-groups ( string/id -- seq ) M: string user-groups ( string -- seq ) - (user-groups) ; + (user-groups) ; M: integer user-groups ( id -- seq ) user-name (user-groups) ; - + : all-groups ( -- seq ) [ unix.ffi:getgrent dup ] [ group-struct>group ] produce nip endgrent ; @@ -139,14 +139,14 @@ GENERIC: set-effective-group ( obj -- ) [ unix.ffi:setegid ] unix-system-call drop ; inline PRIVATE> - + M: integer set-real-group ( id -- ) (set-real-group) ; M: string set-real-group ( string -- ) ?group-id (set-real-group) ; -M: integer set-effective-group ( id -- ) +M: integer set-effective-group ( id -- ) (set-effective-group) ; M: string set-effective-group ( string -- ) diff --git a/basis/unix/linux/inotify/inotify.factor b/basis/unix/linux/inotify/inotify.factor index 1e6edc985e..e641c61847 100644 --- a/basis/unix/linux/inotify/inotify.factor +++ b/basis/unix/linux/inotify/inotify.factor @@ -1,57 +1,57 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types alien.syntax math math.bitwise classes.struct -literals ; -IN: unix.linux.inotify - -STRUCT: inotify-event - { wd int } - { mask uint } - { cookie uint } - { len uint } - { name char[0] } ; - -CONSTANT: IN_ACCESS 0x1 ! File was accessed -CONSTANT: IN_MODIFY 0x2 ! File was modified -CONSTANT: IN_ATTRIB 0x4 ! Metadata changed -CONSTANT: IN_CLOSE_WRITE 0x8 ! Writtable file was closed -CONSTANT: IN_CLOSE_NOWRITE 0x10 ! Unwrittable file closed -CONSTANT: IN_OPEN 0x20 ! File was opened -CONSTANT: IN_MOVED_FROM 0x40 ! File was moved from X -CONSTANT: IN_MOVED_TO 0x80 ! File was moved to Y -CONSTANT: IN_CREATE 0x100 ! Subfile was created -CONSTANT: IN_DELETE 0x200 ! Subfile was deleted -CONSTANT: IN_DELETE_SELF 0x400 ! Self was deleted -CONSTANT: IN_MOVE_SELF 0x800 ! Self was moved - -CONSTANT: IN_UNMOUNT 0x2000 ! Backing fs was unmounted -CONSTANT: IN_Q_OVERFLOW 0x4000 ! Event queued overflowed -CONSTANT: IN_IGNORED 0x8000 ! File was ignored - -CONSTANT: IN_CLOSE flags{ IN_CLOSE_WRITE IN_CLOSE_NOWRITE } -CONSTANT: IN_MOVE flags{ IN_MOVED_FROM IN_MOVED_TO } - -CONSTANT: IN_ONLYDIR 0x1000000 ! only watch the path if it is a directory -CONSTANT: IN_DONT_FOLLOW 0x2000000 ! don't follow a sym link -CONSTANT: IN_MASK_ADD 0x20000000 ! add to the mask of an already existing watch -CONSTANT: IN_ISDIR 0x40000000 ! event occurred against dir -CONSTANT: IN_ONESHOT 0x80000000 ! only send event once - -CONSTANT: IN_CHANGE_EVENTS - flags{ - IN_MODIFY IN_ATTRIB IN_MOVED_FROM - IN_MOVED_TO IN_DELETE IN_CREATE IN_DELETE_SELF - IN_MOVE_SELF - } - -CONSTANT: IN_ALL_EVENTS - flags{ - IN_ACCESS IN_MODIFY IN_ATTRIB IN_CLOSE_WRITE - IN_CLOSE_NOWRITE IN_OPEN IN_MOVED_FROM - IN_MOVED_TO IN_DELETE IN_CREATE IN_DELETE_SELF - IN_MOVE_SELF - } - -FUNCTION: int inotify_init ( ) ; -FUNCTION: int inotify_add_watch ( int fd, c-string name, uint mask ) ; -FUNCTION: int inotify_rm_watch ( int fd, uint wd ) ; +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.c-types alien.syntax math math.bitwise classes.struct +literals ; +IN: unix.linux.inotify + +STRUCT: inotify-event + { wd int } + { mask uint } + { cookie uint } + { len uint } + { name char[0] } ; + +CONSTANT: IN_ACCESS 0x1 ! File was accessed +CONSTANT: IN_MODIFY 0x2 ! File was modified +CONSTANT: IN_ATTRIB 0x4 ! Metadata changed +CONSTANT: IN_CLOSE_WRITE 0x8 ! Writtable file was closed +CONSTANT: IN_CLOSE_NOWRITE 0x10 ! Unwrittable file closed +CONSTANT: IN_OPEN 0x20 ! File was opened +CONSTANT: IN_MOVED_FROM 0x40 ! File was moved from X +CONSTANT: IN_MOVED_TO 0x80 ! File was moved to Y +CONSTANT: IN_CREATE 0x100 ! Subfile was created +CONSTANT: IN_DELETE 0x200 ! Subfile was deleted +CONSTANT: IN_DELETE_SELF 0x400 ! Self was deleted +CONSTANT: IN_MOVE_SELF 0x800 ! Self was moved + +CONSTANT: IN_UNMOUNT 0x2000 ! Backing fs was unmounted +CONSTANT: IN_Q_OVERFLOW 0x4000 ! Event queued overflowed +CONSTANT: IN_IGNORED 0x8000 ! File was ignored + +CONSTANT: IN_CLOSE flags{ IN_CLOSE_WRITE IN_CLOSE_NOWRITE } +CONSTANT: IN_MOVE flags{ IN_MOVED_FROM IN_MOVED_TO } + +CONSTANT: IN_ONLYDIR 0x1000000 ! only watch the path if it is a directory +CONSTANT: IN_DONT_FOLLOW 0x2000000 ! don't follow a sym link +CONSTANT: IN_MASK_ADD 0x20000000 ! add to the mask of an already existing watch +CONSTANT: IN_ISDIR 0x40000000 ! event occurred against dir +CONSTANT: IN_ONESHOT 0x80000000 ! only send event once + +CONSTANT: IN_CHANGE_EVENTS + flags{ + IN_MODIFY IN_ATTRIB IN_MOVED_FROM + IN_MOVED_TO IN_DELETE IN_CREATE IN_DELETE_SELF + IN_MOVE_SELF + } + +CONSTANT: IN_ALL_EVENTS + flags{ + IN_ACCESS IN_MODIFY IN_ATTRIB IN_CLOSE_WRITE + IN_CLOSE_NOWRITE IN_OPEN IN_MOVED_FROM + IN_MOVED_TO IN_DELETE IN_CREATE IN_DELETE_SELF + IN_MOVE_SELF + } + +FUNCTION: int inotify_init ( ) ; +FUNCTION: int inotify_add_watch ( int fd, c-string name, uint mask ) ; +FUNCTION: int inotify_rm_watch ( int fd, uint wd ) ; diff --git a/basis/unix/types/linux/linux.factor b/basis/unix/types/linux/linux.factor index 7a09b0474a..9380e50d84 100644 --- a/basis/unix/types/linux/linux.factor +++ b/basis/unix/types/linux/linux.factor @@ -7,7 +7,7 @@ TYPEDEF: long __sword_type TYPEDEF: ulong __uword_type TYPEDEF: long __slongword_type TYPEDEF: uint __u32_type -TYPEDEF: int __s32_type +TYPEDEF: int __s32_type TYPEDEF: __uquad_type dev_t TYPEDEF: __ulongword_type ino_t diff --git a/basis/unix/users/users.factor b/basis/unix/users/users.factor index cebfb54b3f..ee2e592c1f 100644 --- a/basis/unix/users/users.factor +++ b/basis/unix/users/users.factor @@ -124,7 +124,7 @@ M: string set-real-user ( string -- ) ?user-id (set-real-user) ; M: integer set-effective-user ( id -- ) - (set-effective-user) ; + (set-effective-user) ; M: string set-effective-user ( string -- ) ?user-id (set-effective-user) ; diff --git a/basis/unix/utmpx/linux/linux.factor b/basis/unix/utmpx/linux/linux.factor index e218183087..6374eacaff 100644 --- a/basis/unix/utmpx/linux/linux.factor +++ b/basis/unix/utmpx/linux/linux.factor @@ -14,4 +14,3 @@ M: linux utmpx>utmpx-record ( utmpx -- utmpx-record ) [ ut_tv>> timeval>unix-time >>timestamp ] [ ut_host>> __UT_HOSTSIZE memory>string >>host ] } cleave ; - diff --git a/basis/validators/validators.factor b/basis/validators/validators.factor index a440ccff9c..cee7ccf6e1 100644 --- a/basis/validators/validators.factor +++ b/basis/validators/validators.factor @@ -89,7 +89,7 @@ IN: validators : v-mode ( str -- str ) dup mode-names member? [ - "not a valid syntax mode" throw + "not a valid syntax mode" throw ] unless ; : luhn? ( str -- ? ) diff --git a/basis/vocabs/hierarchy/hierarchy-docs.factor b/basis/vocabs/hierarchy/hierarchy-docs.factor index c6a15749cf..519f3478fe 100644 --- a/basis/vocabs/hierarchy/hierarchy-docs.factor +++ b/basis/vocabs/hierarchy/hierarchy-docs.factor @@ -1,57 +1,57 @@ -USING: help.markup help.syntax strings vocabs.loader -sequences vocabs ; -IN: vocabs.hierarchy - -ARTICLE: "vocabs.hierarchy" "Vocabulary hierarchy tools" -"These tools operate on all vocabularies found in the current set of " { $link vocab-roots } ", loaded or not. A prefix is the first part of a vocabulary name." -$nl -"Loading vocabulary hierarchies:" -{ $subsections - load - load-all - load-root - load-from-root -} -"Getting all vocabularies from disk:" -{ $subsections - all-disk-vocabs-by-root - all-disk-vocabs-recursive -} -"Getting all vocabularies from disk whose names which match a string prefix:" -{ $subsections - disk-vocabs-for-prefix - disk-vocabs-recursive-for-prefix -} -"Words for modifying output:" -{ $subsections - no-roots - no-prefixes - filter-vocabs -} -"Getting " { $link "vocabs.metadata" } " for all vocabularies from disk:" -{ $subsections - all-tags - all-authors -} ; - -ABOUT: "vocabs.hierarchy" - -HELP: load -{ $values { "prefix" string } } -{ $description "Load all vocabularies that match the provided prefix." } -{ $notes "This word differs from " { $link require } " in that it loads all subvocabularies, not just the given one." } ; - -HELP: load-all -{ $description "Load all vocabularies in the source tree." } ; - -HELP: load-from-root -{ $values - { "root" "a vocaulary root" } { "prefix" string } -} -{ $description "Attempts to load all of the vocabularies with a certain prefix from a vocabulary root." } ; - -HELP: load-root -{ $values - { "root" "a vocabulary root" } -} -{ $description "Attempts to load all of the vocabularies in a vocabulary root." } ; +USING: help.markup help.syntax strings vocabs.loader +sequences vocabs ; +IN: vocabs.hierarchy + +ARTICLE: "vocabs.hierarchy" "Vocabulary hierarchy tools" +"These tools operate on all vocabularies found in the current set of " { $link vocab-roots } ", loaded or not. A prefix is the first part of a vocabulary name." +$nl +"Loading vocabulary hierarchies:" +{ $subsections + load + load-all + load-root + load-from-root +} +"Getting all vocabularies from disk:" +{ $subsections + all-disk-vocabs-by-root + all-disk-vocabs-recursive +} +"Getting all vocabularies from disk whose names which match a string prefix:" +{ $subsections + disk-vocabs-for-prefix + disk-vocabs-recursive-for-prefix +} +"Words for modifying output:" +{ $subsections + no-roots + no-prefixes + filter-vocabs +} +"Getting " { $link "vocabs.metadata" } " for all vocabularies from disk:" +{ $subsections + all-tags + all-authors +} ; + +ABOUT: "vocabs.hierarchy" + +HELP: load +{ $values { "prefix" string } } +{ $description "Load all vocabularies that match the provided prefix." } +{ $notes "This word differs from " { $link require } " in that it loads all subvocabularies, not just the given one." } ; + +HELP: load-all +{ $description "Load all vocabularies in the source tree." } ; + +HELP: load-from-root +{ $values + { "root" "a vocaulary root" } { "prefix" string } +} +{ $description "Attempts to load all of the vocabularies with a certain prefix from a vocabulary root." } ; + +HELP: load-root +{ $values + { "root" "a vocabulary root" } +} +{ $description "Attempts to load all of the vocabularies in a vocabulary root." } ; diff --git a/basis/vocabs/hierarchy/hierarchy.factor b/basis/vocabs/hierarchy/hierarchy.factor index 704f7ef63b..5e0cbd6f95 100644 --- a/basis/vocabs/hierarchy/hierarchy.factor +++ b/basis/vocabs/hierarchy/hierarchy.factor @@ -1,158 +1,158 @@ -! Copyright (C) 2007, 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs combinators.short-circuit fry -io.directories io.files io.files.types io.pathnames kernel make -memoize namespaces sequences sorting splitting vocabs sets -vocabs.loader vocabs.metadata vocabs.errors ; -IN: vocabs.hierarchy - -TUPLE: vocab-prefix name ; - -C: vocab-prefix - -M: vocab-prefix vocab-name name>> ; - -> +directory+ = ] - [ name>> "." head? not ] - } 1&& - ] filter ; - -: vocab-subdirs ( dir -- dirs ) - directory-entries visible-dirs [ name>> ] map! natural-sort ; - -: vocab-dir? ( root name -- ? ) - over - [ ".factor" append-vocab-dir append-path exists? ] - [ 2drop f ] - if ; - -ERROR: vocab-root-required root ; - -: ensure-vocab-root ( root -- root ) - dup vocab-roots get member? [ vocab-root-required ] unless ; - -: ensure-vocab-root/prefix ( root prefix -- root prefix ) - [ ensure-vocab-root ] [ check-vocab-name ] bi* ; - -: (disk-vocab-children) ( root prefix -- vocabs ) - check-vocab-name - [ vocab-dir append-path dup exists? [ vocab-subdirs ] [ drop { } ] if ] - [ nip [ "." append '[ _ prepend ] map! ] unless-empty ] - [ drop '[ _ over vocab-dir? [ >vocab-link ] [ ] if ] map! ] - 2tri ; - -: ((disk-vocabs-recursive)) ( root prefix -- ) - dupd vocab-name (disk-vocab-children) [ % ] keep - [ ((disk-vocabs-recursive)) ] with each ; - -: (disk-vocabs-recursive) ( root prefix -- seq ) - [ ensure-vocab-root ] dip - [ ((disk-vocabs-recursive)) ] { } make ; - -: no-rooted ( seq -- seq' ) [ find-vocab-root ] reject ; - -: one-level-only? ( name prefix -- ? ) - ?head [ "." split1 nip not ] [ drop f ] if ; - -: unrooted-disk-vocabs ( prefix -- seq ) - [ loaded-vocab-names no-rooted ] dip - dup empty? [ CHAR: . suffix ] unless - '[ vocab-name _ one-level-only? ] filter ; - -: unrooted-disk-vocabs-recursive ( prefix -- seq ) - loaded-child-vocab-names no-rooted ; - -PRIVATE> - -: no-prefixes ( seq -- seq' ) [ vocab-prefix? ] reject ; - -: convert-prefixes ( seq -- seq' ) - [ dup vocab-prefix? [ name>> ] when ] map ; - -: remove-redundant-prefixes ( seq -- seq' ) - #! Hack. - [ vocab-prefix? ] partition - [ - [ vocab-name ] map fast-set - '[ name>> _ in? ] reject - convert-prefixes - ] keep - append ; - -: no-roots ( assoc -- seq ) values concat ; - -: filter-vocabs ( assoc -- seq ) - no-roots no-prefixes members ; - -: disk-vocabs-for-prefix ( prefix -- assoc ) - [ [ vocab-roots get ] dip '[ dup _ (disk-vocab-children) ] { } map>assoc ] - [ unrooted-disk-vocabs [ lookup-vocab ] map! f swap 2array ] - bi suffix ; - -: all-disk-vocabs-by-root ( -- assoc ) - "" disk-vocabs-for-prefix ; - -: disk-vocabs-recursive-for-prefix ( prefix -- assoc ) - [ [ vocab-roots get ] dip '[ dup _ (disk-vocabs-recursive) ] { } map>assoc ] - [ unrooted-disk-vocabs-recursive [ lookup-vocab ] map! f swap 2array ] - bi suffix ; - -MEMO: all-disk-vocabs-recursive ( -- assoc ) - "" disk-vocabs-recursive-for-prefix ; - -: all-disk-vocab-names ( -- seq ) - all-disk-vocabs-recursive filter-vocabs [ vocab-name ] map! ; - -: disk-child-vocab-names ( prefix -- seq ) - disk-vocabs-for-prefix filter-vocabs [ vocab-name ] map! ; - -vocab-link ] [ drop f ] if ; - -PRIVATE> - -: disk-vocabs-in-root/prefix ( root prefix -- seq ) - [ (disk-vocabs-recursive) ] - [ maybe-include-root/prefix [ prefix ] when* ] 2bi ; - -: disk-vocabs-in-root ( root -- seq ) - "" disk-vocabs-in-root/prefix ; - -: (load-from-root) ( root prefix -- failures ) - disk-vocabs-in-root/prefix - [ don't-load? ] reject no-prefixes - require-all ; - -: load-from-root ( root prefix -- ) - (load-from-root) load-failures. ; - -: load-root ( root -- ) - "" load-from-root ; - -: (load) ( prefix -- failures ) - [ vocab-roots get ] dip '[ _ (load-from-root) ] map concat ; - -: load ( prefix -- ) - (load) load-failures. ; - -: load-all ( -- ) - "" load ; - -MEMO: all-tags ( -- seq ) [ vocab-tags ] collect-vocabs ; - -MEMO: all-authors ( -- seq ) [ vocab-authors ] collect-vocabs ; +! Copyright (C) 2007, 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs combinators.short-circuit fry +io.directories io.files io.files.types io.pathnames kernel make +memoize namespaces sequences sorting splitting vocabs sets +vocabs.loader vocabs.metadata vocabs.errors ; +IN: vocabs.hierarchy + +TUPLE: vocab-prefix name ; + +C: vocab-prefix + +M: vocab-prefix vocab-name name>> ; + +> +directory+ = ] + [ name>> "." head? not ] + } 1&& + ] filter ; + +: vocab-subdirs ( dir -- dirs ) + directory-entries visible-dirs [ name>> ] map! natural-sort ; + +: vocab-dir? ( root name -- ? ) + over + [ ".factor" append-vocab-dir append-path exists? ] + [ 2drop f ] + if ; + +ERROR: vocab-root-required root ; + +: ensure-vocab-root ( root -- root ) + dup vocab-roots get member? [ vocab-root-required ] unless ; + +: ensure-vocab-root/prefix ( root prefix -- root prefix ) + [ ensure-vocab-root ] [ check-vocab-name ] bi* ; + +: (disk-vocab-children) ( root prefix -- vocabs ) + check-vocab-name + [ vocab-dir append-path dup exists? [ vocab-subdirs ] [ drop { } ] if ] + [ nip [ "." append '[ _ prepend ] map! ] unless-empty ] + [ drop '[ _ over vocab-dir? [ >vocab-link ] [ ] if ] map! ] + 2tri ; + +: ((disk-vocabs-recursive)) ( root prefix -- ) + dupd vocab-name (disk-vocab-children) [ % ] keep + [ ((disk-vocabs-recursive)) ] with each ; + +: (disk-vocabs-recursive) ( root prefix -- seq ) + [ ensure-vocab-root ] dip + [ ((disk-vocabs-recursive)) ] { } make ; + +: no-rooted ( seq -- seq' ) [ find-vocab-root ] reject ; + +: one-level-only? ( name prefix -- ? ) + ?head [ "." split1 nip not ] [ drop f ] if ; + +: unrooted-disk-vocabs ( prefix -- seq ) + [ loaded-vocab-names no-rooted ] dip + dup empty? [ CHAR: . suffix ] unless + '[ vocab-name _ one-level-only? ] filter ; + +: unrooted-disk-vocabs-recursive ( prefix -- seq ) + loaded-child-vocab-names no-rooted ; + +PRIVATE> + +: no-prefixes ( seq -- seq' ) [ vocab-prefix? ] reject ; + +: convert-prefixes ( seq -- seq' ) + [ dup vocab-prefix? [ name>> ] when ] map ; + +: remove-redundant-prefixes ( seq -- seq' ) + #! Hack. + [ vocab-prefix? ] partition + [ + [ vocab-name ] map fast-set + '[ name>> _ in? ] reject + convert-prefixes + ] keep + append ; + +: no-roots ( assoc -- seq ) values concat ; + +: filter-vocabs ( assoc -- seq ) + no-roots no-prefixes members ; + +: disk-vocabs-for-prefix ( prefix -- assoc ) + [ [ vocab-roots get ] dip '[ dup _ (disk-vocab-children) ] { } map>assoc ] + [ unrooted-disk-vocabs [ lookup-vocab ] map! f swap 2array ] + bi suffix ; + +: all-disk-vocabs-by-root ( -- assoc ) + "" disk-vocabs-for-prefix ; + +: disk-vocabs-recursive-for-prefix ( prefix -- assoc ) + [ [ vocab-roots get ] dip '[ dup _ (disk-vocabs-recursive) ] { } map>assoc ] + [ unrooted-disk-vocabs-recursive [ lookup-vocab ] map! f swap 2array ] + bi suffix ; + +MEMO: all-disk-vocabs-recursive ( -- assoc ) + "" disk-vocabs-recursive-for-prefix ; + +: all-disk-vocab-names ( -- seq ) + all-disk-vocabs-recursive filter-vocabs [ vocab-name ] map! ; + +: disk-child-vocab-names ( prefix -- seq ) + disk-vocabs-for-prefix filter-vocabs [ vocab-name ] map! ; + +vocab-link ] [ drop f ] if ; + +PRIVATE> + +: disk-vocabs-in-root/prefix ( root prefix -- seq ) + [ (disk-vocabs-recursive) ] + [ maybe-include-root/prefix [ prefix ] when* ] 2bi ; + +: disk-vocabs-in-root ( root -- seq ) + "" disk-vocabs-in-root/prefix ; + +: (load-from-root) ( root prefix -- failures ) + disk-vocabs-in-root/prefix + [ don't-load? ] reject no-prefixes + require-all ; + +: load-from-root ( root prefix -- ) + (load-from-root) load-failures. ; + +: load-root ( root -- ) + "" load-from-root ; + +: (load) ( prefix -- failures ) + [ vocab-roots get ] dip '[ _ (load-from-root) ] map concat ; + +: load ( prefix -- ) + (load) load-failures. ; + +: load-all ( -- ) + "" load ; + +MEMO: all-tags ( -- seq ) [ vocab-tags ] collect-vocabs ; + +MEMO: all-authors ( -- seq ) [ vocab-authors ] collect-vocabs ; diff --git a/basis/windows/advapi32/advapi32.factor b/basis/windows/advapi32/advapi32.factor index a150f054a0..23c4e8f617 100755 --- a/basis/windows/advapi32/advapi32.factor +++ b/basis/windows/advapi32/advapi32.factor @@ -780,7 +780,7 @@ ENUM: TOKEN_INFORMATION_CLASS TokenMandatoryPolicy TokenLogonSid MaxTokenInfoClass ; - + TYPEDEF: TOKEN_INFORMATION_CLASS* PTOKEN_INFORMATION_CLASS TYPEDEF: uint ALG_ID @@ -1568,5 +1568,3 @@ ALIAS: SetNamedSecurityInfo SetNamedSecurityInfoW ! : WmiSetSingleItemW ; ! : Wow64Win32ApiEntry ; ! : WriteEncryptedFileRaw ; - - diff --git a/basis/windows/com/com-docs.factor b/basis/windows/com/com-docs.factor index 3a7b7272d7..d66604d1fc 100644 --- a/basis/windows/com/com-docs.factor +++ b/basis/windows/com/com-docs.factor @@ -1,26 +1,26 @@ -USING: help.markup help.syntax io kernel math quotations -multiline destructors ; -IN: windows.com - -HELP: com-query-interface -{ $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } { "iid" "An interface GUID (IID)" } { "interface'" "Pointer to a COM interface implementing the interface indicated by " { $snippet "iid" } } } -{ $description "A small wrapper around " { $link IUnknown::QueryInterface } ". Queries " { $snippet "interface" } " to see if it implements the interface indicated by " { $snippet "iid" } ". Returns a pointer to the " { $snippet "iid" } " interface if implemented, or raises an error if the object does not implement the interface.\n\nCOM memory management conventions state that the returned pointer must be released using " { $link com-release } " when it is no longer needed." } ; - -HELP: com-add-ref -{ $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } } -{ $description "A small wrapper around " { $link IUnknown::AddRef } ". Increments the reference count on " { $snippet "interface" } ", keeping it on the stack. The reference count must be decremented with " { $link com-release } " when the reference is no longer held." } ; - -HELP: com-release -{ $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } } -{ $description "A small wrapper around " { $link IUnknown::Release } ". Decrements the reference count on " { $snippet "interface" } ", releasing the underlying object if the reference count has reached zero." } ; - -HELP: &com-release -{ $values { "alien" "pointer to a COM interface implementing " { $snippet "IUnknown" } } } -{ $description "Marks the given COM interface for unconditional release via " { $link com-release } " at the end of the enclosing " { $link with-destructors } " scope." } ; - -HELP: |com-release -{ $values { "alien" "pointer to a COM interface implementing " { $snippet "IUnknown" } } } -{ $description "Marks the given COM interface for release via " { $link com-release } " in the event of an error at the end of the enclosing " { $link with-destructors } " scope." } ; - -{ com-release &com-release |com-release } related-words - +USING: help.markup help.syntax io kernel math quotations +multiline destructors ; +IN: windows.com + +HELP: com-query-interface +{ $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } { "iid" "An interface GUID (IID)" } { "interface'" "Pointer to a COM interface implementing the interface indicated by " { $snippet "iid" } } } +{ $description "A small wrapper around " { $link IUnknown::QueryInterface } ". Queries " { $snippet "interface" } " to see if it implements the interface indicated by " { $snippet "iid" } ". Returns a pointer to the " { $snippet "iid" } " interface if implemented, or raises an error if the object does not implement the interface.\n\nCOM memory management conventions state that the returned pointer must be released using " { $link com-release } " when it is no longer needed." } ; + +HELP: com-add-ref +{ $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } } +{ $description "A small wrapper around " { $link IUnknown::AddRef } ". Increments the reference count on " { $snippet "interface" } ", keeping it on the stack. The reference count must be decremented with " { $link com-release } " when the reference is no longer held." } ; + +HELP: com-release +{ $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } } +{ $description "A small wrapper around " { $link IUnknown::Release } ". Decrements the reference count on " { $snippet "interface" } ", releasing the underlying object if the reference count has reached zero." } ; + +HELP: &com-release +{ $values { "alien" "pointer to a COM interface implementing " { $snippet "IUnknown" } } } +{ $description "Marks the given COM interface for unconditional release via " { $link com-release } " at the end of the enclosing " { $link with-destructors } " scope." } ; + +HELP: |com-release +{ $values { "alien" "pointer to a COM interface implementing " { $snippet "IUnknown" } } } +{ $description "Marks the given COM interface for release via " { $link com-release } " in the event of an error at the end of the enclosing " { $link with-destructors } " scope." } ; + +{ com-release &com-release |com-release } related-words + diff --git a/basis/windows/com/com.factor b/basis/windows/com/com.factor index 4aa1bc2512..184f4adf14 100644 --- a/basis/windows/com/com.factor +++ b/basis/windows/com/com.factor @@ -100,5 +100,3 @@ ERROR: null-com-release ; over [ com-release ] curry [ ] cleanup ; inline DESTRUCTOR: com-release - - diff --git a/basis/windows/com/wrapper/wrapper-docs.factor b/basis/windows/com/wrapper/wrapper-docs.factor index 0298e80445..a9004c0b24 100644 --- a/basis/windows/com/wrapper/wrapper-docs.factor +++ b/basis/windows/com/wrapper/wrapper-docs.factor @@ -1,40 +1,40 @@ -USING: help.markup help.syntax io kernel math quotations -alien windows.com windows.com.syntax continuations -destructors ; -IN: windows.com.wrapper - -HELP: -{ $values { "implementations" "an assoc relating COM interface names to arrays of quotations implementing that interface" } { "wrapper" "a " { $link com-wrapper } " tuple" } } -{ $description "Constructs a " { $link com-wrapper } " tuple. Each key in the " { $snippet "implementations" } " assoc must be the name of an interface defined with " { $link POSTPONE: COM-INTERFACE: } ". The corresponding value must be an array of quotations implementing the methods of that interface in order, including those of its parent interfaces. The " { $snippet "IUnknown" } " methods (" { $link IUnknown::QueryInterface } ", " { $link IUnknown::AddRef } ", and " { $link IUnknown::Release } ") will be defined automatically and must not be specified in the array. These quotations should have stack effects mirroring those of the interface methods being implemented; for example, a method " { $snippet "void foobar ( int foo, int bar )" } " should be implemented with a quotation of effect " { $snippet "( this foo bar -- )" } ". The " { $snippet "this" } " parameter (that is, the leftmost parameter of any COM method) will be automatically converted from an alien pointer to the underlying Factor object before the quotation is invoked.\n\nThe resulting wrapper can be applied to a Factor object using the " { $link com-wrap } " word. The COM interface pointer returned by " { $snippet "com-wrap" } " can then be passed to C functions requiring a COM object as a parameter. The vtables constructed by " { $snippet "" } " are stored on the non-GC heap in order to be accessible to C functions; when the wrapper object and its vtables are no longer needed, the object's resources must be freed using " { $link dispose } ".\n\nExample:" } -{ $code """ -COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc} - HRESULT returnOK ( ) - HRESULT returnError ( ) ; - -COM-INTERFACE: IInherited ISimple {9620ecec-8438-423b-bb14-86f835aa40dd} - int getX ( ) - void setX ( int newX ) ; - -COM-INTERFACE: IUnrelated IUnknown {b06ac3f4-30e4-406b-a7cd-c29cead4552c} - int xPlus ( int y ) - int xMulAdd ( int mul, int add ) ; - -{ - { "IInherited" { - [ drop S_OK ] ! ISimple::returnOK - [ drop E_FAIL ] ! ISimple::returnError - [ x>> ] ! IInherited::getX - [ >>x drop ] ! IInherited::setX - } } - { "IUnrelated" { - [ [ x>> ] [ + ] bi* ] ! IUnrelated::xPlus - [ [ x>> ] [ * ] [ + ] tri* ] ! IUnrealted::xMulAdd - } } -} """ } ; - -HELP: com-wrap -{ $values { "object" "The factor object to wrap" } { "wrapper" "A " { $link com-wrapper } " object" } { "wrapped-object" "A COM object referencing " { $snippet "object" } } } -{ $description "Allocates a COM object using the implementations in the " { $snippet "wrapper" } " object for the vtables and " { $snippet "object" } " for the \"this\" parameter. The COM object is allocated on the heap with an initial reference count of 1. The object will automatically deallocate itself when its reference count reaches 0 as a result of calling " { $link IUnknown::Release } " or " { $link com-release } " on it.\n\nNote that if " { $snippet "wrapper" } " implements multiple interfaces, you cannot count on the returned COM object pointer implementing any particular interface beyond " { $snippet "IUnknown" } ". You will need to use " { $link com-query-interface } " or " { $link IUnknown::QueryInterface } " to ask the object for the particular interface you need." } ; - -HELP: com-wrapper -{ $class-description "The tuple class used to store COM wrapper information. Objects of this class should be treated as opaque by user code. A com-wrapper can be constructed using the " { $link } " constructor and applied to a Factor object using " { $link com-wrap } ". When no longer needed, release the com-wrapper's internally allocated data with " { $link dispose } "." } ; +USING: help.markup help.syntax io kernel math quotations +alien windows.com windows.com.syntax continuations +destructors ; +IN: windows.com.wrapper + +HELP: +{ $values { "implementations" "an assoc relating COM interface names to arrays of quotations implementing that interface" } { "wrapper" "a " { $link com-wrapper } " tuple" } } +{ $description "Constructs a " { $link com-wrapper } " tuple. Each key in the " { $snippet "implementations" } " assoc must be the name of an interface defined with " { $link POSTPONE: COM-INTERFACE: } ". The corresponding value must be an array of quotations implementing the methods of that interface in order, including those of its parent interfaces. The " { $snippet "IUnknown" } " methods (" { $link IUnknown::QueryInterface } ", " { $link IUnknown::AddRef } ", and " { $link IUnknown::Release } ") will be defined automatically and must not be specified in the array. These quotations should have stack effects mirroring those of the interface methods being implemented; for example, a method " { $snippet "void foobar ( int foo, int bar )" } " should be implemented with a quotation of effect " { $snippet "( this foo bar -- )" } ". The " { $snippet "this" } " parameter (that is, the leftmost parameter of any COM method) will be automatically converted from an alien pointer to the underlying Factor object before the quotation is invoked.\n\nThe resulting wrapper can be applied to a Factor object using the " { $link com-wrap } " word. The COM interface pointer returned by " { $snippet "com-wrap" } " can then be passed to C functions requiring a COM object as a parameter. The vtables constructed by " { $snippet "" } " are stored on the non-GC heap in order to be accessible to C functions; when the wrapper object and its vtables are no longer needed, the object's resources must be freed using " { $link dispose } ".\n\nExample:" } +{ $code """ +COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc} + HRESULT returnOK ( ) + HRESULT returnError ( ) ; + +COM-INTERFACE: IInherited ISimple {9620ecec-8438-423b-bb14-86f835aa40dd} + int getX ( ) + void setX ( int newX ) ; + +COM-INTERFACE: IUnrelated IUnknown {b06ac3f4-30e4-406b-a7cd-c29cead4552c} + int xPlus ( int y ) + int xMulAdd ( int mul, int add ) ; + +{ + { "IInherited" { + [ drop S_OK ] ! ISimple::returnOK + [ drop E_FAIL ] ! ISimple::returnError + [ x>> ] ! IInherited::getX + [ >>x drop ] ! IInherited::setX + } } + { "IUnrelated" { + [ [ x>> ] [ + ] bi* ] ! IUnrelated::xPlus + [ [ x>> ] [ * ] [ + ] tri* ] ! IUnrealted::xMulAdd + } } +} """ } ; + +HELP: com-wrap +{ $values { "object" "The factor object to wrap" } { "wrapper" "A " { $link com-wrapper } " object" } { "wrapped-object" "A COM object referencing " { $snippet "object" } } } +{ $description "Allocates a COM object using the implementations in the " { $snippet "wrapper" } " object for the vtables and " { $snippet "object" } " for the \"this\" parameter. The COM object is allocated on the heap with an initial reference count of 1. The object will automatically deallocate itself when its reference count reaches 0 as a result of calling " { $link IUnknown::Release } " or " { $link com-release } " on it.\n\nNote that if " { $snippet "wrapper" } " implements multiple interfaces, you cannot count on the returned COM object pointer implementing any particular interface beyond " { $snippet "IUnknown" } ". You will need to use " { $link com-query-interface } " or " { $link IUnknown::QueryInterface } " to ask the object for the particular interface you need." } ; + +HELP: com-wrapper +{ $class-description "The tuple class used to store COM wrapper information. Objects of this class should be treated as opaque by user code. A com-wrapper can be constructed using the " { $link } " constructor and applied to a Factor object using " { $link com-wrap } ". When no longer needed, release the com-wrapper's internally allocated data with " { $link dispose } "." } ; diff --git a/basis/windows/com/wrapper/wrapper.factor b/basis/windows/com/wrapper/wrapper.factor index c191317656..93cfe8f5f2 100644 --- a/basis/windows/com/wrapper/wrapper.factor +++ b/basis/windows/com/wrapper/wrapper.factor @@ -47,7 +47,7 @@ unless [ drop f ] suffix ; : (make-query-interface) ( interfaces -- quot ) - (query-interface-cases) + (query-interface-cases) '[ swap _ case [ @@ -79,7 +79,7 @@ unless [ (make-add-ref) ] [ (make-release) ] tri 3array ; - + : (thunk) ( n -- quot ) dup 0 = [ drop [ ] ] diff --git a/basis/windows/ddk/setupapi/setupapi.factor b/basis/windows/ddk/setupapi/setupapi.factor index f10215d5a2..74336c53eb 100755 --- a/basis/windows/ddk/setupapi/setupapi.factor +++ b/basis/windows/ddk/setupapi/setupapi.factor @@ -2030,4 +2030,3 @@ CONSTANT: SCWMI_CLOBBER_SECURITY 0x00000001 FUNCTION: BOOL SetupConfigureWmiFromInfSectionA ( HINF InfHandle, PCSTR SectionName, DWORD Flags ) ; FUNCTION: BOOL SetupConfigureWmiFromInfSectionW ( HINF InfHandle, PCWSTR SectionName, DWORD Flags ) ; ALIAS: SetupConfigureWmiFromInfSection SetupConfigureWmiFromInfSectionW - diff --git a/basis/windows/directx/d2d1/d2d1.factor b/basis/windows/directx/d2d1/d2d1.factor index a79cd856f3..d665f441ed 100644 --- a/basis/windows/directx/d2d1/d2d1.factor +++ b/basis/windows/directx/d2d1/d2d1.factor @@ -305,7 +305,7 @@ STRUCT: D2D1_FACTORY_OPTIONS { debugLevel D2D1_DEBUG_LEVEL } ; C-TYPE: ID2D1Factory -C-TYPE: ID2D1BitmapRenderTarget +C-TYPE: ID2D1BitmapRenderTarget COM-INTERFACE: ID2D1Resource IUnknown {2cd90691-12e2-11dc-9fed-001143a055f9} void GetFactory ( ID2D1Factory** factory ) ; @@ -564,4 +564,3 @@ FUNCTION: BOOL D2D1IsMatrixInvertible ( FUNCTION: BOOL D2D1InvertMatrix ( D2D1_MATRIX_3X2_F* matrix ) ; - diff --git a/basis/windows/directx/d2dbasetypes/d2dbasetypes.factor b/basis/windows/directx/d2dbasetypes/d2dbasetypes.factor index 3cdb0bbe32..668ef822dc 100644 --- a/basis/windows/directx/d2dbasetypes/d2dbasetypes.factor +++ b/basis/windows/directx/d2dbasetypes/d2dbasetypes.factor @@ -2,7 +2,7 @@ USING: alien.syntax classes.struct windows.types ; IN: windows.directx.d2dbasetypes STRUCT: D3DCOLORVALUE - { r FLOAT } + { r FLOAT } { g FLOAT } { b FLOAT } { a FLOAT } ; diff --git a/basis/windows/directx/d3d10/d3d10.factor b/basis/windows/directx/d3d10/d3d10.factor index 2c97b7365d..562693a115 100644 --- a/basis/windows/directx/d3d10/d3d10.factor +++ b/basis/windows/directx/d3d10/d3d10.factor @@ -681,7 +681,7 @@ STRUCT: D3D10_TEX2D_ARRAY_RTV { MipSlice UINT } { FirstArraySlice UINT } { ArraySize UINT } ; - + STRUCT: D3D10_TEX2DMS_ARRAY_RTV { FirstArraySlice UINT } { ArraySize UINT } ; diff --git a/basis/windows/directx/d3d10_1shader/d3d10_1shader.factor b/basis/windows/directx/d3d10_1shader/d3d10_1shader.factor index 06c151cc1b..424f96dd93 100644 --- a/basis/windows/directx/d3d10_1shader/d3d10_1shader.factor +++ b/basis/windows/directx/d3d10_1shader/d3d10_1shader.factor @@ -25,7 +25,7 @@ CONSTANT: D3D10_SHADER_DEBUG_SCOPE_BLOCK 1 CONSTANT: D3D10_SHADER_DEBUG_SCOPE_FORLOOP 2 CONSTANT: D3D10_SHADER_DEBUG_SCOPE_STRUCT 3 CONSTANT: D3D10_SHADER_DEBUG_SCOPE_FUNC_PARAMS 4 -CONSTANT: D3D10_SHADER_DEBUG_SCOPE_STATEBLOCK 5 +CONSTANT: D3D10_SHADER_DEBUG_SCOPE_STATEBLOCK 5 CONSTANT: D3D10_SHADER_DEBUG_SCOPE_NAMESPACE 6 CONSTANT: D3D10_SHADER_DEBUG_SCOPE_ANNOTATION 7 CONSTANT: D3D10_SHADER_DEBUG_SCOPE_FORCE_DWORD 0x7fffffff diff --git a/basis/windows/directx/d3d10effect/d3d10effect.factor b/basis/windows/directx/d3d10effect/d3d10effect.factor index 5322e042ab..90e7894a5c 100644 --- a/basis/windows/directx/d3d10effect/d3d10effect.factor +++ b/basis/windows/directx/d3d10effect/d3d10effect.factor @@ -267,7 +267,7 @@ COM-INTERFACE: ID3D10EffectSamplerVariable ID3D10EffectVariable {6530D5C7-07E9-4 HRESULT GetSampler ( UINT Index, ID3D10SamplerState** ppSampler ) HRESULT GetBackingStore ( UINT Index, D3D10_SAMPLER_DESC* pSamplerDesc ) ; TYPEDEF: ID3D10EffectSamplerVariable* LPD3D10EFFECTSAMPLERVARIABLE - + STRUCT: D3D10_PASS_DESC { Name LPCSTR } { Annotations UINT } diff --git a/basis/windows/directx/d3d10misc/d3d10misc.factor b/basis/windows/directx/d3d10misc/d3d10misc.factor index d9be571fd6..229210bc8c 100644 --- a/basis/windows/directx/d3d10misc/d3d10misc.factor +++ b/basis/windows/directx/d3d10misc/d3d10misc.factor @@ -34,7 +34,7 @@ FUNCTION: HRESULT D3D10CreateDeviceAndSwapChain ( UINT Flags, UINT SDKVersion, DXGI_SWAP_CHAIN_DESC* pSwapChainDesc, - IDXGISwapChain** ppSwapChain, + IDXGISwapChain** ppSwapChain, ID3D10Device** ppDevice ) ; FUNCTION: HRESULT D3D10CreateBlob ( SIZE_T NumBytes, LPD3D10BLOB* ppBuffer ) ; diff --git a/basis/windows/directx/d3d9/d3d9.factor b/basis/windows/directx/d3d9/d3d9.factor index 0c4481dfca..7bc53e7cb2 100644 --- a/basis/windows/directx/d3d9/d3d9.factor +++ b/basis/windows/directx/d3d9/d3d9.factor @@ -253,7 +253,7 @@ COM-INTERFACE: IDirect3DTexture9 IDirect3DBaseTexture9 {85C31227-3DE5-4f00-9B3A- HRESULT GetSurfaceLevel ( UINT Level, IDirect3DSurface9** ppSurfaceLevel ) HRESULT LockRect ( UINT Level, D3DLOCKED_RECT* pLockedRect, RECT* pRect, DWORD Flags ) HRESULT UnlockRect ( UINT Level ) ; - + TYPEDEF: IDirect3DTexture9* LPDIRECT3DTEXTURE9 TYPEDEF: IDirect3DTexture9* PDIRECT3DTEXTURE9 diff --git a/basis/windows/directx/d3d9caps/d3d9caps.factor b/basis/windows/directx/d3d9caps/d3d9caps.factor index 64f0a9b982..5824c05dac 100644 --- a/basis/windows/directx/d3d9caps/d3d9caps.factor +++ b/basis/windows/directx/d3d9caps/d3d9caps.factor @@ -63,7 +63,7 @@ STRUCT: D3DCONTENTPROTECTIONCAPS { BufferAlignmentStart UINT } { BlockAlignmentSize UINT } { ProtectedMemorySize ULONGLONG } ; - + CONSTANT: D3DCPCAPS_SOFTWARE 0x00000001 CONSTANT: D3DCPCAPS_HARDWARE 0x00000002 CONSTANT: D3DCPCAPS_PROTECTIONALWAYSON 0x00000004 @@ -240,7 +240,7 @@ CONSTANT: D3DPRASTERCAPS_ZFOG 0x00200000 CONSTANT: D3DPRASTERCAPS_COLORPERSPECTIVE 0x00400000 CONSTANT: D3DPRASTERCAPS_SCISSORTEST 0x01000000 CONSTANT: D3DPRASTERCAPS_SLOPESCALEDEPTHBIAS 0x02000000 -CONSTANT: D3DPRASTERCAPS_DEPTHBIAS 0x04000000 +CONSTANT: D3DPRASTERCAPS_DEPTHBIAS 0x04000000 CONSTANT: D3DPRASTERCAPS_MULTISAMPLE_TOGGLE 0x08000000 CONSTANT: D3DPCMPCAPS_NEVER 0x00000001 diff --git a/basis/windows/directx/d3d9types/d3d9types.factor b/basis/windows/directx/d3d9types/d3d9types.factor index fd16bd77ee..38e8e8e96d 100644 --- a/basis/windows/directx/d3d9types/d3d9types.factor +++ b/basis/windows/directx/d3d9types/d3d9types.factor @@ -657,7 +657,7 @@ CONSTANT: D3DSPC_GE 3 CONSTANT: D3DSPC_LT 4 CONSTANT: D3DSPC_NE 5 CONSTANT: D3DSPC_LE 6 -CONSTANT: D3DSPC_RESERVED1 7 +CONSTANT: D3DSPC_RESERVED1 7 CONSTANT: D3DSHADER_COMPARISON_SHIFT D3DSP_OPCODESPECIFICCONTROL_SHIFT : D3DSHADER_COMPARISON_MASK ( -- n ) 7 D3DSHADER_COMPARISON_SHIFT shift ; inline @@ -900,7 +900,7 @@ CONSTANT: D3DMULTISAMPLE_14_SAMPLES 14 CONSTANT: D3DMULTISAMPLE_15_SAMPLES 15 CONSTANT: D3DMULTISAMPLE_16_SAMPLES 16 CONSTANT: D3DMULTISAMPLE_FORCE_DWORD 0x7fffffff - + TYPEDEF: int D3DFORMAT CONSTANT: D3DFMT_UNKNOWN 0 CONSTANT: D3DFMT_R8G8B8 20 @@ -1328,7 +1328,7 @@ TYPEDEF: int D3DDISPLAYROTATION CONSTANT: D3DDISPLAYROTATION_IDENTITY 1 CONSTANT: D3DDISPLAYROTATION_90 2 CONSTANT: D3DDISPLAYROTATION_180 3 -CONSTANT: D3DDISPLAYROTATION_270 4 +CONSTANT: D3DDISPLAYROTATION_270 4 CONSTANT: D3D9_RESOURCE_PRIORITY_MINIMUM 0x28000000 CONSTANT: D3D9_RESOURCE_PRIORITY_LOW 0x50000000 diff --git a/basis/windows/directx/d3dcompiler/d3dcompiler.factor b/basis/windows/directx/d3dcompiler/d3dcompiler.factor index 4f78e4e7f2..9ef94a4832 100644 --- a/basis/windows/directx/d3dcompiler/d3dcompiler.factor +++ b/basis/windows/directx/d3dcompiler/d3dcompiler.factor @@ -56,7 +56,7 @@ FUNCTION: HRESULT D3DDisassemble ( LPD3DBLOB* ppDisassembly ) ; FUNCTION: HRESULT D3DDisassemble10Effect ( - ID3D10Effect* pEffect, + ID3D10Effect* pEffect, UINT Flags, LPD3DBLOB* ppDisassembly ) ; @@ -86,4 +86,3 @@ FUNCTION: HRESULT D3DStripShader ( SIZE_T BytecodeLength, UINT uStripFlags, LPD3DBLOB* ppStrippedBlob ) ; - diff --git a/basis/windows/directx/d3dx10async/d3dx10async.factor b/basis/windows/directx/d3dx10async/d3dx10async.factor index ecaea244d8..9b0bc42fbd 100644 --- a/basis/windows/directx/d3dx10async/d3dx10async.factor +++ b/basis/windows/directx/d3dx10async/d3dx10async.factor @@ -19,94 +19,94 @@ FUNCTION: HRESULT D3DX10CompileFromFileW ( LPCWSTR pSrcFile, D3D10_SHADER_MACRO* ALIAS: D3DX10CompileFromFile D3DX10CompileFromFileW -FUNCTION: HRESULT D3DX10CompileFromResourceA ( HMODULE hSrcModule, LPCSTR pSrcResource, LPCSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines, +FUNCTION: HRESULT D3DX10CompileFromResourceA ( HMODULE hSrcModule, LPCSTR pSrcResource, LPCSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude, LPCSTR pFunctionName, LPCSTR pProfile, UINT Flags1, UINT Flags2, ID3DX10ThreadPump* pPump, ID3D10Blob** ppShader, ID3D10Blob** ppErrorMsgs, HRESULT* pHResult ) ; -FUNCTION: HRESULT D3DX10CompileFromResourceW ( HMODULE hSrcModule, LPCWSTR pSrcResource, LPCWSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines, +FUNCTION: HRESULT D3DX10CompileFromResourceW ( HMODULE hSrcModule, LPCWSTR pSrcResource, LPCWSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude, LPCSTR pFunctionName, LPCSTR pProfile, UINT Flags1, UINT Flags2, ID3DX10ThreadPump* pPump, ID3D10Blob** ppShader, ID3D10Blob** ppErrorMsgs, HRESULT* pHResult ) ; ALIAS: D3DX10CompileFromResource D3DX10CompileFromResourceW -FUNCTION: HRESULT D3DX10CompileFromMemory ( LPCSTR pSrcData, SIZE_T SrcDataLen, LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude, +FUNCTION: HRESULT D3DX10CompileFromMemory ( LPCSTR pSrcData, SIZE_T SrcDataLen, LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude, LPCSTR pFunctionName, LPCSTR pProfile, UINT Flags1, UINT Flags2, ID3DX10ThreadPump* pPump, ID3D10Blob** ppShader, ID3D10Blob** ppErrorMsgs, HRESULT* pHResult ) ; -FUNCTION: HRESULT D3DX10CreateEffectFromFileA ( LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, - ID3D10Include* pInclude, LPCSTR pProfile, UINT HLSLFlags, UINT FXFlags, ID3D10Device* pDevice, +FUNCTION: HRESULT D3DX10CreateEffectFromFileA ( LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, + ID3D10Include* pInclude, LPCSTR pProfile, UINT HLSLFlags, UINT FXFlags, ID3D10Device* pDevice, ID3D10EffectPool* pEffectPool, ID3DX10ThreadPump* pPump, ID3D10Effect** ppEffect, ID3D10Blob** ppErrors, HRESULT* pHResult ) ; -FUNCTION: HRESULT D3DX10CreateEffectFromFileW ( LPCWSTR pFileName, D3D10_SHADER_MACRO* pDefines, - ID3D10Include* pInclude, LPCSTR pProfile, UINT HLSLFlags, UINT FXFlags, ID3D10Device* pDevice, +FUNCTION: HRESULT D3DX10CreateEffectFromFileW ( LPCWSTR pFileName, D3D10_SHADER_MACRO* pDefines, + ID3D10Include* pInclude, LPCSTR pProfile, UINT HLSLFlags, UINT FXFlags, ID3D10Device* pDevice, ID3D10EffectPool* pEffectPool, ID3DX10ThreadPump* pPump, ID3D10Effect** ppEffect, ID3D10Blob** ppErrors, HRESULT* pHResult ) ; -FUNCTION: HRESULT D3DX10CreateEffectFromMemory ( LPCVOID pData, SIZE_T DataLength, LPCSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines, - ID3D10Include* pInclude, LPCSTR pProfile, UINT HLSLFlags, UINT FXFlags, ID3D10Device* pDevice, +FUNCTION: HRESULT D3DX10CreateEffectFromMemory ( LPCVOID pData, SIZE_T DataLength, LPCSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines, + ID3D10Include* pInclude, LPCSTR pProfile, UINT HLSLFlags, UINT FXFlags, ID3D10Device* pDevice, ID3D10EffectPool* pEffectPool, ID3DX10ThreadPump* pPump, ID3D10Effect** ppEffect, ID3D10Blob** ppErrors, HRESULT* pHResult ) ; -FUNCTION: HRESULT D3DX10CreateEffectFromResourceA ( HMODULE hModule, LPCSTR pResourceName, LPCSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines, - ID3D10Include* pInclude, LPCSTR pProfile, UINT HLSLFlags, UINT FXFlags, ID3D10Device* pDevice, +FUNCTION: HRESULT D3DX10CreateEffectFromResourceA ( HMODULE hModule, LPCSTR pResourceName, LPCSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines, + ID3D10Include* pInclude, LPCSTR pProfile, UINT HLSLFlags, UINT FXFlags, ID3D10Device* pDevice, ID3D10EffectPool* pEffectPool, ID3DX10ThreadPump* pPump, ID3D10Effect** ppEffect, ID3D10Blob** ppErrors, HRESULT* pHResult ) ; -FUNCTION: HRESULT D3DX10CreateEffectFromResourceW ( HMODULE hModule, LPCWSTR pResourceName, LPCWSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines, - ID3D10Include* pInclude, LPCSTR pProfile, UINT HLSLFlags, UINT FXFlags, ID3D10Device* pDevice, +FUNCTION: HRESULT D3DX10CreateEffectFromResourceW ( HMODULE hModule, LPCWSTR pResourceName, LPCWSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines, + ID3D10Include* pInclude, LPCSTR pProfile, UINT HLSLFlags, UINT FXFlags, ID3D10Device* pDevice, ID3D10EffectPool* pEffectPool, ID3DX10ThreadPump* pPump, ID3D10Effect** ppEffect, ID3D10Blob** ppErrors, HRESULT* pHResult ) ; ALIAS: D3DX10CreateEffectFromFile D3DX10CreateEffectFromFileW ALIAS: D3DX10CreateEffectFromResource D3DX10CreateEffectFromResourceW -FUNCTION: HRESULT D3DX10CreateEffectPoolFromFileA ( LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, - ID3D10Include* pInclude, LPCSTR pProfile, UINT HLSLFlags, UINT FXFlags, ID3D10Device* pDevice, ID3DX10ThreadPump* pPump, +FUNCTION: HRESULT D3DX10CreateEffectPoolFromFileA ( LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, + ID3D10Include* pInclude, LPCSTR pProfile, UINT HLSLFlags, UINT FXFlags, ID3D10Device* pDevice, ID3DX10ThreadPump* pPump, ID3D10EffectPool** ppEffectPool, ID3D10Blob** ppErrors, HRESULT* pHResult ) ; -FUNCTION: HRESULT D3DX10CreateEffectPoolFromFileW ( LPCWSTR pFileName, D3D10_SHADER_MACRO* pDefines, - ID3D10Include* pInclude, LPCSTR pProfile, UINT HLSLFlags, UINT FXFlags, ID3D10Device* pDevice, ID3DX10ThreadPump* pPump, +FUNCTION: HRESULT D3DX10CreateEffectPoolFromFileW ( LPCWSTR pFileName, D3D10_SHADER_MACRO* pDefines, + ID3D10Include* pInclude, LPCSTR pProfile, UINT HLSLFlags, UINT FXFlags, ID3D10Device* pDevice, ID3DX10ThreadPump* pPump, ID3D10EffectPool** ppEffectPool, ID3D10Blob** ppErrors, HRESULT* pHResult ) ; -FUNCTION: HRESULT D3DX10CreateEffectPoolFromMemory ( LPCVOID pData, SIZE_T DataLength, LPCSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines, +FUNCTION: HRESULT D3DX10CreateEffectPoolFromMemory ( LPCVOID pData, SIZE_T DataLength, LPCSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines, ID3D10Include* pInclude, LPCSTR pProfile, UINT HLSLFlags, UINT FXFlags, ID3D10Device* pDevice, ID3DX10ThreadPump* pPump, ID3D10EffectPool** ppEffectPool, ID3D10Blob** ppErrors, HRESULT* pHResult ) ; -FUNCTION: HRESULT D3DX10CreateEffectPoolFromResourceA ( HMODULE hModule, LPCSTR pResourceName, LPCSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines, +FUNCTION: HRESULT D3DX10CreateEffectPoolFromResourceA ( HMODULE hModule, LPCSTR pResourceName, LPCSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines, ID3D10Include* pInclude, LPCSTR pProfile, UINT HLSLFlags, UINT FXFlags, ID3D10Device* pDevice, ID3DX10ThreadPump* pPump, ID3D10EffectPool** ppEffectPool, ID3D10Blob** ppErrors, HRESULT* pHResult ) ; - -FUNCTION: HRESULT D3DX10CreateEffectPoolFromResourceW ( HMODULE hModule, LPCWSTR pResourceName, LPCWSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines, + +FUNCTION: HRESULT D3DX10CreateEffectPoolFromResourceW ( HMODULE hModule, LPCWSTR pResourceName, LPCWSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines, ID3D10Include* pInclude, LPCSTR pProfile, UINT HLSLFlags, UINT FXFlags, ID3D10Device* pDevice, ID3DX10ThreadPump* pPump, ID3D10EffectPool** ppEffectPool, ID3D10Blob** ppErrors, HRESULT* pHResult ) ; ALIAS: D3DX10CreateEffectPoolFromFile D3DX10CreateEffectPoolFromFileW ALIAS: D3DX10CreateEffectPoolFromResource D3DX10CreateEffectPoolFromResourceW -FUNCTION: HRESULT D3DX10PreprocessShaderFromFileA ( LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, +FUNCTION: HRESULT D3DX10PreprocessShaderFromFileA ( LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude, ID3DX10ThreadPump* pPump, ID3D10Blob** ppShaderText, ID3D10Blob** ppErrorMsgs, HRESULT* pHResult ) ; -FUNCTION: HRESULT D3DX10PreprocessShaderFromFileW ( LPCWSTR pFileName, D3D10_SHADER_MACRO* pDefines, +FUNCTION: HRESULT D3DX10PreprocessShaderFromFileW ( LPCWSTR pFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude, ID3DX10ThreadPump* pPump, ID3D10Blob** ppShaderText, ID3D10Blob** ppErrorMsgs, HRESULT* pHResult ) ; -FUNCTION: HRESULT D3DX10PreprocessShaderFromMemory ( LPCSTR pSrcData, SIZE_T SrcDataSize, LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, +FUNCTION: HRESULT D3DX10PreprocessShaderFromMemory ( LPCSTR pSrcData, SIZE_T SrcDataSize, LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude, ID3DX10ThreadPump* pPump, ID3D10Blob** ppShaderText, ID3D10Blob** ppErrorMsgs, HRESULT* pHResult ) ; -FUNCTION: HRESULT D3DX10PreprocessShaderFromResourceA ( HMODULE hModule, LPCSTR pResourceName, LPCSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines, +FUNCTION: HRESULT D3DX10PreprocessShaderFromResourceA ( HMODULE hModule, LPCSTR pResourceName, LPCSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude, ID3DX10ThreadPump* pPump, ID3D10Blob** ppShaderText, ID3D10Blob** ppErrorMsgs, HRESULT* pHResult ) ; -FUNCTION: HRESULT D3DX10PreprocessShaderFromResourceW ( HMODULE hModule, LPCWSTR pResourceName, LPCWSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines, +FUNCTION: HRESULT D3DX10PreprocessShaderFromResourceW ( HMODULE hModule, LPCWSTR pResourceName, LPCWSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude, ID3DX10ThreadPump* pPump, ID3D10Blob** ppShaderText, ID3D10Blob** ppErrorMsgs, HRESULT* pHResult ) ; ALIAS: D3DX10PreprocessShaderFromFile D3DX10PreprocessShaderFromFileW ALIAS: D3DX10PreprocessShaderFromResource D3DX10PreprocessShaderFromResourceW -FUNCTION: HRESULT D3DX10CreateAsyncCompilerProcessor ( LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude, +FUNCTION: HRESULT D3DX10CreateAsyncCompilerProcessor ( LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude, LPCSTR pFunctionName, LPCSTR pProfile, UINT Flags1, UINT Flags2, ID3D10Blob** ppCompiledShader, ID3D10Blob** ppErrorBuffer, ID3DX10DataProcessor** ppProcessor ) ; -FUNCTION: HRESULT D3DX10CreateAsyncEffectCreateProcessor ( LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude, +FUNCTION: HRESULT D3DX10CreateAsyncEffectCreateProcessor ( LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude, LPCSTR pProfile, UINT Flags, UINT FXFlags, ID3D10Device* pDevice, ID3D10EffectPool* pPool, ID3D10Blob** ppErrorBuffer, ID3DX10DataProcessor** ppProcessor ) ; -FUNCTION: HRESULT D3DX10CreateAsyncEffectPoolCreateProcessor ( LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude, +FUNCTION: HRESULT D3DX10CreateAsyncEffectPoolCreateProcessor ( LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude, LPCSTR pProfile, UINT Flags, UINT FXFlags, ID3D10Device* pDevice, ID3D10Blob** ppErrorBuffer, ID3DX10DataProcessor** ppProcessor ) ; -FUNCTION: HRESULT D3DX10CreateAsyncShaderPreprocessProcessor ( LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude, +FUNCTION: HRESULT D3DX10CreateAsyncShaderPreprocessProcessor ( LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude, ID3D10Blob** ppShaderText, ID3D10Blob** ppErrorBuffer, ID3DX10DataProcessor** ppProcessor ) ; FUNCTION: HRESULT D3DX10CreateAsyncFileLoaderW ( LPCWSTR pFileName, ID3DX10DataLoader** ppDataLoader ) ; diff --git a/basis/windows/directx/d3dx11async/d3dx11async.factor b/basis/windows/directx/d3dx11async/d3dx11async.factor index 8728456aca..2381b4e8f2 100644 --- a/basis/windows/directx/d3dx11async/d3dx11async.factor +++ b/basis/windows/directx/d3dx11async/d3dx11async.factor @@ -11,38 +11,38 @@ FUNCTION: HRESULT D3DX11CompileFromFileW ( LPCWSTR pSrcFile, D3D10_SHADER_MACRO* LPCSTR pFunctionName, LPCSTR pProfile, UINT Flags1, UINT Flags2, ID3DX11ThreadPump* pPump, ID3D10Blob** ppShader, ID3D10Blob** ppErrorMsgs, HRESULT* pHResult ) ; ALIAS: D3DX11CompileFromFile D3DX11CompileFromFileW -FUNCTION: HRESULT D3DX11CompileFromResourceA ( HMODULE hSrcModule, LPCSTR pSrcResource, LPCSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines, +FUNCTION: HRESULT D3DX11CompileFromResourceA ( HMODULE hSrcModule, LPCSTR pSrcResource, LPCSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude, LPCSTR pFunctionName, LPCSTR pProfile, UINT Flags1, UINT Flags2, ID3DX11ThreadPump* pPump, ID3D10Blob** ppShader, ID3D10Blob** ppErrorMsgs, HRESULT* pHResult ) ; -FUNCTION: HRESULT D3DX11CompileFromResourceW ( HMODULE hSrcModule, LPCWSTR pSrcResource, LPCWSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines, +FUNCTION: HRESULT D3DX11CompileFromResourceW ( HMODULE hSrcModule, LPCWSTR pSrcResource, LPCWSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude, LPCSTR pFunctionName, LPCSTR pProfile, UINT Flags1, UINT Flags2, ID3DX11ThreadPump* pPump, ID3D10Blob** ppShader, ID3D10Blob** ppErrorMsgs, HRESULT* pHResult ) ; ALIAS: D3DX11CompileFromResource D3DX11CompileFromResourceW -FUNCTION: HRESULT D3DX11CompileFromMemory ( LPCSTR pSrcData, SIZE_T SrcDataLen, LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude, +FUNCTION: HRESULT D3DX11CompileFromMemory ( LPCSTR pSrcData, SIZE_T SrcDataLen, LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude, LPCSTR pFunctionName, LPCSTR pProfile, UINT Flags1, UINT Flags2, ID3DX11ThreadPump* pPump, ID3D10Blob** ppShader, ID3D10Blob** ppErrorMsgs, HRESULT* pHResult ) ; -FUNCTION: HRESULT D3DX11PreprocessShaderFromFileA ( LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, +FUNCTION: HRESULT D3DX11PreprocessShaderFromFileA ( LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude, ID3DX11ThreadPump* pPump, ID3D10Blob** ppShaderText, ID3D10Blob** ppErrorMsgs, HRESULT* pHResult ) ; -FUNCTION: HRESULT D3DX11PreprocessShaderFromFileW ( LPCWSTR pFileName, D3D10_SHADER_MACRO* pDefines, +FUNCTION: HRESULT D3DX11PreprocessShaderFromFileW ( LPCWSTR pFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude, ID3DX11ThreadPump* pPump, ID3D10Blob** ppShaderText, ID3D10Blob** ppErrorMsgs, HRESULT* pHResult ) ; -FUNCTION: HRESULT D3DX11PreprocessShaderFromMemory ( LPCSTR pSrcData, SIZE_T SrcDataSize, LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, +FUNCTION: HRESULT D3DX11PreprocessShaderFromMemory ( LPCSTR pSrcData, SIZE_T SrcDataSize, LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude, ID3DX11ThreadPump* pPump, ID3D10Blob** ppShaderText, ID3D10Blob** ppErrorMsgs, HRESULT* pHResult ) ; -FUNCTION: HRESULT D3DX11PreprocessShaderFromResourceA ( HMODULE hModule, LPCSTR pResourceName, LPCSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines, +FUNCTION: HRESULT D3DX11PreprocessShaderFromResourceA ( HMODULE hModule, LPCSTR pResourceName, LPCSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude, ID3DX11ThreadPump* pPump, ID3D10Blob** ppShaderText, ID3D10Blob** ppErrorMsgs, HRESULT* pHResult ) ; -FUNCTION: HRESULT D3DX11PreprocessShaderFromResourceW ( HMODULE hModule, LPCWSTR pResourceName, LPCWSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines, +FUNCTION: HRESULT D3DX11PreprocessShaderFromResourceW ( HMODULE hModule, LPCWSTR pResourceName, LPCWSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude, ID3DX11ThreadPump* pPump, ID3D10Blob** ppShaderText, ID3D10Blob** ppErrorMsgs, HRESULT* pHResult ) ; ALIAS: D3DX11PreprocessShaderFromFile D3DX11PreprocessShaderFromFileW ALIAS: D3DX11PreprocessShaderFromResource D3DX11PreprocessShaderFromResourceW -FUNCTION: HRESULT D3DX11CreateAsyncCompilerProcessor ( LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude, +FUNCTION: HRESULT D3DX11CreateAsyncCompilerProcessor ( LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude, LPCSTR pFunctionName, LPCSTR pProfile, UINT Flags1, UINT Flags2, ID3D10Blob** ppCompiledShader, ID3D10Blob** ppErrorBuffer, ID3DX11DataProcessor** ppProcessor ) ; -FUNCTION: HRESULT D3DX11CreateAsyncShaderPreprocessProcessor ( LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude, +FUNCTION: HRESULT D3DX11CreateAsyncShaderPreprocessProcessor ( LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude, ID3D10Blob** ppShaderText, ID3D10Blob** ppErrorBuffer, ID3DX11DataProcessor** ppProcessor ) ; FUNCTION: HRESULT D3DX11CreateAsyncFileLoaderW ( LPCWSTR pFileName, ID3DX11DataLoader** ppDataLoader ) ; diff --git a/basis/windows/directx/d3dx11tex/d3dx11tex.factor b/basis/windows/directx/d3dx11tex/d3dx11tex.factor index 281fa9d433..43f77e368b 100644 --- a/basis/windows/directx/d3dx11tex/d3dx11tex.factor +++ b/basis/windows/directx/d3dx11tex/d3dx11tex.factor @@ -290,4 +290,3 @@ FUNCTION: HRESULT FLOAT* pROut, FLOAT* pGOut, FLOAT* pBOut ) ; - diff --git a/basis/windows/directx/d3dx9anim/d3dx9anim.factor b/basis/windows/directx/d3dx9anim/d3dx9anim.factor index ec3f1711d8..8fc81d5cce 100644 --- a/basis/windows/directx/d3dx9anim/d3dx9anim.factor +++ b/basis/windows/directx/d3dx9anim/d3dx9anim.factor @@ -376,13 +376,13 @@ D3DXFrameRegisterNamedMatrices LPD3DXFRAME pFrameRoot, LPD3DXANIMATIONCONTROLLER pAnimController ) ; - + FUNCTION: UINT D3DXFrameNumNamedMatrices ( D3DXFRAME* pFrameRoot ) ; - + FUNCTION: HRESULT D3DXFrameCalculateBoundingSphere ( diff --git a/basis/windows/directx/d3dx9core/d3dx9core.factor b/basis/windows/directx/d3dx9core/d3dx9core.factor index 545fd60ed7..fda2b07b8d 100644 --- a/basis/windows/directx/d3dx9core/d3dx9core.factor +++ b/basis/windows/directx/d3dx9core/d3dx9core.factor @@ -9,7 +9,7 @@ CONSTANT: D3DX_VERSION 0x0902 CONSTANT: D3DX_SDK_VERSION 42 FUNCTION: BOOL D3DXCheckVersion ( UINT D3DSdkVersion, UINT D3DXSdkVersion ) ; -FUNCTION: BOOL D3DXDebugMute ( BOOL Mute ) ; +FUNCTION: BOOL D3DXDebugMute ( BOOL Mute ) ; FUNCTION: UINT D3DXGetDriverLevel ( LPDIRECT3DDEVICE9 pDevice ) ; C-TYPE: ID3DXBuffer @@ -46,8 +46,8 @@ COM-INTERFACE: ID3DXSprite IUnknown {BA0B762D-7D28-43ec-B9DC-2F84443B0614} HRESULT OnResetDevice ( ) ; FUNCTION: HRESULT - D3DXCreateSprite ( - LPDIRECT3DDEVICE9 pDevice, + D3DXCreateSprite ( + LPDIRECT3DDEVICE9 pDevice, LPD3DXSPRITE* ppSprite ) ; STRUCT: D3DXFONT_DESCA @@ -103,7 +103,7 @@ COM-INTERFACE: ID3DXFont IUnknown {D79DBB70-5F21-4d36-BBC2-FF525C213CDC} FUNCTION: HRESULT D3DXCreateFontA ( - LPDIRECT3DDEVICE9 pDevice, + LPDIRECT3DDEVICE9 pDevice, INT Height, UINT Width, UINT Weight, @@ -118,7 +118,7 @@ FUNCTION: HRESULT FUNCTION: HRESULT D3DXCreateFontW ( - LPDIRECT3DDEVICE9 pDevice, + LPDIRECT3DDEVICE9 pDevice, INT Height, UINT Width, UINT Weight, @@ -134,15 +134,15 @@ FUNCTION: HRESULT ALIAS: D3DXCreateFont D3DXCreateFontW FUNCTION: HRESULT - D3DXCreateFontIndirectA ( - LPDIRECT3DDEVICE9 pDevice, - D3DXFONT_DESCA* pDesc, + D3DXCreateFontIndirectA ( + LPDIRECT3DDEVICE9 pDevice, + D3DXFONT_DESCA* pDesc, LPD3DXFONT* ppFont ) ; FUNCTION: HRESULT - D3DXCreateFontIndirectW ( - LPDIRECT3DDEVICE9 pDevice, - D3DXFONT_DESCW* pDesc, + D3DXCreateFontIndirectW ( + LPDIRECT3DDEVICE9 pDevice, + D3DXFONT_DESCW* pDesc, LPD3DXFONT* ppFont ) ; ALIAS: D3DXCreateFontIndirect D3DXCreateFontIndirectW @@ -216,7 +216,7 @@ COM-INTERFACE: ID3DXLine IUnknown {D379BA7F-9042-4ac4-9F5E-58192A4C6BD8} HRESULT Begin ( ) HRESULT Draw ( D3DXVECTOR2* pVertexList, DWORD dwVertexListCount, D3DCOLOR Color ) HRESULT DrawTransform ( D3DXVECTOR3* pVertexList, - DWORD dwVertexListCount, D3DXMATRIX* pTransform, + DWORD dwVertexListCount, D3DXMATRIX* pTransform, D3DCOLOR Color ) HRESULT SetPattern ( DWORD dwPattern ) DWORD GetPattern ( ) diff --git a/basis/windows/directx/d3dx9effect/d3dx9effect.factor b/basis/windows/directx/d3dx9effect/d3dx9effect.factor index 523569d84e..ce0afa522c 100644 --- a/basis/windows/directx/d3dx9effect/d3dx9effect.factor +++ b/basis/windows/directx/d3dx9effect/d3dx9effect.factor @@ -248,7 +248,7 @@ FUNCTION: HRESULT LPCSTR pSrcFile, D3DXMACRO* pDefines, LPD3DXINCLUDE pInclude, - LPCSTR pSkipConstants, + LPCSTR pSkipConstants, DWORD Flags, LPD3DXEFFECTPOOL pPool, LPD3DXEFFECT* ppEffect, @@ -260,7 +260,7 @@ FUNCTION: HRESULT LPCWSTR pSrcFile, D3DXMACRO* pDefines, LPD3DXINCLUDE pInclude, - LPCSTR pSkipConstants, + LPCSTR pSkipConstants, DWORD Flags, LPD3DXEFFECTPOOL pPool, LPD3DXEFFECT* ppEffect, @@ -275,7 +275,7 @@ FUNCTION: HRESULT LPCSTR pSrcResource, D3DXMACRO* pDefines, LPD3DXINCLUDE pInclude, - LPCSTR pSkipConstants, + LPCSTR pSkipConstants, DWORD Flags, LPD3DXEFFECTPOOL pPool, LPD3DXEFFECT* ppEffect, @@ -288,7 +288,7 @@ FUNCTION: HRESULT LPCWSTR pSrcResource, D3DXMACRO* pDefines, LPD3DXINCLUDE pInclude, - LPCSTR pSkipConstants, + LPCSTR pSkipConstants, DWORD Flags, LPD3DXEFFECTPOOL pPool, LPD3DXEFFECT* ppEffect, @@ -303,7 +303,7 @@ FUNCTION: HRESULT UINT SrcDataLen, D3DXMACRO* pDefines, LPD3DXINCLUDE pInclude, - LPCSTR pSkipConstants, + LPCSTR pSkipConstants, DWORD Flags, LPD3DXEFFECTPOOL pPool, LPD3DXEFFECT* ppEffect, @@ -361,9 +361,8 @@ FUNCTION: HRESULT LPD3DXEFFECTCOMPILER* ppCompiler, LPD3DXBUFFER* ppParseErrors ) ; -FUNCTION: HRESULT +FUNCTION: HRESULT D3DXDisassembleEffect ( - LPD3DXEFFECT pEffect, - BOOL EnableColorCode, + LPD3DXEFFECT pEffect, + BOOL EnableColorCode, LPD3DXBUFFER* ppDisassembly ) ; - diff --git a/basis/windows/directx/d3dx9math/d3dx9math.factor b/basis/windows/directx/d3dx9math/d3dx9math.factor index 394c740267..a37ec57928 100644 --- a/basis/windows/directx/d3dx9math/d3dx9math.factor +++ b/basis/windows/directx/d3dx9math/d3dx9math.factor @@ -157,4 +157,3 @@ FUNCTION: HRESULT D3DXSHEvalHemisphereLight FUNCTION: HRESULT D3DXSHProjectCubeMap ( UINT uOrder, LPDIRECT3DCUBETEXTURE9 pCubeMap, FLOAT* ROut, FLOAT* GOut, FLOAT* BOut ) ; - diff --git a/basis/windows/directx/d3dx9mesh/d3dx9mesh.factor b/basis/windows/directx/d3dx9mesh/d3dx9mesh.factor index 64dec9df7e..d3ca655006 100644 --- a/basis/windows/directx/d3dx9mesh/d3dx9mesh.factor +++ b/basis/windows/directx/d3dx9mesh/d3dx9mesh.factor @@ -558,7 +558,7 @@ FUNCTION: HRESULT DWORD NumBones, D3DXBONECOMBINATION* pBoneCombinationTable, LPD3DXSKININFO* ppSkinInfo ) ; - + FUNCTION: HRESULT D3DXTessellateNPatches ( LPD3DXMESH pMeshIn, @@ -761,8 +761,8 @@ FUNCTION: HRESULT D3DXComputeTangent ( DWORD Wrap, DWORD* pAdjacency ) ; -C-TYPE: D3DXUVATLASCB -TYPEDEF: D3DXUVATLASCB* LPD3DXUVATLASCB +C-TYPE: D3DXUVATLASCB +TYPEDEF: D3DXUVATLASCB* LPD3DXUVATLASCB FUNCTION: HRESULT D3DXUVAtlasCreate ( LPD3DXMESH pMesh, @@ -816,7 +816,7 @@ FUNCTION: HRESULT D3DXUVAtlasPack ( LPVOID pUserContext, DWORD dwOptions, LPD3DXBUFFER pFacePartitioning ) ; - + TYPEDEF: void* LPD3DXIMTSIGNALCALLBACK FUNCTION: HRESULT D3DXComputeIMTFromPerVertexSignal ( @@ -1128,7 +1128,7 @@ ALIAS: D3DXSavePRTBufferToFile D3DXSavePRTBufferToFileW C-TYPE: D3DXPRTCOMPBUFFER TYPEDEF: D3DXPRTCOMPBUFFER* LPD3DXPRTCOMPBUFFER - + FUNCTION: HRESULT D3DXLoadPRTCompBufferFromFileA ( LPCSTR pFilename, @@ -1217,4 +1217,3 @@ FUNCTION: HRESULT UINT* pVertDataLength, UINT* pSCClusterList, D3DXSHPRTSPLITMESHCLUSTERDATA* pSCData ) ; - diff --git a/basis/windows/directx/d3dx9shader/d3dx9shader.factor b/basis/windows/directx/d3dx9shader/d3dx9shader.factor index ad215ee33a..4572e8346f 100644 --- a/basis/windows/directx/d3dx9shader/d3dx9shader.factor +++ b/basis/windows/directx/d3dx9shader/d3dx9shader.factor @@ -291,9 +291,9 @@ FUNCTION: HRESULT FUNCTION: HRESULT D3DXDisassembleShader ( - DWORD* pShader, - BOOL EnableColorCode, - LPCSTR pComments, + DWORD* pShader, + BOOL EnableColorCode, + LPCSTR pComments, LPD3DXBUFFER* ppDisassembly ) ; FUNCTION: LPCSTR @@ -310,7 +310,7 @@ FUNCTION: HRESULT DWORD FourCC, LPCVOID* ppData, UINT* pSizeInBytes ) ; - + FUNCTION: UINT D3DXGetShaderSize ( DWORD* pFunction ) ; @@ -350,18 +350,18 @@ FUNCTION: HRESULT FUNCTION: HRESULT D3DXCreateTextureShader ( - DWORD* pFunction, + DWORD* pFunction, LPD3DXTEXTURESHADER* ppTextureShader ) ; - -FUNCTION: HRESULT + +FUNCTION: HRESULT D3DXPreprocessShaderFromFileA ( LPCSTR pSrcFile, D3DXMACRO* pDefines, LPD3DXINCLUDE pInclude, LPD3DXBUFFER* ppShaderText, LPD3DXBUFFER* ppErrorMsgs ) ; - -FUNCTION: HRESULT + +FUNCTION: HRESULT D3DXPreprocessShaderFromFileW ( LPCWSTR pSrcFile, D3DXMACRO* pDefines, @@ -371,7 +371,7 @@ FUNCTION: HRESULT ALIAS: D3DXPreprocessShaderFromFile D3DXPreprocessShaderFromFileW -FUNCTION: HRESULT +FUNCTION: HRESULT D3DXPreprocessShaderFromResourceA ( HMODULE hSrcModule, LPCSTR pSrcResource, @@ -380,7 +380,7 @@ FUNCTION: HRESULT LPD3DXBUFFER* ppShaderText, LPD3DXBUFFER* ppErrorMsgs ) ; -FUNCTION: HRESULT +FUNCTION: HRESULT D3DXPreprocessShaderFromResourceW ( HMODULE hSrcModule, LPCWSTR pSrcResource, @@ -391,7 +391,7 @@ FUNCTION: HRESULT ALIAS: D3DXPreprocessShaderFromResource D3DXPreprocessShaderFromResourceW -FUNCTION: HRESULT +FUNCTION: HRESULT D3DXPreprocessShader ( LPCSTR pSrcData, UINT SrcDataSize, @@ -434,4 +434,3 @@ STRUCT: D3DXSHADER_STRUCTMEMBERINFO { Name DWORD } { TypeInfo DWORD } ; TYPEDEF: D3DXSHADER_STRUCTMEMBERINFO* LPD3DXSHADER_STRUCTMEMBERINFO - diff --git a/basis/windows/directx/d3dx9shape/d3dx9shape.factor b/basis/windows/directx/d3dx9shape/d3dx9shape.factor index 8f3bab428a..8fc740b271 100644 --- a/basis/windows/directx/d3dx9shape/d3dx9shape.factor +++ b/basis/windows/directx/d3dx9shape/d3dx9shape.factor @@ -5,41 +5,41 @@ IN: windows.directx.d3dx9shape LIBRARY: d3dx9 -TYPEDEF: void* LPGLYPHMETRICSFLOAT +TYPEDEF: void* LPGLYPHMETRICSFLOAT -FUNCTION: HRESULT +FUNCTION: HRESULT D3DXCreatePolygon ( LPDIRECT3DDEVICE9 pDevice, - FLOAT Length, - UINT Sides, + FLOAT Length, + UINT Sides, LPD3DXMESH* ppMesh, LPD3DXBUFFER* ppAdjacency ) ; -FUNCTION: HRESULT +FUNCTION: HRESULT D3DXCreateBox ( - LPDIRECT3DDEVICE9 pDevice, + LPDIRECT3DDEVICE9 pDevice, FLOAT Width, FLOAT Height, FLOAT Depth, LPD3DXMESH* ppMesh, LPD3DXBUFFER* ppAdjacency ) ; -FUNCTION: HRESULT +FUNCTION: HRESULT D3DXCreateCylinder ( LPDIRECT3DDEVICE9 pDevice, - FLOAT Radius1, - FLOAT Radius2, - FLOAT Length, - UINT Slices, - UINT Stacks, + FLOAT Radius1, + FLOAT Radius2, + FLOAT Length, + UINT Slices, + UINT Stacks, LPD3DXMESH* ppMesh, LPD3DXBUFFER* ppAdjacency ) ; FUNCTION: HRESULT D3DXCreateSphere ( - LPDIRECT3DDEVICE9 pDevice, - FLOAT Radius, - UINT Slices, + LPDIRECT3DDEVICE9 pDevice, + FLOAT Radius, + UINT Slices, UINT Stacks, LPD3DXMESH* ppMesh, LPD3DXBUFFER* ppAdjacency ) ; @@ -48,9 +48,9 @@ FUNCTION: HRESULT D3DXCreateTorus ( LPDIRECT3DDEVICE9 pDevice, FLOAT InnerRadius, - FLOAT OuterRadius, + FLOAT OuterRadius, UINT Sides, - UINT Rings, + UINT Rings, LPD3DXMESH* ppMesh, LPD3DXBUFFER* ppAdjacency ) ; diff --git a/basis/windows/directx/d3dx9tex/d3dx9tex.factor b/basis/windows/directx/d3dx9tex/d3dx9tex.factor index e3dc53c985..5acf2b5a2a 100644 --- a/basis/windows/directx/d3dx9tex/d3dx9tex.factor +++ b/basis/windows/directx/d3dx9tex/d3dx9tex.factor @@ -116,7 +116,7 @@ FUNCTION: HRESULT DWORD Filter, D3DCOLOR ColorKey, D3DXIMAGE_INFO* pSrcInfo ) ; - + ALIAS: D3DXLoadSurfaceFromFile D3DXLoadSurfaceFromFileW FUNCTION: HRESULT @@ -167,7 +167,7 @@ FUNCTION: HRESULT RECT* pSrcRect, DWORD Filter, D3DCOLOR ColorKey ) ; - + FUNCTION: HRESULT D3DXLoadSurfaceFromMemory ( LPDIRECT3DSURFACE9 pDestSurface, @@ -217,7 +217,7 @@ FUNCTION: HRESULT DWORD Filter, D3DCOLOR ColorKey, D3DXIMAGE_INFO* pSrcInfo ) ; - + FUNCTION: HRESULT D3DXLoadVolumeFromFileW ( LPDIRECT3DVOLUME9 pDestVolume, @@ -279,7 +279,7 @@ FUNCTION: HRESULT D3DBOX* pSrcBox, DWORD Filter, D3DCOLOR ColorKey ) ; - + FUNCTION: HRESULT D3DXLoadVolumeFromMemory ( LPDIRECT3DVOLUME9 pDestVolume, diff --git a/basis/windows/directx/dinput/constants/constants.factor b/basis/windows/directx/dinput/constants/constants.factor index a47a47da5a..b0b78b68a5 100755 --- a/basis/windows/directx/dinput/constants/constants.factor +++ b/basis/windows/directx/dinput/constants/constants.factor @@ -851,4 +851,3 @@ MACRO: ( dwFlags dwDataSize struct rgodf-array -- alien ) } [ [ rgodf>> free ] uninitialize ] each ; PRIVATE> - diff --git a/basis/windows/directx/dinput/dinput.factor b/basis/windows/directx/dinput/dinput.factor index 44228f95c5..aaaf3ee2d1 100644 --- a/basis/windows/directx/dinput/dinput.factor +++ b/basis/windows/directx/dinput/dinput.factor @@ -367,7 +367,7 @@ COM-INTERFACE: IDirectInputDevice8W IUnknown {54D41081-DC15-4833-A41B-748F73A381 HRESULT GetImageInfo ( LPDIDEVICEIMAGEINFOHEADERW lpdiDeviceImageInfoHeader ) ; CALLBACK: BOOL LPDIENUMDEVICESBYSEMANTICSCBW ( - LPCDIDEVICEINSTANCEW lpddi, + LPCDIDEVICEINSTANCEW lpddi, IDirectInputDevice8W* lpdid, DWORD dwFlags, DWORD dwRemaining, @@ -387,7 +387,7 @@ COM-INTERFACE: IDirectInput8W IUnknown {BF798031-483A-4DA2-AA99-5D64ED369700} FUNCTION: HRESULT DirectInput8Create ( HINSTANCE hinst, DWORD dwVersion, REFIID riidtlf, LPVOID* ppvOut, LPUNKNOWN punkOuter ) ; CONSTANT: DIRECTINPUT_VERSION 0x0800 - + CONSTANT: DI8DEVCLASS_ALL 0 CONSTANT: DI8DEVCLASS_DEVICE 1 CONSTANT: DI8DEVCLASS_POINTER 2 @@ -400,7 +400,7 @@ CONSTANT: DIEDFL_FORCEFEEDBACK 0x00000100 CONSTANT: DIEDFL_INCLUDEALIASES 0x00010000 CONSTANT: DIEDFL_INCLUDEPHANTOMS 0x00020000 CONSTANT: DIEDFL_INCLUDEHIDDEN 0x00040000 - + CONSTANT: DIENUM_STOP 0 CONSTANT: DIENUM_CONTINUE 1 @@ -408,19 +408,19 @@ CONSTANT: DIDF_ABSAXIS 1 CONSTANT: DIDF_RELAXIS 2 CONSTANT: DIDFT_ALL 0x00000000 - + CONSTANT: DIDFT_RELAXIS 0x00000001 CONSTANT: DIDFT_ABSAXIS 0x00000002 CONSTANT: DIDFT_AXIS 0x00000003 - + CONSTANT: DIDFT_PSHBUTTON 0x00000004 CONSTANT: DIDFT_TGLBUTTON 0x00000008 CONSTANT: DIDFT_BUTTON 0x0000000C - + CONSTANT: DIDFT_POV 0x00000010 CONSTANT: DIDFT_COLLECTION 0x00000040 CONSTANT: DIDFT_NODATA 0x00000080 - + CONSTANT: DIDFT_ANYINSTANCE 0x00FFFF00 ALIAS: DIDFT_INSTANCEMASK DIDFT_ANYINSTANCE : DIDFT_MAKEINSTANCE ( n -- instance ) 8 shift ; inline @@ -650,7 +650,7 @@ CONSTANT: DIPH_DEVICE 0 CONSTANT: DIPH_BYOFFSET 1 CONSTANT: DIPH_BYID 2 CONSTANT: DIPH_BYUSAGE 3 - + : DIMAKEUSAGEDWORD ( UsagePage Usage -- DWORD ) 16 shift bitor ; inline : DIPROP_BUFFERSIZE ( -- alien ) 1 ; inline @@ -658,7 +658,7 @@ CONSTANT: DIPH_BYUSAGE 3 CONSTANT: DIPROPAXISMODE_ABS 0 CONSTANT: DIPROPAXISMODE_REL 1 - + : DIPROP_GRANULARITY ( -- alien ) 3 ; inline : DIPROP_RANGE ( -- alien ) 4 ; inline : DIPROP_DEADZONE ( -- alien ) 5 ; inline diff --git a/basis/windows/directx/directx.factor b/basis/windows/directx/directx.factor index 8471d08c6f..4a9291467c 100644 --- a/basis/windows/directx/directx.factor +++ b/basis/windows/directx/directx.factor @@ -9,7 +9,7 @@ IN: windows.directx { "d3d10" "d3d10.dll" stdcall } { "d3d10_1" "d3d10_1.dll" stdcall } { "d3d11" "d3d11.dll" stdcall } - { "d3dcompiler" "d3dcompiler_42.dll" stdcall } + { "d3dcompiler" "d3dcompiler_42.dll" stdcall } { "d3dcsx" "d3dcsx_42.dll" stdcall } { "d3dx9" "d3dx9_42.dll" stdcall } { "d3dx10" "d3dx10_42.dll" stdcall } diff --git a/basis/windows/directx/dwrite/dwrite.factor b/basis/windows/directx/dwrite/dwrite.factor index 49bff6611f..2d5f5059a3 100755 --- a/basis/windows/directx/dwrite/dwrite.factor +++ b/basis/windows/directx/dwrite/dwrite.factor @@ -495,7 +495,7 @@ STRUCT: DWRITE_LINE_METRICS { isTrimmed BOOL } ; STRUCT: DWRITE_CLUSTER_METRICS - { width FLOAT } + { width FLOAT } { length USHORT } { data USHORT } ; diff --git a/basis/windows/directx/dxfile/dxfile.factor b/basis/windows/directx/dxfile/dxfile.factor index a5fc03ab4e..7a74734a64 100755 --- a/basis/windows/directx/dxfile/dxfile.factor +++ b/basis/windows/directx/dxfile/dxfile.factor @@ -92,7 +92,7 @@ COM-INTERFACE: IDirectXFileBinary IDirectXFileObject {3d82ab46-62da-11cf-ab39-00 HRESULT Read ( LPVOID x, DWORD y, LPDWORD z ) ; CONSTANT: DXFILE_OK 0 - + CONSTANT: DXFILEERR_BADOBJECT 0x88760352 CONSTANT: DXFILEERR_BADVALUE 0x88760353 CONSTANT: DXFILEERR_BADTYPE 0x88760354 diff --git a/basis/windows/directx/dxgi/dxgi.factor b/basis/windows/directx/dxgi/dxgi.factor index 48c6eb1354..f5cc177ef8 100644 --- a/basis/windows/directx/dxgi/dxgi.factor +++ b/basis/windows/directx/dxgi/dxgi.factor @@ -119,7 +119,7 @@ COM-INTERFACE: IDXGISurface1 IDXGISurface {4AE63092-6327-4c1b-80AE-BFE12EA32B86} HRESULT GetDC ( BOOL Discard, HDC* phdc ) HRESULT ReleaseDC ( RECT* pDirtyRect ) ; -C-TYPE: IDXGIOutput +C-TYPE: IDXGIOutput COM-INTERFACE: IDXGIAdapter IDXGIObject {2411e7e1-12ac-4ccf-bd14-9798e8534dc0} HRESULT EnumOutputs ( UINT Output, IDXGIOutput** ppOutput ) HRESULT GetDesc ( DXGI_ADAPTER_DESC* pDesc ) diff --git a/basis/windows/directx/xact3/xact3.factor b/basis/windows/directx/xact3/xact3.factor index a1f002a71a..a83a75f85f 100644 --- a/basis/windows/directx/xact3/xact3.factor +++ b/basis/windows/directx/xact3/xact3.factor @@ -365,16 +365,16 @@ COM-INTERFACE: IXACT3Wave f {00000000-0000-0000-0000-000000000000} HRESULT SetMatrixCoefficients ( UINT32 uSrcChannelCount, UINT32 uDstChannelCount, float* pMatrixCoefficients ) HRESULT GetProperties ( LPXACT_WAVE_INSTANCE_PROPERTIES pProperties ) ; -: XACT_FLAG_CUE_STOP_RELEASE ( -- z ) XACT_FLAG_STOP_RELEASE ; inline -: XACT_FLAG_CUE_STOP_IMMEDIATE ( -- z ) XACT_FLAG_STOP_IMMEDIATE ; inline +: XACT_FLAG_CUE_STOP_RELEASE ( -- z ) XACT_FLAG_STOP_RELEASE ; inline +: XACT_FLAG_CUE_STOP_IMMEDIATE ( -- z ) XACT_FLAG_STOP_IMMEDIATE ; inline -: XACT_CUESTATE_CREATED ( -- z ) XACT_STATE_CREATED ; inline -: XACT_CUESTATE_PREPARING ( -- z ) XACT_STATE_PREPARING ; inline -: XACT_CUESTATE_PREPARED ( -- z ) XACT_STATE_PREPARED ; inline -: XACT_CUESTATE_PLAYING ( -- z ) XACT_STATE_PLAYING ; inline -: XACT_CUESTATE_STOPPING ( -- z ) XACT_STATE_STOPPING ; inline -: XACT_CUESTATE_STOPPED ( -- z ) XACT_STATE_STOPPED ; inline -: XACT_CUESTATE_PAUSED ( -- z ) XACT_STATE_PAUSED ; inline +: XACT_CUESTATE_CREATED ( -- z ) XACT_STATE_CREATED ; inline +: XACT_CUESTATE_PREPARING ( -- z ) XACT_STATE_PREPARING ; inline +: XACT_CUESTATE_PREPARED ( -- z ) XACT_STATE_PREPARED ; inline +: XACT_CUESTATE_PLAYING ( -- z ) XACT_STATE_PLAYING ; inline +: XACT_CUESTATE_STOPPING ( -- z ) XACT_STATE_STOPPING ; inline +: XACT_CUESTATE_STOPPED ( -- z ) XACT_STATE_STOPPED ; inline +: XACT_CUESTATE_PAUSED ( -- z ) XACT_STATE_PAUSED ; inline COM-INTERFACE: IXACT3Cue f {00000000-0000-0000-0000-000000000000} HRESULT Play ( ) @@ -390,8 +390,8 @@ COM-INTERFACE: IXACT3Cue f {00000000-0000-0000-0000-000000000000} HRESULT SetOutputVoices ( XAUDIO2_VOICE_SENDS* pSendList ) HRESULT SetOutputVoiceMatrix ( IXAudio2Voice* pDestinationVoice, UINT32 SourceChannels, UINT32 DestinationChannels, float* pLevelMatrix ) ; -: XACT_FLAG_ENGINE_CREATE_MANAGEDATA ( -- z ) XACT_FLAG_MANAGEDATA ; inline -: XACT_FLAG_ENGINE_STOP_IMMEDIATE ( -- z ) XACT_FLAG_STOP_IMMEDIATE ; inline +: XACT_FLAG_ENGINE_CREATE_MANAGEDATA ( -- z ) XACT_FLAG_MANAGEDATA ; inline +: XACT_FLAG_ENGINE_STOP_IMMEDIATE ( -- z ) XACT_FLAG_STOP_IMMEDIATE ; inline STRUCT: WAVEBANKREGION { dwOffset DWORD } @@ -471,4 +471,3 @@ CONSTANT: XACTENGINE_E_AUDITION_INVALIDDSPINDEX 0x8AC70106 CONSTANT: XACTENGINE_E_AUDITION_MISSINGWAVE 0x8AC70107 CONSTANT: XACTENGINE_E_AUDITION_CREATEDIRECTORYFAILED 0x8AC70108 CONSTANT: XACTENGINE_E_AUDITION_INVALIDSESSION 0x8AC70109 - diff --git a/basis/windows/directx/xapo/xapo.factor b/basis/windows/directx/xapo/xapo.factor index 391852ca03..6d2b3fbdcf 100644 --- a/basis/windows/directx/xapo/xapo.factor +++ b/basis/windows/directx/xapo/xapo.factor @@ -23,7 +23,7 @@ CONSTANT: XAPO_FLAG_INPLACE_REQUIRED 0x00000020 CONSTANT: XAPO_FLAG_INPLACE_SUPPORTED 0x00000010 -STRUCT: XAPO_REGISTRATION_PROPERTIES +STRUCT: XAPO_REGISTRATION_PROPERTIES { clsid GUID } { FriendlyName WCHAR[256] } { CopyrightInfo WCHAR[256] } @@ -63,5 +63,3 @@ COM-INTERFACE: IXAPO IUnknown {A90BC001-E897-E897-55E4-9E4700000000} COM-INTERFACE: IXAPOParameters IUnknown {A90BC001-E897-E897-55E4-9E4700000001} void SetParameters ( void* pParameters, UINT32 ParameterByteSize ) void GetParameters ( void* pParameters, UINT32 ParameterByteSize ) ; - - diff --git a/basis/windows/directx/xaudio2/xaudio2.factor b/basis/windows/directx/xaudio2/xaudio2.factor index 74f0db8b38..cd9a3901c0 100644 --- a/basis/windows/directx/xaudio2/xaudio2.factor +++ b/basis/windows/directx/xaudio2/xaudio2.factor @@ -298,7 +298,7 @@ COM-INTERFACE: IXAudio2SourceVoice IXAudio2Voice {00000000-0000-0000-0000-000000 COM-INTERFACE: IXAudio2SubmixVoice IXAudio2Voice {00000000-0000-0000-0000-000000000000} ; COM-INTERFACE: IXAudio2MasteringVoice IXAudio2Voice {00000000-0000-0000-0000-000000000000} ; - + COM-INTERFACE: IXAudio2EngineCallback f {00000000-0000-0000-0000-000000000000} void OnProcessingPassStart ( ) void OnProcessingPassEnd ( ) diff --git a/basis/windows/gdi32/gdi32.factor b/basis/windows/gdi32/gdi32.factor index 5711ffbee2..229638d5eb 100644 --- a/basis/windows/gdi32/gdi32.factor +++ b/basis/windows/gdi32/gdi32.factor @@ -808,7 +808,7 @@ CONSTANT: DC_PEN 19 CONSTANT: SYSPAL_ERROR 0 CONSTANT: SYSPAL_STATIC 1 CONSTANT: SYSPAL_NOSTATIC 2 -CONSTANT: SYSPAL_NOSTATIC256 3 +CONSTANT: SYSPAL_NOSTATIC256 3 CONSTANT: TA_BASELINE 24 CONSTANT: TA_BOTTOM 8 CONSTANT: TA_TOP 0 @@ -1185,7 +1185,7 @@ CONSTANT: NTM_REGULAR 64 CONSTANT: TT_POLYGON_TYPE 24 CONSTANT: TT_PRIM_LINE 1 CONSTANT: TT_PRIM_QSPLINE 2 -CONSTANT: TT_PRIM_CSPLINE 3 +CONSTANT: TT_PRIM_CSPLINE 3 CONSTANT: FONTMAPPER_MAX 10 CONSTANT: ENHMETA_STOCK_OBJECT 0x80000000 CONSTANT: WGL_FONT_LINES 0 diff --git a/basis/windows/gdiplus/gdiplus.factor b/basis/windows/gdiplus/gdiplus.factor index 998b700fa7..eb3f5e59f6 100644 --- a/basis/windows/gdiplus/gdiplus.factor +++ b/basis/windows/gdiplus/gdiplus.factor @@ -915,30 +915,30 @@ STRUCT: ColorMap { oldColor GpColor } { newColor GpColor } ; -C-TYPE: GpGraphics -C-TYPE: GpPen -C-TYPE: GpBrush -C-TYPE: GpHatch -C-TYPE: GpSolidFill -C-TYPE: GpPath -C-TYPE: GpMatrix -C-TYPE: GpPathIterator -C-TYPE: GpCustomLineCap -C-TYPE: GpAdjustableArrowCap -C-TYPE: GpImage -C-TYPE: GpMetafile -C-TYPE: GpImageAttributes -C-TYPE: GpCachedBitmap -C-TYPE: GpBitmap -C-TYPE: GpPathGradient -C-TYPE: GpLineGradient -C-TYPE: GpTexture -C-TYPE: GpFont -C-TYPE: GpFontCollection -C-TYPE: GpFontFamily -C-TYPE: GpStringFormat -C-TYPE: GpRegion -C-TYPE: CGpEffect +C-TYPE: GpGraphics +C-TYPE: GpPen +C-TYPE: GpBrush +C-TYPE: GpHatch +C-TYPE: GpSolidFill +C-TYPE: GpPath +C-TYPE: GpMatrix +C-TYPE: GpPathIterator +C-TYPE: GpCustomLineCap +C-TYPE: GpAdjustableArrowCap +C-TYPE: GpImage +C-TYPE: GpMetafile +C-TYPE: GpImageAttributes +C-TYPE: GpCachedBitmap +C-TYPE: GpBitmap +C-TYPE: GpPathGradient +C-TYPE: GpLineGradient +C-TYPE: GpTexture +C-TYPE: GpFont +C-TYPE: GpFontCollection +C-TYPE: GpFontFamily +C-TYPE: GpStringFormat +C-TYPE: GpRegion +C-TYPE: CGpEffect ! dummy out other windows types we don't care to define yet C-TYPE: LOGFONTA @@ -957,7 +957,7 @@ FUNCTION: GpStatus GdipSetAdjustableArrowCapWidth ( GpAdjustableArrowCap* x, REA FUNCTION: GpStatus GdipBitmapApplyEffect ( GpBitmap* x, CGpEffect* x, RECT* x, BOOL x, VOID** x, INT* x ) ; FUNCTION: GpStatus GdipBitmapCreateApplyEffect ( GpBitmap** x, INT x, CGpEffect* x, RECT* x, RECT* x, GpBitmap** x, BOOL x, VOID** x, INT* x ) ; FUNCTION: GpStatus GdipBitmapGetPixel ( GpBitmap* x, INT x, INT x, ARGB* x ) ; -FUNCTION: GpStatus GdipBitmapLockBits ( GpBitmap* x, GpRect* x, UINT x, +FUNCTION: GpStatus GdipBitmapLockBits ( GpBitmap* x, GpRect* x, UINT x, PixelFormat x, BitmapData* x ) ; FUNCTION: GpStatus GdipBitmapSetPixel ( GpBitmap* x, INT x, INT x, ARGB x ) ; FUNCTION: GpStatus GdipBitmapSetResolution ( GpBitmap* x, REAL x, REAL x ) ; @@ -971,7 +971,7 @@ FUNCTION: GpStatus GdipCreateBitmapFromGraphics ( INT x, INT x, GpGraphics* x, G FUNCTION: GpStatus GdipCreateBitmapFromHBITMAP ( HBITMAP x, HPALETTE x, GpBitmap** x ) ; FUNCTION: GpStatus GdipCreateBitmapFromHICON ( HICON x, GpBitmap** x ) ; FUNCTION: GpStatus GdipCreateBitmapFromResource ( HINSTANCE x, WCHAR* x, GpBitmap** x ) ; -FUNCTION: GpStatus GdipCreateBitmapFromScan0 ( INT x, INT x, INT x, PixelFormat x, BYTE* x, +FUNCTION: GpStatus GdipCreateBitmapFromScan0 ( INT x, INT x, INT x, PixelFormat x, BYTE* x, GpBitmap** x ) ; FUNCTION: GpStatus GdipCreateBitmapFromStream ( IStream* x, GpBitmap** x ) ; FUNCTION: GpStatus GdipCreateBitmapFromStreamICM ( IStream* x, GpBitmap** x ) ; @@ -986,21 +986,21 @@ FUNCTION: GpStatus GdipDeleteBrush ( GpBrush* x ) ; FUNCTION: GpStatus GdipGetBrushType ( GpBrush* x, GpBrushType* x ) ; -FUNCTION: GpStatus GdipCreateCachedBitmap ( GpBitmap* x, GpGraphics* x, +FUNCTION: GpStatus GdipCreateCachedBitmap ( GpBitmap* x, GpGraphics* x, GpCachedBitmap** x ) ; FUNCTION: GpStatus GdipDeleteCachedBitmap ( GpCachedBitmap* x ) ; FUNCTION: GpStatus GdipDrawCachedBitmap ( GpGraphics* x, GpCachedBitmap* x, INT x, INT x ) ; FUNCTION: GpStatus GdipCloneCustomLineCap ( GpCustomLineCap* x, GpCustomLineCap** x ) ; -FUNCTION: GpStatus GdipCreateCustomLineCap ( GpPath* x, GpPath* x, GpLineCap x, REAL x, +FUNCTION: GpStatus GdipCreateCustomLineCap ( GpPath* x, GpPath* x, GpLineCap x, REAL x, GpCustomLineCap** x ) ; FUNCTION: GpStatus GdipDeleteCustomLineCap ( GpCustomLineCap* x ) ; FUNCTION: GpStatus GdipGetCustomLineCapBaseCap ( GpCustomLineCap* x, GpLineCap* x ) ; FUNCTION: GpStatus GdipSetCustomLineCapBaseCap ( GpCustomLineCap* x, GpLineCap x ) ; FUNCTION: GpStatus GdipGetCustomLineCapBaseInset ( GpCustomLineCap* x, REAL* x ) ; FUNCTION: GpStatus GdipSetCustomLineCapBaseInset ( GpCustomLineCap* x, REAL x ) ; -FUNCTION: GpStatus GdipSetCustomLineCapStrokeCaps ( GpCustomLineCap* x, GpLineCap x, +FUNCTION: GpStatus GdipSetCustomLineCapStrokeCaps ( GpCustomLineCap* x, GpLineCap x, GpLineCap x ) ; FUNCTION: GpStatus GdipGetCustomLineCapStrokeJoin ( GpCustomLineCap* x, GpLineJoin* x ) ; FUNCTION: GpStatus GdipSetCustomLineCapStrokeJoin ( GpCustomLineCap* x, GpLineJoin x ) ; @@ -1008,7 +1008,7 @@ FUNCTION: GpStatus GdipGetCustomLineCapWidthScale ( GpCustomLineCap* x, REAL* x FUNCTION: GpStatus GdipSetCustomLineCapWidthScale ( GpCustomLineCap* x, REAL x ) ; FUNCTION: GpStatus GdipCloneFont ( GpFont* x, GpFont** x ) ; -FUNCTION: GpStatus GdipCreateFont ( GpFontFamily* x, REAL x, INT x, GpUnit x, +FUNCTION: GpStatus GdipCreateFont ( GpFontFamily* x, REAL x, INT x, GpUnit x, GpFont** x ) ; FUNCTION: GpStatus GdipCreateFontFromDC ( HDC x, GpFont** x ) ; FUNCTION: GpStatus GdipCreateFontFromLogfontA ( HDC x, LOGFONTA* x, GpFont** x ) ; @@ -1020,7 +1020,7 @@ FUNCTION: GpStatus GdipGetFamily ( GpFont* x, GpFontFamily** x ) ; FUNCTION: GpStatus GdipGetFontUnit ( GpFont* x, GpUnit* x ) ; FUNCTION: GpStatus GdipGetFontSize ( GpFont* x, REAL* x ) ; FUNCTION: GpStatus GdipGetFontStyle ( GpFont* x, INT* x ) ; -FUNCTION: GpStatus GdipGetFontHeight ( GpFont* x, GpGraphics* x, +FUNCTION: GpStatus GdipGetFontHeight ( GpFont* x, GpGraphics* x, REAL* x ) ; FUNCTION: GpStatus GdipGetFontHeightGivenDPI ( GpFont* x, REAL x, REAL* x ) ; @@ -1029,15 +1029,15 @@ FUNCTION: GpStatus GdipNewInstalledFontCollection ( GpFontCollection** x ) ; FUNCTION: GpStatus GdipNewPrivateFontCollection ( GpFontCollection** x ) ; FUNCTION: GpStatus GdipDeletePrivateFontCollection ( GpFontCollection** x ) ; FUNCTION: GpStatus GdipPrivateAddFontFile ( GpFontCollection* x, WCHAR* x ) ; -FUNCTION: GpStatus GdipPrivateAddMemoryFont ( GpFontCollection* x, +FUNCTION: GpStatus GdipPrivateAddMemoryFont ( GpFontCollection* x, void* x, INT x ) ; FUNCTION: GpStatus GdipGetFontCollectionFamilyCount ( GpFontCollection* x, INT* x ) ; -FUNCTION: GpStatus GdipGetFontCollectionFamilyList ( GpFontCollection* x, INT x, +FUNCTION: GpStatus GdipGetFontCollectionFamilyList ( GpFontCollection* x, INT x, GpFontFamily** x, INT* x ) ; FUNCTION: GpStatus GdipCloneFontFamily ( GpFontFamily* x, GpFontFamily** x ) ; -FUNCTION: GpStatus GdipCreateFontFamilyFromName ( WCHAR* x, +FUNCTION: GpStatus GdipCreateFontFamilyFromName ( WCHAR* x, GpFontCollection* x, GpFontFamily** x ) ; FUNCTION: GpStatus GdipDeleteFontFamily ( GpFontFamily* x ) ; FUNCTION: GpStatus GdipGetFamilyName ( GpFontFamily* x, WCHAR* x, LANGID x ) ; @@ -1079,7 +1079,7 @@ FUNCTION: GpStatus GdipDrawCurve2 ( GpGraphics* x, GpPen* x, GpPointF* x, INT x, FUNCTION: GpStatus GdipDrawCurve2I ( GpGraphics* x, GpPen* x, GpPoint* x, INT x, REAL x ) ; FUNCTION: GpStatus GdipDrawCurve3 ( GpGraphics* x, GpPen* x, GpPointF* x, INT x, INT x, INT x, REAL x ) ; FUNCTION: GpStatus GdipDrawCurve3I ( GpGraphics* x, GpPen* x, GpPoint* x, INT x, INT x, INT x, REAL x ) ; -FUNCTION: GpStatus GdipDrawDriverString ( GpGraphics* x, UINT16* x, INT x, +FUNCTION: GpStatus GdipDrawDriverString ( GpGraphics* x, UINT16* x, INT x, GpFont* x, GpBrush* x, GpPointF* x, INT x, GpMatrix* x ) ; FUNCTION: GpStatus GdipDrawEllipse ( GpGraphics* x, GpPen* x, REAL x, REAL x, REAL x, REAL x ) ; FUNCTION: GpStatus GdipDrawEllipseI ( GpGraphics* x, GpPen* x, INT x, INT x, INT x, INT x ) ; @@ -1089,19 +1089,19 @@ FUNCTION: GpStatus GdipDrawImagePointRect ( GpGraphics* x, GpImage* x, REAL x, R FUNCTION: GpStatus GdipDrawImagePointRectI ( GpGraphics* x, GpImage* x, INT x, INT x, INT x, INT x, INT x, INT x, GpUnit x ) ; FUNCTION: GpStatus GdipDrawImagePoints ( GpGraphics* x, GpImage* x, GpPointF* x, INT x ) ; FUNCTION: GpStatus GdipDrawImagePointsI ( GpGraphics* x, GpImage* x, GpPoint* x, INT x ) ; -FUNCTION: GpStatus GdipDrawImagePointsRect ( GpGraphics* x, GpImage* x, - GpPointF* x, INT x, REAL x, REAL x, REAL x, REAL x, GpUnit x, +FUNCTION: GpStatus GdipDrawImagePointsRect ( GpGraphics* x, GpImage* x, + GpPointF* x, INT x, REAL x, REAL x, REAL x, REAL x, GpUnit x, GpImageAttributes* x, DrawImageAbort x, VOID* x ) ; -FUNCTION: GpStatus GdipDrawImagePointsRectI ( GpGraphics* x, GpImage* x, - GpPoint* x, INT x, INT x, INT x, INT x, INT x, GpUnit x, +FUNCTION: GpStatus GdipDrawImagePointsRectI ( GpGraphics* x, GpImage* x, + GpPoint* x, INT x, INT x, INT x, INT x, INT x, GpUnit x, GpImageAttributes* x, DrawImageAbort x, VOID* x ) ; FUNCTION: GpStatus GdipDrawImageRect ( GpGraphics* x, GpImage* x, REAL x, REAL x, REAL x, REAL x ) ; FUNCTION: GpStatus GdipDrawImageRectI ( GpGraphics* x, GpImage* x, INT x, INT x, INT x, INT x ) ; -FUNCTION: GpStatus GdipDrawImageRectRect ( GpGraphics* x, GpImage* x, REAL x, REAL x, REAL x, - REAL x, REAL x, REAL x, REAL x, REAL x, GpUnit x, GpImageAttributes* x, DrawImageAbort x, +FUNCTION: GpStatus GdipDrawImageRectRect ( GpGraphics* x, GpImage* x, REAL x, REAL x, REAL x, + REAL x, REAL x, REAL x, REAL x, REAL x, GpUnit x, GpImageAttributes* x, DrawImageAbort x, VOID* x ) ; -FUNCTION: GpStatus GdipDrawImageRectRectI ( GpGraphics* x, GpImage* x, INT x, INT x, INT x, - INT x, INT x, INT x, INT x, INT x, GpUnit x, GpImageAttributes* x, DrawImageAbort x, +FUNCTION: GpStatus GdipDrawImageRectRectI ( GpGraphics* x, GpImage* x, INT x, INT x, INT x, + INT x, INT x, INT x, INT x, INT x, GpUnit x, GpImageAttributes* x, DrawImageAbort x, VOID* x ) ; FUNCTION: GpStatus GdipDrawLine ( GpGraphics* x, GpPen* x, REAL x, REAL x, REAL x, REAL x ) ; FUNCTION: GpStatus GdipDrawLineI ( GpGraphics* x, GpPen* x, INT x, INT x, INT x, INT x ) ; @@ -1116,21 +1116,21 @@ FUNCTION: GpStatus GdipDrawRectangle ( GpGraphics* x, GpPen* x, REAL x, REAL x, FUNCTION: GpStatus GdipDrawRectangleI ( GpGraphics* x, GpPen* x, INT x, INT x, INT x, INT x ) ; FUNCTION: GpStatus GdipDrawRectangles ( GpGraphics* x, GpPen* x, GpRectF* x, INT x ) ; FUNCTION: GpStatus GdipDrawRectanglesI ( GpGraphics* x, GpPen* x, GpRect* x, INT x ) ; -FUNCTION: GpStatus GdipDrawString ( GpGraphics* x, WCHAR* x, INT x, - GpFont* x, GpRectF* x, GpStringFormat* x, +FUNCTION: GpStatus GdipDrawString ( GpGraphics* x, WCHAR* x, INT x, + GpFont* x, GpRectF* x, GpStringFormat* x, GpBrush* x ) ; -FUNCTION: GpStatus GdipFillClosedCurve2 ( GpGraphics* x, GpBrush* x, GpPointF* x, INT x, +FUNCTION: GpStatus GdipFillClosedCurve2 ( GpGraphics* x, GpBrush* x, GpPointF* x, INT x, REAL x, GpFillMode x ) ; -FUNCTION: GpStatus GdipFillClosedCurve2I ( GpGraphics* x, GpBrush* x, GpPoint* x, INT x, +FUNCTION: GpStatus GdipFillClosedCurve2I ( GpGraphics* x, GpBrush* x, GpPoint* x, INT x, REAL x, GpFillMode x ) ; FUNCTION: GpStatus GdipFillEllipse ( GpGraphics* x, GpBrush* x, REAL x, REAL x, REAL x, REAL x ) ; FUNCTION: GpStatus GdipFillEllipseI ( GpGraphics* x, GpBrush* x, INT x, INT x, INT x, INT x ) ; FUNCTION: GpStatus GdipFillPath ( GpGraphics* x, GpBrush* x, GpPath* x ) ; FUNCTION: GpStatus GdipFillPie ( GpGraphics* x, GpBrush* x, REAL x, REAL x, REAL x, REAL x, REAL x, REAL x ) ; FUNCTION: GpStatus GdipFillPieI ( GpGraphics* x, GpBrush* x, INT x, INT x, INT x, INT x, REAL x, REAL x ) ; -FUNCTION: GpStatus GdipFillPolygon ( GpGraphics* x, GpBrush* x, GpPointF* x, +FUNCTION: GpStatus GdipFillPolygon ( GpGraphics* x, GpBrush* x, GpPointF* x, INT x, GpFillMode x ) ; -FUNCTION: GpStatus GdipFillPolygonI ( GpGraphics* x, GpBrush* x, GpPoint* x, +FUNCTION: GpStatus GdipFillPolygonI ( GpGraphics* x, GpBrush* x, GpPoint* x, INT x, GpFillMode x ) ; FUNCTION: GpStatus GdipFillPolygon2 ( GpGraphics* x, GpBrush* x, GpPointF* x, INT x ) ; FUNCTION: GpStatus GdipFillPolygon2I ( GpGraphics* x, GpBrush* x, GpPoint* x, INT x ) ; @@ -1167,19 +1167,19 @@ FUNCTION: GpStatus GdipIsVisiblePoint ( GpGraphics* x, REAL x, REAL x, BOOL* x ) FUNCTION: GpStatus GdipIsVisiblePointI ( GpGraphics* x, INT x, INT x, BOOL* x ) ; FUNCTION: GpStatus GdipIsVisibleRect ( GpGraphics* x, REAL x, REAL x, REAL x, REAL x, BOOL* x ) ; FUNCTION: GpStatus GdipIsVisibleRectI ( GpGraphics* x, INT x, INT x, INT x, INT x, BOOL* x ) ; -FUNCTION: GpStatus GdipMeasureCharacterRanges ( GpGraphics* x, WCHAR* x, - INT x, GpFont* x, GpRectF* x, GpStringFormat* x, INT x, +FUNCTION: GpStatus GdipMeasureCharacterRanges ( GpGraphics* x, WCHAR* x, + INT x, GpFont* x, GpRectF* x, GpStringFormat* x, INT x, GpRegion** x ) ; -FUNCTION: GpStatus GdipMeasureDriverString ( GpGraphics* x, UINT16* x, INT x, +FUNCTION: GpStatus GdipMeasureDriverString ( GpGraphics* x, UINT16* x, INT x, GpFont* x, GpPointF* x, INT x, GpMatrix* x, GpRectF* x ) ; -FUNCTION: GpStatus GdipMeasureString ( GpGraphics* x, WCHAR* x, INT x, +FUNCTION: GpStatus GdipMeasureString ( GpGraphics* x, WCHAR* x, INT x, GpFont* x, GpRectF* x, GpStringFormat* x, GpRectF* x, INT* x, INT* x ) ; FUNCTION: GpStatus GdipMultiplyWorldTransform ( GpGraphics* x, GpMatrix* x, GpMatrixOrder x ) ; -FUNCTION: GpStatus GdipRecordMetafileFileName ( WCHAR* x, HDC x, EmfType x, +FUNCTION: GpStatus GdipRecordMetafileFileName ( WCHAR* x, HDC x, EmfType x, GpRectF* x, MetafileFrameUnit x, WCHAR* x, GpMetafile** x ) ; -FUNCTION: GpStatus GdipRecordMetafileFileNameI ( WCHAR* x, HDC x, EmfType x, +FUNCTION: GpStatus GdipRecordMetafileFileNameI ( WCHAR* x, HDC x, EmfType x, GpRect* x, MetafileFrameUnit x, WCHAR* x, GpMetafile** x ) ; -FUNCTION: GpStatus GdipRecordMetafileI ( HDC x, EmfType x, GpRect* x, +FUNCTION: GpStatus GdipRecordMetafileI ( HDC x, EmfType x, GpRect* x, MetafileFrameUnit x, WCHAR* x, GpMetafile** x ) ; FUNCTION: GpStatus GdipReleaseDC ( GpGraphics* x, HDC x ) ; FUNCTION: GpStatus GdipResetClip ( GpGraphics* x ) ; @@ -1205,9 +1205,9 @@ FUNCTION: GpStatus GdipSetSmoothingMode ( GpGraphics* x, SmoothingMode x ) ; FUNCTION: GpStatus GdipSetTextContrast ( GpGraphics* x, UINT x ) ; FUNCTION: GpStatus GdipSetTextRenderingHint ( GpGraphics* x, TextRenderingHint x ) ; FUNCTION: GpStatus GdipSetWorldTransform ( GpGraphics* x, GpMatrix* x ) ; -FUNCTION: GpStatus GdipTransformPoints ( GpGraphics* x, GpCoordinateSpace x, GpCoordinateSpace x, +FUNCTION: GpStatus GdipTransformPoints ( GpGraphics* x, GpCoordinateSpace x, GpCoordinateSpace x, GpPointF* x, INT x ) ; -FUNCTION: GpStatus GdipTransformPointsI ( GpGraphics* x, GpCoordinateSpace x, GpCoordinateSpace x, +FUNCTION: GpStatus GdipTransformPointsI ( GpGraphics* x, GpCoordinateSpace x, GpCoordinateSpace x, GpPoint* x, INT x ) ; FUNCTION: GpStatus GdipTranslateClip ( GpGraphics* x, REAL x, REAL x ) ; FUNCTION: GpStatus GdipTranslateClipI ( GpGraphics* x, INT x, INT x ) ; @@ -1252,14 +1252,14 @@ FUNCTION: GpStatus GdipClonePath ( GpPath* x, GpPath** x ) ; FUNCTION: GpStatus GdipClosePathFigure ( GpPath* x ) ; FUNCTION: GpStatus GdipClosePathFigures ( GpPath* x ) ; FUNCTION: GpStatus GdipCreatePath ( GpFillMode x, GpPath** x ) ; -FUNCTION: GpStatus GdipCreatePath2 ( GpPointF* x, BYTE* x, INT x, +FUNCTION: GpStatus GdipCreatePath2 ( GpPointF* x, BYTE* x, INT x, GpFillMode x, GpPath** x ) ; FUNCTION: GpStatus GdipCreatePath2I ( GpPoint* x, BYTE* x, INT x, GpFillMode x, GpPath** x ) ; FUNCTION: GpStatus GdipDeletePath ( GpPath* x ) ; FUNCTION: GpStatus GdipFlattenPath ( GpPath* x, GpMatrix* x, REAL x ) ; -FUNCTION: GpStatus GdipIsOutlineVisiblePathPoint ( GpPath* x, REAL x, REAL x, GpPen* x, +FUNCTION: GpStatus GdipIsOutlineVisiblePathPoint ( GpPath* x, REAL x, REAL x, GpPen* x, GpGraphics* x, BOOL* x ) ; -FUNCTION: GpStatus GdipIsOutlineVisiblePathPointI ( GpPath* x, INT x, INT x, GpPen* x, +FUNCTION: GpStatus GdipIsOutlineVisiblePathPointI ( GpPath* x, INT x, INT x, GpPen* x, GpGraphics* x, BOOL* x ) ; FUNCTION: GpStatus GdipIsVisiblePathPoint ( GpPath* x, REAL x, REAL x, GpGraphics* x, BOOL* x ) ; FUNCTION: GpStatus GdipIsVisiblePathPointI ( GpPath* x, INT x, INT x, GpGraphics* x, BOOL* x ) ; @@ -1278,7 +1278,7 @@ FUNCTION: GpStatus GdipSetPathFillMode ( GpPath* x, GpFillMode x ) ; FUNCTION: GpStatus GdipSetPathMarker ( GpPath* x ) ; FUNCTION: GpStatus GdipStartPathFigure ( GpPath* x ) ; FUNCTION: GpStatus GdipTransformPath ( GpPath* x, GpMatrix* x ) ; -FUNCTION: GpStatus GdipWarpPath ( GpPath* x, GpMatrix* x, GpPointF* x, INT x, REAL x, +FUNCTION: GpStatus GdipWarpPath ( GpPath* x, GpMatrix* x, GpPointF* x, INT x, REAL x, REAL x, REAL x, REAL x, WarpMode x, REAL x ) ; FUNCTION: GpStatus GdipWidenPath ( GpPath* x, GpPen* x, GpMatrix* x, REAL x ) ; @@ -1327,7 +1327,7 @@ FUNCTION: GpStatus GdipLoadImageFromStream ( IStream* x, GpImage** x ) ; FUNCTION: GpStatus GdipLoadImageFromStreamICM ( IStream* x, GpImage** x ) ; FUNCTION: GpStatus GdipRemovePropertyItem ( GpImage* x, PROPID x ) ; FUNCTION: GpStatus GdipSaveImageToFile ( GpImage* x, WCHAR* x, CLSID* x, EncoderParameters* x ) ; -FUNCTION: GpStatus GdipSaveImageToStream ( GpImage* x, IStream* x, +FUNCTION: GpStatus GdipSaveImageToStream ( GpImage* x, IStream* x, CLSID* x, EncoderParameters* x ) ; FUNCTION: GpStatus GdipSetImagePalette ( GpImage* x, ColorPalette* x ) ; FUNCTION: GpStatus GdipSetPropertyItem ( GpImage* x, PropertyItem* x ) ; @@ -1335,59 +1335,59 @@ FUNCTION: GpStatus GdipSetPropertyItem ( GpImage* x, PropertyItem* x ) ; FUNCTION: GpStatus GdipCreateImageAttributes ( GpImageAttributes** x ) ; FUNCTION: GpStatus GdipDisposeImageAttributes ( GpImageAttributes* x ) ; -FUNCTION: GpStatus GdipSetImageAttributesCachedBackground ( GpImageAttributes* x, +FUNCTION: GpStatus GdipSetImageAttributesCachedBackground ( GpImageAttributes* x, BOOL x ) ; -FUNCTION: GpStatus GdipSetImageAttributesColorKeys ( GpImageAttributes* x, +FUNCTION: GpStatus GdipSetImageAttributesColorKeys ( GpImageAttributes* x, ColorAdjustType x, BOOL x, ARGB x, ARGB x ) ; -FUNCTION: GpStatus GdipSetImageAttributesColorMatrix ( GpImageAttributes* x, - ColorAdjustType x, BOOL x, ColorMatrix* x, ColorMatrix* x, +FUNCTION: GpStatus GdipSetImageAttributesColorMatrix ( GpImageAttributes* x, + ColorAdjustType x, BOOL x, ColorMatrix* x, ColorMatrix* x, ColorMatrixFlags x ) ; -FUNCTION: GpStatus GdipSetImageAttributesGamma ( GpImageAttributes* x, +FUNCTION: GpStatus GdipSetImageAttributesGamma ( GpImageAttributes* x, ColorAdjustType x, BOOL x, REAL x ) ; -FUNCTION: GpStatus GdipSetImageAttributesNoOp ( GpImageAttributes* x, +FUNCTION: GpStatus GdipSetImageAttributesNoOp ( GpImageAttributes* x, ColorAdjustType x, BOOL x ) ; -FUNCTION: GpStatus GdipSetImageAttributesOutputChannel ( GpImageAttributes* x, +FUNCTION: GpStatus GdipSetImageAttributesOutputChannel ( GpImageAttributes* x, ColorAdjustType x, BOOL x, ColorChannelFlags x ) ; -FUNCTION: GpStatus GdipSetImageAttributesOutputChannelColorProfile ( +FUNCTION: GpStatus GdipSetImageAttributesOutputChannelColorProfile ( GpImageAttributes* x, ColorAdjustType x, BOOL x, WCHAR* x ) ; -FUNCTION: GpStatus GdipSetImageAttributesRemapTable ( GpImageAttributes* x, +FUNCTION: GpStatus GdipSetImageAttributesRemapTable ( GpImageAttributes* x, ColorAdjustType x, BOOL x, UINT x, ColorMap* x ) ; -FUNCTION: GpStatus GdipSetImageAttributesThreshold ( GpImageAttributes* x, +FUNCTION: GpStatus GdipSetImageAttributesThreshold ( GpImageAttributes* x, ColorAdjustType x, BOOL x, REAL x ) ; -FUNCTION: GpStatus GdipSetImageAttributesToIdentity ( GpImageAttributes* x, +FUNCTION: GpStatus GdipSetImageAttributesToIdentity ( GpImageAttributes* x, ColorAdjustType x ) ; -FUNCTION: GpStatus GdipSetImageAttributesWrapMode ( GpImageAttributes* x, GpWrapMode x, +FUNCTION: GpStatus GdipSetImageAttributesWrapMode ( GpImageAttributes* x, GpWrapMode x, ARGB x, BOOL x ) ; -FUNCTION: GpStatus GdipCreateLineBrush ( GpPointF* x, GpPointF* x, +FUNCTION: GpStatus GdipCreateLineBrush ( GpPointF* x, GpPointF* x, ARGB x, ARGB x, GpWrapMode x, GpLineGradient** x ) ; -FUNCTION: GpStatus GdipCreateLineBrushI ( GpPoint* x, GpPoint* x, +FUNCTION: GpStatus GdipCreateLineBrushI ( GpPoint* x, GpPoint* x, ARGB x, ARGB x, GpWrapMode x, GpLineGradient** x ) ; -FUNCTION: GpStatus GdipCreateLineBrushFromRect ( GpRectF* x, ARGB x, ARGB x, +FUNCTION: GpStatus GdipCreateLineBrushFromRect ( GpRectF* x, ARGB x, ARGB x, LinearGradientMode x, GpWrapMode x, GpLineGradient** x ) ; -FUNCTION: GpStatus GdipCreateLineBrushFromRectI ( GpRect* x, ARGB x, ARGB x, +FUNCTION: GpStatus GdipCreateLineBrushFromRectI ( GpRect* x, ARGB x, ARGB x, LinearGradientMode x, GpWrapMode x, GpLineGradient** x ) ; -FUNCTION: GpStatus GdipCreateLineBrushFromRectWithAngle ( GpRectF* x, +FUNCTION: GpStatus GdipCreateLineBrushFromRectWithAngle ( GpRectF* x, ARGB x, ARGB x, REAL x, BOOL x, GpWrapMode x, GpLineGradient** x ) ; -FUNCTION: GpStatus GdipCreateLineBrushFromRectWithAngleI ( GpRect* x, +FUNCTION: GpStatus GdipCreateLineBrushFromRectWithAngleI ( GpRect* x, ARGB x, ARGB x, REAL x, BOOL x, GpWrapMode x, GpLineGradient** x ) ; FUNCTION: GpStatus GdipGetLineColors ( GpLineGradient* x, ARGB* x ) ; FUNCTION: GpStatus GdipGetLineGammaCorrection ( GpLineGradient* x, BOOL* x ) ; FUNCTION: GpStatus GdipGetLineRect ( GpLineGradient* x, GpRectF* x ) ; FUNCTION: GpStatus GdipGetLineRectI ( GpLineGradient* x, GpRect* x ) ; FUNCTION: GpStatus GdipGetLineWrapMode ( GpLineGradient* x, GpWrapMode* x ) ; -FUNCTION: GpStatus GdipSetLineBlend ( GpLineGradient* x, REAL* x, +FUNCTION: GpStatus GdipSetLineBlend ( GpLineGradient* x, REAL* x, REAL* x, INT x ) ; FUNCTION: GpStatus GdipGetLineBlend ( GpLineGradient* x, REAL* x, REAL* x, INT x ) ; FUNCTION: GpStatus GdipGetLineBlendCount ( GpLineGradient* x, INT* x ) ; -FUNCTION: GpStatus GdipSetLinePresetBlend ( GpLineGradient* x, ARGB* x, +FUNCTION: GpStatus GdipSetLinePresetBlend ( GpLineGradient* x, ARGB* x, REAL* x, INT x ) ; FUNCTION: GpStatus GdipGetLinePresetBlend ( GpLineGradient* x, ARGB* x, REAL* x, INT x ) ; FUNCTION: GpStatus GdipGetLinePresetBlendCount ( GpLineGradient* x, INT* x ) ; FUNCTION: GpStatus GdipResetLineTransform ( GpLineGradient* x ) ; FUNCTION: GpStatus GdipRotateLineTransform ( GpLineGradient* x, REAL x, GpMatrixOrder x ) ; -FUNCTION: GpStatus GdipScaleLineTransform ( GpLineGradient* x, REAL x, REAL x, +FUNCTION: GpStatus GdipScaleLineTransform ( GpLineGradient* x, REAL x, REAL x, GpMatrixOrder x ) ; FUNCTION: GpStatus GdipSetLineColors ( GpLineGradient* x, ARGB x, ARGB x ) ; FUNCTION: GpStatus GdipSetLineGammaCorrection ( GpLineGradient* x, BOOL x ) ; @@ -1395,7 +1395,7 @@ FUNCTION: GpStatus GdipSetLineSigmaBlend ( GpLineGradient* x, REAL x, REAL x ) ; FUNCTION: GpStatus GdipSetLineTransform ( GpLineGradient* x, GpMatrix* x ) ; FUNCTION: GpStatus GdipSetLineLinearBlend ( GpLineGradient* x, REAL x, REAL x ) ; FUNCTION: GpStatus GdipSetLineWrapMode ( GpLineGradient* x, GpWrapMode x ) ; -FUNCTION: GpStatus GdipTranslateLineTransform ( GpLineGradient* x, REAL x, REAL x, +FUNCTION: GpStatus GdipTranslateLineTransform ( GpLineGradient* x, REAL x, REAL x, GpMatrixOrder x ) ; @@ -1422,14 +1422,14 @@ FUNCTION: GpStatus GdipVectorTransformMatrixPoints ( GpMatrix* x, GpPointF* x, I FUNCTION: GpStatus GdipVectorTransformMatrixPointsI ( GpMatrix* x, GpPoint* x, INT x ) ; -FUNCTION: GpStatus GdipConvertToEmfPlus ( GpGraphics* x, GpMetafile* x, INT* x, +FUNCTION: GpStatus GdipConvertToEmfPlus ( GpGraphics* x, GpMetafile* x, INT* x, EmfType x, WCHAR* x, GpMetafile** x ) ; FUNCTION: GpStatus GdipConvertToEmfPlusToFile ( GpGraphics* x, GpMetafile* x, INT* x, WCHAR* x, EmfType x, WCHAR* x, GpMetafile** x ) ; FUNCTION: GpStatus GdipConvertToEmfPlusToStream ( GpGraphics* x, GpMetafile* x, INT* x, IStream* x, EmfType x, WCHAR* x, GpMetafile** x ) ; FUNCTION: GpStatus GdipCreateMetafileFromEmf ( HENHMETAFILE x, BOOL x, GpMetafile** x ) ; -FUNCTION: GpStatus GdipCreateMetafileFromWmf ( HMETAFILE x, BOOL x, +FUNCTION: GpStatus GdipCreateMetafileFromWmf ( HMETAFILE x, BOOL x, WmfPlaceableFileHeader* x, GpMetafile** x ) ; -FUNCTION: GpStatus GdipCreateMetafileFromWmfFile ( WCHAR* x, WmfPlaceableFileHeader* x, +FUNCTION: GpStatus GdipCreateMetafileFromWmfFile ( WCHAR* x, WmfPlaceableFileHeader* x, GpMetafile** x ) ; FUNCTION: GpStatus GdipCreateMetafileFromFile ( WCHAR* x, GpMetafile** x ) ; FUNCTION: GpStatus GdipCreateMetafileFromStream ( IStream* x, GpMetafile** x ) ; @@ -1449,7 +1449,7 @@ FUNCTION: void GdiplusNotificationUnhook ( ULONG_PTR x ) ; FUNCTION: GpStatus GdipCreatePathGradient ( GpPointF* x, INT x, GpWrapMode x, GpPathGradient** x ) ; FUNCTION: GpStatus GdipCreatePathGradientI ( GpPoint* x, INT x, GpWrapMode x, GpPathGradient** x ) ; -FUNCTION: GpStatus GdipCreatePathGradientFromPath ( GpPath* x, +FUNCTION: GpStatus GdipCreatePathGradientFromPath ( GpPath* x, GpPathGradient** x ) ; FUNCTION: GpStatus GdipGetPathGradientBlend ( GpPathGradient* x, REAL* x, REAL* x, INT x ) ; FUNCTION: GpStatus GdipGetPathGradientBlendCount ( GpPathGradient* x, INT* x ) ; @@ -1459,11 +1459,11 @@ FUNCTION: GpStatus GdipGetPathGradientCenterPointI ( GpPathGradient* x, GpPoint* FUNCTION: GpStatus GdipGetPathGradientFocusScales ( GpPathGradient* x, REAL* x, REAL* x ) ; FUNCTION: GpStatus GdipGetPathGradientGammaCorrection ( GpPathGradient* x, BOOL* x ) ; FUNCTION: GpStatus GdipGetPathGradientPointCount ( GpPathGradient* x, INT* x ) ; -FUNCTION: GpStatus GdipSetPathGradientPresetBlend ( GpPathGradient* x, +FUNCTION: GpStatus GdipSetPathGradientPresetBlend ( GpPathGradient* x, ARGB* x, REAL* x, INT x ) ; FUNCTION: GpStatus GdipGetPathGradientRect ( GpPathGradient* x, GpRectF* x ) ; FUNCTION: GpStatus GdipGetPathGradientRectI ( GpPathGradient* x, GpRect* x ) ; -FUNCTION: GpStatus GdipGetPathGradientSurroundColorsWithCount ( GpPathGradient* x, +FUNCTION: GpStatus GdipGetPathGradientSurroundColorsWithCount ( GpPathGradient* x, ARGB* x, INT* x ) ; FUNCTION: GpStatus GdipGetPathGradientWrapMode ( GpPathGradient* x, GpWrapMode* x ) ; FUNCTION: GpStatus GdipSetPathGradientBlend ( GpPathGradient* x, REAL* x, REAL* x, INT x ) ; @@ -1473,7 +1473,7 @@ FUNCTION: GpStatus GdipSetPathGradientCenterPointI ( GpPathGradient* x, GpPoint* FUNCTION: GpStatus GdipSetPathGradientFocusScales ( GpPathGradient* x, REAL x, REAL x ) ; FUNCTION: GpStatus GdipSetPathGradientGammaCorrection ( GpPathGradient* x, BOOL x ) ; FUNCTION: GpStatus GdipSetPathGradientSigmaBlend ( GpPathGradient* x, REAL x, REAL x ) ; -FUNCTION: GpStatus GdipSetPathGradientSurroundColorsWithCount ( GpPathGradient* x, +FUNCTION: GpStatus GdipSetPathGradientSurroundColorsWithCount ( GpPathGradient* x, ARGB* x, INT* x ) ; FUNCTION: GpStatus GdipSetPathGradientWrapMode ( GpPathGradient* x, GpWrapMode x ) ; FUNCTION: GpStatus GdipGetPathGradientSurroundColorCount ( GpPathGradient* x, INT* x ) ; @@ -1481,7 +1481,7 @@ FUNCTION: GpStatus GdipGetPathGradientSurroundColorCount ( GpPathGradient* x, IN FUNCTION: GpStatus GdipCreatePathIter ( GpPathIterator** x, GpPath* x ) ; FUNCTION: GpStatus GdipDeletePathIter ( GpPathIterator* x ) ; -FUNCTION: GpStatus GdipPathIterCopyData ( GpPathIterator* x, INT* x, GpPointF* x, BYTE* x, +FUNCTION: GpStatus GdipPathIterCopyData ( GpPathIterator* x, INT* x, GpPointF* x, BYTE* x, INT x, INT x ) ; FUNCTION: GpStatus GdipPathIterGetCount ( GpPathIterator* x, INT* x ) ; FUNCTION: GpStatus GdipPathIterGetSubpathCount ( GpPathIterator* x, INT* x ) ; @@ -1577,12 +1577,12 @@ FUNCTION: GpStatus GdipCloneStringFormat ( GpStringFormat* x, GpStringFormat** x FUNCTION: GpStatus GdipCreateStringFormat ( INT x, LANGID x, GpStringFormat** x ) ; FUNCTION: GpStatus GdipDeleteStringFormat ( GpStringFormat* x ) ; FUNCTION: GpStatus GdipGetStringFormatAlign ( GpStringFormat* x, StringAlignment* x ) ; -FUNCTION: GpStatus GdipGetStringFormatDigitSubstitution ( GpStringFormat* x, LANGID* x, +FUNCTION: GpStatus GdipGetStringFormatDigitSubstitution ( GpStringFormat* x, LANGID* x, StringDigitSubstitute* x ) ; FUNCTION: GpStatus GdipGetStringFormatFlags ( GpStringFormat* x, INT* x ) ; FUNCTION: GpStatus GdipGetStringFormatHotkeyPrefix ( GpStringFormat* x, INT* x ) ; FUNCTION: GpStatus GdipGetStringFormatLineAlign ( GpStringFormat* x, StringAlignment* x ) ; -FUNCTION: GpStatus GdipGetStringFormatMeasurableCharacterRangeCount ( +FUNCTION: GpStatus GdipGetStringFormatMeasurableCharacterRangeCount ( GpStringFormat* x, INT* x ) ; FUNCTION: GpStatus GdipGetStringFormatTabStopCount ( GpStringFormat* x, INT* x ) ; FUNCTION: GpStatus GdipGetStringFormatTabStops ( GpStringFormat* x, INT x, REAL* x, REAL* x ) ; @@ -1591,7 +1591,7 @@ FUNCTION: GpStatus GdipSetStringFormatAlign ( GpStringFormat* x, StringAlignment FUNCTION: GpStatus GdipSetStringFormatDigitSubstitution ( GpStringFormat* x, LANGID x, StringDigitSubstitute x ) ; FUNCTION: GpStatus GdipSetStringFormatHotkeyPrefix ( GpStringFormat* x, INT x ) ; FUNCTION: GpStatus GdipSetStringFormatLineAlign ( GpStringFormat* x, StringAlignment x ) ; -FUNCTION: GpStatus GdipSetStringFormatMeasurableCharacterRanges ( +FUNCTION: GpStatus GdipSetStringFormatMeasurableCharacterRanges ( GpStringFormat* x, INT x, CharacterRange* x ) ; FUNCTION: GpStatus GdipSetStringFormatTabStops ( GpStringFormat* x, REAL x, INT x, REAL* x ) ; FUNCTION: GpStatus GdipSetStringFormatTrimming ( GpStringFormat* x, StringTrimming x ) ; @@ -1603,20 +1603,20 @@ FUNCTION: GpStatus GdipStringFormatGetGenericTypographic ( GpStringFormat** x ) FUNCTION: GpStatus GdipCreateTexture ( GpImage* x, GpWrapMode x, GpTexture** x ) ; FUNCTION: GpStatus GdipCreateTexture2 ( GpImage* x, GpWrapMode x, REAL x, REAL x, REAL x, REAL x, GpTexture** x ) ; FUNCTION: GpStatus GdipCreateTexture2I ( GpImage* x, GpWrapMode x, INT x, INT x, INT x, INT x, GpTexture** x ) ; -FUNCTION: GpStatus GdipCreateTextureIA ( GpImage* x, GpImageAttributes* x, +FUNCTION: GpStatus GdipCreateTextureIA ( GpImage* x, GpImageAttributes* x, REAL x, REAL x, REAL x, REAL x, GpTexture** x ) ; -FUNCTION: GpStatus GdipCreateTextureIAI ( GpImage* x, GpImageAttributes* x, +FUNCTION: GpStatus GdipCreateTextureIAI ( GpImage* x, GpImageAttributes* x, INT x, INT x, INT x, INT x, GpTexture** x ) ; FUNCTION: GpStatus GdipGetTextureTransform ( GpTexture* x, GpMatrix* x ) ; FUNCTION: GpStatus GdipGetTextureWrapMode ( GpTexture* x, GpWrapMode* x ) ; -FUNCTION: GpStatus GdipMultiplyTextureTransform ( GpTexture* x, +FUNCTION: GpStatus GdipMultiplyTextureTransform ( GpTexture* x, GpMatrix* x, GpMatrixOrder x ) ; FUNCTION: GpStatus GdipResetTextureTransform ( GpTexture* x ) ; FUNCTION: GpStatus GdipRotateTextureTransform ( GpTexture* x, REAL x, GpMatrixOrder x ) ; FUNCTION: GpStatus GdipScaleTextureTransform ( GpTexture* x, REAL x, REAL x, GpMatrixOrder x ) ; FUNCTION: GpStatus GdipSetTextureTransform ( GpTexture* x, GpMatrix* x ) ; FUNCTION: GpStatus GdipSetTextureWrapMode ( GpTexture* x, GpWrapMode x ) ; -FUNCTION: GpStatus GdipTranslateTextureTransform ( GpTexture* x, REAL x, REAL x, +FUNCTION: GpStatus GdipTranslateTextureTransform ( GpTexture* x, REAL x, REAL x, GpMatrixOrder x ) ; diff --git a/basis/windows/iphlpapi/iphlpapi.factor b/basis/windows/iphlpapi/iphlpapi.factor index 42152ad7b5..67e8c14214 100644 --- a/basis/windows/iphlpapi/iphlpapi.factor +++ b/basis/windows/iphlpapi/iphlpapi.factor @@ -58,7 +58,7 @@ STRUCT: IP_ADDR_STRING { IpAddress IP_ADDRESS_STRING } { IpMask IP_MASK_STRING } { Context DWORD } ; - + TYPEDEF: IP_ADDR_STRING* PIP_ADDR_STRING STRUCT: FIXED_INFO @@ -86,7 +86,7 @@ ENUM: IP_DAD_STATE IpDadStateDuplicate, IpDadStateDeprecated, IpDadStatePreferred ; - + ENUM: IP_PREFIX_ORIGIN IpPrefixOriginOther, IpPrefixOriginManual, @@ -94,7 +94,7 @@ ENUM: IP_PREFIX_ORIGIN IpPrefixOriginDhcp, IpPrefixOriginRouterAdvertisement, { IpPrefixOriginUnchanged 16 } ; - + ENUM: IP_SUFFIX_ORIGIN IpSuffixOriginOther IpSuffixOriginManual, @@ -103,7 +103,7 @@ ENUM: IP_SUFFIX_ORIGIN IpSuffixOriginLinkLayerAddress, IpSuffixOriginRandom, { IpSuffixOriginUnchanged 16 } ; - + ENUM: IF_OPER_STATUS { IfOperStatusUp 1 } IfOperStatusDown, @@ -118,34 +118,34 @@ ENUM: NET_IF_CONNECTION_TYPE NET_IF_CONNECTION_PASSIVE, NET_IF_CONNECTION_DEMAND, NET_IF_CONNECTION_MAXIMUM ; - - + + ENUM: TUNNEL_TYPE TUNNEL_TYPE_NONE, TUNNEL_TYPE_OTHER, TUNNEL_TYPE_DIRECT, - TUNNEL_TYPE_6TO4, + TUNNEL_TYPE_6TO4, TUNNEL_TYPE_ISATAP, TUNNEL_TYPE_TEREDO, TUNNEL_TYPE_IPHTTPS ; - - + + STRUCT: SOCKET_ADDRESS { lpSockaddr LPSOCKADDR } { iSockaddrLength INT } ; - + ERROR: unknown-sockaddr-length sockaddr length ; - + : SOCKET_ADDRESS>sockaddr ( obj -- sockaddr ) dup iSockaddrLength>> { { 16 [ lpSockaddr>> sockaddr-in memory>struct ] } { 28 [ lpSockaddr>> sockaddr-in6 memory>struct ] } [ unknown-sockaddr-length ] } case ; - + TYPEDEF: SOCKET_ADDRESS* PSOCKET_ADDRESS - + STRUCT: IP_ADAPTER_INFO { Next IP_ADAPTER_INFO* } { ComboIndex DWORD } @@ -171,13 +171,13 @@ TYPEDEF: IP_ADAPTER_INFO* PIP_ADAPTER_INFO STRUCT: LengthIndex { Length ULONG } { IfIndex DWORD } ; - + TYPEDEF: LengthIndex LengthFlags UNION-STRUCT: AlignmentLenIndex { Alignment ULONGLONG } { LenIndex LengthIndex } ; - + UNION-STRUCT: AlignmentLenFlags { Alignment ULONGLONG } { LenFlags LengthFlags } ; @@ -190,7 +190,7 @@ STRUCT: ResNetIf UNION-STRUCT: NET_LUID { Value ULONG64 } { Info ResNetIf } ; - + TYPEDEF: NET_LUID* PNET_LUID TYPEDEF: NET_LUID IF_LUID @@ -207,7 +207,7 @@ STRUCT: IP_ADAPTER_UNICAST_ADDRESS { PreferredLifetime ULONG } { LeaseLifeTime ULONG } { OnLinkPrefixLength UINT8 } ; - + TYPEDEF: IP_ADAPTER_UNICAST_ADDRESS* PIP_ADAPTER_UNICAST_ADDRESS DEFER: IP_ADAPTER_ANYCAST_ADDRESS @@ -215,7 +215,7 @@ STRUCT: IP_ADAPTER_ANYCAST_ADDRESS { Header AlignmentLenFlags } { Next IP_ADAPTER_ANYCAST_ADDRESS* } { Address SOCKET_ADDRESS } ; - + TYPEDEF: IP_ADAPTER_ANYCAST_ADDRESS* PIP_ADAPTER_ANYCAST_ADDRESS @@ -224,7 +224,7 @@ STRUCT: IP_ADAPTER_MULTICAST_ADDRESS { Header AlignmentLenFlags } { Next IP_ADAPTER_MULTICAST_ADDRESS* } { Address SOCKET_ADDRESS } ; - + TYPEDEF: IP_ADAPTER_MULTICAST_ADDRESS* PIP_ADAPTER_MULTICAST_ADDRESS @@ -233,7 +233,7 @@ STRUCT: IP_ADAPTER_DNS_SERVER_ADDRESS { Header AlignmentLenFlags } { Next IP_ADAPTER_DNS_SERVER_ADDRESS* } { Address SOCKET_ADDRESS } ; - + TYPEDEF: IP_ADAPTER_DNS_SERVER_ADDRESS* PIP_ADAPTER_DNS_SERVER_ADDRESS @@ -242,7 +242,7 @@ STRUCT: IP_ADAPTER_WINS_SERVER_ADDRESS { Header AlignmentLenFlags } { Next IP_ADAPTER_WINS_SERVER_ADDRESS* } { Address SOCKET_ADDRESS } ; - + TYPEDEF: IP_ADAPTER_WINS_SERVER_ADDRESS* PIP_ADAPTER_WINS_SERVER_ADDRESS TYPEDEF: IP_ADAPTER_WINS_SERVER_ADDRESS* PIP_ADAPTER_WINS_SERVER_ADDRESS_LH @@ -254,7 +254,7 @@ STRUCT: IP_ADAPTER_GATEWAY_ADDRESS { Header AlignmentLenFlags } { Next IP_ADAPTER_GATEWAY_ADDRESS* } { Address SOCKET_ADDRESS } ; - + TYPEDEF: IP_ADAPTER_GATEWAY_ADDRESS* PIP_ADAPTER_GATEWAY_ADDRESS TYPEDEF: IP_ADAPTER_GATEWAY_ADDRESS* PIP_ADAPTER_GATEWAY_ADDRESS_LH @@ -265,7 +265,7 @@ STRUCT: IP_ADAPTER_PREFIX { Next IP_ADAPTER_PREFIX* } { Address SOCKET_ADDRESS } { PrefixLength ULONG } ; - + TYPEDEF: IP_ADAPTER_PREFIX* PIP_ADAPTER_PREFIX @@ -273,7 +273,7 @@ DEFER: IP_ADAPTER_DNS_SUFFIX STRUCT: IP_ADAPTER_DNS_SUFFIX { Next IP_ADAPTER_DNS_SUFFIX* } { String WCHAR[MAX_DNS_SUFFIX_STRING_LENGTH] } ; - + TYPEDEF: IP_ADAPTER_DNS_SUFFIX* PIP_ADAPTER_DNS_SUFFIX @@ -336,7 +336,7 @@ STRUCT: S_un_b { s_b2 uchar } { s_b3 uchar } { s_b4 uchar } ; - + STRUCT: S_un_w { s_w1 ushort } { s_w2 ushort } ; @@ -345,12 +345,12 @@ UNION-STRUCT: IPAddr { S_un_b S_un_b } { S_un_w S_un_w } { S_addr ulong } ; - + UNION-STRUCT: S_un { S_un_b S_un_b } { S_un_w S_un_w } { S_addr ulong } ; - + STRUCT: IP_ADAPTER_INDEX_MAP { Index ULONG } { Name WCHAR[MAX_ADAPTER_NAME] } ; @@ -382,13 +382,13 @@ FUNCTION: ULONG GetAdaptersAddresses ( FUNCTION: DWORD GetAdaptersInfo ( PIP_ADAPTER_INFO pAdapterInfo, PULONG pOutBufLen ) ; - + FUNCTION: DWORD GetNetworkParams ( PFIXED_INFO pFixedInfo, PULONG pOutBufLen ) ; : get-fixed-info ( -- FIXED_INFO ) FIXED_INFO dup byte-length ulong [ GetNetworkParams n>win32-error-check ] 2keep drop ; - + : dns-server-ips ( -- sequence ) get-fixed-info DnsServerList>> [ [ @@ -396,7 +396,7 @@ FUNCTION: DWORD GetNetworkParams ( PFIXED_INFO pFixedInfo, PULONG pOutBufLen ) ; [ Next>> ] bi dup ] loop drop ] { } make ; - + ! second struct starts at 720h @@ -429,7 +429,7 @@ PRIVATE> [ [ PhysicalAddress>> ] [ PhysicalAddressLength>> ] bi head ] } cleave>array ] interfaces-map ; - + : interface-ips ( -- seq ) [ { diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor index 3e963a7777..b3b22029a1 100644 --- a/basis/windows/kernel32/kernel32.factor +++ b/basis/windows/kernel32/kernel32.factor @@ -27,7 +27,7 @@ CONSTANT: CREATE_ALWAYS 2 CONSTANT: OPEN_EXISTING 3 CONSTANT: OPEN_ALWAYS 4 CONSTANT: TRUNCATE_EXISTING 5 - + CONSTANT: FILE_LIST_DIRECTORY 0x00000001 CONSTANT: FILE_READ_DAT 0x00000001 CONSTANT: FILE_ADD_FILE 0x00000002 @@ -1016,7 +1016,7 @@ FUNCTION: HANDLE CreateRemoteThread ( HANDLE hProcess, LPVOID lpStartAddress, LPVOID lpParameter, DWORD dwCreationFlags, - LPDWORD lpThreadId ) ; + LPDWORD lpThreadId ) ; ! FUNCTION: CreateSemaphoreA ! FUNCTION: CreateSemaphoreW ! FUNCTION: CreateSocketHandle diff --git a/basis/windows/messages/messages.factor b/basis/windows/messages/messages.factor index d70ba29afa..4a115269b4 100644 --- a/basis/windows/messages/messages.factor +++ b/basis/windows/messages/messages.factor @@ -432,7 +432,7 @@ CONSTANT: CCM_FIRST 0x2000 ! Common control shared messages : HDM_SETBITMAPMARGIN ( -- n ) HDM_FIRST 20 + ; inline : HDM_GETBITMAPMARGIN ( -- n ) HDM_FIRST 21 + ; inline CONSTANT: HDM_SETUNICODEFORMAT CCM_SETUNICODEFORMAT -CONSTANT: HDM_GETUNICODEFORMAT CCM_GETUNICODEFORMAT +CONSTANT: HDM_GETUNICODEFORMAT CCM_GETUNICODEFORMAT : HDM_SETFILTERCHANGETIMEOUT ( -- n ) HDM_FIRST 22 + ; inline : HDM_EDITFILTER ( -- n ) HDM_FIRST 23 + ; inline : HDM_CLEARFILTER ( -- n ) HDM_FIRST 24 + ; inline diff --git a/basis/windows/ntdll/ntdll.factor b/basis/windows/ntdll/ntdll.factor index 57c46d2d00..0dd203bbc5 100644 --- a/basis/windows/ntdll/ntdll.factor +++ b/basis/windows/ntdll/ntdll.factor @@ -160,4 +160,4 @@ FUNCTION: NTSTATUS NtQueryInformationProcess ( PVOID ProcessInformation, ULONG ProcessInformationLength, PULONG ReturnLength -) ; \ No newline at end of file +) ; diff --git a/basis/windows/offscreen/offscreen-tests.factor b/basis/windows/offscreen/offscreen-tests.factor index 58273979b7..a0384237e5 100644 --- a/basis/windows/offscreen/offscreen-tests.factor +++ b/basis/windows/offscreen/offscreen-tests.factor @@ -1,5 +1,5 @@ -IN: windows.offscreen.tests -USING: windows.offscreen effects tools.test kernel images ; - -{ 1 1 } [ [ [ ] make-bitmap-image ] with-memory-dc ] must-infer-as -[ t ] [ [ { 10 10 } swap [ ] make-bitmap-image ] with-memory-dc image? ] unit-test +IN: windows.offscreen.tests +USING: windows.offscreen effects tools.test kernel images ; + +{ 1 1 } [ [ [ ] make-bitmap-image ] with-memory-dc ] must-infer-as +[ t ] [ [ { 10 10 } swap [ ] make-bitmap-image ] with-memory-dc image? ] unit-test diff --git a/basis/windows/registry/registry.factor b/basis/windows/registry/registry.factor index 1d6a302b2a..060f9d7162 100644 --- a/basis/windows/registry/registry.factor +++ b/basis/windows/registry/registry.factor @@ -54,7 +54,7 @@ CONSTANT: registry-value-max-length 16384 [ hkey quot call ] [ hkey close-key ] [ ] cleanup ; inline - + :: with-create-registry-key ( key subkey quot -- ) key subkey create-key :> hkey [ hkey quot call ] @@ -107,7 +107,7 @@ TUPLE: registry-enum-key ; f ! 0 BYTE dup :> data f ! 0 BYTE dup :> buffer RegEnumKeyEx dup ERROR_SUCCESS = [ - + ] [ ] if ] map ; @@ -147,7 +147,7 @@ TUPLE: registry-enum-key ; [ 0 ] 3dip RegSetValueEx dup ERROR_SUCCESS = [ drop - ] [ + ] [ "omg" throw ] if ; @@ -189,6 +189,6 @@ PRIVATE> : windows-performance-data ( -- byte-array ) HKEY_PERFORMANCE_DATA "Global" f f 21 2^ reg-query-value-ex ; - + : read-registry ( key subkey -- registry-info ) KEY_READ [ reg-query-info-key ] with-open-registry-key ; diff --git a/basis/windows/shell32/shell32.factor b/basis/windows/shell32/shell32.factor index 52e034ac85..dc9b119a57 100644 --- a/basis/windows/shell32/shell32.factor +++ b/basis/windows/shell32/shell32.factor @@ -172,7 +172,7 @@ INSTANCE: +win32-nt-executable+ windows-executable ! pe : program-files-common-x86 ( -- str ) CSIDL_PROGRAM_FILES_COMMONX86 shell32-directory ; - + CONSTANT: SHCONTF_FOLDERS 32 CONSTANT: SHCONTF_NONFOLDERS 64 diff --git a/basis/windows/streams/streams.factor b/basis/windows/streams/streams.factor index 1109692168..6bbb2aa55e 100644 --- a/basis/windows/streams/streams.factor +++ b/basis/windows/streams/streams.factor @@ -1,123 +1,123 @@ -USING: accessors alien.c-types alien.data classes.struct -combinators continuations io kernel libc literals locals -sequences specialized-arrays windows.com memoize -windows.com.wrapper windows.kernel32 windows.ole32 -windows.types ; -IN: windows.streams - -SPECIALIZED-ARRAY: uchar - - buf - buf length :> bytes - pv buf bytes memcpy - out-read [ bytes out-read 0 ULONG set-alien-value ] when - - cb bytes = [ S_OK ] [ S_FALSE ] if - ] with-hresult ; inline - -:: IStream-write ( stream pv cb out-written -- hresult ) - [ - pv cb uchar stream stream-write - out-written [ cb out-written 0 ULONG set-alien-value ] when - S_OK - ] with-hresult ; inline - -: origin>seek-type ( origin -- seek-type ) - { - { $ STREAM_SEEK_SET [ seek-absolute ] } - { $ STREAM_SEEK_CUR [ seek-relative ] } - { $ STREAM_SEEK_END [ seek-end ] } - } case ; - -:: IStream-seek ( stream move origin new-position -- hresult ) - [ - move origin origin>seek-type stream stream-seek - new-position [ - stream stream-tell new-position 0 ULARGE_INTEGER set-alien-value - ] when - S_OK - ] with-hresult ; inline - -:: IStream-set-size ( stream new-size -- hresult ) - STG_E_INVALIDFUNCTION ; - -:: IStream-copy-to ( stream other-stream cb out-read out-written -- hresult ) - [ - cb stream stream-read :> buf - buf length :> bytes - out-read [ bytes out-read 0 ULONG set-alien-value ] when - - other-stream buf bytes out-written IStream::Write - ] with-hresult ; inline - -:: IStream-commit ( stream flags -- hresult ) - stream stream-flush S_OK ; - -:: IStream-revert ( stream -- hresult ) - STG_E_INVALIDFUNCTION ; - -:: IStream-lock-region ( stream offset cb lock-type -- hresult ) - STG_E_INVALIDFUNCTION ; - -:: IStream-unlock-region ( stream offset cb lock-type -- hresult ) - STG_E_INVALIDFUNCTION ; - -:: stream-size ( stream -- size ) - stream stream-tell :> old-pos - 0 seek-end stream stream-seek - stream stream-tell :> size - old-pos seek-absolute stream stream-seek - size ; - -:: IStream-stat ( stream out-stat stat-flag -- hresult ) - [ - out-stat - f >>pwcsName - STGTY_STREAM >>type - stream stream-size >>cbSize - FILETIME >>mtime - FILETIME >>ctime - FILETIME >>atime - STGM_READWRITE >>grfMode - 0 >>grfLocksSupported - GUID_NULL >>clsid - 0 >>grfStateBits - 0 >>reserved - drop - S_OK - ] with-hresult ; - -:: IStream-clone ( stream out-clone-stream -- hresult ) - f out-clone-stream 0 void* set-alien-value - STG_E_INVALIDFUNCTION ; - -CONSTANT: stream-wrapper - $[ - { - { IStream { - [ IStream-read ] - [ IStream-write ] - [ IStream-seek ] - [ IStream-set-size ] - [ IStream-copy-to ] - [ IStream-commit ] - [ IStream-revert ] - [ IStream-lock-region ] - [ IStream-unlock-region ] - [ IStream-stat ] - [ IStream-clone ] - } } - } - ] - -PRIVATE> - -: stream>IStream ( stream -- IStream ) - stream-wrapper com-wrap ; +USING: accessors alien.c-types alien.data classes.struct +combinators continuations io kernel libc literals locals +sequences specialized-arrays windows.com memoize +windows.com.wrapper windows.kernel32 windows.ole32 +windows.types ; +IN: windows.streams + +SPECIALIZED-ARRAY: uchar + + buf + buf length :> bytes + pv buf bytes memcpy + out-read [ bytes out-read 0 ULONG set-alien-value ] when + + cb bytes = [ S_OK ] [ S_FALSE ] if + ] with-hresult ; inline + +:: IStream-write ( stream pv cb out-written -- hresult ) + [ + pv cb uchar stream stream-write + out-written [ cb out-written 0 ULONG set-alien-value ] when + S_OK + ] with-hresult ; inline + +: origin>seek-type ( origin -- seek-type ) + { + { $ STREAM_SEEK_SET [ seek-absolute ] } + { $ STREAM_SEEK_CUR [ seek-relative ] } + { $ STREAM_SEEK_END [ seek-end ] } + } case ; + +:: IStream-seek ( stream move origin new-position -- hresult ) + [ + move origin origin>seek-type stream stream-seek + new-position [ + stream stream-tell new-position 0 ULARGE_INTEGER set-alien-value + ] when + S_OK + ] with-hresult ; inline + +:: IStream-set-size ( stream new-size -- hresult ) + STG_E_INVALIDFUNCTION ; + +:: IStream-copy-to ( stream other-stream cb out-read out-written -- hresult ) + [ + cb stream stream-read :> buf + buf length :> bytes + out-read [ bytes out-read 0 ULONG set-alien-value ] when + + other-stream buf bytes out-written IStream::Write + ] with-hresult ; inline + +:: IStream-commit ( stream flags -- hresult ) + stream stream-flush S_OK ; + +:: IStream-revert ( stream -- hresult ) + STG_E_INVALIDFUNCTION ; + +:: IStream-lock-region ( stream offset cb lock-type -- hresult ) + STG_E_INVALIDFUNCTION ; + +:: IStream-unlock-region ( stream offset cb lock-type -- hresult ) + STG_E_INVALIDFUNCTION ; + +:: stream-size ( stream -- size ) + stream stream-tell :> old-pos + 0 seek-end stream stream-seek + stream stream-tell :> size + old-pos seek-absolute stream stream-seek + size ; + +:: IStream-stat ( stream out-stat stat-flag -- hresult ) + [ + out-stat + f >>pwcsName + STGTY_STREAM >>type + stream stream-size >>cbSize + FILETIME >>mtime + FILETIME >>ctime + FILETIME >>atime + STGM_READWRITE >>grfMode + 0 >>grfLocksSupported + GUID_NULL >>clsid + 0 >>grfStateBits + 0 >>reserved + drop + S_OK + ] with-hresult ; + +:: IStream-clone ( stream out-clone-stream -- hresult ) + f out-clone-stream 0 void* set-alien-value + STG_E_INVALIDFUNCTION ; + +CONSTANT: stream-wrapper + $[ + { + { IStream { + [ IStream-read ] + [ IStream-write ] + [ IStream-seek ] + [ IStream-set-size ] + [ IStream-copy-to ] + [ IStream-commit ] + [ IStream-revert ] + [ IStream-lock-region ] + [ IStream-unlock-region ] + [ IStream-stat ] + [ IStream-clone ] + } } + } + ] + +PRIVATE> + +: stream>IStream ( stream -- IStream ) + stream-wrapper com-wrap ; diff --git a/basis/windows/types/types.factor b/basis/windows/types/types.factor index f7a9db1b81..f735f6c5a5 100644 --- a/basis/windows/types/types.factor +++ b/basis/windows/types/types.factor @@ -271,7 +271,7 @@ TYPEDEF: void* PAINTSTRUCT STRUCT: POINT { x LONG } - { y LONG } ; + { y LONG } ; STRUCT: SIZE { cx LONG } diff --git a/basis/windows/user32/user32.factor b/basis/windows/user32/user32.factor index c46d3e35ca..a7747ff63a 100644 --- a/basis/windows/user32/user32.factor +++ b/basis/windows/user32/user32.factor @@ -78,7 +78,7 @@ CONSTANT: WS_EX_APPWINDOW 0x00040000 CONSTANT: WS_EX_OVERLAPPEDWINDOW flags{ WS_EX_WINDOWEDGE WS_EX_CLIENTEDGE } -CONSTANT: WS_EX_PALETTEWINDOW +CONSTANT: WS_EX_PALETTEWINDOW flags{ WS_EX_WINDOWEDGE WS_EX_TOOLWINDOW WS_EX_TOPMOST } CONSTANT: CS_VREDRAW 0x0001 @@ -149,7 +149,7 @@ CONSTANT: PM_NOYIELD 2 ! : PM_QS_SENDMESSAGE (QS_SENDMESSAGE << 16) ; -! +! ! Standard Cursor IDs ! CONSTANT: IDC_ARROW 32512 @@ -1551,7 +1551,7 @@ ALIAS: MapVirtualKeyEx MapVirtualKeyExW ! -1 is Simple beep FUNCTION: BOOL MessageBeep ( UINT uType ) ; -FUNCTION: int MessageBoxA ( +FUNCTION: int MessageBoxA ( HWND hWnd, LPCSTR lpText, LPCSTR lpCaption, @@ -1731,7 +1731,7 @@ FUNCTION: BOOL SetForegroundWindow ( HWND hWnd ) ; ! FUNCTION: SetInternalWindowPos ! FUNCTION: SetKeyboardState ! type is ignored -FUNCTION: void SetLastErrorEx ( DWORD dwErrCode, DWORD dwType ) ; +FUNCTION: void SetLastErrorEx ( DWORD dwErrCode, DWORD dwType ) ; : SetLastError ( errcode -- ) 0 SetLastErrorEx ; inline ! FUNCTION: SetLayeredWindowAttributes ! FUNCTION: SetLogonNotifyWindow diff --git a/basis/windows/winmm/winmm.factor b/basis/windows/winmm/winmm.factor index 29908c7dc6..e1d0c49198 100644 --- a/basis/windows/winmm/winmm.factor +++ b/basis/windows/winmm/winmm.factor @@ -25,7 +25,7 @@ ERROR: mci-error n ; : open-command ( path -- ) "open \"%s\" type mpegvideo alias MediaFile" sprintf f 0 f mciSendString check-mci-error ; - + : play-command ( -- ) "play MediaFile" f 0 f mciSendString check-mci-error ; @@ -37,4 +37,4 @@ ERROR: mci-error n ; : close-command ( -- ) - "close MediaFile" f 0 f mciSendString check-mci-error ; \ No newline at end of file + "close MediaFile" f 0 f mciSendString check-mci-error ; diff --git a/basis/wrap/words/words.factor b/basis/wrap/words/words.factor index f282658d68..2b47249ba9 100644 --- a/basis/wrap/words/words.factor +++ b/basis/wrap/words/words.factor @@ -39,4 +39,3 @@ PRIVATE> : wrap-words ( words line-max line-ideal -- lines ) [ words>elements ] 2dip wrap [ concat ] map! ; - diff --git a/basis/x11/constants/constants.factor b/basis/x11/constants/constants.factor index e0b040211e..f872837c20 100644 --- a/basis/x11/constants/constants.factor +++ b/basis/x11/constants/constants.factor @@ -59,7 +59,7 @@ CONSTANT: NotifyUngrab 2 CONSTANT: NotifyWhileGrabbed 3 CONSTANT: NotifyHint 1 ! for MotionNotify events - + ! Notify detail CONSTANT: NotifyAncestor 0 diff --git a/basis/x11/io/io.factor b/basis/x11/io/io.factor index 0e618cd323..2eaf434072 100644 --- a/basis/x11/io/io.factor +++ b/basis/x11/io/io.factor @@ -13,4 +13,4 @@ M: object wait-for-display 10 milliseconds sleep ; HOOK: awaken-event-loop io-backend ( -- ) -M: object awaken-event-loop ; \ No newline at end of file +M: object awaken-event-loop ; diff --git a/basis/x11/xinput2/constants/constants.factor b/basis/x11/xinput2/constants/constants.factor index e58928f526..36bd05d6f0 100644 --- a/basis/x11/xinput2/constants/constants.factor +++ b/basis/x11/xinput2/constants/constants.factor @@ -138,4 +138,3 @@ CONSTANT: XI_RawMotion 17 : XI_RawButtonPressMask ( -- n ) XI_RawButtonPress 2^ ; inline : XI_RawButtonReleaseMask ( -- n ) XI_RawButtonRelease 2^ ; inline : XI_RawMotionMask ( -- n ) XI_RawMotion 2^ ; inline - diff --git a/basis/x11/xinput2/ffi/ffi.factor b/basis/x11/xinput2/ffi/ffi.factor index c2a03b6201..06ad9e706b 100644 --- a/basis/x11/xinput2/ffi/ffi.factor +++ b/basis/x11/xinput2/ffi/ffi.factor @@ -481,4 +481,3 @@ X-FUNCTION: Status XIGetProperty ( uchar** data ) ; X-FUNCTION: void XIFreeDeviceInfo ( XIDeviceInfo* info ) ; - diff --git a/basis/x11/xinput2/xinput2.factor b/basis/x11/xinput2/xinput2.factor index 5e38d70cb6..c60c13b049 100644 --- a/basis/x11/xinput2/xinput2.factor +++ b/basis/x11/xinput2/xinput2.factor @@ -14,4 +14,3 @@ IN: x11.xinput2 } case ; : xi2-available? ( -- ? ) dpy get (xi2-available?) ; inline - diff --git a/basis/x11/xlib/xlib.factor b/basis/x11/xlib/xlib.factor index 70e2a449af..3e8533c13d 100644 --- a/basis/x11/xlib/xlib.factor +++ b/basis/x11/xlib/xlib.factor @@ -1339,7 +1339,7 @@ CONSTANT: XA_WM_CLASS 67 CONSTANT: XA_WM_TRANSIENT_FOR 68 CONSTANT: XA_LAST_PREDEFINED 68 - + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! The rest of the stuff is not from the book. ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -1422,7 +1422,7 @@ X-FUNCTION: XIC XCreateIC ( XIM im, c-string key1, Window value1, c-string key2, X-FUNCTION: void XDestroyIC ( XIC ic ) ; X-FUNCTION: void XSetICFocus ( XIC ic ) ; - + X-FUNCTION: void XUnsetICFocus ( XIC ic ) ; X-FUNCTION: int XwcLookupString ( XIC ic, XKeyPressedEvent* event, ulong* buffer_return, int bytes_buffer, KeySym* keysym_return, Status* status_return ) ; @@ -1446,4 +1446,3 @@ X-FUNCTION: c-string XSetLocaleModifiers ( c-string modifier_list ) ; ! uncategorized xlib bindings X-FUNCTION: int XQueryKeymap ( Display* display, char[32] keys_return ) ; - diff --git a/basis/xml/autoencoding/autoencoding.factor b/basis/xml/autoencoding/autoencoding.factor index ed9b341c52..061369197e 100644 --- a/basis/xml/autoencoding/autoencoding.factor +++ b/basis/xml/autoencoding/autoencoding.factor @@ -82,4 +82,3 @@ IN: xml.autoencoding { 0xFE [ skip-utf16be-bom ] } [ drop utf8 decode-stream check f ] } case ; - diff --git a/basis/xml/dtd/dtd.factor b/basis/xml/dtd/dtd.factor index 50de78ec11..8658a814f8 100644 --- a/basis/xml/dtd/dtd.factor +++ b/basis/xml/dtd/dtd.factor @@ -15,7 +15,7 @@ IN: xml.dtd take-decl-contents ; : take-notation-decl ( -- notation-decl ) - take-decl-contents ; + take-decl-contents ; UNION: dtd-acceptable directive comment instruction ; diff --git a/basis/xml/elements/elements.factor b/basis/xml/elements/elements.factor index eb84b110e8..25d66bd8cf 100644 --- a/basis/xml/elements/elements.factor +++ b/basis/xml/elements/elements.factor @@ -57,7 +57,7 @@ IN: xml.elements T{ name f "" "encoding" f } T{ name f "" "standalone" f } } diff - [ extra-attrs ] unless-empty ; + [ extra-attrs ] unless-empty ; : good-version ( version -- version ) dup { "1.0" "1.1" } member? [ bad-version ] unless ; diff --git a/basis/xml/syntax/inverse/inverse.factor b/basis/xml/syntax/inverse/inverse.factor index cdcc364741..9e5dfc9eca 100644 --- a/basis/xml/syntax/inverse/inverse.factor +++ b/basis/xml/syntax/inverse/inverse.factor @@ -44,7 +44,7 @@ M: xml-chunk [undo-xml] M: tag [undo-xml] ( tag -- quot: ( tag -- ) ) { [ name>> main>> '[ name>> main>> _ =/fail ] ] - [ attrs>> undo-attrs ] + [ attrs>> undo-attrs ] [ children>> [undo-xml] '[ children>> @ ] ] } cleave '[ _ _ _ tri ] ; diff --git a/basis/xml/writer/writer.factor b/basis/xml/writer/writer.factor index 0243edec6f..06c0fcf87d 100644 --- a/basis/xml/writer/writer.factor +++ b/basis/xml/writer/writer.factor @@ -1,190 +1,190 @@ -! Copyright (C) 2005, 2009 Daniel Ehrenberg -! See http://factorcode.org/license.txt for BSD license. -USING: hashtables kernel math namespaces sequences strings -assocs combinators io io.streams.string accessors -xml.data wrap.strings xml.entities unicode.categories fry ; -IN: xml.writer - -SYMBOL: sensitive-tags -SYMBOL: indenter -" " indenter set-global - - "" concat-as ] - [ "" ] if ; - -: ?indent ( -- ) - xml-pprint? get [ nl indent-string write ] when ; - -: indent ( -- ) - xml-pprint? get [ 1 indentation +@ ] when ; - -: unindent ( -- ) - xml-pprint? get [ -1 indentation +@ ] when ; - -: ?filter-children ( children -- no-whitespace ) - xml-pprint? get [ - [ dup string? [ [ blank? ] trim ] when ] map - [ "" = ] reject - ] when ; - -PRIVATE> - -: name>string ( name -- string ) - [ main>> ] [ space>> ] bi [ ":" rot 3append ] unless-empty ; - -: print-name ( name -- ) - name>string write ; - -> print-attrs ; - -: write-start-tag ( tag -- ) - write-tag ">" write ; - -M: contained-tag write-xml - write-tag "/>" write ; - -: write-children ( tag -- ) - indent children>> ?filter-children - [ write-xml ] each unindent ; - -: write-end-tag ( tag -- ) - ?indent " write1 ; - -M: open-tag write-xml - xml-pprint? get [ - { - [ write-start-tag ] - [ sensitive? not xml-pprint? get and xml-pprint? set ] - [ write-children ] - [ write-end-tag ] - } cleave - ] dip xml-pprint? set ; - -M: unescaped write-xml - string>> write ; - -M: comment write-xml - "" write ; - -: write-decl ( decl name quot: ( decl -- slot ) -- ) - "> write bl ] - swap '[ @ write ">" write ] bi ; inline - -M: element-decl write-xml - "ELEMENT" [ content-spec>> ] write-decl ; - -M: attlist-decl write-xml - "ATTLIST" [ att-defs>> ] write-decl ; - -M: notation-decl write-xml - "NOTATION" [ id>> ] write-decl ; - -M: entity-decl write-xml - "> [ " % " write ] when ] - [ name>> write " \"" write ] [ - def>> f xml-pprint? - [ write-xml ] with-variable - "\">" write - ] tri ; - -M: system-id write-xml - "SYSTEM" write bl system-literal>> write-quoted ; - -M: public-id write-xml - "PUBLIC" write bl - [ pubid-literal>> write-quoted bl ] - [ system-literal>> write-quoted ] bi ; - -: write-internal-subset ( dtd -- ) - [ - "[" write indent - directives>> [ ?indent write-xml ] each - unindent ?indent "]" write - ] when* ; - -M: doctype-decl write-xml - ?indent "> write bl ] - [ external-id>> [ write-xml bl ] when* ] - [ internal-subset>> write-internal-subset ">" write ] tri ; - -M: directive write-xml - "> write CHAR: > write1 nl ; - -M: instruction write-xml - "> write "?>" write ; - -M: number write-xml - "Numbers are not allowed in XML" throw ; - -M: sequence write-xml - [ write-xml ] each ; - -M: prolog write-xml - "> write-quoted ] - [ drop " encoding=\"UTF-8\"" write ] - [ standalone>> [ " standalone=\"yes\"" write ] when ] tri - "?>" write ; - -M: xml write-xml - { - [ prolog>> write-xml ] - [ before>> write-xml ] - [ body>> write-xml ] - [ after>> write-xml ] - } cleave ; - -PRIVATE> - -: xml>string ( xml -- string ) - [ write-xml ] with-string-writer ; - -: pprint-xml ( xml -- ) - [ - sensitive-tags [ [ assure-name ] map ] change - 0 indentation set - xml-pprint? on - write-xml - ] with-scope ; - -: pprint-xml>string ( xml -- string ) - [ pprint-xml ] with-string-writer ; +! Copyright (C) 2005, 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: hashtables kernel math namespaces sequences strings +assocs combinators io io.streams.string accessors +xml.data wrap.strings xml.entities unicode.categories fry ; +IN: xml.writer + +SYMBOL: sensitive-tags +SYMBOL: indenter +" " indenter set-global + + "" concat-as ] + [ "" ] if ; + +: ?indent ( -- ) + xml-pprint? get [ nl indent-string write ] when ; + +: indent ( -- ) + xml-pprint? get [ 1 indentation +@ ] when ; + +: unindent ( -- ) + xml-pprint? get [ -1 indentation +@ ] when ; + +: ?filter-children ( children -- no-whitespace ) + xml-pprint? get [ + [ dup string? [ [ blank? ] trim ] when ] map + [ "" = ] reject + ] when ; + +PRIVATE> + +: name>string ( name -- string ) + [ main>> ] [ space>> ] bi [ ":" rot 3append ] unless-empty ; + +: print-name ( name -- ) + name>string write ; + +> print-attrs ; + +: write-start-tag ( tag -- ) + write-tag ">" write ; + +M: contained-tag write-xml + write-tag "/>" write ; + +: write-children ( tag -- ) + indent children>> ?filter-children + [ write-xml ] each unindent ; + +: write-end-tag ( tag -- ) + ?indent " write1 ; + +M: open-tag write-xml + xml-pprint? get [ + { + [ write-start-tag ] + [ sensitive? not xml-pprint? get and xml-pprint? set ] + [ write-children ] + [ write-end-tag ] + } cleave + ] dip xml-pprint? set ; + +M: unescaped write-xml + string>> write ; + +M: comment write-xml + "" write ; + +: write-decl ( decl name quot: ( decl -- slot ) -- ) + "> write bl ] + swap '[ @ write ">" write ] bi ; inline + +M: element-decl write-xml + "ELEMENT" [ content-spec>> ] write-decl ; + +M: attlist-decl write-xml + "ATTLIST" [ att-defs>> ] write-decl ; + +M: notation-decl write-xml + "NOTATION" [ id>> ] write-decl ; + +M: entity-decl write-xml + "> [ " % " write ] when ] + [ name>> write " \"" write ] [ + def>> f xml-pprint? + [ write-xml ] with-variable + "\">" write + ] tri ; + +M: system-id write-xml + "SYSTEM" write bl system-literal>> write-quoted ; + +M: public-id write-xml + "PUBLIC" write bl + [ pubid-literal>> write-quoted bl ] + [ system-literal>> write-quoted ] bi ; + +: write-internal-subset ( dtd -- ) + [ + "[" write indent + directives>> [ ?indent write-xml ] each + unindent ?indent "]" write + ] when* ; + +M: doctype-decl write-xml + ?indent "> write bl ] + [ external-id>> [ write-xml bl ] when* ] + [ internal-subset>> write-internal-subset ">" write ] tri ; + +M: directive write-xml + "> write CHAR: > write1 nl ; + +M: instruction write-xml + "> write "?>" write ; + +M: number write-xml + "Numbers are not allowed in XML" throw ; + +M: sequence write-xml + [ write-xml ] each ; + +M: prolog write-xml + "> write-quoted ] + [ drop " encoding=\"UTF-8\"" write ] + [ standalone>> [ " standalone=\"yes\"" write ] when ] tri + "?>" write ; + +M: xml write-xml + { + [ prolog>> write-xml ] + [ before>> write-xml ] + [ body>> write-xml ] + [ after>> write-xml ] + } cleave ; + +PRIVATE> + +: xml>string ( xml -- string ) + [ write-xml ] with-string-writer ; + +: pprint-xml ( xml -- ) + [ + sensitive-tags [ [ assure-name ] map ] change + 0 indentation set + xml-pprint? on + write-xml + ] with-scope ; + +: pprint-xml>string ( xml -- string ) + [ pprint-xml ] with-string-writer ; diff --git a/basis/xml/xml-docs.factor b/basis/xml/xml-docs.factor index 3d37cfec8e..3ea09e09ec 100644 --- a/basis/xml/xml-docs.factor +++ b/basis/xml/xml-docs.factor @@ -1,120 +1,120 @@ -! Copyright (C) 2005, 2009 Daniel Ehrenberg -! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax xml.data io strings byte-arrays ; -IN: xml - -HELP: string>xml -{ $values { "string" string } { "xml" xml } } -{ $description "Converts a string into an " { $link xml } - " tree for further processing." } ; - -HELP: read-xml -{ $values { "stream" "an input stream" } { "xml" xml } } -{ $description "Exhausts the given stream, reading an XML document from it. A binary stream, one without encoding, should be used as input, and the encoding is automatically detected." } ; - -HELP: file>xml -{ $values { "filename" string } { "xml" xml } } -{ $description "Opens the given file, reads it in as XML, closes the file and returns the corresponding XML tree. The encoding is automatically detected." } ; - -HELP: bytes>xml -{ $values { "byte-array" byte-array } { "xml" xml } } -{ $description "Parses a byte array as an XML document. The encoding is automatically detected." } ; - -{ string>xml read-xml file>xml bytes>xml } related-words - -HELP: read-xml-chunk -{ $values { "stream" "an input stream" } { "seq" "a sequence of elements" } } -{ $description "Rather than parse a document, as " { $link read-xml } " does, this word parses and returns a sequence of XML elements (tags, strings, etc), ie a document fragment. This is useful for pieces of XML which may have more than one main tag. The encoding is not automatically detected, and a stream with an encoding (ie. one which returns strings from " { $link read } ") should be used as input." } -{ $see-also read-xml } ; - -HELP: each-element -{ $values { "stream" "an input stream" } { "quot" "a quotation ( xml-elem -- )" } } -{ $description "Parses the XML document, and whenever an event is encountered (a tag piece, comment, parsing instruction, directive or string element), the quotation is called with that event on the stack. The quotation has all responsibility to deal with the event properly. The encoding of the stream is automatically detected, so a binary input stream should be used." } -{ $see-also read-xml } ; - -HELP: pull-xml -{ $class-description "Represents the state of a pull-parser for XML. Has one slot, " { $snippet "scope" } ", which is a namespace which contains all relevant state information." } -{ $see-also pull-event pull-elem } ; - -HELP: -{ $values { "pull-xml" pull-xml } } -{ $description "Creates an XML pull-based parser which reads from " { $link input-stream } ", executing all initial XML commands to set up the parser." } -{ $see-also pull-xml pull-elem pull-event } ; - -HELP: pull-elem -{ $values { "pull" "an XML pull parser" } { "xml-elem/f" "an XML tag, string, or f" } } -{ $description "Gets the next XML element from the given XML pull parser. Returns f upon exhaustion." } -{ $see-also pull-xml pull-event } ; - -HELP: pull-event -{ $values { "pull" "an XML pull parser" } { "xml-event/f" "an XML tag event, string, or f" } } -{ $description "Gets the next XML event from the given XML pull parser. Returns f upon exhaustion." } -{ $see-also pull-xml pull-elem } ; - -HELP: read-dtd -{ $values { "stream" "an input stream" } { "dtd" dtd } } -{ $description "Exhausts a stream, producing a " { $link dtd } " from the contents." } ; - -HELP: file>dtd -{ $values { "filename" string } { "dtd" dtd } } -{ $description "Reads a file in UTF-8, converting it into an XML " { $link dtd } "." } ; - -HELP: string>dtd -{ $values { "string" string } { "dtd" dtd } } -{ $description "Interprets a string as an XML " { $link dtd } "." } ; - -{ read-dtd file>dtd string>dtd } related-words - -ARTICLE: { "xml" "reading" } "Reading XML" -"The following words are used to read something into an XML document" -{ $subsections - read-xml - read-xml-chunk - string>xml - string>xml-chunk - file>xml - bytes>xml -} -"To read a DTD:" -{ $subsections - read-dtd - file>dtd - string>dtd -} ; - -ARTICLE: { "xml" "events" } "Event-based XML parsing" - "In addition to DOM-style parsing based around " { $link read-xml } ", the XML module also provides SAX-style event-based parsing. This uses much of the same data structures as normal XML, with the exception of the classes " { $link xml } " and " { $link tag } " and as such, the article " { $vocab-link "xml.data" } " may be useful in learning how to process documents in this way. Other useful words are:" -{ $subsections - each-element - opener - closer - contained -} -"There is also pull-based parsing to augment the push-parsing of SAX. This is probably easier to use and more logical. It uses the same parsing objects as the above style of parsing, except string elements are always in arrays, for example { \"\" }. Relevant pull-parsing words are:" -{ $subsections - - pull-xml - pull-event - pull-elem -} ; - -ARTICLE: { "xml" "namespaces" } "Working with XML namespaces" -"The Factor XML parser implements XML namespaces, and provides convenient utilities for working with them. Anywhere in the public API that a name is accepted as an argument, either a string or an XML name is accepted. If a string is used, it is coerced into a name by giving it a null namespace. Names are stored as " { $link name } " tuples, which have slots for the namespace prefix and namespace URL as well as the main part of the tag name." $nl -"To make it easier to create XML names, the parsing word " { $snippet "XML-NS:" } " is provided in the " { $vocab-link "xml.syntax" } " vocabulary." $nl -"When parsing XML, names are automatically augmented with the appropriate namespace URL when the information is available. This does not take into account any XML schema which might allow for such prefixes to be omitted. When generating XML to be written, keep in mind that the XML writer knows only about the literal prefixes and ignores the URLs. It is your job to make sure that they match up correctly, and that there is the appropriate " { $snippet "xmlns" } " declaration." ; - -ARTICLE: "xml" "XML parser" -"The " { $vocab-link "xml" } " vocabulary implements the XML 1.0 and 1.1 standards, converting strings of text into XML and vice versa. The parser checks for well-formedness but is not validating. There is only partial support for processing DTDs." -{ $subsections - { "xml" "reading" } - { "xml" "events" } - { "xml" "namespaces" } -} -{ $vocab-subsection "Writing XML" "xml.writer" } -{ $vocab-subsection "XML parsing errors" "xml.errors" } -{ $vocab-subsection "XML entities" "xml.entities" } -{ $vocab-subsection "XML data types" "xml.data" } -{ $vocab-subsection "Utilities for traversing XML" "xml.traversal" } -{ $vocab-subsection "Syntax extensions for XML" "xml.syntax" } ; - -ABOUT: "xml" +! Copyright (C) 2005, 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax xml.data io strings byte-arrays ; +IN: xml + +HELP: string>xml +{ $values { "string" string } { "xml" xml } } +{ $description "Converts a string into an " { $link xml } + " tree for further processing." } ; + +HELP: read-xml +{ $values { "stream" "an input stream" } { "xml" xml } } +{ $description "Exhausts the given stream, reading an XML document from it. A binary stream, one without encoding, should be used as input, and the encoding is automatically detected." } ; + +HELP: file>xml +{ $values { "filename" string } { "xml" xml } } +{ $description "Opens the given file, reads it in as XML, closes the file and returns the corresponding XML tree. The encoding is automatically detected." } ; + +HELP: bytes>xml +{ $values { "byte-array" byte-array } { "xml" xml } } +{ $description "Parses a byte array as an XML document. The encoding is automatically detected." } ; + +{ string>xml read-xml file>xml bytes>xml } related-words + +HELP: read-xml-chunk +{ $values { "stream" "an input stream" } { "seq" "a sequence of elements" } } +{ $description "Rather than parse a document, as " { $link read-xml } " does, this word parses and returns a sequence of XML elements (tags, strings, etc), ie a document fragment. This is useful for pieces of XML which may have more than one main tag. The encoding is not automatically detected, and a stream with an encoding (ie. one which returns strings from " { $link read } ") should be used as input." } +{ $see-also read-xml } ; + +HELP: each-element +{ $values { "stream" "an input stream" } { "quot" "a quotation ( xml-elem -- )" } } +{ $description "Parses the XML document, and whenever an event is encountered (a tag piece, comment, parsing instruction, directive or string element), the quotation is called with that event on the stack. The quotation has all responsibility to deal with the event properly. The encoding of the stream is automatically detected, so a binary input stream should be used." } +{ $see-also read-xml } ; + +HELP: pull-xml +{ $class-description "Represents the state of a pull-parser for XML. Has one slot, " { $snippet "scope" } ", which is a namespace which contains all relevant state information." } +{ $see-also pull-event pull-elem } ; + +HELP: +{ $values { "pull-xml" pull-xml } } +{ $description "Creates an XML pull-based parser which reads from " { $link input-stream } ", executing all initial XML commands to set up the parser." } +{ $see-also pull-xml pull-elem pull-event } ; + +HELP: pull-elem +{ $values { "pull" "an XML pull parser" } { "xml-elem/f" "an XML tag, string, or f" } } +{ $description "Gets the next XML element from the given XML pull parser. Returns f upon exhaustion." } +{ $see-also pull-xml pull-event } ; + +HELP: pull-event +{ $values { "pull" "an XML pull parser" } { "xml-event/f" "an XML tag event, string, or f" } } +{ $description "Gets the next XML event from the given XML pull parser. Returns f upon exhaustion." } +{ $see-also pull-xml pull-elem } ; + +HELP: read-dtd +{ $values { "stream" "an input stream" } { "dtd" dtd } } +{ $description "Exhausts a stream, producing a " { $link dtd } " from the contents." } ; + +HELP: file>dtd +{ $values { "filename" string } { "dtd" dtd } } +{ $description "Reads a file in UTF-8, converting it into an XML " { $link dtd } "." } ; + +HELP: string>dtd +{ $values { "string" string } { "dtd" dtd } } +{ $description "Interprets a string as an XML " { $link dtd } "." } ; + +{ read-dtd file>dtd string>dtd } related-words + +ARTICLE: { "xml" "reading" } "Reading XML" +"The following words are used to read something into an XML document" +{ $subsections + read-xml + read-xml-chunk + string>xml + string>xml-chunk + file>xml + bytes>xml +} +"To read a DTD:" +{ $subsections + read-dtd + file>dtd + string>dtd +} ; + +ARTICLE: { "xml" "events" } "Event-based XML parsing" + "In addition to DOM-style parsing based around " { $link read-xml } ", the XML module also provides SAX-style event-based parsing. This uses much of the same data structures as normal XML, with the exception of the classes " { $link xml } " and " { $link tag } " and as such, the article " { $vocab-link "xml.data" } " may be useful in learning how to process documents in this way. Other useful words are:" +{ $subsections + each-element + opener + closer + contained +} +"There is also pull-based parsing to augment the push-parsing of SAX. This is probably easier to use and more logical. It uses the same parsing objects as the above style of parsing, except string elements are always in arrays, for example { \"\" }. Relevant pull-parsing words are:" +{ $subsections + + pull-xml + pull-event + pull-elem +} ; + +ARTICLE: { "xml" "namespaces" } "Working with XML namespaces" +"The Factor XML parser implements XML namespaces, and provides convenient utilities for working with them. Anywhere in the public API that a name is accepted as an argument, either a string or an XML name is accepted. If a string is used, it is coerced into a name by giving it a null namespace. Names are stored as " { $link name } " tuples, which have slots for the namespace prefix and namespace URL as well as the main part of the tag name." $nl +"To make it easier to create XML names, the parsing word " { $snippet "XML-NS:" } " is provided in the " { $vocab-link "xml.syntax" } " vocabulary." $nl +"When parsing XML, names are automatically augmented with the appropriate namespace URL when the information is available. This does not take into account any XML schema which might allow for such prefixes to be omitted. When generating XML to be written, keep in mind that the XML writer knows only about the literal prefixes and ignores the URLs. It is your job to make sure that they match up correctly, and that there is the appropriate " { $snippet "xmlns" } " declaration." ; + +ARTICLE: "xml" "XML parser" +"The " { $vocab-link "xml" } " vocabulary implements the XML 1.0 and 1.1 standards, converting strings of text into XML and vice versa. The parser checks for well-formedness but is not validating. There is only partial support for processing DTDs." +{ $subsections + { "xml" "reading" } + { "xml" "events" } + { "xml" "namespaces" } +} +{ $vocab-subsection "Writing XML" "xml.writer" } +{ $vocab-subsection "XML parsing errors" "xml.errors" } +{ $vocab-subsection "XML entities" "xml.entities" } +{ $vocab-subsection "XML data types" "xml.data" } +{ $vocab-subsection "Utilities for traversing XML" "xml.traversal" } +{ $vocab-subsection "Syntax extensions for XML" "xml.syntax" } ; + +ABOUT: "xml" diff --git a/basis/xml/xml.factor b/basis/xml/xml.factor index 14b017a207..8e75c5ec7e 100644 --- a/basis/xml/xml.factor +++ b/basis/xml/xml.factor @@ -77,7 +77,7 @@ M: closer process : no-post-tags ( post -- post/* ) ! this does *not* affect the contents of the stack - dup [ tag? ] any? [ multitags ] when ; + dup [ tag? ] any? [ multitags ] when ; : assure-tags ( seq -- seq ) ! this does *not* affect the contents of the stack diff --git a/basis/xmode/code2html/responder/responder.factor b/basis/xmode/code2html/responder/responder.factor index 74ef3ece83..d272748afc 100644 --- a/basis/xmode/code2html/responder/responder.factor +++ b/basis/xmode/code2html/responder/responder.factor @@ -1,16 +1,16 @@ -! Copyright (C) 2007, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: io io.files io.pathnames io.encodings.utf8 namespaces -http.server http.server.responses http.server.static http -xmode.code2html kernel sequences accessors fry ; -IN: xmode.code2html.responder - -: ( root -- responder ) - [ - drop - dup '[ - _ utf8 [ - _ file-name input-stream get htmlize-stream - ] with-file-reader - ] - ] ; +! Copyright (C) 2007, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: io io.files io.pathnames io.encodings.utf8 namespaces +http.server http.server.responses http.server.static http +xmode.code2html kernel sequences accessors fry ; +IN: xmode.code2html.responder + +: ( root -- responder ) + [ + drop + dup '[ + _ utf8 [ + _ file-name input-stream get htmlize-stream + ] with-file-reader + ] + ] ; diff --git a/core/byte-arrays/byte-arrays-tests.factor b/core/byte-arrays/byte-arrays-tests.factor index 985df28460..09f9b927f2 100644 --- a/core/byte-arrays/byte-arrays-tests.factor +++ b/core/byte-arrays/byte-arrays-tests.factor @@ -1,21 +1,21 @@ -USING: byte-arrays kernel math sequences sequences.private -tools.test ; -IN: byte-arrays.tests - -[ 6 B{ 1 2 3 } ] [ - 6 B{ 1 2 3 } resize-byte-array - [ length ] [ 3 head ] bi -] unit-test - -[ B{ 1 2 } ] [ 2 B{ 1 2 3 4 5 6 7 8 9 } resize-byte-array ] unit-test - -[ -10 B{ } resize-byte-array ] must-fail - -[ B{ 123 } ] [ 123 1byte-array ] unit-test - -[ B{ 123 } ] [ 123 0 B{ 0 } [ set-nth ] keep ] unit-test - -[ B{ 123 } ] [ 123 >bignum 0 B{ 0 } [ set-nth ] keep ] unit-test - -[ 1.5 B{ 1 2 3 } nth-unsafe ] must-fail -[ 0 1.5 B{ 1 2 3 } set-nth-unsafe ] must-fail +USING: byte-arrays kernel math sequences sequences.private +tools.test ; +IN: byte-arrays.tests + +[ 6 B{ 1 2 3 } ] [ + 6 B{ 1 2 3 } resize-byte-array + [ length ] [ 3 head ] bi +] unit-test + +[ B{ 1 2 } ] [ 2 B{ 1 2 3 4 5 6 7 8 9 } resize-byte-array ] unit-test + +[ -10 B{ } resize-byte-array ] must-fail + +[ B{ 123 } ] [ 123 1byte-array ] unit-test + +[ B{ 123 } ] [ 123 0 B{ 0 } [ set-nth ] keep ] unit-test + +[ B{ 123 } ] [ 123 >bignum 0 B{ 0 } [ set-nth ] keep ] unit-test + +[ 1.5 B{ 1 2 3 } nth-unsafe ] must-fail +[ 0 1.5 B{ 1 2 3 } set-nth-unsafe ] must-fail diff --git a/core/byte-vectors/byte-vectors-docs.factor b/core/byte-vectors/byte-vectors-docs.factor index 79c73c86ef..436120c2ca 100644 --- a/core/byte-vectors/byte-vectors-docs.factor +++ b/core/byte-vectors/byte-vectors-docs.factor @@ -1,40 +1,40 @@ -USING: help.markup help.syntax sequences ; -IN: byte-vectors - -ARTICLE: "byte-vectors" "Byte vectors" -"The " { $vocab-link "byte-vectors" } " vocabulary implements resizable mutable sequence of unsigned bytes. Byte vectors implement the " { $link "sequence-protocol" } " and thus all " { $link "sequences" } " can be used with them." -$nl -"Byte vectors form a class:" -{ $subsections - byte-vector - byte-vector? -} -"Creating byte vectors:" -{ $subsections - >byte-vector - -} -"Literal syntax:" -{ $subsections POSTPONE: BV{ } -"If you don't care about initial capacity, a more elegant way to create a new byte vector is to write:" -{ $code "BV{ } clone" } ; - -ABOUT: "byte-vectors" - -HELP: byte-vector -{ $description "The class of resizable byte vectors. See " { $link "byte-vectors" } " for information." } ; - -HELP: -{ $values { "n" "a positive integer specifying initial capacity" } { "byte-vector" byte-vector } } -{ $description "Creates a new byte vector that can hold " { $snippet "n" } " bytes before resizing." } ; - -HELP: >byte-vector -{ $values { "seq" sequence } { "byte-vector" byte-vector } } -{ $description "Outputs a freshly-allocated byte vector with the same elements as a given sequence." } -{ $errors "Throws an error if the sequence contains elements other than integers." } ; - -HELP: BV{ -{ $syntax "BV{ elements... }" } -{ $values { "elements" "a list of bytes" } } -{ $description "Marks the beginning of a literal byte vector. Literal byte vectors are terminated by " { $link POSTPONE: } } "." } -{ $examples { $code "BV{ 1 2 3 12 }" } } ; +USING: help.markup help.syntax sequences ; +IN: byte-vectors + +ARTICLE: "byte-vectors" "Byte vectors" +"The " { $vocab-link "byte-vectors" } " vocabulary implements resizable mutable sequence of unsigned bytes. Byte vectors implement the " { $link "sequence-protocol" } " and thus all " { $link "sequences" } " can be used with them." +$nl +"Byte vectors form a class:" +{ $subsections + byte-vector + byte-vector? +} +"Creating byte vectors:" +{ $subsections + >byte-vector + +} +"Literal syntax:" +{ $subsections POSTPONE: BV{ } +"If you don't care about initial capacity, a more elegant way to create a new byte vector is to write:" +{ $code "BV{ } clone" } ; + +ABOUT: "byte-vectors" + +HELP: byte-vector +{ $description "The class of resizable byte vectors. See " { $link "byte-vectors" } " for information." } ; + +HELP: +{ $values { "n" "a positive integer specifying initial capacity" } { "byte-vector" byte-vector } } +{ $description "Creates a new byte vector that can hold " { $snippet "n" } " bytes before resizing." } ; + +HELP: >byte-vector +{ $values { "seq" sequence } { "byte-vector" byte-vector } } +{ $description "Outputs a freshly-allocated byte vector with the same elements as a given sequence." } +{ $errors "Throws an error if the sequence contains elements other than integers." } ; + +HELP: BV{ +{ $syntax "BV{ elements... }" } +{ $values { "elements" "a list of bytes" } } +{ $description "Marks the beginning of a literal byte vector. Literal byte vectors are terminated by " { $link POSTPONE: } } "." } +{ $examples { $code "BV{ 1 2 3 12 }" } } ; diff --git a/core/byte-vectors/byte-vectors-tests.factor b/core/byte-vectors/byte-vectors-tests.factor index 6638b9df7a..4022eaf7db 100644 --- a/core/byte-vectors/byte-vectors-tests.factor +++ b/core/byte-vectors/byte-vectors-tests.factor @@ -1,17 +1,17 @@ -USING: tools.test byte-vectors vectors sequences kernel -prettyprint math ; -IN: byte-vectors.tests - -[ 0 ] [ 123 length ] unit-test - -: do-it ( seq -- seq ) - 123 [ suffix! ] each-integer ; - -[ t ] [ - 3 do-it - 3 do-it sequence= -] unit-test - -[ t ] [ BV{ } byte-vector? ] unit-test - -[ "BV{ }" ] [ BV{ } unparse ] unit-test +USING: tools.test byte-vectors vectors sequences kernel +prettyprint math ; +IN: byte-vectors.tests + +[ 0 ] [ 123 length ] unit-test + +: do-it ( seq -- seq ) + 123 [ suffix! ] each-integer ; + +[ t ] [ + 3 do-it + 3 do-it sequence= +] unit-test + +[ t ] [ BV{ } byte-vector? ] unit-test + +[ "BV{ }" ] [ BV{ } unparse ] unit-test diff --git a/core/classes/algebra/algebra-docs.factor b/core/classes/algebra/algebra-docs.factor index cd23dfc87d..01663ad116 100644 --- a/core/classes/algebra/algebra-docs.factor +++ b/core/classes/algebra/algebra-docs.factor @@ -1,70 +1,70 @@ -USING: classes classes.private help.markup help.syntax kernel -math sequences ; -IN: classes.algebra - -ARTICLE: "class-operations" "Class operations" -"Set-theoretic operations on classes:" -{ $subsections - class= - class< - class<= - class-and - class-or - classes-intersect? - flatten-class -} ; - -ARTICLE: "class-linearization" "Class linearization" -"Classes have an intrinsic partial order; given two classes A and B, we either have that A is a subset of B, B is a subset of A, A and B are equal as sets, or they are incomparable. The last two situations present difficulties for method dispatch:" -{ $list - "If a generic word defines a method on a mixin class A and another on class B, and B is the only instance of A, there is an ambiguity because A and B are equal as sets; any object that is an instance of one is an instance of both." - { "If a generic word defines methods on two union classes which are incomparable but not disjoint, for example " { $link sequence } " and " { $link number } ", there is an ambiguity because the generic word may be called on an object that is an instance of both unions." } -} -"The first ambiguity is resolved with a tie-breaker that compares metaclasses. The intrinsic meta-class order, from most-specific to least-specific:" -{ $list - "Built-in classes and tuple classes" - "Predicate classes" - "Union classes" - "Mixin classes" -} -"This means that in the above example, the generic word with methods on a mixin and its sole instance will always call the method for the sole instance, since it is more specific than a mixin class." -$nl -"The second problem is resolved with another tie-breaker. When performing the topological sort of classes, if there are multiple candidates at any given step of the sort, lexicographical order on the class name is used." -$nl -"Operations:" -{ $subsections - class< - sort-classes - smallest-class -} -"Metaclass order:" -{ $subsections rank-class } ; - -HELP: flatten-class -{ $values { "class" class } { "assoc" "an assoc whose keys are classes" } } -{ $description "Outputs a set of builtin and tuple classes whose union is the smallest cover of " { $snippet "class" } "." } ; - -HELP: class<= -{ $values { "first" "a class" } { "second" "a class" } { "?" boolean } } -{ $description "Tests if all instances of " { $snippet "class1" } " are also instances of " { $snippet "class2" } "." } -{ $notes "Classes are partially ordered. This means that if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class1" } ", then " { $snippet "class1 <= class2" } ". Also, if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class3" } ", then " { $snippet "class1 <= class3" } "." } ; - -HELP: sort-classes -{ $values { "seq" "a sequence of class" } { "newseq" "a new sequence of classes" } } -{ $description "Outputs a linear sort of a sequence of classes. Larger classes come before their subclasses." } ; - -HELP: class-or -{ $values { "first" class } { "second" class } { "class" class } } -{ $description "Outputs the smallest anonymous class containing both " { $snippet "class1" } " and " { $snippet "class2" } "." } ; - -HELP: class-and -{ $values { "first" class } { "second" class } { "class" class } } -{ $description "Outputs the largest anonymous class contained in both " { $snippet "class1" } " and " { $snippet "class2" } "." } ; - -HELP: classes-intersect? -{ $values { "first" class } { "second" class } { "?" boolean } } -{ $description "Tests if two classes have a non-empty intersection. If the intersection is empty, no object can be an instance of both classes at once." } ; - -HELP: smallest-class -{ $values { "classes" "a sequence of class words" } { "class/f" { $maybe class } } } -{ $description "Outputs a minimum class from the given sequence." } ; +USING: classes classes.private help.markup help.syntax kernel +math sequences ; +IN: classes.algebra + +ARTICLE: "class-operations" "Class operations" +"Set-theoretic operations on classes:" +{ $subsections + class= + class< + class<= + class-and + class-or + classes-intersect? + flatten-class +} ; + +ARTICLE: "class-linearization" "Class linearization" +"Classes have an intrinsic partial order; given two classes A and B, we either have that A is a subset of B, B is a subset of A, A and B are equal as sets, or they are incomparable. The last two situations present difficulties for method dispatch:" +{ $list + "If a generic word defines a method on a mixin class A and another on class B, and B is the only instance of A, there is an ambiguity because A and B are equal as sets; any object that is an instance of one is an instance of both." + { "If a generic word defines methods on two union classes which are incomparable but not disjoint, for example " { $link sequence } " and " { $link number } ", there is an ambiguity because the generic word may be called on an object that is an instance of both unions." } +} +"The first ambiguity is resolved with a tie-breaker that compares metaclasses. The intrinsic meta-class order, from most-specific to least-specific:" +{ $list + "Built-in classes and tuple classes" + "Predicate classes" + "Union classes" + "Mixin classes" +} +"This means that in the above example, the generic word with methods on a mixin and its sole instance will always call the method for the sole instance, since it is more specific than a mixin class." +$nl +"The second problem is resolved with another tie-breaker. When performing the topological sort of classes, if there are multiple candidates at any given step of the sort, lexicographical order on the class name is used." +$nl +"Operations:" +{ $subsections + class< + sort-classes + smallest-class +} +"Metaclass order:" +{ $subsections rank-class } ; + +HELP: flatten-class +{ $values { "class" class } { "assoc" "an assoc whose keys are classes" } } +{ $description "Outputs a set of builtin and tuple classes whose union is the smallest cover of " { $snippet "class" } "." } ; + +HELP: class<= +{ $values { "first" "a class" } { "second" "a class" } { "?" boolean } } +{ $description "Tests if all instances of " { $snippet "class1" } " are also instances of " { $snippet "class2" } "." } +{ $notes "Classes are partially ordered. This means that if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class1" } ", then " { $snippet "class1 <= class2" } ". Also, if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class3" } ", then " { $snippet "class1 <= class3" } "." } ; + +HELP: sort-classes +{ $values { "seq" "a sequence of class" } { "newseq" "a new sequence of classes" } } +{ $description "Outputs a linear sort of a sequence of classes. Larger classes come before their subclasses." } ; + +HELP: class-or +{ $values { "first" class } { "second" class } { "class" class } } +{ $description "Outputs the smallest anonymous class containing both " { $snippet "class1" } " and " { $snippet "class2" } "." } ; + +HELP: class-and +{ $values { "first" class } { "second" class } { "class" class } } +{ $description "Outputs the largest anonymous class contained in both " { $snippet "class1" } " and " { $snippet "class2" } "." } ; + +HELP: classes-intersect? +{ $values { "first" class } { "second" class } { "?" boolean } } +{ $description "Tests if two classes have a non-empty intersection. If the intersection is empty, no object can be an instance of both classes at once." } ; + +HELP: smallest-class +{ $values { "classes" "a sequence of class words" } { "class/f" { $maybe class } } } +{ $description "Outputs a minimum class from the given sequence." } ; diff --git a/core/io/pathnames/pathnames.factor b/core/io/pathnames/pathnames.factor index 005d73a596..2d382e49d1 100644 --- a/core/io/pathnames/pathnames.factor +++ b/core/io/pathnames/pathnames.factor @@ -170,4 +170,3 @@ C: pathname M: pathname absolute-path string>> absolute-path ; M: pathname <=> [ string>> ] compare ; - diff --git a/core/layouts/layouts-tests.factor b/core/layouts/layouts-tests.factor index f38d0aaa1a..123d1347a7 100644 --- a/core/layouts/layouts-tests.factor +++ b/core/layouts/layouts-tests.factor @@ -1,11 +1,11 @@ -USING: layouts math tools.test ; -IN: system.tests - -[ t ] [ cell integer? ] unit-test -[ t ] [ bootstrap-cell integer? ] unit-test - -! Smoke test -[ t ] [ max-array-capacity cell-bits 2^ < ] unit-test - -[ t ] [ most-negative-fixnum fixnum? ] unit-test -[ t ] [ most-positive-fixnum fixnum? ] unit-test +USING: layouts math tools.test ; +IN: system.tests + +[ t ] [ cell integer? ] unit-test +[ t ] [ bootstrap-cell integer? ] unit-test + +! Smoke test +[ t ] [ max-array-capacity cell-bits 2^ < ] unit-test + +[ t ] [ most-negative-fixnum fixnum? ] unit-test +[ t ] [ most-positive-fixnum fixnum? ] unit-test diff --git a/core/parser/test/assert-depth.factor b/core/parser/test/assert-depth.factor index 3008dc05b6..b85905ec0b 100644 --- a/core/parser/test/assert-depth.factor +++ b/core/parser/test/assert-depth.factor @@ -1 +1 @@ -1 2 3 +1 2 3 diff --git a/extra/alien/data/map/map.factor b/extra/alien/data/map/map.factor index 43b4d258d2..7a7311b0e9 100644 --- a/extra/alien/data/map/map.factor +++ b/extra/alien/data/map/map.factor @@ -28,7 +28,7 @@ M: data-map-param nth-unsafe [ iter-length>> * >fixnum ] [ bytes>> ] [ count>> ] - [ c-type>> ] + [ c-type>> ] } cleave ; inline INSTANCE: data-map-param immutable-sequence @@ -55,7 +55,7 @@ INSTANCE: data-map-param immutable-sequence : [>param] ( type -- quot ) c-type-count over c-type-name? - [ [>c-type-param] ] [ [>object-param] ] if ; + [ [>c-type-param] ] [ [>object-param] ] if ; MACRO: >param ( in -- quot: ( array -- param ) ) [>param] ; @@ -75,7 +75,7 @@ MACRO: >param ( in -- quot: ( array -- param ) ) : [alloc-param] ( type -- quot ) c-type-count over c-type-name? - [ [alloc-c-type-param] ] [ [alloc-object-param] ] if ; + [ [alloc-c-type-param] ] [ [alloc-object-param] ] if ; MACRO: alloc-param ( out -- quot: ( len -- param ) ) [alloc-param] ; @@ -128,4 +128,3 @@ SYNTAX: data-map( SYNTAX: data-map!( parse-data-map-effect \ data-map! suffix! ; - diff --git a/extra/alien/fortran/fortran.factor b/extra/alien/fortran/fortran.factor index 0dc7b79fc2..6f9bae57ac 100755 --- a/extra/alien/fortran/fortran.factor +++ b/extra/alien/fortran/fortran.factor @@ -34,7 +34,7 @@ library-fortran-abis [ H{ } clone ] initialize : lowercase-name-with-underscore ( name -- name' ) >lower "_" append ; : lowercase-name-with-extra-underscore ( name -- name' ) - >lower CHAR: _ over member? + >lower CHAR: _ over member? [ "__" append ] [ "_" append ] if ; HOOK: fortran-c-abi fortran-abi ( -- abi ) @@ -305,7 +305,7 @@ M: misc-type (fortran-result>) GENERIC: () ( type -- quot ) -M: fortran-type () +M: fortran-type () (fortran-type>c-type) \ heap-size \ [ ] 3sequence ; M: character-type () @@ -321,14 +321,14 @@ M: character-type () : [fortran-args>c-args] ( parameters -- quot ) [ [ ] ] [ [ parse-fortran-type (fortran-arg>c-args) 2array ] map flip first2 - [ [ \ spread [ ] 2sequence ] bi@ 2array ] [ length ] bi + [ [ \ spread [ ] 2sequence ] bi@ 2array ] [ length ] bi \ ncleave [ ] 3sequence ] if-empty ; -:: [fortran-invoke] ( [args>args] return library function parameters -- [args>args] quot ) +:: [fortran-invoke] ( [args>args] return library function parameters -- [args>args] quot ) return parameters fortran-sig>c-sig :> ( c-return c-parameters ) function fortran-name>symbol-name :> c-function - [args>args] + [args>args] c-return library c-function c-parameters \ alien-invoke 5 [ ] nsequence c-parameters length \ nkeep @@ -396,7 +396,7 @@ PRIVATE> : fortran-ret-type>c-type ( fortran-type -- c-type added-args ) parse-fortran-type dup returns-by-value? [ (fortran-ret-type>c-type) { } ] [ - c:void swap + c:void swap [ added-c-args ] [ (fortran-type>c-type) ] bi prefix ] if ; @@ -440,7 +440,7 @@ MACRO: fortran-invoke ( return library function parameters -- ) return library function parameters return [ c:void ] unless* parse-arglist [ \ fortran-invoke 5 [ ] nsequence ] dip define-declared ; -SYNTAX: SUBROUTINE: +SYNTAX: SUBROUTINE: f current-library get scan-token ";" parse-tokens [ "()" subseq? ] reject define-fortran-function ; @@ -452,4 +452,3 @@ SYNTAX: LIBRARY: scan-token [ current-library set ] [ set-fortran-abi ] bi ; - diff --git a/extra/alien/handles/handles.factor b/extra/alien/handles/handles.factor index e1b5a716d2..0c47c8258a 100644 --- a/extra/alien/handles/handles.factor +++ b/extra/alien/handles/handles.factor @@ -46,4 +46,3 @@ DESTRUCTOR: release-alien-handle alien-address release-alien-handle ; inline DESTRUCTOR: release-alien-handle-ptr - diff --git a/extra/annotations/annotations.factor b/extra/annotations/annotations.factor index e463206e4f..9c69d1feb4 100644 --- a/extra/annotations/annotations.factor +++ b/extra/annotations/annotations.factor @@ -41,4 +41,3 @@ CONSTANT: annotation-tags { annotation-tags [ define-annotation ] each >> - diff --git a/extra/asn1/asn1.factor b/extra/asn1/asn1.factor index ae6611b2c1..ad86a8877d 100644 --- a/extra/asn1/asn1.factor +++ b/extra/asn1/asn1.factor @@ -33,7 +33,7 @@ PRIVATE> { "universal" H{ { "primitive" - H{ + H{ { 1 "boolean" } { 2 "integer" } { 4 "string" } @@ -90,7 +90,7 @@ ERROR: unsupported-tag-encoding id ; : set-content-length ( -- ) read1 - dup 127 <= [ + dup 127 <= [ 127 bitand read be> ] unless elements get contentlength<< ; @@ -103,7 +103,7 @@ ERROR: unsupported-tag-encoding id ; elements get tagclass>> of elements get encoding>> of elements get tag>> - of [ + of [ elements get objtype<< ] when* ] each ; diff --git a/extra/asn1/ldap/ldap.factor b/extra/asn1/ldap/ldap.factor index 449c9dcbd0..8115e10165 100644 --- a/extra/asn1/ldap/ldap.factor +++ b/extra/asn1/ldap/ldap.factor @@ -17,7 +17,7 @@ CONSTANT: SearchScope_WholeSubtree 2 } } { "constructed" - H{ + H{ { 0 "array" } ! BindRequest { 1 "array" } ! BindResponse { 2 "array" } ! UnbindRequest diff --git a/extra/audio/aiff/aiff.factor b/extra/audio/aiff/aiff.factor index 549134003b..62d31a4624 100644 --- a/extra/audio/aiff/aiff.factor +++ b/extra/audio/aiff/aiff.factor @@ -43,7 +43,7 @@ STRUCT: sound-data-chunk : verify-aiff ( chunk -- ) { [ FORM-MAGIC id= ] - [ form-chunk memory>struct form-type>> 4 memory>byte-array AIFF-MAGIC id= ] + [ form-chunk memory>struct form-type>> 4 memory>byte-array AIFF-MAGIC id= ] } 1&& [ invalid-audio-file ] unless ; diff --git a/extra/audio/audio.factor b/extra/audio/audio.factor index 1d4e17292d..dab3be1363 100644 --- a/extra/audio/audio.factor +++ b/extra/audio/audio.factor @@ -21,4 +21,3 @@ ERROR: format-unsupported-by-openal audio ; { { 2 16 } [ drop AL_FORMAT_STEREO16 ] } [ drop format-unsupported-by-openal ] } case ; - diff --git a/extra/audio/chunked-file/chunked-file.factor b/extra/audio/chunked-file/chunked-file.factor index f5844a60d0..271e56b171 100644 --- a/extra/audio/chunked-file/chunked-file.factor +++ b/extra/audio/chunked-file/chunked-file.factor @@ -25,4 +25,3 @@ ERROR: invalid-audio-file ; : check-chunk ( chunk id class -- ? ) heap-size [ id= ] [ [ length ] dip >= ] bi-curry* bi and ; inline - diff --git a/extra/audio/engine/engine.factor b/extra/audio/engine/engine.factor index 8fd28f3456..5da13cd33e 100644 --- a/extra/audio/engine/engine.factor +++ b/extra/audio/engine/engine.factor @@ -198,7 +198,7 @@ M:: streaming-audio-clip (update-audio-clip) ( audio-clip -- ) : update-audio-clip ( audio-clip -- ) [ update-source ] [ - dup al-source>> AL_SOURCE_STATE get-source-param AL_STOPPED = + dup al-source>> AL_SOURCE_STATE get-source-param AL_STOPPED = [ dispose ] [ (update-audio-clip) ] if ] bi ; @@ -319,7 +319,7 @@ M: streaming-audio-clip dispose* : play-static-audio-clip ( audio-engine source audio loop? -- audio-clip/f ) dup [ play-clip ] when* ; -: play-streaming-audio-clip ( audio-engine source generator buffer-count -- audio-clip/f ) +: play-streaming-audio-clip ( audio-engine source generator buffer-count -- audio-clip/f ) dup [ play-clip ] when* ; : pause-clip ( audio-clip -- ) @@ -341,4 +341,3 @@ M: streaming-audio-clip dispose* [ update-listener ] [ clips>> clone [ update-audio-clip ] each ] } cleave ; - diff --git a/extra/backtrack/backtrack.factor b/extra/backtrack/backtrack.factor index 2b4c771c93..a87a031e00 100644 --- a/extra/backtrack/backtrack.factor +++ b/extra/backtrack/backtrack.factor @@ -1,81 +1,81 @@ -! Copyright (C) 2008 William Schlieper -! See http://factorcode.org/license.txt for BSD license. - -USING: assocs combinators continuations fry kernel macros math -namespaces quotations sequences summary ; - -IN: backtrack - -SYMBOL: failure - -ERROR: amb-failure ; - -M: amb-failure summary drop "Backtracking failure" ; - -: fail ( -- ) - failure get [ continue ] [ amb-failure ] if* ; - -: must-be-true ( ? -- ) - [ fail ] unless ; - -MACRO: checkpoint ( quot -- quot' ) - '[ - failure get _ '[ - '[ failure set _ continue ] callcc0 - _ failure set @ - ] callcc0 - ] ; - -: number-from ( from -- from+n ) - [ 1 + number-from ] checkpoint ; - - - -: amb-lazy ( seq -- elt ) - [ amb-integer ] [ nth ] bi ; - -: amb ( seq -- elt ) - [ fail f ] [ unsafe-amb ] if-empty ; inline - -MACRO: amb-execute ( seq -- quot ) - [ length 1 - ] [ [ 1quotation ] assoc-map ] bi - '[ _ 0 unsafe-number-from-to nip _ case ] ; - -: if-amb ( true false -- ? ) - [ - [ { t f } amb ] - [ '[ @ must-be-true t ] ] - [ '[ @ f ] ] - tri* if - ] amb-preserve ; inline - -: cut-amb ( -- ) - f failure set ; - -: amb-all ( quot -- ) - [ { t f } amb [ call fail ] [ drop ] if ] amb-preserve ; inline - -: bag-of ( quot -- seq ) - V{ } clone [ '[ @ _ push ] amb-all ] keep ; inline +! Copyright (C) 2008 William Schlieper +! See http://factorcode.org/license.txt for BSD license. + +USING: assocs combinators continuations fry kernel macros math +namespaces quotations sequences summary ; + +IN: backtrack + +SYMBOL: failure + +ERROR: amb-failure ; + +M: amb-failure summary drop "Backtracking failure" ; + +: fail ( -- ) + failure get [ continue ] [ amb-failure ] if* ; + +: must-be-true ( ? -- ) + [ fail ] unless ; + +MACRO: checkpoint ( quot -- quot' ) + '[ + failure get _ '[ + '[ failure set _ continue ] callcc0 + _ failure set @ + ] callcc0 + ] ; + +: number-from ( from -- from+n ) + [ 1 + number-from ] checkpoint ; + + + +: amb-lazy ( seq -- elt ) + [ amb-integer ] [ nth ] bi ; + +: amb ( seq -- elt ) + [ fail f ] [ unsafe-amb ] if-empty ; inline + +MACRO: amb-execute ( seq -- quot ) + [ length 1 - ] [ [ 1quotation ] assoc-map ] bi + '[ _ 0 unsafe-number-from-to nip _ case ] ; + +: if-amb ( true false -- ? ) + [ + [ { t f } amb ] + [ '[ @ must-be-true t ] ] + [ '[ @ f ] ] + tri* if + ] amb-preserve ; inline + +: cut-amb ( -- ) + f failure set ; + +: amb-all ( quot -- ) + [ { t f } amb [ call fail ] [ drop ] if ] amb-preserve ; inline + +: bag-of ( quot -- seq ) + V{ } clone [ '[ @ _ push ] amb-all ] keep ; inline diff --git a/extra/balloon-bomber/balloon-bomber-docs.factor b/extra/balloon-bomber/balloon-bomber-docs.factor index e80ccb9b2f..7c956b0ed2 100644 --- a/extra/balloon-bomber/balloon-bomber-docs.factor +++ b/extra/balloon-bomber/balloon-bomber-docs.factor @@ -1,39 +1,39 @@ -! Copyright (C) 2007 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -USING: help.syntax help.markup cpu.8080.emulator ; -IN: balloon-bomber - -HELP: run-balloon -{ $description -"Run the Balloon Bomber emulator in a new window." $nl -{ $link rom-root } " must be set to the directory containing the " -"location of the Balloon Bomber ROM files. See " -{ $link { "balloon-bomber" "balloon-bomber" } } " for details." -} ; - -ARTICLE: { "balloon-bomber" "balloon-bomber" } "Balloon Bomber Emulator" -"Provides an emulation of the original 8080 Arcade Game 'Balloon Bomber'." $nl -"More information on the arcade game can be obtained from " { $url "http://www.mameworld.net/maws/romset/ballbomb" } "." $nl -"To play the game you need the ROM files for the arcade game. They should " -"be placed in a directory called 'ballbomb' in the location specified by " -"the variable " { $link rom-root } ". The specific files needed are:" -{ $list - "ballbomb/tn01" - "ballbomb/tn02" - "ballbomb/tn03" - "ballbomb/tn04" - "ballbomb/tn05-1" -} -"These are the same ROM files as used by MAME. To run the game use the " -{ $link run-balloon } " word." $nl -"Keys:" -{ $table - { "Backspace" "Insert Coin" } - { "1" "1 Player" } - { "2" "2 Player" } - { "Left" "Move Left" } - { "Right" "Move Right" } - { "Up" "Fire" } -} -"If you save the Factor image while a game is running, when you restart " -"the image the game continues where it left off." ; +! Copyright (C) 2007 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +USING: help.syntax help.markup cpu.8080.emulator ; +IN: balloon-bomber + +HELP: run-balloon +{ $description +"Run the Balloon Bomber emulator in a new window." $nl +{ $link rom-root } " must be set to the directory containing the " +"location of the Balloon Bomber ROM files. See " +{ $link { "balloon-bomber" "balloon-bomber" } } " for details." +} ; + +ARTICLE: { "balloon-bomber" "balloon-bomber" } "Balloon Bomber Emulator" +"Provides an emulation of the original 8080 Arcade Game 'Balloon Bomber'." $nl +"More information on the arcade game can be obtained from " { $url "http://www.mameworld.net/maws/romset/ballbomb" } "." $nl +"To play the game you need the ROM files for the arcade game. They should " +"be placed in a directory called 'ballbomb' in the location specified by " +"the variable " { $link rom-root } ". The specific files needed are:" +{ $list + "ballbomb/tn01" + "ballbomb/tn02" + "ballbomb/tn03" + "ballbomb/tn04" + "ballbomb/tn05-1" +} +"These are the same ROM files as used by MAME. To run the game use the " +{ $link run-balloon } " word." $nl +"Keys:" +{ $table + { "Backspace" "Insert Coin" } + { "1" "1 Player" } + { "2" "2 Player" } + { "Left" "Move Left" } + { "Right" "Move Right" } + { "Up" "Fire" } +} +"If you save the Factor image while a game is running, when you restart " +"the image the game continues where it left off." ; diff --git a/extra/balloon-bomber/balloon-bomber.factor b/extra/balloon-bomber/balloon-bomber.factor index 7cd77a0950..94a48695fc 100644 --- a/extra/balloon-bomber/balloon-bomber.factor +++ b/extra/balloon-bomber/balloon-bomber.factor @@ -1,27 +1,27 @@ -! Copyright (C) 2007 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -! -! Balloon Bomber: http://www.mameworld.net/maws/romset/ballbomb -! -USING: kernel space-invaders ui ; -IN: balloon-bomber - -TUPLE: balloon-bomber < space-invaders ; - -: ( -- cpu ) - balloon-bomber new cpu-init ; - -CONSTANT: rom-info { - { 0x0000 "ballbomb/tn01" } - { 0x0800 "ballbomb/tn02" } - { 0x1000 "ballbomb/tn03" } - { 0x1800 "ballbomb/tn04" } - { 0x4000 "ballbomb/tn05-1" } -} - -: run-balloon ( -- ) - [ - "Ballon Bomber" rom-info run-rom - ] with-ui ; - -MAIN: run-balloon +! Copyright (C) 2007 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +! +! Balloon Bomber: http://www.mameworld.net/maws/romset/ballbomb +! +USING: kernel space-invaders ui ; +IN: balloon-bomber + +TUPLE: balloon-bomber < space-invaders ; + +: ( -- cpu ) + balloon-bomber new cpu-init ; + +CONSTANT: rom-info { + { 0x0000 "ballbomb/tn01" } + { 0x0800 "ballbomb/tn02" } + { 0x1000 "ballbomb/tn03" } + { 0x1800 "ballbomb/tn04" } + { 0x4000 "ballbomb/tn05-1" } +} + +: run-balloon ( -- ) + [ + "Ballon Bomber" rom-info run-rom + ] with-ui ; + +MAIN: run-balloon diff --git a/extra/benchmark/dispatch5/dispatch5.factor b/extra/benchmark/dispatch5/dispatch5.factor index e5834970c7..291d61ecba 100644 --- a/extra/benchmark/dispatch5/dispatch5.factor +++ b/extra/benchmark/dispatch5/dispatch5.factor @@ -1,77 +1,77 @@ -USING: classes classes.tuple kernel sequences vocabs math ; -IN: benchmark.dispatch5 - -MIXIN: g - -TUPLE: x1 ; -INSTANCE: x1 g -TUPLE: x2 ; -INSTANCE: x2 g -TUPLE: x3 ; -INSTANCE: x3 g -TUPLE: x4 ; -INSTANCE: x4 g -TUPLE: x5 ; -INSTANCE: x5 g -TUPLE: x6 ; -INSTANCE: x6 g -TUPLE: x7 ; -INSTANCE: x7 g -TUPLE: x8 ; -INSTANCE: x8 g -TUPLE: x9 ; -INSTANCE: x9 g -TUPLE: x10 ; -INSTANCE: x10 g -TUPLE: x11 ; -INSTANCE: x11 g -TUPLE: x12 ; -INSTANCE: x12 g -TUPLE: x13 ; -INSTANCE: x13 g -TUPLE: x14 ; -INSTANCE: x14 g -TUPLE: x15 ; -INSTANCE: x15 g -TUPLE: x16 ; -INSTANCE: x16 g -TUPLE: x17 ; -INSTANCE: x17 g -TUPLE: x18 ; -INSTANCE: x18 g -TUPLE: x19 ; -INSTANCE: x19 g -TUPLE: x20 ; -INSTANCE: x20 g -TUPLE: x21 ; -INSTANCE: x21 g -TUPLE: x22 ; -INSTANCE: x22 g -TUPLE: x23 ; -INSTANCE: x23 g -TUPLE: x24 ; -INSTANCE: x24 g -TUPLE: x25 ; -INSTANCE: x25 g -TUPLE: x26 ; -INSTANCE: x26 g -TUPLE: x27 ; -INSTANCE: x27 g -TUPLE: x28 ; -INSTANCE: x28 g -TUPLE: x29 ; -INSTANCE: x29 g -TUPLE: x30 ; -INSTANCE: x30 g - -: my-classes ( -- seq ) - "benchmark.dispatch5" vocab-words [ tuple-class? ] filter ; - -: a-bunch-of-objects ( -- seq ) - my-classes [ new ] map ; - -: dispatch5-benchmark ( -- ) - 1000000 a-bunch-of-objects - [ f [ g? or ] reduce drop ] curry times ; - -MAIN: dispatch5-benchmark +USING: classes classes.tuple kernel sequences vocabs math ; +IN: benchmark.dispatch5 + +MIXIN: g + +TUPLE: x1 ; +INSTANCE: x1 g +TUPLE: x2 ; +INSTANCE: x2 g +TUPLE: x3 ; +INSTANCE: x3 g +TUPLE: x4 ; +INSTANCE: x4 g +TUPLE: x5 ; +INSTANCE: x5 g +TUPLE: x6 ; +INSTANCE: x6 g +TUPLE: x7 ; +INSTANCE: x7 g +TUPLE: x8 ; +INSTANCE: x8 g +TUPLE: x9 ; +INSTANCE: x9 g +TUPLE: x10 ; +INSTANCE: x10 g +TUPLE: x11 ; +INSTANCE: x11 g +TUPLE: x12 ; +INSTANCE: x12 g +TUPLE: x13 ; +INSTANCE: x13 g +TUPLE: x14 ; +INSTANCE: x14 g +TUPLE: x15 ; +INSTANCE: x15 g +TUPLE: x16 ; +INSTANCE: x16 g +TUPLE: x17 ; +INSTANCE: x17 g +TUPLE: x18 ; +INSTANCE: x18 g +TUPLE: x19 ; +INSTANCE: x19 g +TUPLE: x20 ; +INSTANCE: x20 g +TUPLE: x21 ; +INSTANCE: x21 g +TUPLE: x22 ; +INSTANCE: x22 g +TUPLE: x23 ; +INSTANCE: x23 g +TUPLE: x24 ; +INSTANCE: x24 g +TUPLE: x25 ; +INSTANCE: x25 g +TUPLE: x26 ; +INSTANCE: x26 g +TUPLE: x27 ; +INSTANCE: x27 g +TUPLE: x28 ; +INSTANCE: x28 g +TUPLE: x29 ; +INSTANCE: x29 g +TUPLE: x30 ; +INSTANCE: x30 g + +: my-classes ( -- seq ) + "benchmark.dispatch5" vocab-words [ tuple-class? ] filter ; + +: a-bunch-of-objects ( -- seq ) + my-classes [ new ] map ; + +: dispatch5-benchmark ( -- ) + 1000000 a-bunch-of-objects + [ f [ g? or ] reduce drop ] curry times ; + +MAIN: dispatch5-benchmark diff --git a/extra/benchmark/fib6/fib6.factor b/extra/benchmark/fib6/fib6.factor index 5d6ec15649..7af5ce31d1 100644 --- a/extra/benchmark/fib6/fib6.factor +++ b/extra/benchmark/fib6/fib6.factor @@ -1,14 +1,14 @@ -USING: math kernel alien alien.c-types ; -IN: benchmark.fib6 - -: fib ( x -- y ) - int { int } cdecl [ - dup 1 <= [ drop 1 ] [ - 1 - dup fib swap 1 - fib + - ] if - ] alien-callback - int { int } cdecl alien-indirect ; - -: fib6-benchmark ( -- ) 32 fib drop ; - -MAIN: fib6-benchmark +USING: math kernel alien alien.c-types ; +IN: benchmark.fib6 + +: fib ( x -- y ) + int { int } cdecl [ + dup 1 <= [ drop 1 ] [ + 1 - dup fib swap 1 - fib + + ] if + ] alien-callback + int { int } cdecl alien-indirect ; + +: fib6-benchmark ( -- ) 32 fib drop ; + +MAIN: fib6-benchmark diff --git a/extra/benchmark/mandel/params/params.factor b/extra/benchmark/mandel/params/params.factor index 8a19180d73..f357e344ed 100644 --- a/extra/benchmark/mandel/params/params.factor +++ b/extra/benchmark/mandel/params/params.factor @@ -1,8 +1,8 @@ IN: benchmark.mandel.params -CONSTANT: max-color 360 -CONSTANT: zoom-fact 0.8 -CONSTANT: width 640 -CONSTANT: height 480 -CONSTANT: max-iterations 40 -CONSTANT: center -0.65 +CONSTANT: max-color 360 +CONSTANT: zoom-fact 0.8 +CONSTANT: width 640 +CONSTANT: height 480 +CONSTANT: max-iterations 40 +CONSTANT: center -0.65 diff --git a/extra/benchmark/nbody-simd/nbody-simd.factor b/extra/benchmark/nbody-simd/nbody-simd.factor index 83c3fe9149..6e8a0bb3da 100644 --- a/extra/benchmark/nbody-simd/nbody-simd.factor +++ b/extra/benchmark/nbody-simd/nbody-simd.factor @@ -45,7 +45,7 @@ SPECIALIZED-ARRAY: body : ( -- body ) double-4{ 0 0 0 0 } double-4{ 0 0 0 0 } 1 ; - + : offset-momentum ( body offset -- body ) vneg solar-mass v/n >>velocity ; inline diff --git a/extra/benchmark/nbody/nbody.factor b/extra/benchmark/nbody/nbody.factor index a65afdef19..d816435245 100644 --- a/extra/benchmark/nbody/nbody.factor +++ b/extra/benchmark/nbody/nbody.factor @@ -44,7 +44,7 @@ TUPLE: body : ( -- body ) double-array{ 0 0 0 } double-array{ 0 0 0 } 1 ; - + : offset-momentum ( body offset -- body ) vneg solar-mass v/n >>velocity ; inline diff --git a/extra/benchmark/nsieve-bits/nsieve-bits.factor b/extra/benchmark/nsieve-bits/nsieve-bits.factor index 675718c8d8..dbceaf3ecd 100644 --- a/extra/benchmark/nsieve-bits/nsieve-bits.factor +++ b/extra/benchmark/nsieve-bits/nsieve-bits.factor @@ -27,7 +27,7 @@ IN: benchmark.nsieve-bits print ; inline : nsieve-bits-main ( n -- ) - [ 2^ 10000 * nsieve-bits. ] + [ 2^ 10000 * nsieve-bits. ] [ 1 - 2^ 10000 * nsieve-bits. ] [ 2 - 2^ 10000 * nsieve-bits. ] tri ; diff --git a/extra/benchmark/reverse-complement/reverse-complement-tests.factor b/extra/benchmark/reverse-complement/reverse-complement-tests.factor index ed803c11e1..3eade1370e 100644 --- a/extra/benchmark/reverse-complement/reverse-complement-tests.factor +++ b/extra/benchmark/reverse-complement/reverse-complement-tests.factor @@ -1,9 +1,9 @@ -IN: benchmark.reverse-complement.tests -USING: benchmark.reverse-complement checksums checksums.md5 io.files -io.files.temp kernel tools.test ; - -[ "c071aa7e007a9770b2fb4304f55a17e5" ] [ - "resource:extra/benchmark/reverse-complement/reverse-complement-test-in.txt" - "reverse-complement-test-out.txt" temp-file - [ reverse-complement ] keep md5 checksum-file hex-string -] unit-test +IN: benchmark.reverse-complement.tests +USING: benchmark.reverse-complement checksums checksums.md5 io.files +io.files.temp kernel tools.test ; + +[ "c071aa7e007a9770b2fb4304f55a17e5" ] [ + "resource:extra/benchmark/reverse-complement/reverse-complement-test-in.txt" + "reverse-complement-test-out.txt" temp-file + [ reverse-complement ] keep md5 checksum-file hex-string +] unit-test diff --git a/extra/benchmark/ring/ring.factor b/extra/benchmark/ring/ring.factor index 18583e861e..509538a175 100644 --- a/extra/benchmark/ring/ring.factor +++ b/extra/benchmark/ring/ring.factor @@ -13,13 +13,13 @@ SYMBOL: done ] times ; : send-messages ( messages target -- ) - [ dup iota ] dip [ send ] curry each [ receive drop ] times ; + [ dup iota ] dip [ send ] curry each [ receive drop ] times ; : destroy-ring ( target -- ) done swap send [ done eq? ] receive-if drop ; : ring-bench ( messages processes -- ) - create-ring [ send-messages ] keep destroy-ring ; + create-ring [ send-messages ] keep destroy-ring ; : ring-benchmark ( -- ) 1000 1000 ring-bench ; diff --git a/extra/benchmark/spectral-norm-simd/spectral-norm-simd.factor b/extra/benchmark/spectral-norm-simd/spectral-norm-simd.factor index f64f98e99d..c0c4af8526 100644 --- a/extra/benchmark/spectral-norm-simd/spectral-norm-simd.factor +++ b/extra/benchmark/spectral-norm-simd/spectral-norm-simd.factor @@ -31,7 +31,7 @@ IN: benchmark.spectral-norm-simd : eval-A-times-u ( n u -- seq ) [ (eval-A-times-u) ] inner-loop ; inline - + :: eval4-A' ( i j -- n ) j i 4 * 0 + eval-A j i 4 * 1 + eval-A diff --git a/extra/benchmark/timers/timers.factor b/extra/benchmark/timers/timers.factor index e81e536705..500e0375a8 100644 --- a/extra/benchmark/timers/timers.factor +++ b/extra/benchmark/timers/timers.factor @@ -22,4 +22,3 @@ SYMBOL: loop-max 20,000 [ outer-loop ] [ loop-max get-global assert= ] bi ; MAIN: timers-benchmark - diff --git a/extra/bitcoin/client/client.factor b/extra/bitcoin/client/client.factor index 88926b0912..d2221a77c3 100644 --- a/extra/bitcoin/client/client.factor +++ b/extra/bitcoin/client/client.factor @@ -48,7 +48,7 @@ IN: bitcoin.client bitcoin-server >>host bitcoin-port >>port ; -:: payload ( method params -- data ) +:: payload ( method params -- data ) "text/plain" binary >>content-encoding H{ @@ -58,10 +58,10 @@ IN: bitcoin.client : basic-auth ( -- string ) bitcoin-user bitcoin-password ":" glue >base64 >string - "Basic " prepend ; + "Basic " prepend ; : bitcoin-request ( method params -- request ) - payload bitcoin-url + payload bitcoin-url basic-auth "Authorization" set-header dup post-data>> data>> length "Content-Length" set-header http-request nip >string json> "result" of ; @@ -137,4 +137,3 @@ PRIVATE> #! requires patched bitcoind :: list-transactions ( count include-generated -- seq ) "listtransactions" { count include-generated } bitcoin-request ; - diff --git a/extra/boids/boids.factor b/extra/boids/boids.factor index 69605f8b4b..d4314ade37 100644 --- a/extra/boids/boids.factor +++ b/extra/boids/boids.factor @@ -144,7 +144,7 @@ M: range-observer model-changed { 2 2 } >>gap 1.0 >>fill boids-gadget simulation-panel - add-gadget + add-gadget boids-gadget behaviours>> [ behavior-panel add-gadget ] each @@ -155,4 +155,3 @@ M: range-observer model-changed MAIN-WINDOW: boids { { title "Boids" } } create-gadgets >>gadgets ; - diff --git a/extra/bson/constants/constants.factor b/extra/bson/constants/constants.factor index 9684a4d1f8..2282aabff1 100644 --- a/extra/bson/constants/constants.factor +++ b/extra/bson/constants/constants.factor @@ -85,4 +85,3 @@ CONSTANT: T_Binary_Bytes_Deprecated 0x2 CONSTANT: T_Binary_UUID 0x3 CONSTANT: T_Binary_MD5 0x5 CONSTANT: T_Binary_Custom 0x80 - diff --git a/extra/bson/reader/reader.factor b/extra/bson/reader/reader.factor index 30f9fda15e..9fc3824847 100644 --- a/extra/bson/reader/reader.factor +++ b/extra/bson/reader/reader.factor @@ -56,7 +56,7 @@ DEFER: read-elements read-int32 [ f ] [ drop read-elements t ] if-zero ; inline recursive : bson-binary-read ( -- binary ) - read-int32 read-byte + read-int32 read-byte { { T_Binary_Default [ read ] } { T_Binary_Bytes_Deprecated [ drop read-int32 read ] } @@ -101,7 +101,7 @@ TYPED: (read-object) ( type: integer name: string -- ) [ element-data-read ] dip state get set-at ; inline recursive TYPED: (element-read) ( type: integer -- cont?: boolean ) - dup T_EOO > + dup T_EOO > [ read-cstring (read-object) t ] [ drop f ] if ; inline recursive diff --git a/extra/bson/writer/writer.factor b/extra/bson/writer/writer.factor index a4fe92ee3f..c9c4f26b0d 100644 --- a/extra/bson/writer/writer.factor +++ b/extra/bson/writer/writer.factor @@ -80,7 +80,7 @@ TYPED: write-oid ( oid: oid -- ) : write-oid-field ( assoc -- ) [ MDB_OID_FIELD dup ] dip at - [ dup oid? [ T_OID write-header write-oid ] [ write-pair ] if ] + [ dup oid? [ T_OID write-header write-oid ] [ write-pair ] if ] [ drop ] if* ; inline : skip-field? ( name value -- name value boolean ) @@ -90,7 +90,7 @@ UNION: hashtables hashtable linked-assoc ; TYPED: write-assoc ( assoc: hashtables -- ) '[ _ [ write-oid-field ] [ - [ skip-field? [ 2drop ] [ write-pair ] if ] assoc-each + [ skip-field? [ 2drop ] [ write-pair ] if ] assoc-each ] bi write-eoo ] with-length-prefix ; inline recursive @@ -102,7 +102,7 @@ TYPED: (serialize-code) ( code: code -- ) [ T_Binary_Custom write1 write ] bi ; inline : write-string-length ( string -- ) - [ length>> 1 + ] + [ length>> 1 + ] [ aux>> [ length ] [ 0 ] if* ] bi + write-int32 ; inline TYPED: write-string ( string: string -- ) @@ -132,7 +132,7 @@ TYPED: write-pair ( name: string obj -- ) [ dup integer? ] [ T_Integer write-header write-int32 ] } { - [ dup boolean? ] + [ dup boolean? ] [ T_Boolean write-header write-boolean ] } { [ dup real? ] diff --git a/extra/bunny/cel-shaded/cel-shaded.factor b/extra/bunny/cel-shaded/cel-shaded.factor index b1e24243f0..c55ace6ba9 100644 --- a/extra/bunny/cel-shaded/cel-shaded.factor +++ b/extra/bunny/cel-shaded/cel-shaded.factor @@ -93,4 +93,3 @@ M: bunny-cel-shaded draw-bunny M: bunny-cel-shaded dispose program>> delete-gl-program ; - diff --git a/extra/bunny/fixed-pipeline/fixed-pipeline.factor b/extra/bunny/fixed-pipeline/fixed-pipeline.factor index 07528c35e8..b5b42c06f2 100644 --- a/extra/bunny/fixed-pipeline/fixed-pipeline.factor +++ b/extra/bunny/fixed-pipeline/fixed-pipeline.factor @@ -23,4 +23,3 @@ M: bunny-fixed-pipeline draw-bunny M: bunny-fixed-pipeline dispose drop ; - diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor index 858689738f..4f280b56b8 100644 --- a/extra/bunny/outlined/outlined.factor +++ b/extra/bunny/outlined/outlined.factor @@ -69,7 +69,7 @@ border_factor(vec2 c) coord2 = c + vec2( SAMPLE_SPREAD, -SAMPLE_SPREAD), coord3 = c + vec2(-SAMPLE_SPREAD, SAMPLE_SPREAD), coord4 = c + vec2( SAMPLE_SPREAD, SAMPLE_SPREAD); - + vec3 normal1 = normal_sample(coord1), normal2 = normal_sample(coord2), normal3 = normal_sample(coord3), @@ -85,9 +85,9 @@ border_factor(vec2 c) depth_sample(coord2), depth_sample(coord3), depth_sample(coord4)); - + vec3 ratios1 = depths.xxx/depths.yzw, ratios2 = depths.yyz/depths.zww; - + if (are_depths_border(ratios1) || are_depths_border(ratios2)) { return 1.0; } else { @@ -99,7 +99,7 @@ border_factor(vec2 c) dot(normal2, normal4), dot(normal3, normal4) ); - + return normal_border; } } diff --git a/extra/c/preprocessor/preprocessor.factor b/extra/c/preprocessor/preprocessor.factor index d69583e124..55e11edde5 100644 --- a/extra/c/preprocessor/preprocessor.factor +++ b/extra/c/preprocessor/preprocessor.factor @@ -111,7 +111,7 @@ ERROR: header-file-missing path ; [ [ 1 + ] change-ifdef-nesting ] dip take-token over symbol-table>> key? [ t >>processing-disabled? drop ] - [ drop ] if ; + [ drop ] if ; : handle-endif ( preprocessor-state sequence-parser -- ) drop [ 1 - ] change-ifdef-nesting drop ; @@ -176,7 +176,7 @@ ERROR: header-file-missing path ; [ swap processing-disabled?>> [ drop ] [ write-full nl ] if ] if ; : preprocess-lines ( preprocessor-state -- ) - readln + readln [ [ preprocess-line ] [ drop preprocess-lines ] 2bi ] [ drop ] if* ; diff --git a/extra/calendar/holidays/holidays.factor b/extra/calendar/holidays/holidays.factor index d8f5e0e9cc..273e2609a2 100644 --- a/extra/calendar/holidays/holidays.factor +++ b/extra/calendar/holidays/holidays.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs calendar fry kernel locals parser +USING: accessors assocs calendar fry kernel locals parser sequences vocabs words memoize ; IN: calendar.holidays diff --git a/extra/calendar/holidays/us/us.factor b/extra/calendar/holidays/us/us.factor index bf52f0ca39..5315cae675 100644 --- a/extra/calendar/holidays/us/us.factor +++ b/extra/calendar/holidays/us/us.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs calendar calendar.holidays calendar.holidays.private combinators combinators.short-circuit -fry kernel lexer math namespaces parser sequences +fry kernel lexer math namespaces parser sequences vocabs words ; IN: calendar.holidays.us diff --git a/extra/cap/cap.factor b/extra/cap/cap.factor index f558342bb1..564d0b9711 100644 --- a/extra/cap/cap.factor +++ b/extra/cap/cap.factor @@ -33,4 +33,4 @@ IN: cap normalize-image ; : screenshot. ( window -- ) - [ screenshot ] [ title>> ] bi open-window ; + [ screenshot ] [ title>> ] bi open-window ; diff --git a/extra/cgi/cgi.factor b/extra/cgi/cgi.factor index 9030c00e99..10ec32720d 100644 --- a/extra/cgi/cgi.factor +++ b/extra/cgi/cgi.factor @@ -49,5 +49,3 @@ PRIVATE> : ( -- assoc ) [ first ] assoc-map ; - - diff --git a/extra/chicago-talk/chicago-talk.factor b/extra/chicago-talk/chicago-talk.factor index 9d42ff13f2..9f84c023ce 100644 --- a/extra/chicago-talk/chicago-talk.factor +++ b/extra/chicago-talk/chicago-talk.factor @@ -62,4 +62,4 @@ CONSTANT: chicago-slides : chicago-talk ( -- ) chicago-slides slides-window ; -MAIN: chicago-talk \ No newline at end of file +MAIN: chicago-talk diff --git a/extra/chipmunk/demo/demo.factor b/extra/chipmunk/demo/demo.factor index 1f9b709c82..7f5222342a 100644 --- a/extra/chipmunk/demo/demo.factor +++ b/extra/chipmunk/demo/demo.factor @@ -118,7 +118,7 @@ M:: chipmunk-world begin-game-world ( world -- ) ] when ] each ] each - + space cpBodyAlloc NAN: 0 dup cpBodyInit cpSpaceAddBody :> body body -1000 -10 cpv >>p drop body 400 0 cpv >>v drop diff --git a/extra/chipmunk/ffi/ffi.factor b/extra/chipmunk/ffi/ffi.factor index 788da22a42..1622fd6345 100644 --- a/extra/chipmunk/ffi/ffi.factor +++ b/extra/chipmunk/ffi/ffi.factor @@ -845,4 +845,3 @@ FUNCTION: void cpInitChipmunk ( ) ; FUNCTION: cpFloat cpMomentForCircle ( cpFloat m, cpFloat r1, cpFloat r2, cpVect offset ) ; FUNCTION: cpFloat cpMomentForSegment ( cpFloat m, cpVect a, cpVect b ) ; FUNCTION: cpFloat cpMomentForPoly ( cpFloat m, int numVerts, cpVect* verts, cpVect offset ) ; - diff --git a/extra/classes/tuple/change-tracking/change-tracking.factor b/extra/classes/tuple/change-tracking/change-tracking.factor index 0d5e41076d..a9a91f4a30 100644 --- a/extra/classes/tuple/change-tracking/change-tracking.factor +++ b/extra/classes/tuple/change-tracking/change-tracking.factor @@ -20,4 +20,3 @@ M: change-tracking-tuple-class writer-quot ( class slot-spec -- quot ) [ name>> "changed?" = [ '[ _ [ t >>changed? drop ] bi ] ] unless ] bi ; PRIVATE> - diff --git a/extra/clutter/cally/cally.factor b/extra/clutter/cally/cally.factor index b4b91829d6..8db7033a8a 100644 --- a/extra/clutter/cally/cally.factor +++ b/extra/clutter/cally/cally.factor @@ -2,4 +2,3 @@ ! See http://factorcode.org/license.txt for BSD license. USING: clutter.cally.ffi ; IN: clutter.cally - diff --git a/extra/clutter/cally/ffi/ffi.factor b/extra/clutter/cally/ffi/ffi.factor index 6b75f4d7c9..8cd4b36e9b 100644 --- a/extra/clutter/cally/ffi/ffi.factor +++ b/extra/clutter/cally/ffi/ffi.factor @@ -20,4 +20,3 @@ LIBRARY: clutter.cally >> GIR: Cally-1.0.gir - diff --git a/extra/clutter/clutter.factor b/extra/clutter/clutter.factor index a69a8574b6..2507497016 100644 --- a/extra/clutter/clutter.factor +++ b/extra/clutter/clutter.factor @@ -2,4 +2,3 @@ ! See http://factorcode.org/license.txt for BSD license. USING: clutter.ffi ; IN: clutter - diff --git a/extra/clutter/cogl/cogl.factor b/extra/clutter/cogl/cogl.factor index 6b54a07aef..6d0d8e46df 100644 --- a/extra/clutter/cogl/cogl.factor +++ b/extra/clutter/cogl/cogl.factor @@ -2,4 +2,3 @@ ! See http://factorcode.org/license.txt for BSD license. USING: clutter.cogl.ffi ; IN: clutter.cogl - diff --git a/extra/clutter/cogl/ffi/ffi.factor b/extra/clutter/cogl/ffi/ffi.factor index eebd4ed7bb..23fcc12977 100644 --- a/extra/clutter/cogl/ffi/ffi.factor +++ b/extra/clutter/cogl/ffi/ffi.factor @@ -22,4 +22,3 @@ FOREIGN-ATOMIC-TYPE: GL.uint GLuint FOREIGN-ATOMIC-TYPE: GL.enum GLenum GIR: Cogl-1.0.gir - diff --git a/extra/clutter/ffi/ffi.factor b/extra/clutter/ffi/ffi.factor index 300d1d85dc..c099fdd03b 100644 --- a/extra/clutter/ffi/ffi.factor +++ b/extra/clutter/ffi/ffi.factor @@ -25,4 +25,3 @@ LIBRARY: clutter FOREIGN-RECORD-TYPE: cairo.Path cairo_path_t GIR: Clutter-1.0.gir - diff --git a/extra/clutter/gtk/ffi/ffi.factor b/extra/clutter/gtk/ffi/ffi.factor index 5dc53b7348..ae60b18f64 100644 --- a/extra/clutter/gtk/ffi/ffi.factor +++ b/extra/clutter/gtk/ffi/ffi.factor @@ -20,4 +20,3 @@ LIBRARY: clutter.gtk >> GIR: GtkClutter-1.0.gir - diff --git a/extra/clutter/gtk/gtk.factor b/extra/clutter/gtk/gtk.factor index 6c495f5460..86c588e4af 100644 --- a/extra/clutter/gtk/gtk.factor +++ b/extra/clutter/gtk/gtk.factor @@ -2,4 +2,3 @@ ! See http://factorcode.org/license.txt for BSD license. USING: clutter.gtk.ffi ; IN: clutter.gtk - diff --git a/extra/clutter/json/ffi/ffi.factor b/extra/clutter/json/ffi/ffi.factor index 23eb8323e5..1e7301e4f9 100644 --- a/extra/clutter/json/ffi/ffi.factor +++ b/extra/clutter/json/ffi/ffi.factor @@ -20,4 +20,3 @@ LIBRARY: clutter.json >> GIR: Json-1.0.gir - diff --git a/extra/clutter/json/json.factor b/extra/clutter/json/json.factor index 95304836c7..d52e6ef04f 100644 --- a/extra/clutter/json/json.factor +++ b/extra/clutter/json/json.factor @@ -2,4 +2,3 @@ ! See http://factorcode.org/license.txt for BSD license. USING: clutter.json.ffi ; IN: clutter.json - diff --git a/extra/codebook/codebook.factor b/extra/codebook/codebook.factor index 5056e8453e..af05ff2894 100644 --- a/extra/codebook/codebook.factor +++ b/extra/codebook/codebook.factor @@ -44,7 +44,7 @@ TUPLE: code-file : include-file-name? ( name -- ? ) { - [ path-components [ "." head? ] any? not ] + [ path-components [ "." head? ] any? not ] [ link-info type>> +regular-file+ = ] } 1&& ; @@ -140,7 +140,7 @@ TUPLE: code-file file name>> :> name name file-html-name :> filename i 2 + number>string :> istr - + [XML playOrder=<-istr->> <-name-> /> @@ -157,7 +157,7 @@ TUPLE: code-file <-file-nav-points-> XML> ; - + :: code>opf ( dir name files -- xml ) "Generating OPF manifest" print flush name ".ncx" append :> ncx-name diff --git a/extra/combinators/tuple/tuple.factor b/extra/combinators/tuple/tuple.factor index c4e0ef40a1..8a8dd9eda5 100644 --- a/extra/combinators/tuple/tuple.factor +++ b/extra/combinators/tuple/tuple.factor @@ -17,7 +17,7 @@ MACRO:: nmake-tuple ( class assoc n -- ) class all-slots [ assoc n (tuple-slot-quot) ] map :> quots class :> \class { quots n ncleave \class boa } >quotation ; - + : make-tuple ( x class assoc -- tuple ) 1 nmake-tuple ; inline @@ -26,4 +26,3 @@ MACRO:: nmake-tuple ( class assoc n -- ) : 3make-tuple ( x y z class assoc -- tuple ) 3 nmake-tuple ; inline - diff --git a/extra/compiler/cfg/gvn/expressions/expressions.factor b/extra/compiler/cfg/gvn/expressions/expressions.factor index a56eb64425..e5efdfce83 100644 --- a/extra/compiler/cfg/gvn/expressions/expressions.factor +++ b/extra/compiler/cfg/gvn/expressions/expressions.factor @@ -29,7 +29,7 @@ GENERIC: >expr ( insn -- expr ) : narray-quot ( length -- quot ) [ [ , [ f ] % ] - [ + [ dup iota [ - 1 - , [ swap [ set-array-nth ] keep ] % ] with each diff --git a/extra/compiler/cfg/gvn/simd/simd.factor b/extra/compiler/cfg/gvn/simd/simd.factor index 17fa4f355a..5ca35162e7 100644 --- a/extra/compiler/cfg/gvn/simd/simd.factor +++ b/extra/compiler/cfg/gvn/simd/simd.factor @@ -132,7 +132,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? ] [ { diff --git a/extra/constructors/constructors.factor b/extra/constructors/constructors.factor index c1a5ef55d0..b3d671f368 100644 --- a/extra/constructors/constructors.factor +++ b/extra/constructors/constructors.factor @@ -17,7 +17,7 @@ MACRO:: slots>boa ( slots class -- quot ) slots length default-params length '[ - _ narray slot-assoc swap zip + _ narray slot-assoc swap zip default-params swap assoc-union values _ firstn class boa ] ; @@ -62,4 +62,3 @@ SYNTAX: CONSTRUCTOR: SYNTAX: SLOT-CONSTRUCTOR: scan-new-word [ name>> "(" append create-reset ] keep '[ scan-rest-input-effect in>> _ '[ _ _ slots>boa ] append! ] define-syntax ; - diff --git a/extra/coroutines/coroutines.factor b/extra/coroutines/coroutines.factor index ea57460f2f..3038fea869 100644 --- a/extra/coroutines/coroutines.factor +++ b/extra/coroutines/coroutines.factor @@ -12,7 +12,7 @@ TUPLE: coroutine resumecc exitcc originalcc ; coroutine new dup current-coro associate [ - swapd , , \ with-variables , + swapd , , \ with-variables , "Coroutine has terminated illegally." , \ throw , ] [ ] make [ >>resumecc ] [ >>originalcc ] bi ; diff --git a/extra/couchdb/couchdb.factor b/extra/couchdb/couchdb.factor index ca1f8306c2..df59232ea7 100644 --- a/extra/couchdb/couchdb.factor +++ b/extra/couchdb/couchdb.factor @@ -129,7 +129,7 @@ C: db >json utf8 encode "application/json" swap >>data ; ! documents -: id> ( assoc -- id ) "_id" of ; +: id> ( assoc -- id ) "_id" of ; : >id ( assoc id -- assoc ) "_id" pick set-at ; : rev> ( assoc -- rev ) "_rev" of ; : >rev ( assoc rev -- assoc ) "_rev" pick set-at ; @@ -166,7 +166,7 @@ C: db couch get server>> next-uuid save-doc-as ; : save-doc ( assoc -- ) - dup id> [ save-doc-as ] [ save-new-doc ] if* ; + dup id> [ save-doc-as ] [ save-new-doc ] if* ; : load-doc ( id -- assoc ) id-url couch-get ; @@ -185,10 +185,10 @@ C: db ! : construct-attachment ( content-type data -- assoc ) ! H{ } clone "name" pick set-at "content-type" pick set-at ; -! +! ! : add-attachment ( assoc name attachment -- ) ! pick attachments> [ H{ } clone ] unless* -! +! ! : attach ( assoc name content-type data -- ) ! construct-attachment H{ } clone diff --git a/extra/cpu/8080/8080-docs.factor b/extra/cpu/8080/8080-docs.factor index 48b68360cb..d1f90b6400 100644 --- a/extra/cpu/8080/8080-docs.factor +++ b/extra/cpu/8080/8080-docs.factor @@ -1,16 +1,16 @@ -! Copyright (C) 2007 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax sequences strings cpu.8080.emulator ; -IN: cpu.8080 - - -ARTICLE: { "cpu-8080" "cpu-8080" } "Intel 8080 CPU Emulator" -"The cpu-8080 library provides an emulator for the Intel 8080 CPU" -" instruction set. It is complete enough to emulate some 8080" -" based arcade games." $nl -"The emulated CPU can load 'ROM' files from disk using the " -{ $link load-rom } " and " { $link load-rom* } " words. These expect " -"the " { $link rom-root } " variable to be set to the path " -"containing the ROM file's." ; - -ABOUT: { "cpu-8080" "cpu-8080" } +! Copyright (C) 2007 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax sequences strings cpu.8080.emulator ; +IN: cpu.8080 + + +ARTICLE: { "cpu-8080" "cpu-8080" } "Intel 8080 CPU Emulator" +"The cpu-8080 library provides an emulator for the Intel 8080 CPU" +" instruction set. It is complete enough to emulate some 8080" +" based arcade games." $nl +"The emulated CPU can load 'ROM' files from disk using the " +{ $link load-rom } " and " { $link load-rom* } " words. These expect " +"the " { $link rom-root } " variable to be set to the path " +"containing the ROM file's." ; + +ABOUT: { "cpu-8080" "cpu-8080" } diff --git a/extra/cpu/8080/emulator/emulator-docs.factor b/extra/cpu/8080/emulator/emulator-docs.factor index 3f7ddbc595..da2e1f318b 100644 --- a/extra/cpu/8080/emulator/emulator-docs.factor +++ b/extra/cpu/8080/emulator/emulator-docs.factor @@ -1,36 +1,36 @@ -! Copyright (C) 2007 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax sequences strings ; -IN: cpu.8080.emulator - -HELP: load-rom -{ $values { "filename" string } { "cpu" cpu } } -{ $description -"Read the ROM file into the cpu's memory starting at address 0000. " -"The filename is relative to the path stored in the " { $link rom-root } -" variable. An exception is thrown if this variable is not set." -} -{ $see-also load-rom* } ; - -HELP: load-rom* -{ $values { "seq" sequence } { "cpu" cpu } } -{ $description -"Loads one or more ROM files into the cpu's memory. Each file is " -"loaded at a particular starting address. 'seq' is a sequence of " -"2 element arrays. The first element is the address and the second " -"element is the file to load at that address." $nl -"The filenames are relative to the path stored in the " { $link rom-root } -" variable. An exception is thrown if this variable is not set." -} -{ $examples - { $code "{ { 0x0000 \"invaders.rom\" } } load-rom*" } -} -{ $see-also load-rom } ; - -HELP: rom-root -{ $description -"Holds the path where the ROM files are stored. Used for expanding " -"the relative filenames passed to " { $link load-rom } " and " -{ $link load-rom* } "." -} -{ $see-also load-rom load-rom* } ; +! Copyright (C) 2007 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax sequences strings ; +IN: cpu.8080.emulator + +HELP: load-rom +{ $values { "filename" string } { "cpu" cpu } } +{ $description +"Read the ROM file into the cpu's memory starting at address 0000. " +"The filename is relative to the path stored in the " { $link rom-root } +" variable. An exception is thrown if this variable is not set." +} +{ $see-also load-rom* } ; + +HELP: load-rom* +{ $values { "seq" sequence } { "cpu" cpu } } +{ $description +"Loads one or more ROM files into the cpu's memory. Each file is " +"loaded at a particular starting address. 'seq' is a sequence of " +"2 element arrays. The first element is the address and the second " +"element is the file to load at that address." $nl +"The filenames are relative to the path stored in the " { $link rom-root } +" variable. An exception is thrown if this variable is not set." +} +{ $examples + { $code "{ { 0x0000 \"invaders.rom\" } } load-rom*" } +} +{ $see-also load-rom } ; + +HELP: rom-root +{ $description +"Holds the path where the ROM files are stored. Used for expanding " +"the relative filenames passed to " { $link load-rom } " and " +{ $link load-rom* } "." +} +{ $see-also load-rom load-rom* } ; diff --git a/extra/cpu/8080/emulator/emulator.factor b/extra/cpu/8080/emulator/emulator.factor index 557bddc6f7..b5ca713671 100644 --- a/extra/cpu/8080/emulator/emulator.factor +++ b/extra/cpu/8080/emulator/emulator.factor @@ -361,7 +361,7 @@ CONSTANT: sign-flag 0x80 : pop-pc ( cpu -- pc ) #! Pop the value of the PC off the stack. - [ sp>> ] [ read-word ] [ -2 swap decrement-sp ] tri ; + [ sp>> ] [ read-word ] [ -2 swap decrement-sp ] tri ; : push-sp ( value cpu -- ) [ 2 swap decrement-sp ] [ sp>> ] [ write-word ] tri ; diff --git a/extra/cpu/8080/test/test.factor b/extra/cpu/8080/test/test.factor index a7b1624bda..8bbf743602 100644 --- a/extra/cpu/8080/test/test.factor +++ b/extra/cpu/8080/test/test.factor @@ -1,70 +1,70 @@ -USING: - accessors - combinators - cpu.8080 - cpu.8080.emulator - io - io.files - io.encodings.ascii - kernel - math - math.bits - sequences - tools.time -; -IN: cpu.8080.test - -: step ( cpu -- ) - #! Run a single 8080 instruction - [ read-instruction ] keep ! n cpu - over get-cycles over inc-cycles - [ swap instructions nth call( cpu -- ) ] keep - [ pc>> 0xFFFF bitand ] keep - [ pc<< ] keep - process-interrupts ; - -: test-step ( cpu -- cpu ) - [ step ] keep dup cpu. ; - -: invaders ( -- seq ) - { - { 0x0000 "invaders/invaders.h" } - { 0x0800 "invaders/invaders.g" } - { 0x1000 "invaders/invaders.f" } - { 0x1800 "invaders/invaders.e" } - } ; - -: test-cpu ( -- cpu ) - invaders over load-rom* dup cpu. ; - -: test-n ( n -- ) - test-cpu swap [ test-step ] times drop ; - -: run-n ( cpu n -- cpu ) - [ dup step ] times ; - -: each-8bit ( n quot -- ) - [ 8 ] dip each ; inline - -: >ppm ( cpu filename -- cpu ) - #! Dump the current screen image to a ppm image file with the given name. - ascii [ - "P3" print - "256 224" print - "1" print - 224 [ - 32 [ - over 32 * over + 0x2400 + ! cpu h w addr - [ pick ] dip swap ram>> nth [ - [ - " 0 0 0" write - ] [ - " 1 1 1" write - ] if - ] each-8bit drop - ] each drop nl - ] each - ] with-file-writer ; - -: time-test ( -- ) - test-cpu [ 1000000 run-n drop ] time ; +USING: + accessors + combinators + cpu.8080 + cpu.8080.emulator + io + io.files + io.encodings.ascii + kernel + math + math.bits + sequences + tools.time +; +IN: cpu.8080.test + +: step ( cpu -- ) + #! Run a single 8080 instruction + [ read-instruction ] keep ! n cpu + over get-cycles over inc-cycles + [ swap instructions nth call( cpu -- ) ] keep + [ pc>> 0xFFFF bitand ] keep + [ pc<< ] keep + process-interrupts ; + +: test-step ( cpu -- cpu ) + [ step ] keep dup cpu. ; + +: invaders ( -- seq ) + { + { 0x0000 "invaders/invaders.h" } + { 0x0800 "invaders/invaders.g" } + { 0x1000 "invaders/invaders.f" } + { 0x1800 "invaders/invaders.e" } + } ; + +: test-cpu ( -- cpu ) + invaders over load-rom* dup cpu. ; + +: test-n ( n -- ) + test-cpu swap [ test-step ] times drop ; + +: run-n ( cpu n -- cpu ) + [ dup step ] times ; + +: each-8bit ( n quot -- ) + [ 8 ] dip each ; inline + +: >ppm ( cpu filename -- cpu ) + #! Dump the current screen image to a ppm image file with the given name. + ascii [ + "P3" print + "256 224" print + "1" print + 224 [ + 32 [ + over 32 * over + 0x2400 + ! cpu h w addr + [ pick ] dip swap ram>> nth [ + [ + " 0 0 0" write + ] [ + " 1 1 1" write + ] if + ] each-8bit drop + ] each drop nl + ] each + ] with-file-writer ; + +: time-test ( -- ) + test-cpu [ 1000000 run-n drop ] time ; diff --git a/extra/crypto/aes/aes.factor b/extra/crypto/aes/aes.factor index 3bd6377657..5861cf2fc1 100644 --- a/extra/crypto/aes/aes.factor +++ b/extra/crypto/aes/aes.factor @@ -108,7 +108,7 @@ MEMO:: t-table ( -- array ) a1 xtime :> a2 a2 xtime :> a4 a4 xtime :> a8 - a8 a1 bitxor :> a9 + a8 a1 bitxor :> a9 a9 a2 bitxor :> ab a9 a4 bitxor :> ad a8 a4 a2 bitxor bitxor :> ae @@ -180,7 +180,7 @@ M: aes-256-key key-expand-round ( temp i -- temp' ) TUPLE: aes-state nrounds key state ; -: ( nrounds key state -- aes-state ) \ aes-state boa ; +: ( nrounds key state -- aes-state ) \ aes-state boa ; #! grabs the 4n...4(n+1) words of the key : (key-at-nth-round) ( nth aes -- seq ) @@ -190,9 +190,9 @@ SYMBOL: aes-strategy HOOK: (expand-key) aes-strategy ( K Nr -- sched ) HOOK: (first-round) aes-strategy ( aes -- aes' ) HOOK: (counter) aes-strategy ( nrounds -- seq ) -HOOK: (round) aes-strategy ( state -- ) +HOOK: (round) aes-strategy ( state -- ) HOOK: (add-key) aes-strategy ( aes -- aes' ) -HOOK: (final-round) aes-strategy ( aes -- aes' ) +HOOK: (final-round) aes-strategy ( aes -- aes' ) SINGLETON: aes-decrypt SINGLETON: aes-encrypt @@ -299,7 +299,7 @@ M: aes-decrypt (round) ( state -- ) : (aes-crypt-block-inner) ( nrounds key block -- crypted-block ) (aes-crypt) state>> ; - + : (aes-crypt-block) ( key block -- output-block ) [ (aes-expand-key) ] dip bytes>words (aes-crypt-block-inner) ; diff --git a/extra/crypto/aes/utils/utils.factor b/extra/crypto/aes/utils/utils.factor index 4336bcc92f..6548d3e077 100644 --- a/extra/crypto/aes/utils/utils.factor +++ b/extra/crypto/aes/utils/utils.factor @@ -61,4 +61,3 @@ IN: crypto.aes.utils : 4th-from-end ( seq -- el ) [ length 4 - ] keep nth ; - diff --git a/extra/crypto/passwd-md5/passwd-md5.factor b/extra/crypto/passwd-md5/passwd-md5.factor index a8706a7531..4a09e82842 100644 --- a/extra/crypto/passwd-md5/passwd-md5.factor +++ b/extra/crypto/passwd-md5/passwd-md5.factor @@ -40,9 +40,9 @@ PRIVATE> { 12 0 6 13 1 7 14 2 8 15 3 9 5 4 10 } final nths 3 group [ first3 [ 16 shift ] [ 8 shift ] bi* + + 4 to64 ] map concat 11 final nth 2 to64 3append ; - + : parse-shadow-password ( string -- magic salt password ) "$" split harvest first3 [ "$" dup surround ] 2dip ; - + : authenticate-password ( shadow password -- ? ) '[ parse-shadow-password drop _ passwd-md5 ] keep = ; diff --git a/extra/crypto/rsa/rsa.factor b/extra/crypto/rsa/rsa.factor index 5bbcc435c9..a712a1a1f3 100644 --- a/extra/crypto/rsa/rsa.factor +++ b/extra/crypto/rsa/rsa.factor @@ -23,7 +23,7 @@ CONSTANT: public-key 65537 : rsa-primes ( numbits -- p q ) 2/ 2 swap unique-primes first2 ; -: modulus-phi ( numbits -- n phi ) +: modulus-phi ( numbits -- n phi ) #! Loop until phi is not divisible by the public key. dup rsa-primes [ * ] 2keep [ 1 - ] bi@ * diff --git a/extra/ctags/etags/etags.factor b/extra/ctags/etags/etags.factor index baee3c4911..90e3615ba3 100644 --- a/extra/ctags/etags/etags.factor +++ b/extra/ctags/etags/etags.factor @@ -24,7 +24,7 @@ IN: ctags.etags [ etag-vector ] 2keep [ [ etag-pair ] [ ctag-path ] bi [ suffix ] dip ] dip set-at ; - + : etag-hash ( seq -- hash ) H{ } clone swap [ swap [ etag-add ] keep ] each ; @@ -66,7 +66,7 @@ IN: ctags.etags ] each ; : etags-write ( alist path -- ) - [ etag-strings ] dip ascii set-file-lines ; + [ etag-strings ] dip ascii set-file-lines ; : etags ( path -- ) [ (ctags) sort-values etag-hash >alist ] dip etags-write ; diff --git a/extra/cuda/contexts/contexts.factor b/extra/cuda/contexts/contexts.factor index 5218f7b23e..3674b4e686 100644 --- a/extra/cuda/contexts/contexts.factor +++ b/extra/cuda/contexts/contexts.factor @@ -31,4 +31,3 @@ DESTRUCTOR: clean-up-context : with-cuda-context ( device flags quot -- ) [ set-up-cuda-context create-context ] dip (with-cuda-context) ; inline - diff --git a/extra/cuda/cuda.factor b/extra/cuda/cuda.factor index d549e107ae..9ecaebce29 100644 --- a/extra/cuda/cuda.factor +++ b/extra/cuda/cuda.factor @@ -20,4 +20,3 @@ ERROR: cuda-error-state code ; : init-cuda ( -- ) 0 cuInit cuda-error ; inline - diff --git a/extra/cuda/ffi/ffi.factor b/extra/cuda/ffi/ffi.factor index 4a7db0f474..74f63f04de 100644 --- a/extra/cuda/ffi/ffi.factor +++ b/extra/cuda/ffi/ffi.factor @@ -310,7 +310,7 @@ FUNCTION: CUresult cuDeviceComputeCapability ( int* major, int* minor, CUdevice FUNCTION: CUresult cuDeviceTotalMem ( uint* bytes, CUdevice dev ) ; FUNCTION: CUresult cuDeviceGetProperties ( CUdevprop* prop, CUdevice dev ) ; FUNCTION: CUresult cuDeviceGetAttribute ( int* pi, CUdevice_attribute attrib, CUdevice dev ) ; - + FUNCTION: CUresult cuCtxCreate ( CUcontext* pctx, uint flags, CUdevice dev ) ; FUNCTION: CUresult cuCtxDestroy ( CUcontext ctx ) ; FUNCTION: CUresult cuCtxAttach ( CUcontext* pctx, uint flags ) ; @@ -328,14 +328,14 @@ FUNCTION: CUresult cuModuleUnload ( CUmodule hmod ) ; FUNCTION: CUresult cuModuleGetFunction ( CUfunction* hfunc, CUmodule hmod, c-string name ) ; FUNCTION: CUresult cuModuleGetGlobal ( CUdeviceptr* dptr, uint* bytes, CUmodule hmod, char* name ) ; FUNCTION: CUresult cuModuleGetTexRef ( CUtexref* pTexRef, CUmodule hmod, char* name ) ; - + FUNCTION: CUresult cuMemGetInfo ( uint* free, uint* total ) ; FUNCTION: CUresult cuMemAlloc ( CUdeviceptr* dptr, uint bytesize ) ; -FUNCTION: CUresult cuMemAllocPitch ( CUdeviceptr* dptr, +FUNCTION: CUresult cuMemAllocPitch ( CUdeviceptr* dptr, uint* pPitch, - uint WidthInBytes, - uint Height, + uint WidthInBytes, + uint Height, uint ElementSizeBytes ) ; FUNCTION: CUresult cuMemFree ( CUdeviceptr dptr ) ; @@ -345,7 +345,7 @@ FUNCTION: CUresult cuMemAllocHost ( void** pp, uint bytesize ) ; FUNCTION: CUresult cuMemFreeHost ( void* p ) ; FUNCTION: CUresult cuMemHostAlloc ( void** pp, size_t bytesize, uint Flags ) ; - + FUNCTION: CUresult cuMemHostGetDevicePointer ( CUdeviceptr* pdptr, void* p, uint Flags ) ; FUNCTION: CUresult cuMemHostGetFlags ( uint* pFlags, void* p ) ; @@ -367,17 +367,17 @@ FUNCTION: CUresult cuMemcpy2DUnaligned ( CUDA_MEMCPY2D* pCopy ) ; FUNCTION: CUresult cuMemcpy3D ( CUDA_MEMCPY3D* pCopy ) ; -FUNCTION: CUresult cuMemcpyHtoDAsync ( CUdeviceptr dstDevice, +FUNCTION: CUresult cuMemcpyHtoDAsync ( CUdeviceptr dstDevice, void* srcHost, uint ByteCount, CUstream hStream ) ; -FUNCTION: CUresult cuMemcpyDtoHAsync ( void* dstHost, +FUNCTION: CUresult cuMemcpyDtoHAsync ( void* dstHost, CUdeviceptr srcDevice, uint ByteCount, CUstream hStream ) ; FUNCTION: CUresult cuMemcpyDtoDAsync ( CUdeviceptr dstDevice, CUdeviceptr srcDevice, uint ByteCount, CUstream hStream ) ; -FUNCTION: CUresult cuMemcpyHtoAAsync ( CUarray dstArray, uint dstIndex, +FUNCTION: CUresult cuMemcpyHtoAAsync ( CUarray dstArray, uint dstIndex, void* pSrc, uint ByteCount, CUstream hStream ) ; -FUNCTION: CUresult cuMemcpyAtoHAsync ( void* dstHost, CUarray srcArray, uint srcIndex, +FUNCTION: CUresult cuMemcpyAtoHAsync ( void* dstHost, CUarray srcArray, uint srcIndex, uint ByteCount, CUstream hStream ) ; FUNCTION: CUresult cuMemcpy2DAsync ( CUDA_MEMCPY2D* pCopy, CUstream hStream ) ; @@ -405,7 +405,7 @@ FUNCTION: CUresult cuArray3DGetDescriptor ( CUDA_ARRAY3D_DESCRIPTOR* pArrayDesc FUNCTION: CUresult cuTexRefCreate ( CUtexref* pTexRef ) ; FUNCTION: CUresult cuTexRefDestroy ( CUtexref hTexRef ) ; - + FUNCTION: CUresult cuTexRefSetArray ( CUtexref hTexRef, CUarray hArray, uint Flags ) ; FUNCTION: CUresult cuTexRefSetAddress ( uint* ByteOffset, CUtexref hTexRef, CUdeviceptr dptr, uint bytes ) ; FUNCTION: CUresult cuTexRefSetAddress2D ( CUtexref hTexRef, CUDA_ARRAY_DESCRIPTOR* desc, CUdeviceptr dptr, uint Pitch ) ; @@ -446,7 +446,7 @@ FUNCTION: CUresult cuStreamDestroy ( CUstream hStream ) ; FUNCTION: CUresult cuGraphicsUnregisterResource ( CUgraphicsResource resource ) ; FUNCTION: CUresult cuGraphicsSubResourceGetMappedArray ( CUarray* pArray, CUgraphicsResource resource, uint arrayIndex, uint mipLevel ) ; FUNCTION: CUresult cuGraphicsResourceGetMappedPointer ( CUdeviceptr* pDevPtr, uint* pSize, CUgraphicsResource resource ) ; -FUNCTION: CUresult cuGraphicsResourceSetMapFlags ( CUgraphicsResource resource, uint flags ) ; +FUNCTION: CUresult cuGraphicsResourceSetMapFlags ( CUgraphicsResource resource, uint flags ) ; FUNCTION: CUresult cuGraphicsMapResources ( uint count, CUgraphicsResource* resources, CUstream hStream ) ; FUNCTION: CUresult cuGraphicsUnmapResources ( uint count, CUgraphicsResource* resources, CUstream hStream ) ; diff --git a/extra/cuda/gl/ffi/ffi.factor b/extra/cuda/gl/ffi/ffi.factor index 8c20efde3b..c58dda3c59 100644 --- a/extra/cuda/gl/ffi/ffi.factor +++ b/extra/cuda/gl/ffi/ffi.factor @@ -7,4 +7,3 @@ LIBRARY: cuda FUNCTION: CUresult cuGLCtxCreate ( CUcontext* pCtx, uint Flags, CUdevice device ) ; FUNCTION: CUresult cuGraphicsGLRegisterBuffer ( CUgraphicsResource* pCudaResource, GLuint buffer, uint Flags ) ; FUNCTION: CUresult cuGraphicsGLRegisterImage ( CUgraphicsResource* pCudaResource, GLuint image, GLenum target, uint Flags ) ; - diff --git a/extra/cuda/gl/gl.factor b/extra/cuda/gl/gl.factor index e4e093c1e9..e5aa2ef118 100644 --- a/extra/cuda/gl/gl.factor +++ b/extra/cuda/gl/gl.factor @@ -10,7 +10,7 @@ IN: cuda.gl '[ _ _ cuGLCtxCreate cuda-error ] with-out-parameters ; inline : with-gl-cuda-context ( device flags quot -- ) - [ set-up-cuda-context create-gl-cuda-context ] dip (with-cuda-context) ; inline + [ set-up-cuda-context create-gl-cuda-context ] dip (with-cuda-context) ; inline : gl-buffer>resource ( gl-buffer flags -- resource ) enum>number diff --git a/extra/cuda/libraries/libraries.factor b/extra/cuda/libraries/libraries.factor index b57939fb26..2e5c36bff6 100644 --- a/extra/cuda/libraries/libraries.factor +++ b/extra/cuda/libraries/libraries.factor @@ -171,7 +171,7 @@ MACRO: cuda-invoke ( module-name function-name arguments -- ) : cuda-global* ( module-name symbol-name -- device-ptr size ) [ { CUdeviceptr { c:uint initial: 0 } } ] 2dip - [ cached-module ] dip + [ cached-module ] dip '[ _ _ cuModuleGetGlobal cuda-error ] with-out-parameters ; inline : cuda-global ( module-name symbol-name -- device-ptr ) @@ -200,4 +200,3 @@ ERROR: bad-cuda-abi abi ; : add-cuda-library ( name abi path -- ) normalize-path dup name>> cuda-libraries get-global set-at ; - diff --git a/extra/cuda/ptx/ptx.factor b/extra/cuda/ptx/ptx.factor index 28c8f8e088..6c9f7caa7b 100644 --- a/extra/cuda/ptx/ptx.factor +++ b/extra/cuda/ptx/ptx.factor @@ -59,7 +59,7 @@ TUPLE: ptx-variable { initializer maybe{ string } } ; TUPLE: ptx-negation - { var string } ; + { var string } ; TUPLE: ptx-vector elements ; @@ -367,7 +367,7 @@ GENERIC: (write-ptx-element) ( elt -- ) : write-ptx-element ( elt -- ) dup ptx-element-label [ write ":" write ] when* - "\t" write dup (write-ptx-element) + "\t" write dup (write-ptx-element) ptx-semicolon? [ ";" print ] [ nl ] if ; : write-ptx ( ptx -- ) diff --git a/extra/cuda/types/types.factor b/extra/cuda/types/types.factor index 99be696cbe..db58c5ac5a 100644 --- a/extra/cuda/types/types.factor +++ b/extra/cuda/types/types.factor @@ -183,110 +183,110 @@ STRUCT: double4 { z double } { w double } ; -char2 lookup-c-type +char2 lookup-c-type 2 >>align 2 >>align-first drop -char4 lookup-c-type +char4 lookup-c-type 4 >>align 4 >>align-first drop -uchar2 lookup-c-type +uchar2 lookup-c-type 2 >>align 2 >>align-first drop -uchar4 lookup-c-type +uchar4 lookup-c-type 4 >>align 4 >>align-first drop -short2 lookup-c-type +short2 lookup-c-type 4 >>align 4 >>align-first drop -short4 lookup-c-type +short4 lookup-c-type 8 >>align 8 >>align-first drop -ushort2 lookup-c-type +ushort2 lookup-c-type 4 >>align 4 >>align-first drop -ushort4 lookup-c-type +ushort4 lookup-c-type 8 >>align 8 >>align-first drop -int2 lookup-c-type +int2 lookup-c-type 8 >>align 8 >>align-first drop -int4 lookup-c-type +int4 lookup-c-type 16 >>align 16 >>align-first drop -uint2 lookup-c-type +uint2 lookup-c-type 8 >>align 8 >>align-first drop -uint4 lookup-c-type +uint4 lookup-c-type 16 >>align 16 >>align-first drop -long2 lookup-c-type +long2 lookup-c-type long heap-size 2 * >>align long heap-size 2 * >>align-first drop -long4 lookup-c-type +long4 lookup-c-type 16 >>align 16 >>align-first drop -ulong2 lookup-c-type +ulong2 lookup-c-type long heap-size 2 * >>align long heap-size 2 * >>align-first drop -ulong4 lookup-c-type +ulong4 lookup-c-type 16 >>align 16 >>align-first drop -longlong2 lookup-c-type +longlong2 lookup-c-type 16 >>align 16 >>align-first drop -longlong4 lookup-c-type +longlong4 lookup-c-type 16 >>align 16 >>align-first drop -ulonglong2 lookup-c-type +ulonglong2 lookup-c-type 16 >>align 16 >>align-first drop -ulonglong4 lookup-c-type +ulonglong4 lookup-c-type 16 >>align 16 >>align-first drop -float2 lookup-c-type +float2 lookup-c-type 8 >>align 8 >>align-first drop -float4 lookup-c-type +float4 lookup-c-type 16 >>align 16 >>align-first drop -double2 lookup-c-type +double2 lookup-c-type 16 >>align 16 >>align-first drop -double4 lookup-c-type +double4 lookup-c-type 16 >>align 16 >>align-first drop diff --git a/extra/cursors/cursors.factor b/extra/cursors/cursors.factor index 5f28c7ec47..c03940e654 100644 --- a/extra/cursors/cursors.factor +++ b/extra/cursors/cursors.factor @@ -538,7 +538,7 @@ ALIAS: -2in- -assoc- [ 2in- ] dip -map-as ; inline : 2map ( ... a b quot: ( ... x y -- ... z ) -- ... c ) - pick 2map-as ; inline + pick 2map-as ; inline ! ! generalized zips @@ -576,4 +576,3 @@ MACRO: -nin- ( n -- ) MACRO: -nwith- ( n -- ) [ -with- ] n*quot ; - diff --git a/extra/decimals/decimals.factor b/extra/decimals/decimals.factor index a356e8a6e1..1d244f0355 100644 --- a/extra/decimals/decimals.factor +++ b/extra/decimals/decimals.factor @@ -16,7 +16,7 @@ TUPLE: decimal { mantissa read-only } { exponent read-only } ; "." split1 [ [ CHAR: 0 = ] trim-head [ "0" ] when-empty ] [ [ CHAR: 0 = ] trim-tail [ "" ] when-empty ] bi* - [ append string>number ] [ nip length neg ] 2bi ; + [ append string>number ] [ nip length neg ] 2bi ; : parse-decimal ( -- decimal ) scan-token string>decimal ; @@ -27,7 +27,7 @@ SYNTAX: D: parse-decimal suffix! ; : scale-mantissas ( D1 D2 -- m1 m2 exp ) [ [ mantissa>> ] bi@ ] - [ + [ [ exponent>> ] bi@ [ - dup 0 < @@ -79,7 +79,7 @@ M: decimal before? D2 >decimal< :> ( m2 e2 ) m1 a 10^ * m2 /i - + e1 e2 a + - ; diff --git a/extra/descriptive/descriptive-docs.factor b/extra/descriptive/descriptive-docs.factor index e488f0ccb7..38b478a220 100644 --- a/extra/descriptive/descriptive-docs.factor +++ b/extra/descriptive/descriptive-docs.factor @@ -1,32 +1,32 @@ -USING: help.syntax help.markup words ; -IN: descriptive - -HELP: DESCRIPTIVE: -{ $syntax "DESCRIPTIVE: word ( inputs -- outputs ) definition ;" } -{ $description "Defines a word such that, if an error is thrown from within it, that error is wrapped in a " { $link descriptive-error } " with the arguments to that word." } ; - -HELP: DESCRIPTIVE:: -{ $syntax "DESCRIPTIVE:: word ( inputs -- outputs ) definition ;" } -{ $description "Defines a word which uses locals such that, if an error is thrown from within it, that error is wrapped in a " { $link descriptive-error } " with the arguments to that word." } ; - -HELP: descriptive-error -{ $error-description "The class of errors wrapping another error (in the underlying slot) which were thrown in a word (in the word slot) with a given set of arguments (in the args slot)." } ; - -HELP: make-descriptive -{ $values { "word" word } } -{ $description "Makes the word wrap errors in " { $link descriptive-error } " instances." } ; - -ARTICLE: "descriptive" "Descriptive errors" -"This vocabulary defines automatic descriptive errors. Using it, you can define a word which acts as normal, except when it throws an error, the error is wrapped in an instance of a class:" -{ $subsections descriptive-error } -"The wrapper contains the word itself, the input parameters, as well as the original error." -$nl -"To annotate an existing word with descriptive error checking:" -{ $subsections make-descriptive } -"To define words which throw descriptive errors, use the following words:" -{ $subsections - POSTPONE: DESCRIPTIVE: - POSTPONE: DESCRIPTIVE:: -} ; - -ABOUT: "descriptive" +USING: help.syntax help.markup words ; +IN: descriptive + +HELP: DESCRIPTIVE: +{ $syntax "DESCRIPTIVE: word ( inputs -- outputs ) definition ;" } +{ $description "Defines a word such that, if an error is thrown from within it, that error is wrapped in a " { $link descriptive-error } " with the arguments to that word." } ; + +HELP: DESCRIPTIVE:: +{ $syntax "DESCRIPTIVE:: word ( inputs -- outputs ) definition ;" } +{ $description "Defines a word which uses locals such that, if an error is thrown from within it, that error is wrapped in a " { $link descriptive-error } " with the arguments to that word." } ; + +HELP: descriptive-error +{ $error-description "The class of errors wrapping another error (in the underlying slot) which were thrown in a word (in the word slot) with a given set of arguments (in the args slot)." } ; + +HELP: make-descriptive +{ $values { "word" word } } +{ $description "Makes the word wrap errors in " { $link descriptive-error } " instances." } ; + +ARTICLE: "descriptive" "Descriptive errors" +"This vocabulary defines automatic descriptive errors. Using it, you can define a word which acts as normal, except when it throws an error, the error is wrapped in an instance of a class:" +{ $subsections descriptive-error } +"The wrapper contains the word itself, the input parameters, as well as the original error." +$nl +"To annotate an existing word with descriptive error checking:" +{ $subsections make-descriptive } +"To define words which throw descriptive errors, use the following words:" +{ $subsections + POSTPONE: DESCRIPTIVE: + POSTPONE: DESCRIPTIVE:: +} ; + +ABOUT: "descriptive" diff --git a/extra/descriptive/descriptive-tests.factor b/extra/descriptive/descriptive-tests.factor index 6630d2addb..cc1c1be942 100644 --- a/extra/descriptive/descriptive-tests.factor +++ b/extra/descriptive/descriptive-tests.factor @@ -1,34 +1,34 @@ -USING: descriptive kernel math tools.test continuations prettyprint io.streams.string see -math.ratios ; -IN: descriptive.tests - -DESCRIPTIVE: divide ( num denom -- fraction ) / ; - -[ 3 ] [ 9 3 divide ] unit-test - -[ - T{ descriptive-error f - { { "num" 3 } { "denom" 0 } } - T{ division-by-zero f 3 } - divide - } -] [ - [ 3 0 divide ] [ ] recover -] unit-test - -[ "USING: descriptive math ;\nIN: descriptive.tests\nDESCRIPTIVE: divide ( num denom -- fraction ) / ;\n" ] -[ \ divide [ see ] with-string-writer ] unit-test - -DESCRIPTIVE:: divide* ( num denom -- fraction ) num denom / ; - -[ 3 ] [ 9 3 divide* ] unit-test - -[ - T{ descriptive-error f - { { "num" 3 } { "denom" 0 } } - T{ division-by-zero f 3 } - divide* - } -] [ [ 3 0 divide* ] [ ] recover ] unit-test - -[ "USING: descriptive math ;\nIN: descriptive.tests\nDESCRIPTIVE:: divide* ( num denom -- fraction ) num denom / ;\n" ] [ \ divide* [ see ] with-string-writer ] unit-test +USING: descriptive kernel math tools.test continuations prettyprint io.streams.string see +math.ratios ; +IN: descriptive.tests + +DESCRIPTIVE: divide ( num denom -- fraction ) / ; + +[ 3 ] [ 9 3 divide ] unit-test + +[ + T{ descriptive-error f + { { "num" 3 } { "denom" 0 } } + T{ division-by-zero f 3 } + divide + } +] [ + [ 3 0 divide ] [ ] recover +] unit-test + +[ "USING: descriptive math ;\nIN: descriptive.tests\nDESCRIPTIVE: divide ( num denom -- fraction ) / ;\n" ] +[ \ divide [ see ] with-string-writer ] unit-test + +DESCRIPTIVE:: divide* ( num denom -- fraction ) num denom / ; + +[ 3 ] [ 9 3 divide* ] unit-test + +[ + T{ descriptive-error f + { { "num" 3 } { "denom" 0 } } + T{ division-by-zero f 3 } + divide* + } +] [ [ 3 0 divide* ] [ ] recover ] unit-test + +[ "USING: descriptive math ;\nIN: descriptive.tests\nDESCRIPTIVE:: divide* ( num denom -- fraction ) num denom / ;\n" ] [ \ divide* [ see ] with-string-writer ] unit-test diff --git a/extra/dns/dns.factor b/extra/dns/dns.factor index b9077237bc..726dcd21b9 100644 --- a/extra/dns/dns.factor +++ b/extra/dns/dns.factor @@ -159,7 +159,7 @@ CONSTANT: ipv6-arpa-suffix ".ip6.arpa" : trim-ipv6-arpa ( string -- string' ) dotted> ipv6-arpa-suffix ?tail drop ; - + : arpa>ipv4 ( string -- ip ) trim-ipv4-arpa reverse-ipv4 ; : arpa>ipv6 ( string -- ip ) @@ -270,7 +270,7 @@ M: HINFO rdata>byte-array [ os>> >name ] bi append ; M: MX rdata>byte-array - drop + drop [ preference>> 2 >be ] [ exchange>> >name ] bi append ; @@ -384,7 +384,7 @@ M: TXT rdata>byte-array : message>mxs ( message -- assoc ) answer-section>> [ rdata>> [ preference>> ] [ exchange>> ] bi 2array ] map ; -: messages>names ( messages -- names ) +: messages>names ( messages -- names ) [ message>names ] map concat ; : forward-confirmed-reverse-dns-ipv4? ( ipv4-string -- ? ) @@ -407,7 +407,7 @@ M: string resolve-host dns-A-query message>a-names [ ] map ] if ; *) - + HOOK: initial-dns-servers os ( -- sequence ) { @@ -417,5 +417,5 @@ HOOK: initial-dns-servers os ( -- sequence ) : with-dns-servers ( servers quot -- ) [ dns-servers ] dip with-variable ; inline - + dns-servers [ initial-dns-servers >vector ] initialize diff --git a/extra/dns/windows/windows.factor b/extra/dns/windows/windows.factor index a43eede183..9c111c6316 100644 --- a/extra/dns/windows/windows.factor +++ b/extra/dns/windows/windows.factor @@ -3,4 +3,4 @@ USING: dns system windows.iphlpapi ; IN: dns.windows -M: windows initial-dns-servers dns-server-ips ; \ No newline at end of file +M: windows initial-dns-servers dns-server-ips ; diff --git a/extra/dwarf/dwarf.factor b/extra/dwarf/dwarf.factor index afa29ff3e4..63edd1b97a 100644 --- a/extra/dwarf/dwarf.factor +++ b/extra/dwarf/dwarf.factor @@ -99,7 +99,7 @@ CONSTANT: DW_TAG_SUN_dtor 0x420b CONSTANT: DW_TAG_SUN_f90_interface 0x420c CONSTANT: DW_TAG_SUN_fortran_vax_structure 0x420d CONSTANT: DW_TAG_SUN_hi 0x42ff - + CONSTANT: DW_TAG_hi_user 0xffff CONSTANT: DW_children_no 0 @@ -280,7 +280,7 @@ CONSTANT: DW_AT_body_end 0x2106 CONSTANT: DW_AT_GNU_vector 0x2107 CONSTANT: DW_AT_GNU_template_name 0x2108 -CONSTANT: DW_AT_ALTIUM_loclist 0x2300 +CONSTANT: DW_AT_ALTIUM_loclist 0x2300 CONSTANT: DW_AT_SUN_template 0x2201 CONSTANT: DW_AT_VMS_rtnbeg_pd_address 0x2201 @@ -333,8 +333,8 @@ CONSTANT: DW_AT_SUN_fortran_based 0x223b CONSTANT: DW_AT_upc_threads_scaled 0x3210 CONSTANT: DW_AT_PGI_lbase 0x3a00 -CONSTANT: DW_AT_PGI_soffset 0x3a01 -CONSTANT: DW_AT_PGI_lstride 0x3a02 +CONSTANT: DW_AT_PGI_soffset 0x3a01 +CONSTANT: DW_AT_PGI_lstride 0x3a02 CONSTANT: DW_AT_APPLE_closure 0x3fe4 CONSTANT: DW_AT_APPLE_major_runtime_vers 0x3fe5 @@ -599,7 +599,7 @@ CONSTANT: DW_LANG_Python 0x0014 CONSTANT: DW_LANG_lo_user 0x8000 CONSTANT: DW_LANG_Mips_Assembler 0x8001 CONSTANT: DW_LANG_Upc 0x8765 -CONSTANT: DW_LANG_ALTIUM_Assembler 0x9101 +CONSTANT: DW_LANG_ALTIUM_Assembler 0x9101 CONSTANT: DW_LANG_SUN_Assembler 0x9001 CONSTANT: DW_LANG_hi_user 0xffff @@ -613,10 +613,10 @@ CONSTANT: DW_CC_program 0x02 CONSTANT: DW_CC_nocall 0x03 CONSTANT: DW_CC_lo_user 0x40 -CONSTANT: DW_CC_ALTIUM_interrupt 0x65 -CONSTANT: DW_CC_ALTIUM_near_system_stack 0x66 -CONSTANT: DW_CC_ALTIUM_near_user_stack 0x67 -CONSTANT: DW_CC_ALTIUM_huge_user_stack 0x68 +CONSTANT: DW_CC_ALTIUM_interrupt 0x65 +CONSTANT: DW_CC_ALTIUM_near_system_stack 0x66 +CONSTANT: DW_CC_ALTIUM_near_user_stack 0x67 +CONSTANT: DW_CC_ALTIUM_huge_user_stack 0x68 CONSTANT: DW_CC_hi_user 0xff CONSTANT: DW_INL_not_inlined 0x00 @@ -646,7 +646,7 @@ CONSTANT: DW_LNS_set_isa 0x0c CONSTANT: DW_LNE_end_sequence 0x01 CONSTANT: DW_LNE_set_address 0x02 CONSTANT: DW_LNE_define_file 0x03 -CONSTANT: DW_LNE_set_discriminator 0x04 +CONSTANT: DW_LNE_set_discriminator 0x04 CONSTANT: DW_LNE_HP_negate_is_UV_update 0x11 CONSTANT: DW_LNE_HP_push_context 0x12 @@ -720,7 +720,7 @@ CONSTANT: DW_EH_PE_funcrel 0x40 CONSTANT: DW_EH_PE_aligned 0x50 CONSTANT: DW_EH_PE_omit 0xff -CONSTANT: DW_FRAME_CFA_COL 0 +CONSTANT: DW_FRAME_CFA_COL 0 CONSTANT: DW_FRAME_REG1 1 CONSTANT: DW_FRAME_REG2 2 diff --git a/extra/ecdsa/ecdsa.factor b/extra/ecdsa/ecdsa.factor index 74fdad63ea..63fda8ab40 100644 --- a/extra/ecdsa/ecdsa.factor +++ b/extra/ecdsa/ecdsa.factor @@ -54,7 +54,7 @@ PRIVATE> :: get-public-key ( -- bin/f ) ec-key-handle :> KEY - KEY EC_KEY_get0_public_key dup + KEY EC_KEY_get0_public_key dup [| PUB | KEY EC_KEY_get0_group :> GROUP GROUP EC_GROUP_get_degree bits>bytes 1 + :> LEN diff --git a/extra/echo-server/echo-server.factor b/extra/echo-server/echo-server.factor index 3807b8cee7..50364c02b9 100644 --- a/extra/echo-server/echo-server.factor +++ b/extra/echo-server/echo-server.factor @@ -20,4 +20,3 @@ IN: echo-server : echod-main ( -- ) 1234 echod drop ; MAIN: echod-main - diff --git a/extra/elf/elf.factor b/extra/elf/elf.factor index 8b43d01b03..6d98319419 100644 --- a/extra/elf/elf.factor +++ b/extra/elf/elf.factor @@ -513,7 +513,7 @@ TYPED:: virtual-address-section ( elf: Elf32/64_Ehdr address -- section-header/f ] find nip ; TYPED:: elf-segment-data ( elf: Elf32/64_Ehdr header: Elf32/64_Phdr -- uchar-array/f ) - header p_offset>> elf >c-ptr + header p_offset>> elf >c-ptr header p_filesz>> uchar ; TYPED:: elf-section-data ( elf: Elf32/64_Ehdr header: Elf32/64_Shdr -- uchar-array/f ) diff --git a/extra/elf/nm/nm.factor b/extra/elf/nm/nm.factor index a36ff1f832..43eb1f6eba 100644 --- a/extra/elf/nm/nm.factor +++ b/extra/elf/nm/nm.factor @@ -15,7 +15,7 @@ IN: elf.nm } case "%-16s " printf ] [ name>> "%s\n" printf ] tri ; - + : elf-nm ( path -- ) [ sections dup ".symtab" find-section diff --git a/extra/env/env.factor b/extra/env/env.factor index f7f4c5d231..07fd244a91 100644 --- a/extra/env/env.factor +++ b/extra/env/env.factor @@ -23,4 +23,3 @@ M: env delete-at M: env clear-assoc drop os-envs keys [ unset-os-env ] each ; - diff --git a/extra/euler/b-rep/b-rep-tests.factor b/extra/euler/b-rep/b-rep-tests.factor index 63a7ce1077..f5ef8981d8 100644 --- a/extra/euler/b-rep/b-rep-tests.factor +++ b/extra/euler/b-rep/b-rep-tests.factor @@ -1,79 +1,79 @@ -USING: accessors euler.b-rep euler.modeling euler.operators -euler.b-rep.examples kernel locals math.vectors.simd.cords -namespaces sequences tools.test ; -IN: euler.b-rep.tests - -[ double-4{ 0.0 0.0 -1.0 0.0 } ] -[ valid-cube-b-rep edges>> first face-normal ] unit-test - -[ double-4{ 0.0 0.0 -1.0 0.0 } -1.0 ] -[ valid-cube-b-rep edges>> first face-plane ] unit-test - -[ t ] [ 0 multi-ringed-face-cube-b-rep faces>> nth base-face? ] unit-test -[ t ] [ 5 multi-ringed-face-cube-b-rep faces>> nth base-face? ] unit-test -[ f ] [ 6 multi-ringed-face-cube-b-rep faces>> nth base-face? ] unit-test - -:: mock-face ( p0 p1 p2 -- edge ) - b-edge new vertex new p0 >>position >>vertex :> e0 - b-edge new vertex new p1 >>position >>vertex :> e1 - b-edge new vertex new p2 >>position >>vertex :> e2 - - e1 e0 next-edge<< - e2 e1 next-edge<< - e0 e2 next-edge<< - - e0 ; - -[ - double-4{ - 0x1.279a74590331dp-1 - 0x1.279a74590331dp-1 - 0x1.279a74590331dp-1 - 0.0 - } - -0x1.bb67ae8584cabp1 -] [ - double-4{ 1 0 5 0 } - double-4{ 0 1 5 0 } - double-4{ 0 0 6 0 } mock-face face-plane -] unit-test - -V{ t } clone sharpness-stack [ - [ t ] [ get-sharpness ] unit-test - [ V{ f } ] [ f set-sharpness sharpness-stack get ] unit-test - [ V{ f t } t ] [ t push-sharpness sharpness-stack get get-sharpness ] unit-test - [ t V{ f } f ] [ pop-sharpness sharpness-stack get get-sharpness ] unit-test -] with-variable - -[ t ] [ valid-cube-b-rep [ edges>> first ] keep is-valid-edge? ] unit-test -[ f ] [ b-edge new valid-cube-b-rep is-valid-edge? ] unit-test - -[ t ] [ - valid-cube-b-rep edges>> - [ [ 0 swap nth ] [ 1 swap nth ] bi connecting-edge ] - [ 0 swap nth ] bi eq? -] unit-test - -[ t ] [ - valid-cube-b-rep edges>> - [ [ 1 swap nth ] [ 0 swap nth ] bi connecting-edge ] - [ 6 swap nth ] bi eq? -] unit-test - -[ t ] [ - valid-cube-b-rep edges>> - [ [ 0 swap nth ] [ 3 swap nth ] bi connecting-edge ] - [ 21 swap nth ] bi eq? -] unit-test - -[ f ] [ - valid-cube-b-rep edges>> - [ 0 swap nth ] [ 2 swap nth ] bi connecting-edge -] unit-test - -[ double-4{ 0 0 -1 0 } ] [ - [ - { double-4{ 0 0 0 0 } double-4{ 0 1 0 0 } double-4{ 0 2 0 0 } double-4{ 1 1 0 0 } } - smooth-smooth polygon>double-face face-normal - ] make-b-rep drop -] unit-test +USING: accessors euler.b-rep euler.modeling euler.operators +euler.b-rep.examples kernel locals math.vectors.simd.cords +namespaces sequences tools.test ; +IN: euler.b-rep.tests + +[ double-4{ 0.0 0.0 -1.0 0.0 } ] +[ valid-cube-b-rep edges>> first face-normal ] unit-test + +[ double-4{ 0.0 0.0 -1.0 0.0 } -1.0 ] +[ valid-cube-b-rep edges>> first face-plane ] unit-test + +[ t ] [ 0 multi-ringed-face-cube-b-rep faces>> nth base-face? ] unit-test +[ t ] [ 5 multi-ringed-face-cube-b-rep faces>> nth base-face? ] unit-test +[ f ] [ 6 multi-ringed-face-cube-b-rep faces>> nth base-face? ] unit-test + +:: mock-face ( p0 p1 p2 -- edge ) + b-edge new vertex new p0 >>position >>vertex :> e0 + b-edge new vertex new p1 >>position >>vertex :> e1 + b-edge new vertex new p2 >>position >>vertex :> e2 + + e1 e0 next-edge<< + e2 e1 next-edge<< + e0 e2 next-edge<< + + e0 ; + +[ + double-4{ + 0x1.279a74590331dp-1 + 0x1.279a74590331dp-1 + 0x1.279a74590331dp-1 + 0.0 + } + -0x1.bb67ae8584cabp1 +] [ + double-4{ 1 0 5 0 } + double-4{ 0 1 5 0 } + double-4{ 0 0 6 0 } mock-face face-plane +] unit-test + +V{ t } clone sharpness-stack [ + [ t ] [ get-sharpness ] unit-test + [ V{ f } ] [ f set-sharpness sharpness-stack get ] unit-test + [ V{ f t } t ] [ t push-sharpness sharpness-stack get get-sharpness ] unit-test + [ t V{ f } f ] [ pop-sharpness sharpness-stack get get-sharpness ] unit-test +] with-variable + +[ t ] [ valid-cube-b-rep [ edges>> first ] keep is-valid-edge? ] unit-test +[ f ] [ b-edge new valid-cube-b-rep is-valid-edge? ] unit-test + +[ t ] [ + valid-cube-b-rep edges>> + [ [ 0 swap nth ] [ 1 swap nth ] bi connecting-edge ] + [ 0 swap nth ] bi eq? +] unit-test + +[ t ] [ + valid-cube-b-rep edges>> + [ [ 1 swap nth ] [ 0 swap nth ] bi connecting-edge ] + [ 6 swap nth ] bi eq? +] unit-test + +[ t ] [ + valid-cube-b-rep edges>> + [ [ 0 swap nth ] [ 3 swap nth ] bi connecting-edge ] + [ 21 swap nth ] bi eq? +] unit-test + +[ f ] [ + valid-cube-b-rep edges>> + [ 0 swap nth ] [ 2 swap nth ] bi connecting-edge +] unit-test + +[ double-4{ 0 0 -1 0 } ] [ + [ + { double-4{ 0 0 0 0 } double-4{ 0 1 0 0 } double-4{ 0 2 0 0 } double-4{ 1 1 0 0 } } + smooth-smooth polygon>double-face face-normal + ] make-b-rep drop +] unit-test diff --git a/extra/euler/b-rep/b-rep.factor b/extra/euler/b-rep/b-rep.factor index cb9a8ff19a..57234f5659 100644 --- a/extra/euler/b-rep/b-rep.factor +++ b/extra/euler/b-rep/b-rep.factor @@ -127,7 +127,7 @@ ERROR: all-points-colinear ; tri ; : connect-opposite-edges ( b-rep -- ) - edges>> + edges>> [ [ [ next-edge>> vertex>> ] [ vertex>> 2array ] [ ] tri ] H{ } map>assoc ] [ swap '[ [ vertex>> ] [ next-edge>> vertex>> 2array _ at ] [ opposite-edge<< ] tri ] each ] bi ; diff --git a/extra/euler/b-rep/io/obj/obj.factor b/extra/euler/b-rep/io/obj/obj.factor index 2a68fb3401..3f37e52e49 100644 --- a/extra/euler/b-rep/io/obj/obj.factor +++ b/extra/euler/b-rep/io/obj/obj.factor @@ -45,7 +45,7 @@ PRIVATE> V{ } clone :> edges faces-vertices [ vertices reconstruct-face edges push-all ] { } map-as :> faces - b-rep new + b-rep new faces >>faces edges >>edges vertices >>vertices diff --git a/extra/euler/b-rep/subdivision/subdivision.factor b/extra/euler/b-rep/subdivision/subdivision.factor index 6af1fd585c..14ce362787 100644 --- a/extra/euler/b-rep/subdivision/subdivision.factor +++ b/extra/euler/b-rep/subdivision/subdivision.factor @@ -27,7 +27,7 @@ IN: euler.b-rep.subdivision [ opposite-n edge-pts set-nth-unsafe ] bi ] when ] each-index - + edge-pts ; inline :: vertex-points ( vertices edge-indices face-indices edge-pts face-points -- vertex-pts ) @@ -47,7 +47,7 @@ IN: euler.b-rep.subdivision ] map ; inline TYPED:: subdivide ( brep: b-rep -- brep': b-rep ) - brep vertices>> :> vertices + brep vertices>> :> vertices brep edges>> :> edges brep faces>> :> faces @@ -73,7 +73,7 @@ TYPED:: subdivide ( brep: b-rep -- brep': b-rep ) face new dup >>base-face :> fac - + b-edge new fac >>face point-a >>vertex :> edg-a @@ -104,7 +104,7 @@ TYPED:: subdivide ( brep: b-rep -- brep': b-rep ) point-d [ edg-d or ] change-edge drop ] each-vertex-edge ] each - + b-rep new sub-faces { } like >>faces sub-edges { } like >>edges diff --git a/extra/euler/modeling/modeling-tests.factor b/extra/euler/modeling/modeling-tests.factor index f038818984..53088ee007 100644 --- a/extra/euler/modeling/modeling-tests.factor +++ b/extra/euler/modeling/modeling-tests.factor @@ -1,46 +1,46 @@ -USING: accessors kernel tools.test euler.b-rep euler.operators -euler.modeling game.models.half-edge ; -IN: euler.modeling.tests - -! polygon>double-face -[ ] [ - [ - { { -1 -1 0 } { 1 -1 0 } { 1 1 0 } { -1 1 0 } } - smooth-smooth polygon>double-face - [ face-sides 4 assert= ] - [ opposite-edge>> face-sides 4 assert= ] - [ face-normal { 0.0 0.0 1.0 } assert= ] - tri - ] make-b-rep check-b-rep -] unit-test - -! extrude-simple -[ ] [ - [ - { { -1 -1 0 } { 1 -1 0 } { 1 1 0 } } - smooth-smooth polygon>double-face - 1 f extrude-simple - [ face-sides 3 assert= ] - [ opposite-edge>> face-sides 4 assert= ] - bi - ] make-b-rep check-b-rep -] unit-test - -! project-pt-line -[ { 0 1 0 } ] [ { 0 0 0 } { 0 1 0 } { 1 1 0 } project-pt-line ] unit-test -[ { 0 1 0 } ] [ { 0 0 0 } { 1 1 0 } { 0 1 0 } project-pt-line ] unit-test -[ { 0 1 0 } ] [ { 0 0 0 } { 2 1 0 } { 1 1 0 } project-pt-line ] unit-test -[ { -1 1 0 } ] [ { -1 0 0 } { 2 1 0 } { 1 1 0 } project-pt-line ] unit-test -[ { 1/2 1/2 0 } ] [ { 0 0 0 } { 0 1 0 } { 1 0 0 } project-pt-line ] unit-test - -! project-pt-plane -[ { 0 0 1 } ] [ { 0 0 0 } { 0 0 1 } { 0 0 1 } -1 project-pt-plane ] unit-test -[ { 0 0 -1 } ] [ { 0 0 0 } { 0 0 1 } { 0 0 1 } 1 project-pt-plane ] unit-test -[ { 0 0 3 } ] [ { 0 0 0 } { 0 0 1 } { 0 0 1 } -3 project-pt-plane ] unit-test -[ { 0 0 3 } ] [ { 0 0 0 } { 0 0 1 } { 0 0 -1 } 3 project-pt-plane ] unit-test -[ { 0 0 1 } ] [ { 0 0 0 } { 0 0 1 } { 0 1 1 } -1 project-pt-plane ] unit-test - -[ { 0 2/3 1/3 } ] [ { 0 0 0 } { 0 2 1 } { 0 1 1 } -1 project-pt-plane ] unit-test - -[ { 0 0 1 } ] [ { 0 0 0 } { 0 0 1/2 } { 0 0 1 } -1 project-pt-plane ] unit-test -[ { 0 1 1 } ] [ { 0 0 0 } { 0 1/2 1/2 } { 0 0 1 } -1 project-pt-plane ] unit-test +USING: accessors kernel tools.test euler.b-rep euler.operators +euler.modeling game.models.half-edge ; +IN: euler.modeling.tests + +! polygon>double-face +[ ] [ + [ + { { -1 -1 0 } { 1 -1 0 } { 1 1 0 } { -1 1 0 } } + smooth-smooth polygon>double-face + [ face-sides 4 assert= ] + [ opposite-edge>> face-sides 4 assert= ] + [ face-normal { 0.0 0.0 1.0 } assert= ] + tri + ] make-b-rep check-b-rep +] unit-test + +! extrude-simple +[ ] [ + [ + { { -1 -1 0 } { 1 -1 0 } { 1 1 0 } } + smooth-smooth polygon>double-face + 1 f extrude-simple + [ face-sides 3 assert= ] + [ opposite-edge>> face-sides 4 assert= ] + bi + ] make-b-rep check-b-rep +] unit-test + +! project-pt-line +[ { 0 1 0 } ] [ { 0 0 0 } { 0 1 0 } { 1 1 0 } project-pt-line ] unit-test +[ { 0 1 0 } ] [ { 0 0 0 } { 1 1 0 } { 0 1 0 } project-pt-line ] unit-test +[ { 0 1 0 } ] [ { 0 0 0 } { 2 1 0 } { 1 1 0 } project-pt-line ] unit-test +[ { -1 1 0 } ] [ { -1 0 0 } { 2 1 0 } { 1 1 0 } project-pt-line ] unit-test +[ { 1/2 1/2 0 } ] [ { 0 0 0 } { 0 1 0 } { 1 0 0 } project-pt-line ] unit-test + +! project-pt-plane +[ { 0 0 1 } ] [ { 0 0 0 } { 0 0 1 } { 0 0 1 } -1 project-pt-plane ] unit-test +[ { 0 0 -1 } ] [ { 0 0 0 } { 0 0 1 } { 0 0 1 } 1 project-pt-plane ] unit-test +[ { 0 0 3 } ] [ { 0 0 0 } { 0 0 1 } { 0 0 1 } -3 project-pt-plane ] unit-test +[ { 0 0 3 } ] [ { 0 0 0 } { 0 0 1 } { 0 0 -1 } 3 project-pt-plane ] unit-test +[ { 0 0 1 } ] [ { 0 0 0 } { 0 0 1 } { 0 1 1 } -1 project-pt-plane ] unit-test + +[ { 0 2/3 1/3 } ] [ { 0 0 0 } { 0 2 1 } { 0 1 1 } -1 project-pt-plane ] unit-test + +[ { 0 0 1 } ] [ { 0 0 0 } { 0 0 1/2 } { 0 0 1 } -1 project-pt-plane ] unit-test +[ { 0 1 1 } ] [ { 0 0 0 } { 0 1/2 1/2 } { 0 0 1 } -1 project-pt-plane ] unit-test diff --git a/extra/euler/modeling/modeling.factor b/extra/euler/modeling/modeling.factor index 7b4dfa21e0..21c6974283 100644 --- a/extra/euler/modeling/modeling.factor +++ b/extra/euler/modeling/modeling.factor @@ -1,78 +1,78 @@ -! Copyright (C) 2010 Slava Pestov. -USING: accessors combinators fry kernel locals math.vectors -namespaces sets sequences game.models.half-edge euler.b-rep -euler.operators math ; -IN: euler.modeling - -: (polygon>double-face) ( polygon -- edge ) - [ first2 make-vefs ] keep - [ drop opposite-edge>> ] [ 2 tail-slice [ make-ev-one ] each ] 2bi - make-ef face-ccw ; - -SYMBOLS: smooth-smooth -sharp-smooth -smooth-sharp -sharp-sharp -smooth-like-vertex -sharp-like-vertex -smooth-continue -sharp-continue ; - -: polygon>double-face ( polygon mode -- edge ) - ! This only handles the simple case with no repeating vertices - drop - dup all-unique? [ "polygon>double-face doesn't support repeating vertices yet" throw ] unless - (polygon>double-face) ; - -:: extrude-simple ( edge dist sharp? -- edge ) - edge face-normal dist v*n :> vec - edge vertex-pos vec v+ :> pos - edge pos make-ev-one :> e0! - e0 opposite-edge>> :> e-end - edge face-ccw :> edge! - - [ edge e-end eq? not ] [ - edge vertex-pos vec v+ :> pos - edge pos make-ev-one :> e1 - e0 e1 make-ef drop - e1 e0! - edge face-ccw edge! - ] do while - - e-end face-ccw :> e-end - e0 e-end make-ef drop - - e-end ; - -: check-bridge-rings ( e1 e2 -- ) - { - [ [ face>> assert-no-rings ] bi@ ] - [ [ face>> assert-base-face ] bi@ ] - [ assert-different-faces ] - [ [ face-sides ] bi@ assert= ] - } 2cleave ; - -:: bridge-rings-simple ( e1 e2 sharp? -- edge ) - e1 e2 check-bridge-rings - e1 e2 kill-f-make-rh - e1 e2 make-e-kill-r face-cw :> ea! - e2 face-ccw :> eb! - [ ea e1 eq? not ] [ - ea eb make-ef opposite-edge>> face-cw ea! - eb face-ccw eb! - ] while - eb ; - -:: project-pt-line ( p p0 p1 -- q ) - p1 p0 v- :> vt - p p0 v- vt v* sum - vt norm-sq / - vt n*v p0 v+ ; inline - -:: project-pt-plane ( line-p0 line-vt plane-n plane-d -- q ) - plane-d neg plane-n line-p0 v. - - line-vt plane-n v. / - line-vt n*v line-p0 v+ ; inline - -: project-poly-plane ( poly vdir plane-n plane-d -- qoly ) - '[ _ _ _ project-pt-plane ] map ; inline +! Copyright (C) 2010 Slava Pestov. +USING: accessors combinators fry kernel locals math.vectors +namespaces sets sequences game.models.half-edge euler.b-rep +euler.operators math ; +IN: euler.modeling + +: (polygon>double-face) ( polygon -- edge ) + [ first2 make-vefs ] keep + [ drop opposite-edge>> ] [ 2 tail-slice [ make-ev-one ] each ] 2bi + make-ef face-ccw ; + +SYMBOLS: smooth-smooth +sharp-smooth +smooth-sharp +sharp-sharp +smooth-like-vertex +sharp-like-vertex +smooth-continue +sharp-continue ; + +: polygon>double-face ( polygon mode -- edge ) + ! This only handles the simple case with no repeating vertices + drop + dup all-unique? [ "polygon>double-face doesn't support repeating vertices yet" throw ] unless + (polygon>double-face) ; + +:: extrude-simple ( edge dist sharp? -- edge ) + edge face-normal dist v*n :> vec + edge vertex-pos vec v+ :> pos + edge pos make-ev-one :> e0! + e0 opposite-edge>> :> e-end + edge face-ccw :> edge! + + [ edge e-end eq? not ] [ + edge vertex-pos vec v+ :> pos + edge pos make-ev-one :> e1 + e0 e1 make-ef drop + e1 e0! + edge face-ccw edge! + ] do while + + e-end face-ccw :> e-end + e0 e-end make-ef drop + + e-end ; + +: check-bridge-rings ( e1 e2 -- ) + { + [ [ face>> assert-no-rings ] bi@ ] + [ [ face>> assert-base-face ] bi@ ] + [ assert-different-faces ] + [ [ face-sides ] bi@ assert= ] + } 2cleave ; + +:: bridge-rings-simple ( e1 e2 sharp? -- edge ) + e1 e2 check-bridge-rings + e1 e2 kill-f-make-rh + e1 e2 make-e-kill-r face-cw :> ea! + e2 face-ccw :> eb! + [ ea e1 eq? not ] [ + ea eb make-ef opposite-edge>> face-cw ea! + eb face-ccw eb! + ] while + eb ; + +:: project-pt-line ( p p0 p1 -- q ) + p1 p0 v- :> vt + p p0 v- vt v* sum + vt norm-sq / + vt n*v p0 v+ ; inline + +:: project-pt-plane ( line-p0 line-vt plane-n plane-d -- q ) + plane-d neg plane-n line-p0 v. - + line-vt plane-n v. / + line-vt n*v line-p0 v+ ; inline + +: project-poly-plane ( poly vdir plane-n plane-d -- qoly ) + '[ _ _ _ project-pt-plane ] map ; inline diff --git a/extra/euler/operators/operators.factor b/extra/euler/operators/operators.factor index f144df45b9..f2dea708d1 100644 --- a/extra/euler/operators/operators.factor +++ b/extra/euler/operators/operators.factor @@ -253,7 +253,7 @@ TYPED:: kill-ef ( edge: b-edge -- ) e1 [ f2 >>face drop ] each-face-edge f1 b-rep delete-face - e1 e2 incident? [ + e1 e2 incident? [ e2 next-edge>> e2p next-edge<< ] [ diff --git a/extra/fastcgi/fastcgi.factor b/extra/fastcgi/fastcgi.factor index 7c4da7d50a..d02d89728c 100644 --- a/extra/fastcgi/fastcgi.factor +++ b/extra/fastcgi/fastcgi.factor @@ -84,7 +84,7 @@ ENUM: fcgi-protocol-status t ] [ 2drop f ] if ] loop ; - + : delete-if-exists ( file -- ) dup exists? [ delete-file ] [ drop ] if ; @@ -189,9 +189,9 @@ ENUM: fcgi-protocol-status [ . ] debug-print ; : fcgi-handler ( -- ) - make-new-request parse-packets + make-new-request parse-packets prepare-request - "/path" main-responder get call-responder* + "/path" main-responder get call-responder* [ content-type>> "\n\n" append ] [ body>> ] bi append write-response ; : ( addr -- server ) @@ -202,7 +202,7 @@ ENUM: fcgi-protocol-status [ fcgi-handler ] >>handler ; : test-output ( -- str ) - "
    " 
+    "
    "
     request tget header>> [ "%s => %s\n" sprintf ] { }
     assoc>map concat append
     "
    " append ;
diff --git a/extra/fjsc/fjsc.factor b/extra/fjsc/fjsc.factor
index 8c2e883c58..065ddc0dfe 100644
--- a/extra/fjsc/fjsc.factor
+++ b/extra/fjsc/fjsc.factor
@@ -360,4 +360,3 @@ M: quotation fjsc-parse ( object -- ast )
     [
         [ (literal) ] { } make [ write ] each
     ] with-string-writer ;
-
diff --git a/extra/flip-text/flip-text.factor b/extra/flip-text/flip-text.factor
index 07e5e3977d..a1bb0c7558 100644
--- a/extra/flip-text/flip-text.factor
+++ b/extra/flip-text/flip-text.factor
@@ -97,5 +97,3 @@ PRIVATE>
 
 : flip-text ( str -- str' )
     [ ch>flip ] map reverse ;
-
-
diff --git a/extra/fluids/fluids.factor b/extra/fluids/fluids.factor
index 87fa4b93e7..21e3b24278 100644
--- a/extra/fluids/fluids.factor
+++ b/extra/fluids/fluids.factor
@@ -29,7 +29,7 @@ CONSTANT: initial-particles
 particle_t-array{
     S{ particle_t f float-array{ 0.5 0.6 } float-array{ 0 0.1 } 1.0 }
     S{ particle_t f float-array{ 0.5 0.6 } float-array{ 0.1 0 } 3.0 }
-    
+
     S{ particle_t f float-array{ 0.5 0.5 } float-array{ 0.1 0.1 } 2.0 }
     S{ particle_t f float-array{ 0.5 0.6 } float-array{ -0.1 0 } 1.0 }
     S{ particle_t f float-array{ 0.6 0.5 } float-array{ 0 -0.1 } 3.0 }
@@ -92,8 +92,8 @@ M:: fluids-world draw-world* ( world -- )
     world particles>> [
         [ p>> [ first , ] [ second , ] bi ] each
     ] curry float-array{ } make :> verts
-    
-    [ 
+
+    [
         verts world texture>> 30.0 world dim>> { 4 4 } v/
         blended-point-sprite-batch &dispose
         blend-state new set-gpu-state
diff --git a/extra/forestdb/lib/lib.factor b/extra/forestdb/lib/lib.factor
index 4e76208298..f3ce44dc86 100644
--- a/extra/forestdb/lib/lib.factor
+++ b/extra/forestdb/lib/lib.factor
@@ -411,4 +411,4 @@ PRIVATE>
 : with-forestdb-path ( path quot -- )
     [ absolute-path fdb-open-default-config ] dip with-forestdb-handles-commit-wal ; inline
     ! [ absolute-path fdb-open-default-config ] dip with-forestdb-handle-commit-normal ; inline
-*/
\ No newline at end of file
+*/
diff --git a/extra/forestdb/paths/paths.factor b/extra/forestdb/paths/paths.factor
index af6c397211..37d010bb18 100644
--- a/extra/forestdb/paths/paths.factor
+++ b/extra/forestdb/paths/paths.factor
@@ -81,4 +81,3 @@ ERROR: not-a-string-number string ;
 
 ! : path>next-vnode-version-name ( path -- path' )
     ! [ file-name ] 
-
diff --git a/extra/forestdb/utils/utils.factor b/extra/forestdb/utils/utils.factor
index 36a440c92b..ea86d0d495 100644
--- a/extra/forestdb/utils/utils.factor
+++ b/extra/forestdb/utils/utils.factor
@@ -35,4 +35,3 @@ IN: forestdb.utils
 
 : set-kv-range ( a b -- )
     make-kv-range [ fdb-set-kv ] assoc-each ;
-
diff --git a/extra/freetype/freetype.factor b/extra/freetype/freetype.factor
index e7b59ca60f..ed682ca85b 100644
--- a/extra/freetype/freetype.factor
+++ b/extra/freetype/freetype.factor
@@ -197,4 +197,3 @@ FUNCTION: void FT_Done_Face ( face* face ) ;
 FUNCTION: void FT_Done_FreeType ( void* library ) ;
 
 FUNCTION: FT_Long FT_MulFix ( FT_Long a, FT_Long b ) ;
-
diff --git a/extra/fuel/remote/remote.factor b/extra/fuel/remote/remote.factor
index b643614226..27f0ffc9dd 100644
--- a/extra/fuel/remote/remote.factor
+++ b/extra/fuel/remote/remote.factor
@@ -18,4 +18,3 @@ PRIVATE>
     print-banner integer? [ 9000 ] unless*  start-server drop ;
 
 : fuel-start-remote-listener* ( -- ) f fuel-start-remote-listener ;
-
diff --git a/extra/fullscreen/fullscreen.factor b/extra/fullscreen/fullscreen.factor
index 56c1426554..7b30d25f0e 100755
--- a/extra/fullscreen/fullscreen.factor
+++ b/extra/fullscreen/fullscreen.factor
@@ -64,7 +64,7 @@ ERROR: display-change-error n ;
 
 : get-style ( hwnd n -- style )
     GetWindowLongPtr [ win32-error=0/f ] keep ;
-    
+
 : set-style ( hwnd n style -- )
     SetWindowLongPtr win32-error=0/f ;
 
@@ -100,7 +100,7 @@ ERROR: unsupported-resolution triple ;
 
 :: enable-fullscreen ( triple hwnd -- rect )
     hwnd hwnd>RECT :> rect
-    
+
     desktop-monitor-info
     triple GetDesktopWindow find-devmode
     hwnd set-fullscreen-styles
diff --git a/extra/game/debug/debug.factor b/extra/game/debug/debug.factor
index 1bdc3fc295..c05f3488f1 100644
--- a/extra/game/debug/debug.factor
+++ b/extra/game/debug/debug.factor
@@ -80,21 +80,21 @@ GLSL-PROGRAM: debug-text-program debug-text-vertex-shader
 debug-text-fragment-shader debug-text-vertex-format ;
 
 CONSTANT: debug-text-font
-    T{ font 
+    T{ font
        { name       "monospace"  }
        { size       16           }
        { bold?      f            }
        { italic?    f            }
        { foreground COLOR: white }
        { background COLOR: black } }
-       
-CONSTANT: debug-text-texture-parameters       
+
+CONSTANT: debug-text-texture-parameters
     T{ texture-parameters
        { wrap              repeat-texcoord }
        { min-filter        filter-linear   }
        { min-mipmap-filter f               } }
-       
-: text>image ( string color -- image )      
+
+: text>image ( string color -- image )
     debug-text-font clone swap >>foreground swap string>image drop ;
 
 :: image>texture ( image -- texture )
@@ -119,7 +119,7 @@ CONSTANT: debug-text-texture-parameters
 : debug-text-vertex-array ( image pt dim -- vertex-array )
     screen-quad stream-upload draw-usage vertex-buffer byte-array>buffer &dispose
     debug-text-program   &dispose ;
- 
+
 : debug-text-index-buffer ( -- index-buffer )
     uint-array{ 0 1 2 2 3 0 } stream-upload draw-usage index-buffer
     byte-array>buffer &dispose 0  6 uint-indexes  ;
@@ -160,10 +160,10 @@ CONSTANT: box-vertices
       { { -1  1 -1 } {  1  1 -1 } }
       { {  1 -1 -1 } {  1 -1  1 } }
       { {  1 -1 -1 } {  1  1 -1 } } }
-      
+
 CONSTANT: cylinder-vertices
     $[ 12 iota [ 2pi 12 / * [ cos ] [ drop 0.0 ] [ sin ] tri 3array ] map ]
-    
+
 :: scale-cylinder-vertices ( radius half-height verts -- bot-verts top-verts )
     verts
     [ [ radius v*n { 0 half-height 0 } v- ] map ]
@@ -183,7 +183,7 @@ PRIVATE>
     [ 1  normalize over v+ COLOR: green debug-line ]
     [ 2  normalize over v+ COLOR: blue debug-line ]
     2tri ; inline
-        
+
 :: debug-box ( pt half-widths color -- )
     box-vertices [
         first2 [ half-widths v* pt v+ ] bi@ color debug-line
@@ -203,7 +203,7 @@ TYPED: draw-debug-lines ( lines: float-array mvp-matrix -- )
 
 TYPED: draw-debug-points ( points: float-array mvp-matrix -- )
     [ points-mode -rot draw-debug-primitives ] with-destructors ; inline
-        
+
 TYPED: draw-text ( string color: rgba pt dim -- )
     [
         [ debug-text-uniform-variables ] 2dip
diff --git a/extra/game/debug/tests/tests.factor b/extra/game/debug/tests/tests.factor
index b6bcacc780..2bc2f3e708 100644
--- a/extra/game/debug/tests/tests.factor
+++ b/extra/game/debug/tests/tests.factor
@@ -19,7 +19,7 @@ IN: game.debug.tests
 :: draw-debug-tests ( world -- )
     world [ wasd-p-matrix ] [ wasd-mv-matrix ] bi m. :> mvp-matrix
     { 0 0 0 } clear-screen
-    
+
     [
         { 0 0 0 } { 1 0 0 } COLOR: red   debug-line
         { 0 0 0 } { 0 1 0 } COLOR: green debug-line
diff --git a/extra/game/input/demos/key-caps/key-caps.factor b/extra/game/input/demos/key-caps/key-caps.factor
index c8d8e0bc53..1788ad1320 100644
--- a/extra/game/input/demos/key-caps/key-caps.factor
+++ b/extra/game/input/demos/key-caps/key-caps.factor
@@ -93,7 +93,7 @@ CONSTANT: key-locations H{
     { key-print-screen  { { 155   0 } {  10  10 } } }
     { key-scroll-lock   { { 165   0 } {  10  10 } } }
     { key-pause         { { 175   0 } {  10  10 } } }
-    
+
     { key-insert        { { 155  15 } {  10  10 } } }
     { key-home          { { 165  15 } {  10  10 } } }
     { key-page-up       { { 175  15 } {  10  10 } } }
@@ -137,8 +137,8 @@ CONSTANT: FREQUENCY $[ 1/30 seconds ]
 TUPLE: key-caps-gadget < gadget keys timer ;
 
 : make-key-gadget ( scancode dim array -- )
-    [ 
-        swap [ 
+    [
+        swap [
             " " [ drop ] 
             swap [ first >>loc ] [ second >>dim ] bi
         ] [ execute( -- value ) ] bi*
@@ -147,7 +147,7 @@ TUPLE: key-caps-gadget < gadget keys timer ;
 : add-keys-gadgets ( gadget -- gadget )
     key-locations 256 f 
     [ [ make-key-gadget ] curry assoc-each ]
-    [ [ [ add-gadget ] when* ] each ] 
+    [ [ [ add-gadget ] when* ] each ]
     [ >>keys ] tri ;
 
 :  ( -- gadget )
@@ -157,8 +157,8 @@ TUPLE: key-caps-gadget < gadget keys timer ;
 M: key-caps-gadget pref-dim* drop KEYBOARD-SIZE ;
 
 : update-key-caps-state ( gadget -- )
-    read-keyboard keys>> over keys>> 
-    [ [ selected?<< ] [ drop ] if* ] 2each 
+    read-keyboard keys>> over keys>>
+    [ [ selected?<< ] [ drop ] if* ] 2each
     relayout-1 ;
 
 M: key-caps-gadget graft*
diff --git a/extra/game/loop/benchmark/benchmark.factor b/extra/game/loop/benchmark/benchmark.factor
index 9e1b3fe915..2584c08fba 100644
--- a/extra/game/loop/benchmark/benchmark.factor
+++ b/extra/game/loop/benchmark/benchmark.factor
@@ -34,4 +34,3 @@ M: game-loop record-benchmarking ( loop quot: ( loop -- benchmark-data-pair ) --
     ]
     [ drop ensure-benchmark-data ]
     2bi push ;
-                                
diff --git a/extra/game/models/half-edge/half-edge.factor b/extra/game/models/half-edge/half-edge.factor
index eeb3e6116f..26095b6842 100644
--- a/extra/game/models/half-edge/half-edge.factor
+++ b/extra/game/models/half-edge/half-edge.factor
@@ -29,7 +29,7 @@ TUPLE: edge < identity-tuple face vertex opposite-edge next-edge ;
 : each-face-edge ( ... edge quot: ( ... edge -- ... ) -- ... )
     [ next-edge>> ] edge-loop ; inline
 
-! 
+!
 
 : vertex-edges ( edge -- edges )
     [ ] [ each-vertex-edge ] (collect) ;
@@ -51,4 +51,3 @@ TUPLE: edge < identity-tuple face vertex opposite-edge next-edge ;
 
 : face-sides ( edge -- count )
     [ each-face-edge ] (count) ;
-
diff --git a/extra/game/models/models.factor b/extra/game/models/models.factor
index fad59b853e..1069562c18 100644
--- a/extra/game/models/models.factor
+++ b/extra/game/models/models.factor
@@ -4,4 +4,3 @@ USING: ;
 IN: game.models
 
 TUPLE: model attribute-buffer index-buffer vertex-format material ;
-
diff --git a/extra/game/models/obj/obj.factor b/extra/game/models/obj/obj.factor
index 33e871a91f..15d1e2133c 100644
--- a/extra/game/models/obj/obj.factor
+++ b/extra/game/models/obj/obj.factor
@@ -158,4 +158,3 @@ M: obj-models stream>models
         [ line>obj ] each-stream-line push-current-model
         models get
     ] with-variables ;
-
diff --git a/extra/game/models/util/util.factor b/extra/game/models/util/util.factor
index de25ad4a1a..4d617aefea 100644
--- a/extra/game/models/util/util.factor
+++ b/extra/game/models/util/util.factor
@@ -41,4 +41,3 @@ M: indexed-seq new-resizable
     [ [ iseq>> new-resizable ] keep iseq<< ]
     [ [ rassoc>> clone nip ] keep rassoc<< ]
     2tri ;
-
diff --git a/extra/gdbm/gdbm.factor b/extra/gdbm/gdbm.factor
index be0838404c..b7573072a5 100644
--- a/extra/gdbm/gdbm.factor
+++ b/extra/gdbm/gdbm.factor
@@ -160,4 +160,3 @@ PRIVATE>
 
 : with-gdbm-writer ( name quot -- )
     writer swap with-gdbm-role ; inline
-
diff --git a/extra/geobytes/geobytes.factor b/extra/geobytes/geobytes.factor
index c398bdde7a..cb366672c5 100644
--- a/extra/geobytes/geobytes.factor
+++ b/extra/geobytes/geobytes.factor
@@ -47,7 +47,7 @@ MEMO: load-countries ( -- seq )
                 [ ]
                 [ ]
             } spread country boa
-        ] inputnumber ]
             } spread city boa
-        ] inputnumber ]
             } spread version boa
-        ] inputdouble-face ;
-
-GML: extrude-simple ( edge dist sharp -- edge ) extrude-simple ;
-
-GML: bridgerings-simple ( e1 e2 sharp -- edge ) bridge-rings-simple ;
-
-GML: project_ptline ( p p0 p1 -- q ) project-pt-line ;
-
-GML: project_ptplane ( p dir n d -- q ) project-pt-plane ;
-
-GML: project_polyplane ( [p] dir n d -- [q] ) project-poly-plane ;
+! Copyright (C) 2010 Slava Pestov.
+USING: kernel sequences euler.modeling gml.runtime ;
+IN: gml.modeling
+
+GML: poly2doubleface ( poly mode -- edge )
+    {
+        smooth-smooth
+        sharp-smooth
+        smooth-sharp
+        sharp-sharp
+        smooth-like-vertex
+        sharp-like-vertex
+        smooth-continue
+        sharp-continue
+    } nth polygon>double-face ;
+
+GML: extrude-simple ( edge dist sharp -- edge ) extrude-simple ;
+
+GML: bridgerings-simple ( e1 e2 sharp -- edge ) bridge-rings-simple ;
+
+GML: project_ptline ( p p0 p1 -- q ) project-pt-line ;
+
+GML: project_ptplane ( p dir n d -- q ) project-pt-plane ;
+
+GML: project_polyplane ( [p] dir n d -- [q] ) project-poly-plane ;
diff --git a/extra/gml/parser/parser.factor b/extra/gml/parser/parser.factor
index 60d97b0777..9b198719b9 100644
--- a/extra/gml/parser/parser.factor
+++ b/extra/gml/parser/parser.factor
@@ -125,4 +125,3 @@ Tokens = Token* => [[ [ comment? ] reject ]]
 Program = Tokens Spaces !(.) => [[ parse-proc ]]
 
 ;EBNF
-
diff --git a/extra/gml/runtime/runtime.factor b/extra/gml/runtime/runtime.factor
index 4b6424bdf9..798de511e4 100644
--- a/extra/gml/runtime/runtime.factor
+++ b/extra/gml/runtime/runtime.factor
@@ -199,7 +199,7 @@ SYNTAX: GML::
         scan-gml-name :> ( word name )
         word [ parse-definition ] parse-locals-definition :> ( word def effect )
         word name effect def define-gml-primitive
-    ] ; 
+    ] ;
 
 :  ( -- gml )
     gml new
diff --git a/extra/gml/ui/ui.factor b/extra/gml/ui/ui.factor
index 1ea385db8a..aac7d3c4a3 100644
--- a/extra/gml/ui/ui.factor
+++ b/extra/gml/ui/ui.factor
@@ -1,121 +1,121 @@
-! Copyright (C) 2010 Slava Pestov.
-USING: arrays accessors euler.b-rep fry gml gml.runtime gml.viewer
-gml.printer io.directories io.encodings.utf8 io.files
-io.pathnames io.streams.string kernel locals models namespaces
-sequences ui ui.gadgets ui.gadgets.buttons ui.gadgets.editors
-ui.gadgets.frames ui.gadgets.grids ui.gadgets.labels
-ui.gadgets.packs ui.gadgets.scrollers ui.gadgets.worlds
-ui.gadgets.tables ui.gadgets.labeled unicode.case ;
-FROM: gml => gml ;
-IN: gml.ui
-
-SINGLETON: stack-entry-renderer
-
-M: stack-entry-renderer row-columns
-    drop [ write-gml ] with-string-writer 1array ;
-
-M: stack-entry-renderer row-value
-    drop ;
-
-:  ( model -- table )
-    stack-entry-renderer 
-        10 >>min-rows
-        10 >>max-rows
-        40 >>min-cols
-        40 >>max-cols ;
-
-:  ( model -- gadget )
-      "Operand stack"  ;
-
-TUPLE: gml-editor < frame editor gml stack-model b-rep b-rep-model ;
-
-: update-models ( gml-editor -- )
-    [ [ b-rep>> dup finish-b-rep ] [ b-rep-model>> ] bi set-model ]
-    [ [ gml>> operand-stack>> ] [ stack-model>> ] bi set-model ]
-    bi ;
-
-: with-gml-editor ( gml-editor quot -- )
-    '[
-        [ [ gml>> gml set ] [ b-rep>> b-rep set ] bi @ ]
-        [ update-models ]
-        bi
-    ] with-scope ; inline
-
-: find-gml-editor ( gadget -- gml-editor )
-    [ gml-editor? ] find-parent ;
-
-: load-input ( file gml-editor -- )
-    [ utf8 file-contents ] dip editor>> set-editor-string ;
-
-: update-viewer ( gml-editor -- )
-    dup [ editor>> editor-string run-gml-string ] with-gml-editor ;
-
-: new-viewer ( gml-editor -- )
-    [ update-viewer ]
-    [ [ b-rep-model>> ] [ stack-model>> ] bi gml-viewer ]
-    bi ;
-
-: reset-viewer ( gml-editor -- )
-    [
-        b-rep get clear-b-rep
-        gml get operand-stack>> delete-all
-    ] with-gml-editor ;
-
-:  ( -- button )
-    "New viewer" [ find-gml-editor new-viewer ]  ;
-
-:  ( -- button )
-    "Update viewer" [ find-gml-editor update-viewer ]  ;
-
-:  ( -- button )
-    "Reset viewer" [ find-gml-editor reset-viewer ]  ;
-
-:  ( -- gadget )
-     { 5 5 } >>gap
-     add-gadget
-     add-gadget
-     add-gadget ;
-
-CONSTANT: example-dir "vocab:gml/examples/"
-
-: gml-files ( -- seq )
-    example-dir directory-files
-    [ file-extension >lower "gml" = ] filter ;
-
-:  ( file -- button )
-    dup '[ example-dir _ append-path swap find-gml-editor load-input ]
-     ;
-
-:  ( -- gadget )
-    gml-files
-     { 5 5 } >>gap 
-    "Examples:" 
    
+        10 >>min-rows
+        10 >>max-rows
+        40 >>min-cols
+        40 >>max-cols ;
+
+:  ( model -- gadget )
+      "Operand stack"  ;
+
+TUPLE: gml-editor < frame editor gml stack-model b-rep b-rep-model ;
+
+: update-models ( gml-editor -- )
+    [ [ b-rep>> dup finish-b-rep ] [ b-rep-model>> ] bi set-model ]
+    [ [ gml>> operand-stack>> ] [ stack-model>> ] bi set-model ]
+    bi ;
+
+: with-gml-editor ( gml-editor quot -- )
+    '[
+        [ [ gml>> gml set ] [ b-rep>> b-rep set ] bi @ ]
+        [ update-models ]
+        bi
+    ] with-scope ; inline
+
+: find-gml-editor ( gadget -- gml-editor )
+    [ gml-editor? ] find-parent ;
+
+: load-input ( file gml-editor -- )
+    [ utf8 file-contents ] dip editor>> set-editor-string ;
+
+: update-viewer ( gml-editor -- )
+    dup [ editor>> editor-string run-gml-string ] with-gml-editor ;
+
+: new-viewer ( gml-editor -- )
+    [ update-viewer ]
+    [ [ b-rep-model>> ] [ stack-model>> ] bi gml-viewer ]
+    bi ;
+
+: reset-viewer ( gml-editor -- )
+    [
+        b-rep get clear-b-rep
+        gml get operand-stack>> delete-all
+    ] with-gml-editor ;
+
+:  ( -- button )
+    "New viewer" [ find-gml-editor new-viewer ]  ;
+
+:  ( -- button )
+    "Update viewer" [ find-gml-editor update-viewer ]  ;
+
+:  ( -- button )
+    "Reset viewer" [ find-gml-editor reset-viewer ]  ;
+
+:  ( -- gadget )
+     { 5 5 } >>gap
+     add-gadget
+     add-gadget
+     add-gadget ;
+
+CONSTANT: example-dir "vocab:gml/examples/"
+
+: gml-files ( -- seq )
+    example-dir directory-files
+    [ file-extension >lower "gml" = ] filter ;
+
+:  ( file -- button )
+    dup '[ example-dir _ append-path swap find-gml-editor load-input ]
+     ;
+
+:  ( -- gadget )
+    gml-files
+     { 5 5 } >>gap
+    "Examples:" 
     swap data>> push ;
 
 M: pdf-writer dispose drop ;
-
diff --git a/extra/pdf/text/text.factor b/extra/pdf/text/text.factor
index 338c5d772b..64e0c71f81 100644
--- a/extra/pdf/text/text.factor
+++ b/extra/pdf/text/text.factor
@@ -78,7 +78,3 @@ IN: pdf.text
 : b ( -- ) "b" print ;
 
 : c ( -- ) "300 400 400 400 400 300 c" print ; ! FIXME:
-
-
-
-
diff --git a/extra/pdf/wrap/wrap.factor b/extra/pdf/wrap/wrap.factor
index 59058d21d7..0b137212a3 100644
--- a/extra/pdf/wrap/wrap.factor
+++ b/extra/pdf/wrap/wrap.factor
@@ -41,4 +41,3 @@ PRIVATE>
 
 : visual-wrap ( line font line-width -- lines )
     [ string>elements ] dip dup wrap [ concat ] map ;
-
diff --git a/extra/peg/javascript/javascript-docs.factor b/extra/peg/javascript/javascript-docs.factor
index c05a61b235..b6b1f41e47 100644
--- a/extra/peg/javascript/javascript-docs.factor
+++ b/extra/peg/javascript/javascript-docs.factor
@@ -1,14 +1,14 @@
-! Copyright (C) 2007 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax strings ;
-IN: peg.javascript
-
-HELP: parse-javascript
-{ $values
-  { "string" string }
-  { "ast" "a JavaScript abstract syntax tree" }
-}
-{ $description
-    "Parse the input string using the JavaScript parser. Throws an error if "
-    "the string does not contain valid JavaScript. Returns the abstract syntax tree "
-    "if successful." } ;
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax strings ;
+IN: peg.javascript
+
+HELP: parse-javascript
+{ $values
+  { "string" string }
+  { "ast" "a JavaScript abstract syntax tree" }
+}
+{ $description
+    "Parse the input string using the JavaScript parser. Throws an error if "
+    "the string does not contain valid JavaScript. Returns the abstract syntax tree "
+    "if successful." } ;
diff --git a/extra/peg/javascript/parser/parser.factor b/extra/peg/javascript/parser/parser.factor
index 82b50c454a..95c3286511 100644
--- a/extra/peg/javascript/parser/parser.factor
+++ b/extra/peg/javascript/parser/parser.factor
@@ -197,4 +197,4 @@ SrcElem            =   "function" Name:n FuncRest:f                  => [[ n f a
                      | Stmt
 SrcElems           = SrcElem*                                      => [[ ast-begin boa ]]
 TopLevel           = SrcElems Spaces                               
-;EBNF
\ No newline at end of file
+;EBNF
diff --git a/extra/peg/javascript/tokenizer/tokenizer.factor b/extra/peg/javascript/tokenizer/tokenizer.factor
index 34beedcaea..5aade74fb3 100644
--- a/extra/peg/javascript/tokenizer/tokenizer.factor
+++ b/extra/peg/javascript/tokenizer/tokenizer.factor
@@ -77,4 +77,3 @@ Special            =   "("    | ")"   | "{"   | "}"   | "["   | "]"   | ","   |
 Tok                = Spaces (Name | Keyword | Number | Str | RegExp | Special )
 Toks               = Tok* Spaces 
 ;EBNF
-
diff --git a/extra/persistency/persistency.factor b/extra/persistency/persistency.factor
index 58ab480537..92ee7374f9 100644
--- a/extra/persistency/persistency.factor
+++ b/extra/persistency/persistency.factor
@@ -24,7 +24,7 @@ SYNTAX: STORED-TUPLE: parse-tuple-definition [ drop persistent ] dip [ remove-ty
 : store-tuple ( tuple -- ) [ insert-tuple ] w/db ;
 : modify-tuple ( tuple -- ) [ update-tuple ] w/db ;
 : remove-tuples ( tuple -- ) [ delete-tuples ] w/db ;
-    
+
 TUPLE: pattern value ; C:  pattern
 SYNTAX: %" parse-string  suffix! ;
 M: pattern where value>> over column-name>> 0% " LIKE " 0% bind# ;
diff --git a/extra/picomath/picomath.factor b/extra/picomath/picomath.factor
index ff614b58d2..51e8433c14 100644
--- a/extra/picomath/picomath.factor
+++ b/extra/picomath/picomath.factor
@@ -367,7 +367,7 @@ DEFER: gamma
 :: log-gamma ( x -- value )
     x 0 <= [ "Invalid input" throw ] when
     x 12 < [ x gamma abs log ] [
-        1.0 x x * / :> z 
+        1.0 x x * / :> z
         7 c nth 7 iota reverse [ [ z * ] [ c nth ] bi* + ] each x / :> series
         x 0.5 - x log * x - halfLogTwoPi + series +
     ] if ;
diff --git a/extra/ping/ping.factor b/extra/ping/ping.factor
index 4988a486b0..df7e9e3315 100644
--- a/extra/ping/ping.factor
+++ b/extra/ping/ping.factor
@@ -59,4 +59,3 @@ M: macosx   ;
 
 : alive? ( host -- ? )
     [ ping drop t ] [ 2drop f ] recover ;
-
diff --git a/extra/pong/pong.factor b/extra/pong/pong.factor
index e7e6c47002..4f77e431ff 100644
--- a/extra/pong/pong.factor
+++ b/extra/pong/pong.factor
@@ -9,12 +9,12 @@ FROM: syntax => M: ;
 IN: pong
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! 
+!
 ! Inspired by this Ruby/Shoes version by why: http://gist.github.com/26431
 !
 ! Which was based on this Nodebox version: http://billmill.org/pong.html
 ! by Bill Mill.
-! 
+!
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : clamp-to-interval ( x interval -- x )
@@ -68,7 +68,7 @@ TUPLE:  < 
 : mouse-x ( -- x ) hand-loc get first ;
 
 :: valid-paddle-interval ( PADDLE PLAY-FIELD -- interval )
-    
+
    PLAY-FIELD [ left ] [ right ] bi PADDLE width - [a,b] ;
 
 :: align-paddle-with-mouse ( PADDLE PLAY-FIELD -- )
@@ -80,7 +80,7 @@ TUPLE:  < 
    clamp-to-interval
 
    PADDLE pos>> (x!) ;
-   
+
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 ! Protocol for drawing PONG objects
@@ -103,7 +103,7 @@ TUPLE:  < gadget paused field ball player computer ;
 
 M:  pref-dim* (  -- dim ) drop { 400 400 } ;
 M:  ungraft*  (  --     ) t >>paused drop  ;
-    
+
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 M::  draw-gadget* ( PONG -- )
diff --git a/extra/pop3/server/server.factor b/extra/pop3/server/server.factor
index 8774a2287e..038f40a4b3 100644
--- a/extra/pop3/server/server.factor
+++ b/extra/pop3/server/server.factor
@@ -42,7 +42,7 @@ IN: pop3.server
 ! To: username@host.com
 ! Subject: First test with mock POP3 server
 ! Content-Type: text/plain; charset=UTF-8
-! 
+!
 ! .
 ! DELE 1
 ! +OK Marked for deletion
@@ -55,7 +55,7 @@ IN: pop3.server
         {
             [ dup "USER" head? ]
             [
-                 
+
                 "+OK Password required\r\n"
                 write flush t
             ]
@@ -80,7 +80,7 @@ IN: pop3.server
                 "+OK 2 1753\r\n"
                 write flush t
             ]
-        }       
+        }
         {
             [ dup "LIST" = ]
             [
diff --git a/extra/processing/shapes/shapes.factor b/extra/processing/shapes/shapes.factor
index 8ef832b2e9..f18fe2e523 100644
--- a/extra/processing/shapes/shapes.factor
+++ b/extra/processing/shapes/shapes.factor
@@ -119,4 +119,3 @@ T{ rgba f 1 1 1 1 } fill-color   set-global
 : circle ( center size -- ) dup 2array ellipse ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
diff --git a/extra/progress-bars/models/models.factor b/extra/progress-bars/models/models.factor
index eb53daf925..66b53160be 100644
--- a/extra/progress-bars/models/models.factor
+++ b/extra/progress-bars/models/models.factor
@@ -38,4 +38,3 @@ SYMBOL: file-size
         [ update-file-progress drop ] compose
         with-file-reader
     ] with-progress-bar ; inline
-
diff --git a/extra/progress-bars/progress-bars.factor b/extra/progress-bars/progress-bars.factor
index f1796b4cf2..b397a0b287 100644
--- a/extra/progress-bars/progress-bars.factor
+++ b/extra/progress-bars/progress-bars.factor
@@ -21,4 +21,3 @@ ERROR: invalid-length x ;
 : make-progress-bar ( percent length -- string )
     [ check-percent ] [ check-length ] bi*
     CHAR: = CHAR: - (make-progress-bar) ;
-
diff --git a/extra/project-euler/051/051.factor b/extra/project-euler/051/051.factor
index f0bdd69901..f36f369851 100644
--- a/extra/project-euler/051/051.factor
+++ b/extra/project-euler/051/051.factor
@@ -16,7 +16,7 @@
 ! 56003, 56113, 56333, 56443, 56663, 56773, and 56993.
 ! Consequently 56003, being the first member of this family,
 ! is the smallest prime with this property.
-! 
+!
 ! Find the smallest prime which, by replacing part of the number
 ! (not necessarily adjacent digits) with the same digit,
 ! is part of an eight prime value family.
@@ -34,11 +34,11 @@ IN: project-euler.051
 string families [ handle-family ] each ] each
     large-families get ;
 
@@ -73,8 +73,8 @@ SYMBOL: large-families
 
 ! recursively test all primes by length until we find an answer
 : (euler051) ( i -- answer )
-    dup test-n-digits-primes 
-    dup assoc-size 0 > 
+    dup test-n-digits-primes
+    dup assoc-size 0 >
     [ nip values [ fill-*-with-ones string>number ] [ min ] map-reduce ]
     [ drop 1 + (euler051) ] if ;
 PRIVATE>
diff --git a/extra/project-euler/062/062.factor b/extra/project-euler/062/062.factor
index 037cdc1af5..1a348e77ec 100644
--- a/extra/project-euler/062/062.factor
+++ b/extra/project-euler/062/062.factor
@@ -32,7 +32,7 @@ IN: project-euler.062
         2dup [ >key ] dip
         [ dup 0 swap [ 1 + ] change-nth ] change-at
         2dup [ >key ] dip at first 5 =
-        [ 
+        [
             [ >key ] dip at second
         ] [
             [ 1 + ] dip (euler062)
diff --git a/extra/project-euler/074/074.factor b/extra/project-euler/074/074.factor
index 1fff789cf7..9962847b75 100644
--- a/extra/project-euler/074/074.factor
+++ b/extra/project-euler/074/074.factor
@@ -65,4 +65,3 @@ PRIVATE>
 ! 25134 ms ave run time - 31.96 SD (10 trials)
 
 SOLUTION: euler074
-
diff --git a/extra/project-euler/081/081.factor b/extra/project-euler/081/081.factor
index 73936ba2ed..1c858e63de 100644
--- a/extra/project-euler/081/081.factor
+++ b/extra/project-euler/081/081.factor
@@ -45,7 +45,7 @@ IN: project-euler.081
 :: minimal-path-sum-to ( x y matrix -- n )
     x y + zero? [ 0 ] [
         x zero? [ 0 y 1 - matrix get-matrix
-        ] [ 
+        ] [
             y zero? [
                 x 1 - 0 matrix get-matrix
             ] [
diff --git a/extra/project-euler/102/102.factor b/extra/project-euler/102/102.factor
index 2ad1437e3e..600580201b 100644
--- a/extra/project-euler/102/102.factor
+++ b/extra/project-euler/102/102.factor
@@ -1,6 +1,6 @@
 ! Copyright (c) 2009 Guillaume Nargeot.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays grouping io.encodings.ascii io.files kernel math 
+USING: arrays grouping io.encodings.ascii io.files kernel math
 math.parser sequences splitting project-euler.common ;
 IN: project-euler.102
 
diff --git a/extra/quadtrees/quadtrees.factor b/extra/quadtrees/quadtrees.factor
index 36524da583..95befc24fe 100644
--- a/extra/quadtrees/quadtrees.factor
+++ b/extra/quadtrees/quadtrees.factor
@@ -30,10 +30,10 @@ TUPLE: quadtree { bounds rect } point value ll lr ul ur leaf? ;
 
 : each-quadrant ( node quot -- )
     {
-        [ [ ll>> ] [ call ] bi* ] 
-        [ [ lr>> ] [ call ] bi* ] 
-        [ [ ul>> ] [ call ] bi* ] 
-        [ [ ur>> ] [ call ] bi* ] 
+        [ [ ll>> ] [ call ] bi* ]
+        [ [ lr>> ] [ call ] bi* ]
+        [ [ ul>> ] [ call ] bi* ]
+        [ [ ur>> ] [ call ] bi* ]
     } 2cleave ; inline
 : map-quadrant ( node quot: ( child-node -- x ) -- array )
     each-quadrant 4array ; inline
@@ -104,7 +104,7 @@ DEFER: in-rect*
 : node-in-rect* ( values rect node -- values )
     [ (node-in-rect*) ] with each-quadrant ;
 
-:: leaf-in-rect* ( values rect leaf -- values ) 
+:: leaf-in-rect* ( values rect leaf -- values )
     { [ leaf point>> ] [ leaf point>> rect contains-point? ] } 0&&
     [ values leaf value>> suffix! ] [ values ] if ;
 
@@ -155,8 +155,8 @@ DEFER: in-rect*
 : leaf-size ( leaf -- count )
     point>> [ 1 ] [ 0 ] if ;
 : node-size ( node -- count )
-    0 swap [ quadtree-size + ] each-quadrant ; 
-    
+    0 swap [ quadtree-size + ] each-quadrant ;
+
 : quadtree-size ( tree -- count )
     dup leaf?>> [ leaf-size ] [ node-size ] if ;
 
@@ -196,4 +196,3 @@ M: quadtree clear-assoc ( assoc -- )
     [ dup ] dip map
     [ zip ] [ rect-containing  ] bi
     [ '[ first2 _ set-at ] each ] [ values ] bi ; inline
-
diff --git a/extra/random/lagged-fibonacci/lagged-fibonacci.factor b/extra/random/lagged-fibonacci/lagged-fibonacci.factor
index 6109a727b5..0cfcbe5680 100644
--- a/extra/random/lagged-fibonacci/lagged-fibonacci.factor
+++ b/extra/random/lagged-fibonacci/lagged-fibonacci.factor
@@ -59,7 +59,7 @@ M:: lagged-fibonacci seed-random ( lagged-fibonacci seed! -- lagged-fibonacci )
         swap seed-random ; inline
 
 GENERIC: random-float* ( tuple -- r )
- 
+
 : random-float ( -- n ) random-generator get random-float* ; inline
 
 M:: lagged-fibonacci random-float* ( lagged-fibonacci -- x )
diff --git a/extra/reports/noise/noise.factor b/extra/reports/noise/noise.factor
index fb07701461..8f30dd4244 100644
--- a/extra/reports/noise/noise.factor
+++ b/extra/reports/noise/noise.factor
@@ -1,153 +1,153 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs math kernel shuffle generalizations
-words quotations arrays combinators sequences math.vectors
-io.styles prettyprint vocabs sorting io generic
-math.statistics math.order locals.types
-locals.definitions ;
-IN: reports.noise
-
-: badness ( word -- n )
-    H{
-        { -nrot 5 }
-        { -rot 3 }
-        { bi@ 1 }
-        { 2curry 1 }
-        { 2drop 1 }
-        { 2dup 1 }
-        { 2keep 1 }
-        { 2nip 2 }
-        { 2over 4 }
-        { 2swap 3 }
-        { 3curry 2 }
-        { 3drop 1 }
-        { 3dup 2 }
-        { 3keep 3 }
-        { 4drop 2 }
-        { 4dup 3 }
-        { compose 1/2 }
-        { curry 1/3 }
-        { dip 1 }
-        { 2dip 2 }
-        { drop 1/3 }
-        { dup 1/3 }
-        { if 1/3 }
-        { when 1/4 }
-        { unless 1/4 }
-        { when* 1/3 }
-        { unless* 1/3 }
-        { ?if 1/2 }
-        { cond 1/2 }
-        { case 1/2 }
-        { keep 1 }
-        { napply 2 }
-        { ncurry 3 }
-        { ndip 5 }
-        { ndrop 2 }
-        { ndup 3 }
-        { nip 2 }
-        { nkeep 5 }
-        { npick 6 }
-        { nrot 5 }
-        { nwith 4 }
-        { over 2 }
-        { pick 4 }
-        { rot 3 }
-        { swap 1 }
-        { swapd 3 }
-        { with 1/2 }
-
-        { bi 1/2 }
-        { tri 1 }
-        { bi* 1/2 }
-        { tri* 1 }
-
-        { cleave 2 }
-        { spread 2 }
-    } at 0 or ;
-
-: vsum ( pairs -- pair ) { 0 0 } [ v+ ] reduce ;
-
-GENERIC: noise ( obj -- pair )
-
-M: word noise badness 1 2array ;
-
-M: wrapper noise wrapped>> noise ;
-
-M: let noise body>> noise ;
-
-M: lambda noise body>> noise ;
-
-M: object noise drop { 0 0 } ;
-
-M: quotation noise [ noise ] map vsum { 1/4 1/2 } v+ ;
-
-M: array noise [ noise ] map vsum ;
-
-: noise-factor ( x y -- z ) / 100 * >integer ;
-
-: quot-noise-factor ( quot -- n )
-    #! For very short words, noise doesn't count so much
-    #! (so dup foo swap bar isn't penalized as badly).
-    noise first2 {
-        { [ over 4 <= ] [ [ drop 0 ] dip ] }
-        { [ over 15 >= ] [ [ 2 * ] dip ] }
-        [ ]
-    } cond
-    {
-        ! short words are easier to read
-        { [ dup 10 <= ] [ [ 2 / ] dip ] }
-        { [ dup 5 <= ] [ [ 3 / ] dip ] }
-        ! long words are penalized even more
-        { [ dup 25 >= ] [ [ 2 * ] dip 20 max ] }
-        { [ dup 20 >= ] [ [ 5/3 * ] dip ] }
-        { [ dup 15 >= ] [ [ 3/2 * ] dip ] }
-        [ ]
-    } cond noise-factor ;
-
-GENERIC: word-noise-factor ( word -- factor )
-
-M: word word-noise-factor
-    def>> quot-noise-factor ;
-
-M: lambda-word word-noise-factor
-    "lambda" word-prop quot-noise-factor ;
-
-: flatten-generics ( words -- words' )
-    [
-        dup generic? [ "methods" word-prop values ] [ 1array ] if
-    ] map concat ;
-
-: noisy-words ( -- alist )
-    all-words flatten-generics
-    [ dup word-noise-factor ] { } map>assoc
-    sort-values reverse ;
-
-: noise. ( alist -- )
-    standard-table-style [
-        [
-            [ [ pprint-cell ] [ pprint-cell ] bi* ] with-row
-        ] assoc-each
-    ] tabular-output ;
-
-: vocab-noise-factor ( vocab -- factor )
-    vocab-words flatten-generics
-    [ word-noise-factor dup 20 < [ drop 0 ] when ] map
-    [ 0 ] [
-        [ [ sum ] [ length 5 max ] bi /i ]
-        [ supremum ]
-        bi +
-    ] if-empty ;
-
-: noisy-vocabs ( -- alist )
-    loaded-vocab-names [ dup vocab-noise-factor ] { } map>assoc
-    sort-values reverse ;
-
-: noise-report ( -- )
-    "NOISY WORDS:" print
-    noisy-words 80 head noise.
-    nl
-    "NOISY VOCABS:" print
-    noisy-vocabs 80 head noise. ;
-
-MAIN: noise-report
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs math kernel shuffle generalizations
+words quotations arrays combinators sequences math.vectors
+io.styles prettyprint vocabs sorting io generic
+math.statistics math.order locals.types
+locals.definitions ;
+IN: reports.noise
+
+: badness ( word -- n )
+    H{
+        { -nrot 5 }
+        { -rot 3 }
+        { bi@ 1 }
+        { 2curry 1 }
+        { 2drop 1 }
+        { 2dup 1 }
+        { 2keep 1 }
+        { 2nip 2 }
+        { 2over 4 }
+        { 2swap 3 }
+        { 3curry 2 }
+        { 3drop 1 }
+        { 3dup 2 }
+        { 3keep 3 }
+        { 4drop 2 }
+        { 4dup 3 }
+        { compose 1/2 }
+        { curry 1/3 }
+        { dip 1 }
+        { 2dip 2 }
+        { drop 1/3 }
+        { dup 1/3 }
+        { if 1/3 }
+        { when 1/4 }
+        { unless 1/4 }
+        { when* 1/3 }
+        { unless* 1/3 }
+        { ?if 1/2 }
+        { cond 1/2 }
+        { case 1/2 }
+        { keep 1 }
+        { napply 2 }
+        { ncurry 3 }
+        { ndip 5 }
+        { ndrop 2 }
+        { ndup 3 }
+        { nip 2 }
+        { nkeep 5 }
+        { npick 6 }
+        { nrot 5 }
+        { nwith 4 }
+        { over 2 }
+        { pick 4 }
+        { rot 3 }
+        { swap 1 }
+        { swapd 3 }
+        { with 1/2 }
+
+        { bi 1/2 }
+        { tri 1 }
+        { bi* 1/2 }
+        { tri* 1 }
+
+        { cleave 2 }
+        { spread 2 }
+    } at 0 or ;
+
+: vsum ( pairs -- pair ) { 0 0 } [ v+ ] reduce ;
+
+GENERIC: noise ( obj -- pair )
+
+M: word noise badness 1 2array ;
+
+M: wrapper noise wrapped>> noise ;
+
+M: let noise body>> noise ;
+
+M: lambda noise body>> noise ;
+
+M: object noise drop { 0 0 } ;
+
+M: quotation noise [ noise ] map vsum { 1/4 1/2 } v+ ;
+
+M: array noise [ noise ] map vsum ;
+
+: noise-factor ( x y -- z ) / 100 * >integer ;
+
+: quot-noise-factor ( quot -- n )
+    #! For very short words, noise doesn't count so much
+    #! (so dup foo swap bar isn't penalized as badly).
+    noise first2 {
+        { [ over 4 <= ] [ [ drop 0 ] dip ] }
+        { [ over 15 >= ] [ [ 2 * ] dip ] }
+        [ ]
+    } cond
+    {
+        ! short words are easier to read
+        { [ dup 10 <= ] [ [ 2 / ] dip ] }
+        { [ dup 5 <= ] [ [ 3 / ] dip ] }
+        ! long words are penalized even more
+        { [ dup 25 >= ] [ [ 2 * ] dip 20 max ] }
+        { [ dup 20 >= ] [ [ 5/3 * ] dip ] }
+        { [ dup 15 >= ] [ [ 3/2 * ] dip ] }
+        [ ]
+    } cond noise-factor ;
+
+GENERIC: word-noise-factor ( word -- factor )
+
+M: word word-noise-factor
+    def>> quot-noise-factor ;
+
+M: lambda-word word-noise-factor
+    "lambda" word-prop quot-noise-factor ;
+
+: flatten-generics ( words -- words' )
+    [
+        dup generic? [ "methods" word-prop values ] [ 1array ] if
+    ] map concat ;
+
+: noisy-words ( -- alist )
+    all-words flatten-generics
+    [ dup word-noise-factor ] { } map>assoc
+    sort-values reverse ;
+
+: noise. ( alist -- )
+    standard-table-style [
+        [
+            [ [ pprint-cell ] [ pprint-cell ] bi* ] with-row
+        ] assoc-each
+    ] tabular-output ;
+
+: vocab-noise-factor ( vocab -- factor )
+    vocab-words flatten-generics
+    [ word-noise-factor dup 20 < [ drop 0 ] when ] map
+    [ 0 ] [
+        [ [ sum ] [ length 5 max ] bi /i ]
+        [ supremum ]
+        bi +
+    ] if-empty ;
+
+: noisy-vocabs ( -- alist )
+    loaded-vocab-names [ dup vocab-noise-factor ] { } map>assoc
+    sort-values reverse ;
+
+: noise-report ( -- )
+    "NOISY WORDS:" print
+    noisy-words 80 head noise.
+    nl
+    "NOISY VOCABS:" print
+    noisy-vocabs 80 head noise. ;
+
+MAIN: noise-report
diff --git a/extra/robots/robots.factor b/extra/robots/robots.factor
index 7562c65d3c..a9ef7448a0 100644
--- a/extra/robots/robots.factor
+++ b/extra/robots/robots.factor
@@ -42,7 +42,7 @@ visit-time request-rate crawl-delay unknowns ;
         {
             [ [ first "user-agent" = ] both? ]
             [ nip first "user-agent" = not ]
-        } 2|| 
+        } 2||
     ] monotonic-split ;
 
 :  ( -- rules )
diff --git a/extra/roles/roles.factor b/extra/roles/roles.factor
index 46da7fb549..58341a79da 100644
--- a/extra/roles/roles.factor
+++ b/extra/roles/roles.factor
@@ -66,5 +66,3 @@ PREDICATE: role < mixin-class
 
 SYNTAX: ROLE: parse-role-definition define-role ;
 SYNTAX: TUPLE: parse-role-definition define-tuple-class-with-roles ;
-
-
diff --git a/extra/rosetta-code/animate-pendulum/animate-pendulum.factor b/extra/rosetta-code/animate-pendulum/animate-pendulum.factor
index 9125c7ba9d..53b94470ee 100644
--- a/extra/rosetta-code/animate-pendulum/animate-pendulum.factor
+++ b/extra/rosetta-code/animate-pendulum/animate-pendulum.factor
@@ -25,7 +25,7 @@ CONSTANT: theta0 0.5
 : omega0 ( -- omega0 ) 2 pi * T0 / ;
 : theta ( -- theta ) current-time omega0 * cos theta0 * ;
 
-: relative-xy ( theta l -- xy ) 
+: relative-xy ( theta l -- xy )
     [ [ sin ] [ cos ] bi ]
     [ [ * ] curry ] bi* bi@ 2array ;
 : theta-to-xy ( origin theta l -- xy ) relative-xy v+ ;
@@ -36,7 +36,7 @@ TUPLE: pendulum-gadget < gadget alarm ;
 : window-l ( gadget -- l ) rect-bounds [ drop ] [ second ] bi* ;
 : gadget-xy ( gadget -- xy ) [ O ] [ drop theta ] [ window-l ] tri theta-to-xy ;
 
-M: pendulum-gadget draw-gadget* 
+M: pendulum-gadget draw-gadget*
     COLOR: black gl-color
     [ O ] [ gadget-xy ] bi gl-line ;
 
@@ -50,8 +50,8 @@ M: pendulum-gadget graft* ( gadget -- )
 M: pendulum-gadget ungraft*
     [ alarm>> stop-timer ] [ call-next-method ] bi ;
 
-:  ( -- gadget ) 
-    pendulum-gadget new 
+:  ( -- gadget )
+    pendulum-gadget new
     { 500 500 } >>pref-dim ;
 
 : pendulum-main ( -- )
diff --git a/extra/rosetta-code/animation/animation.factor b/extra/rosetta-code/animation/animation.factor
index 62e40a711f..f6e2147872 100644
--- a/extra/rosetta-code/animation/animation.factor
+++ b/extra/rosetta-code/animation/animation.factor
@@ -25,7 +25,7 @@ CONSTANT: sentence "Hello World! "
 TUPLE: animated-label < label-control reversed alarm ;
 
 :  ( model --  )
-    sentence animated-label new-label swap >>model 
+    sentence animated-label new-label swap >>model
     monospace-font >>font ;
 
 : update-string ( str reverse -- str )
diff --git a/extra/rosetta-code/bitmap-bezier/bitmap-bezier.factor b/extra/rosetta-code/bitmap-bezier/bitmap-bezier.factor
index e223daca92..e65a13aab7 100644
--- a/extra/rosetta-code/bitmap-bezier/bitmap-bezier.factor
+++ b/extra/rosetta-code/bitmap-bezier/bitmap-bezier.factor
@@ -26,7 +26,7 @@ IN: rosetta-code.bitmap-bezier
 : points-to-lines ( seq -- seq )
     dup rest [ 2array ] 2map ;
 
-: draw-lines ( {R,G,B} points image -- ) 
+: draw-lines ( {R,G,B} points image -- )
     [ [ first2 ] dip draw-line ] curry with each ;
 
 :: bezier-lines ( {R,G,B} P0 P1 P2 P3 image -- )
diff --git a/extra/rosetta-code/bitmap-line/bitmap-line.factor b/extra/rosetta-code/bitmap-line/bitmap-line.factor
index 18d96ce0bd..8c393f269f 100644
--- a/extra/rosetta-code/bitmap-line/bitmap-line.factor
+++ b/extra/rosetta-code/bitmap-line/bitmap-line.factor
@@ -31,8 +31,8 @@ IN: rosetta-code.bitmap-line
     y0 :> y!
     y0 y1 < [ 1 ystep! ] [ -1 ystep! ] if
     x0 x1 1  [
-        y steep [ swap ] when 2array  
-        current-error deltaerr + current-error! 
+        y steep [ swap ] when 2array
+        current-error deltaerr + current-error!
         current-error 0.5 >= [
             ystep y + y!
             current-error 1 - current-error!
diff --git a/extra/rosetta-code/bitmap/bitmap.factor b/extra/rosetta-code/bitmap/bitmap.factor
index 3cac8cba12..e45fbb9a74 100644
--- a/extra/rosetta-code/bitmap/bitmap.factor
+++ b/extra/rosetta-code/bitmap/bitmap.factor
@@ -21,12 +21,12 @@ IN: rosetta-code.bitmap
 
 ! Various utilities
 : meach ( matrix quot -- ) [ each ] curry each ; inline
-: meach-index ( matrix quot -- ) 
+: meach-index ( matrix quot -- )
     [ swap 2array ] prepose
     [ curry each-index ] curry each-index ; inline
 : mmap ( matrix quot -- matrix' ) [ map ] curry map ; inline
 : mmap! ( matrix quot -- matrix' ) [ map! ] curry map! ; inline
-: mmap-index ( matrix quot -- matrix' ) 
+: mmap-index ( matrix quot -- matrix' )
     [ swap 2array ] prepose
     [ curry map-index ] curry map-index ; inline
 
@@ -35,9 +35,9 @@ IN: rosetta-code.bitmap
 : Mi,j ( {i,j} matrix -- elt ) [ first2 swap ] dip nth nth ;
 
 ! The storage functions
-:  ( width height -- image ) 
+:  ( width height -- image )
     zero-matrix [ drop { 0 0 0 } ] mmap ;
-: fill-image ( {R,G,B} image -- image ) 
+: fill-image ( {R,G,B} image -- image )
     swap '[ drop _ ] mmap! ;
 : set-pixel ( {R,G,B} {i,j} image -- ) set-Mi,j ; inline
 : get-pixel ( {i,j} image -- pixel ) Mi,j ; inline
diff --git a/extra/rosetta-code/bulls-and-cows/bulls-and-cows.factor b/extra/rosetta-code/bulls-and-cows/bulls-and-cows.factor
index af24b1b0d2..d9a02ecd84 100644
--- a/extra/rosetta-code/bulls-and-cows/bulls-and-cows.factor
+++ b/extra/rosetta-code/bulls-and-cows/bulls-and-cows.factor
@@ -78,7 +78,7 @@ TUPLE: bull ;
       write flush drop validate-readln ]
     when ;
 
-: win ( -- ) "\nYou've won! Good job. You're so smart." print flush ; 
+: win ( -- ) "\nYou've won! Good job. You're so smart." print flush ;
 
 : main-loop ( x -- )
     "Enter a 4 digit number: " write flush validate-readln num>hash swap
diff --git a/extra/rosetta-code/gray-code/gray-code.factor b/extra/rosetta-code/gray-code/gray-code.factor
index d2d818f15c..c3a7e103f1 100644
--- a/extra/rosetta-code/gray-code/gray-code.factor
+++ b/extra/rosetta-code/gray-code/gray-code.factor
@@ -43,7 +43,7 @@ IN: rosetta-code.gray-code
     ] while
     p ;
 
-: gray-code-main ( -- ) 
+: gray-code-main ( -- )
     -1 32 [a,b] [
         dup [ >bin ] [ gray-encode ] bi
         [ >bin ] [ gray-decode ] bi 4array .
diff --git a/extra/rosetta-code/hailstone-sequence/hailstone-sequence.factor b/extra/rosetta-code/hailstone-sequence/hailstone-sequence.factor
index 1b867ab025..fb8d28f8e9 100644
--- a/extra/rosetta-code/hailstone-sequence/hailstone-sequence.factor
+++ b/extra/rosetta-code/hailstone-sequence/hailstone-sequence.factor
@@ -53,4 +53,3 @@ IN: rosetta-code.hailstone-sequence
     " has length " write pprint "." print ;
 
 MAIN: hailstone-main
-
diff --git a/extra/rosetta-code/hamming-lazy/hamming-lazy.factor b/extra/rosetta-code/hamming-lazy/hamming-lazy.factor
index 02bfcaf1fb..55cf30059f 100644
--- a/extra/rosetta-code/hamming-lazy/hamming-lazy.factor
+++ b/extra/rosetta-code/hamming-lazy/hamming-lazy.factor
@@ -35,4 +35,3 @@ IN: rosetta-code.hamming-lazy
         h 2 3 5 [ '[ _ * ] lazy-map ] tri-curry@ tri
         sort-merge sort-merge
     ] lazy-cons h! h ;
-
diff --git a/extra/rosetta-code/image-noise/image-noise.factor b/extra/rosetta-code/image-noise/image-noise.factor
index 50affe3650..6cf2f647ae 100644
--- a/extra/rosetta-code/image-noise/image-noise.factor
+++ b/extra/rosetta-code/image-noise/image-noise.factor
@@ -26,7 +26,7 @@ IN: rosetta-code.image-noise
 TUPLE: bw-noise-gadget < image-control timers cnt old-cnt fps-model ;
 
 : animate-image ( control -- )
-    [ 1 + ] change-cnt 
+    [ 1 + ] change-cnt
     model>>  swap set-model ;
 
 : update-cnt ( gadget -- )
@@ -55,7 +55,7 @@ M: bw-noise-gadget graft* [ call-next-method ] [ setup-timers ] bi ;
 M: bw-noise-gadget ungraft* [ stop-animation ] [ call-next-method ] bi ;
 
 :  ( -- gadget )
-      bw-noise-gadget new-image-gadget* 
+      bw-noise-gadget new-image-gadget*
     0 >>cnt 0 >>old-cnt 0  >>fps-model V{ } clone >>timers ;
 
 : fps-gadget ( model -- gadget )
diff --git a/extra/rosetta-code/knapsack-unbounded/knapsack-unbounded.factor b/extra/rosetta-code/knapsack-unbounded/knapsack-unbounded.factor
index 369edb5c08..940eb4e3b6 100644
--- a/extra/rosetta-code/knapsack-unbounded/knapsack-unbounded.factor
+++ b/extra/rosetta-code/knapsack-unbounded/knapsack-unbounded.factor
@@ -65,4 +65,3 @@ M:: bounty <=> ( a b -- <=> )
 : best-bounty ( -- bounty )
     find-max-amounts [ 1 + iota ] map 
     [  ] [ max ] map-reduce ;
-
diff --git a/extra/rosetta-code/knapsack/knapsack.factor b/extra/rosetta-code/knapsack/knapsack.factor
index ada59fd96d..4f989c2938 100644
--- a/extra/rosetta-code/knapsack/knapsack.factor
+++ b/extra/rosetta-code/knapsack/knapsack.factor
@@ -53,12 +53,12 @@ CONSTANT: items {
         T{ item f "socks" 4 50 }
         T{ item f "book" 30 10 }
     }
- 
+
 CONSTANT: limit 400
- 
+
 : make-table ( -- table )
     items length 1 + [ limit 1 + 0  ] replicate ;
- 
+
 :: iterate ( item-no table -- )
     item-no table nth :> prev
     item-no 1 + table nth :> curr
diff --git a/extra/rosetta-code/luhn-test/luhn-test.factor b/extra/rosetta-code/luhn-test/luhn-test.factor
index 814cc31b9e..a25d1ca80f 100644
--- a/extra/rosetta-code/luhn-test/luhn-test.factor
+++ b/extra/rosetta-code/luhn-test/luhn-test.factor
@@ -69,4 +69,3 @@ IN: rosetta-code.luhn-test
 
 : luhn? ( n -- ? )
     luhn-digit 0 = ;
-
diff --git a/extra/rosetta-code/odd-word/odd-word.factor b/extra/rosetta-code/odd-word/odd-word.factor
index 67f9f57103..403ef9daf2 100644
--- a/extra/rosetta-code/odd-word/odd-word.factor
+++ b/extra/rosetta-code/odd-word/odd-word.factor
@@ -98,4 +98,3 @@ PRIVATE>
 
 : odd-word ( string -- )
     [ read-odd-word ] with-string-reader ;
-
diff --git a/extra/rosetta-code/one-d-cellular/one-d-cellular.factor b/extra/rosetta-code/one-d-cellular/one-d-cellular.factor
index 1f3af66393..405b1924bd 100644
--- a/extra/rosetta-code/one-d-cellular/one-d-cellular.factor
+++ b/extra/rosetta-code/one-d-cellular/one-d-cellular.factor
@@ -49,4 +49,3 @@ IN: rosetta-code.one-d-cellular
     10 [ dup print-cellular step ] times print-cellular ;
 
 MAIN: main-cellular
-
diff --git a/extra/rosetta-code/opengl/opengl.factor b/extra/rosetta-code/opengl/opengl.factor
index dfdf8fa446..aad769a313 100644
--- a/extra/rosetta-code/opengl/opengl.factor
+++ b/extra/rosetta-code/opengl/opengl.factor
@@ -18,7 +18,7 @@ TUPLE: triangle-gadget < gadget ;
     -30.0 30.0 -30.0 30.0 -30.0 30.0 glOrtho
     GL_MODELVIEW glMatrixMode ;
 
-: paint ( -- ) 
+: paint ( -- )
     0.3 0.3 0.3 0.0 glClearColor
     GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
     GL_SMOOTH glShadeModel
@@ -27,7 +27,7 @@ TUPLE: triangle-gadget < gadget ;
     GL_TRIANGLES glBegin
     1.0 0.0 0.0 glColor3f 0.0 0.0 glVertex2f
     0.0 1.0 0.0 glColor3f 30.0 0.0 glVertex2f
-    0.0 0.0 1.0 glColor3f 0.0 30.0 glVertex2f 
+    0.0 0.0 1.0 glColor3f 0.0 30.0 glVertex2f
     glEnd
     glFlush ;
 
@@ -39,4 +39,3 @@ M: triangle-gadget draw-gadget*
    [ triangle-gadget new "Triangle" open-window ] with-ui ;
 
 MAIN: triangle-window
-
diff --git a/extra/rosetta-code/pythagorean-triples/pythagorean-triples.factor b/extra/rosetta-code/pythagorean-triples/pythagorean-triples.factor
index f99affcfc2..4c591b0cc3 100644
--- a/extra/rosetta-code/pythagorean-triples/pythagorean-triples.factor
+++ b/extra/rosetta-code/pythagorean-triples/pythagorean-triples.factor
@@ -59,11 +59,11 @@ TUPLE: triplets-count primitives total ;
 : add-triplets ( current-triples limit triplet -- stop )
     sum 2dup > [
     /i [ + ] curry change-total
-    [ 1 + ] change-primitives drop t 
+    [ 1 + ] change-primitives drop t
     ] [ 3drop f ] if ;
 
 : all-triplets ( current-triples limit seed -- triplets )
-    3dup add-triplets [ 
+    3dup add-triplets [
         candidates-triplets [ all-triplets ] with swapd reduce
     ] [ 2drop ] if ;
 
@@ -71,10 +71,8 @@ TUPLE: triplets-count primitives total ;
     <0-triplets-count> swap base all-triplets ;
 
 : pprint-triplet-count ( limit count -- )
-    [ total>> ] [ primitives>> ] bi 
+    [ total>> ] [ primitives>> ] bi
     "Up to %d: %d triples, %d primitives.\n" printf ;
 
 : pyth ( -- )
     8 [1,b] [ 10^ dup count-triplets pprint-triplet-count ] each ;
-
-
diff --git a/extra/rosetta-code/top-rank/top-rank.factor b/extra/rosetta-code/top-rank/top-rank.factor
index 6f8bf95502..49553f8686 100644
--- a/extra/rosetta-code/top-rank/top-rank.factor
+++ b/extra/rosetta-code/top-rank/top-rank.factor
@@ -29,7 +29,7 @@ IN: rosetta-code.top-rank
 ! Timothy Grove,E16398,29900,D190
 
 TUPLE: employee name id salary department ;
- 
+
 CONSTANT: employees {
         T{ employee f "Tyler Bennett" "E10297" 32000 "D101" }
         T{ employee f "John Rappl" "E21437" 47000 "D050" }
diff --git a/extra/rosetta-code/tree-traversal/tree-traversal.factor b/extra/rosetta-code/tree-traversal/tree-traversal.factor
index b9e413355d..cd26da86cb 100644
--- a/extra/rosetta-code/tree-traversal/tree-traversal.factor
+++ b/extra/rosetta-code/tree-traversal/tree-traversal.factor
@@ -71,7 +71,7 @@ CONSTANT: example-tree
             [ [ data>> ] dip call drop ]
             [ drop left>> [ swap push-back ] [ drop ] if* ]
             [ drop right>> [ swap push-back ] [ drop ] if* ]
-            [ nip (levelorder) ] 
+            [ nip (levelorder) ]
         } 3cleave
     ] if ; inline recursive
 
diff --git a/extra/s3/s3-docs.factor b/extra/s3/s3-docs.factor
index bac372bc15..f4a5cbc1a1 100644
--- a/extra/s3/s3-docs.factor
+++ b/extra/s3/s3-docs.factor
@@ -1,121 +1,121 @@
-! Copyright (C) 2009 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-USING: assocs help.markup help.syntax kernel strings ;
-IN: s3
-
-HELP: buckets
-{ $values 
-  { "seq" "a sequence of " { $link bucket } " objects" } 
-}
-{ $description 
-    "Returns a list of " { $link bucket } " objects containing data on the buckets available on S3."}
-{ $examples
-  { $unchecked-example "USING: s3 ;" "buckets ." "{ }" }
-}
-;
-
-HELP: create-bucket
-{ $values 
-  { "bucket" string } 
-}
-{ $description 
-    "Creates a bucket with the given name."
-} 
-{ $examples
-  { $unchecked-example "USING: s3 ;" "\"testbucket\" create-bucket" "" }
-}
-;
-
-HELP: delete-bucket
-{ $values 
-  { "bucket" string } 
-}
-{ $description 
-    "Deletes the bucket with the given name."
-} 
-{ $examples
-  { $unchecked-example "USING: s3 ;" "\"testbucket\" delete-bucket" "" }
-}
-;
-
-HELP: keys
-{ $values 
-  { "bucket" string } 
-  { "seq" "a sequence of " { $link key } " objects"} 
-}
-{ $description 
-    "Returns a sequence of " { $link key } " objects. Each object in the sequence has information about the keys contained within the bucket."
-} 
-{ $examples
-  { $unchecked-example "USING: s3 ;" "\"testbucket\" keys . " "{ }" }
-}
-;
-
-HELP: get-object
-{ $values 
-  { "bucket" string }
-  { "key" string }
-  { "response" "The HTTP response object"}
-  { "data" "The data returned from the http request"}
-}
-{ $description 
-    "Does an HTTP request to retrieve the object in the bucket with the given key."
-} 
-{ $examples
-  { $unchecked-example "USING: s3 ;" "\"testbucket\" \"mykey\" http-get " "" }
-}
-;
-
-HELP: put-object
-{ $values
-  { "data" object }
-  { "mime-type" string }
-  { "bucket" string }
-  { "key" string }
-  { "headers" assoc }
-}
-{ $description 
-    "Stores the object under the key in the given bucket. The object has "
-"the given mimetype. 'headers' should contain key/values for any headers to "
-"be associated with the object. 'data' is any Factor object that can be "
-"used as the 'data' slot in . If it's a  it stores "
-"the contents of the file. If it's a stream, it's the contents of the "
-"stream, etc."
-} 
-{ $examples
-  { $unchecked-example "USING: s3 ;" "\"hello\" binary encode \"text/plain\" \"testbucket\" \"hello.txt\" H{ { \"x-amz-acl\" \"public-read\" } } put-object" "" }
-  { $unchecked-example "USING: s3 ;" "\"hello.txt\"  \"text/plain\" \"testbucket\" \"hello.txt\" H{ { \"x-amz-acl\" \"public-read\" } } put-object" "" }
-}
-;
-
-HELP: delete-object
-{ $values 
-  { "bucket" string }
-  { "key" string }
-}
-{ $description 
-    "Deletes the object in the bucket with the given key."
-} 
-{ $examples
-  { $unchecked-example "USING: s3 ;" "\"testbucket\" \"mykey\" delete-object" "" }
-}
-;
-
-ARTICLE: "s3" "Amazon S3"
-"The " { $vocab-link "s3" } " vocabulary provides a wrapper to the Amazon "
-"Simple Storage Service API."
-$nl
-"To use the api you must set the variables " { $link key-id } " and " 
-{ $link secret-key } " to your Amazon S3 key and secret key respectively. Once "
-"this is done you can call any of the words below."
-{ $subsections buckets
-    create-bucket
-    delete-bucket
-    keys
-    get-object
-    put-object
-    delete-object
-}
-;
-
-ABOUT: "s3"
+! Copyright (C) 2009 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs help.markup help.syntax kernel strings ;
+IN: s3
+
+HELP: buckets
+{ $values 
+  { "seq" "a sequence of " { $link bucket } " objects" } 
+}
+{ $description 
+    "Returns a list of " { $link bucket } " objects containing data on the buckets available on S3."}
+{ $examples
+  { $unchecked-example "USING: s3 ;" "buckets ." "{ }" }
+}
+;
+
+HELP: create-bucket
+{ $values 
+  { "bucket" string } 
+}
+{ $description 
+    "Creates a bucket with the given name."
+} 
+{ $examples
+  { $unchecked-example "USING: s3 ;" "\"testbucket\" create-bucket" "" }
+}
+;
+
+HELP: delete-bucket
+{ $values 
+  { "bucket" string } 
+}
+{ $description 
+    "Deletes the bucket with the given name."
+} 
+{ $examples
+  { $unchecked-example "USING: s3 ;" "\"testbucket\" delete-bucket" "" }
+}
+;
+
+HELP: keys
+{ $values 
+  { "bucket" string } 
+  { "seq" "a sequence of " { $link key } " objects"} 
+}
+{ $description 
+    "Returns a sequence of " { $link key } " objects. Each object in the sequence has information about the keys contained within the bucket."
+} 
+{ $examples
+  { $unchecked-example "USING: s3 ;" "\"testbucket\" keys . " "{ }" }
+}
+;
+
+HELP: get-object
+{ $values 
+  { "bucket" string }
+  { "key" string }
+  { "response" "The HTTP response object"}
+  { "data" "The data returned from the http request"}
+}
+{ $description 
+    "Does an HTTP request to retrieve the object in the bucket with the given key."
+} 
+{ $examples
+  { $unchecked-example "USING: s3 ;" "\"testbucket\" \"mykey\" http-get " "" }
+}
+;
+
+HELP: put-object
+{ $values
+  { "data" object }
+  { "mime-type" string }
+  { "bucket" string }
+  { "key" string }
+  { "headers" assoc }
+}
+{ $description 
+    "Stores the object under the key in the given bucket. The object has "
+"the given mimetype. 'headers' should contain key/values for any headers to "
+"be associated with the object. 'data' is any Factor object that can be "
+"used as the 'data' slot in . If it's a  it stores "
+"the contents of the file. If it's a stream, it's the contents of the "
+"stream, etc."
+} 
+{ $examples
+  { $unchecked-example "USING: s3 ;" "\"hello\" binary encode \"text/plain\" \"testbucket\" \"hello.txt\" H{ { \"x-amz-acl\" \"public-read\" } } put-object" "" }
+  { $unchecked-example "USING: s3 ;" "\"hello.txt\"  \"text/plain\" \"testbucket\" \"hello.txt\" H{ { \"x-amz-acl\" \"public-read\" } } put-object" "" }
+}
+;
+
+HELP: delete-object
+{ $values 
+  { "bucket" string }
+  { "key" string }
+}
+{ $description 
+    "Deletes the object in the bucket with the given key."
+} 
+{ $examples
+  { $unchecked-example "USING: s3 ;" "\"testbucket\" \"mykey\" delete-object" "" }
+}
+;
+
+ARTICLE: "s3" "Amazon S3"
+"The " { $vocab-link "s3" } " vocabulary provides a wrapper to the Amazon "
+"Simple Storage Service API."
+$nl
+"To use the api you must set the variables " { $link key-id } " and " 
+{ $link secret-key } " to your Amazon S3 key and secret key respectively. Once "
+"this is done you can call any of the words below."
+{ $subsections buckets
+    create-bucket
+    delete-bucket
+    keys
+    get-object
+    put-object
+    delete-object
+}
+;
+
+ABOUT: "s3"
diff --git a/extra/s3/s3.factor b/extra/s3/s3.factor
index e04117024b..6977fac032 100644
--- a/extra/s3/s3.factor
+++ b/extra/s3/s3.factor
@@ -37,7 +37,7 @@ TUPLE: s3-request path mime-type date method headers  bucket data ;
 
 : signature ( s3-request -- string )
     [
-        { 
+        {
             [ method>> % "\n" % "\n" % ]
             [ mime-type>> % "\n" % ]
             [ date>> timestamp>rfc822 % "\n" % ]
@@ -57,8 +57,8 @@ TUPLE: s3-request path mime-type date method headers  bucket data ;
 
 : s3-url ( s3-request -- string )
     [
-        "http://" % 
-        dup bucket>> [ % "." % ] when* 
+        "http://" %
+        dup bucket>> [ % "." % ] when*
         "s3.amazonaws.com" %
         path>> %
     ] "" make ;
@@ -76,11 +76,11 @@ TUPLE: s3-request path mime-type date method headers  bucket data ;
     swap sign "Authorization" set-header ;
 
 : s3-get ( bucket path headers -- request data )
-    "GET"  dup s3-url  
+    "GET"  dup s3-url 
     sign-http-request http-request ;
 
 : s3-put ( data bucket path headers -- request data )
-    "PUT"  dup s3-url swapd  
+    "PUT"  dup s3-url swapd 
     sign-http-request http-request ;
 
 PRIVATE>
@@ -90,13 +90,13 @@ TUPLE: bucket name date ;
 string ] 
+        [ "Name" tag-named children>string ]
         [ "CreationDate" tag-named children>string ] bi bucket boa
     ] map ;
 PRIVATE>
- 
+
 : buckets ( -- seq )
     f "/" H{ } clone s3-get nip >string string>xml (buckets) ;
 
@@ -131,7 +131,7 @@ PRIVATE>
     "" swap "/" H{ } clone "PUT" 
     "application/octet-stream" >>mime-type
     dup s3-url swapd 
-    0 "content-length" set-header 
+    0 "content-length" set-header
     sign-http-request
     http-request 2drop ;
 
@@ -140,12 +140,12 @@ PRIVATE>
     dup s3-url  sign-http-request http-request 2drop ;
 
 : put-object ( data mime-type bucket key headers -- )
-    [ "/" prepend ] dip "PUT"  
+    [ "/" prepend ] dip "PUT" 
     over >>mime-type
     [  swap >>data ] dip
-    dup s3-url swapd  
+    dup s3-url swapd 
     dup header>> pick headers>> assoc-union >>header
-    sign-http-request 
+    sign-http-request
     http-request 2drop ;
 
 : delete-object ( bucket key -- )
diff --git a/extra/sequences/inserters/inserters.factor b/extra/sequences/inserters/inserters.factor
index e0075f158c..26369dcb9d 100644
--- a/extra/sequences/inserters/inserters.factor
+++ b/extra/sequences/inserters/inserters.factor
@@ -41,4 +41,3 @@ INSTANCE: replacer inserter
 
 M: replacer new-sequence
     underlying>> [ set-length ] keep ; inline
-
diff --git a/extra/sequences/n-based/n-based.factor b/extra/sequences/n-based/n-based.factor
index 78fe851389..4343bf2f9d 100644
--- a/extra/sequences/n-based/n-based.factor
+++ b/extra/sequences/n-based/n-based.factor
@@ -15,7 +15,7 @@ C:  n-based-assoc
 
 PRIVATE>
 
-INSTANCE: n-based-assoc assoc 
+INSTANCE: n-based-assoc assoc
 M: n-based-assoc at* ( key assoc -- value ? )
     n-based@ 2dup bounds-check?
     [ nth-unsafe t ] [ 2drop f f ] if ;
diff --git a/extra/site-watcher/db/db.factor b/extra/site-watcher/db/db.factor
index 0f1a3820b8..47b8fac9b9 100644
--- a/extra/site-watcher/db/db.factor
+++ b/extra/site-watcher/db/db.factor
@@ -106,7 +106,7 @@ TUPLE: reporting-site site-id email url up? changed? last-up? error last-error ;
     update-tuple ;
 
 : sites-to-report ( -- seq )
-    "select users.email, site.url, site.up, site.changed, site.last_up, site.error, site.last_error from users, site, watching_site where users.username = watching_site.account_name and site.site_id = watching_site.site_id and site.changed = '1'" sql-query 
+    "select users.email, site.url, site.up, site.changed, site.last_up, site.error, site.last_error from users, site, watching_site where users.username = watching_site.account_name and site.site_id = watching_site.site_id and site.changed = '1'" sql-query
     [ [ reporting-site boa ] input> email>> ] 2dip
     pick [
         [  site-watcher-from get >>from ] 3dip
-        [ 1array >>to ] [ >>body ] [ >>subject ] tri* send-email 
+        [ 1array >>to ] [ >>body ] [ >>subject ] tri* send-email
     ] [ 3drop ] if ;
diff --git a/extra/site-watcher/site-watcher.factor b/extra/site-watcher/site-watcher.factor
index 2c3bed7812..49e90bff03 100644
--- a/extra/site-watcher/site-watcher.factor
+++ b/extra/site-watcher/site-watcher.factor
@@ -8,7 +8,7 @@ IN: site-watcher
 
 SYMBOL: site-watcher-frequency
 5 minutes site-watcher-frequency set-global
- 
+
 SYMBOL: running-site-watcher
 [ f running-site-watcher set-global ] "site-watcher" add-startup-hook
 
@@ -42,7 +42,7 @@ PRIVATE>
     find-sites check-sites sites-to-report send-reports ;
 
 : run-site-watcher ( db -- )
-    [ running-site-watcher get ] dip '[ 
+    [ running-site-watcher get ] dip '[
         [ _ [ watch-sites ] with-db ] site-watcher-frequency get every
         running-site-watcher set
     ] unless ;
diff --git a/extra/site-watcher/spider/spider.factor b/extra/site-watcher/spider/spider.factor
index 335f1f11f9..ad3bb76ccb 100644
--- a/extra/site-watcher/spider/spider.factor
+++ b/extra/site-watcher/spider/spider.factor
@@ -22,4 +22,4 @@ IN: site-watcher.spider
     send-site-email ;
 
 : spider-sites ( -- )
-    f spidering-sites [ spider-and-email ] parallel-each ;
\ No newline at end of file
+    f spidering-sites [ spider-and-email ] parallel-each ;
diff --git a/extra/slots/macros/macros.factor b/extra/slots/macros/macros.factor
index c3bbda6525..cedccade7b 100644
--- a/extra/slots/macros/macros.factor
+++ b/extra/slots/macros/macros.factor
@@ -36,7 +36,7 @@ MACRO: set-slot ( name -- quot: ( value tuple -- ) )
 : set-slot* ( tuple value name -- tuple )
     swapd '[ _ set-slot ] keep ; inline
 
-: change-slot* ( tuple name quot: ( ..a old -- ..b new ) -- ..b tuple ) 
+: change-slot* ( tuple name quot: ( ..a old -- ..b new ) -- ..b tuple )
     '[ _ _ change-slot ] keep ; inline
 
 ! Multiple-slot accessors
diff --git a/extra/slots/syntax/syntax.factor b/extra/slots/syntax/syntax.factor
index a570c4e4d4..a17bee4c19 100755
--- a/extra/slots/syntax/syntax.factor
+++ b/extra/slots/syntax/syntax.factor
@@ -14,7 +14,7 @@ SYNTAX: slots{
 
 : >>writer-word ( name -- word )
     ">>" prepend "accessors" lookup-word ;
-    
+
 : writer-word<< ( name -- word )
     ">>" prepend "accessors" lookup-word ;
 
@@ -33,7 +33,7 @@ SYNTAX: copy-slots{
         [ writer-word<< 1quotation ] bi append
     ] map-tokens
     '[ swap _ cleave ] append! ;
-    
+
 SYNTAX: get[ POSTPONE: slots[ ;
 SYNTAX: get{ POSTPONE: slots{ ;
 SYNTAX: set[ POSTPONE: set-slots[ ;
diff --git a/extra/smalltalk/ast/ast.factor b/extra/smalltalk/ast/ast.factor
index fc415aa361..b3f8375587 100644
--- a/extra/smalltalk/ast/ast.factor
+++ b/extra/smalltalk/ast/ast.factor
@@ -50,4 +50,4 @@ M: ast-sequence arguments>> drop { } ;
     self suffix  ast-method boa ;
 
 TUPLE: symbol { name string } ;
-MEMO: intern ( name -- symbol ) symbol boa ;
\ No newline at end of file
+MEMO: intern ( name -- symbol ) symbol boa ;
diff --git a/extra/smalltalk/compiler/assignment/assignment.factor b/extra/smalltalk/compiler/assignment/assignment.factor
index 3a0a769f86..99d8d6b6b3 100644
--- a/extra/smalltalk/compiler/assignment/assignment.factor
+++ b/extra/smalltalk/compiler/assignment/assignment.factor
@@ -33,4 +33,4 @@ M: ast-sequence assigned-locals
 M: array assigned-locals
     [ assigned-locals ] map concat ;
 
-M: object assigned-locals drop f ;
\ No newline at end of file
+M: object assigned-locals drop f ;
diff --git a/extra/smalltalk/compiler/compiler.factor b/extra/smalltalk/compiler/compiler.factor
index 31fd6c9a55..c7f4807faf 100644
--- a/extra/smalltalk/compiler/compiler.factor
+++ b/extra/smalltalk/compiler/compiler.factor
@@ -138,7 +138,7 @@ M: ast-class compile-ast
     nip
     [
         [ name>> ] [ superclass>> ] [ ivars>> ] tri
-        define-class  
+        define-class 
     ]
     [ methods>> ] bi
     [ compile-method ] with each
diff --git a/extra/smalltalk/compiler/lexenv/lexenv.factor b/extra/smalltalk/compiler/lexenv/lexenv.factor
index cd06314fd9..21fe1698e0 100644
--- a/extra/smalltalk/compiler/lexenv/lexenv.factor
+++ b/extra/smalltalk/compiler/lexenv/lexenv.factor
@@ -64,4 +64,4 @@ M: bad-identifier summary drop "Unknown identifier" ;
         [ local-writer ]
         [ ivar-writer ]
         [ drop bad-identifier ]
-    } 2|| ;
\ No newline at end of file
+    } 2|| ;
diff --git a/extra/smalltalk/compiler/return/return.factor b/extra/smalltalk/compiler/return/return.factor
index 8c36bdac64..f34aba012b 100644
--- a/extra/smalltalk/compiler/return/return.factor
+++ b/extra/smalltalk/compiler/return/return.factor
@@ -42,4 +42,4 @@ M: object need-return-continuation? drop f ;
     block need-return-continuation? [
         quot clone [ lexenv return>>  '[ _ ] prepend ] change-body
         n '[ _ _ ncurry callcc1 ]
-    ] [ quot ] if rewrite-closures first ;
\ No newline at end of file
+    ] [ quot ] if rewrite-closures first ;
diff --git a/extra/smalltalk/library/library.factor b/extra/smalltalk/library/library.factor
index 28acf98dff..d7bc1e6570 100644
--- a/extra/smalltalk/library/library.factor
+++ b/extra/smalltalk/library/library.factor
@@ -98,4 +98,4 @@ M: object selector-new new ;
 
 SELECTOR: time
 
-M: object selector-time '[ _ call( -- result ) ] time ;
\ No newline at end of file
+M: object selector-time '[ _ call( -- result ) ] time ;
diff --git a/extra/smalltalk/listener/listener.factor b/extra/smalltalk/listener/listener.factor
index dc84fd90fb..dd65a7a95b 100644
--- a/extra/smalltalk/listener/listener.factor
+++ b/extra/smalltalk/listener/listener.factor
@@ -15,4 +15,4 @@ IN: smalltalk.listener
     "Smalltalk>" { { background COLOR: light-blue } } format bl flush readln
     [ eval-interactively smalltalk-listener ] when* ;
 
-MAIN: smalltalk-listener
\ No newline at end of file
+MAIN: smalltalk-listener
diff --git a/extra/smalltalk/printer/printer.factor b/extra/smalltalk/printer/printer.factor
index 9b6aa11114..cbf4baf74d 100644
--- a/extra/smalltalk/printer/printer.factor
+++ b/extra/smalltalk/printer/printer.factor
@@ -31,4 +31,4 @@ M: byte-array smalltalk>string
 M: symbol smalltalk>string
     name>> smalltalk>string "#" prepend ;
 
-M: object smalltalk>string unparse-short ;
\ No newline at end of file
+M: object smalltalk>string unparse-short ;
diff --git a/extra/space-invaders/space-invaders-docs.factor b/extra/space-invaders/space-invaders-docs.factor
index 0c02f8fd4c..550e05c7bd 100644
--- a/extra/space-invaders/space-invaders-docs.factor
+++ b/extra/space-invaders/space-invaders-docs.factor
@@ -1,40 +1,40 @@
-! Copyright (C) 2007 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.syntax help.markup cpu.8080.emulator ;
-IN: space-invaders 
-
-HELP: run-invaders
-{ $description 
-"Run the Space Invaders emulator in a new window." $nl
-{ $link rom-root } " must be set to the directory containing the "
-"location of the Space Invaders ROM files. See " 
-{ $link { "space-invaders" "space-invaders" } } "  for details."
-} ;
-
-ARTICLE: { "space-invaders" "space-invaders" } "Space Invaders Emulator"
-"Provides an emulation of the original 8080 Arcade Game 'Space Invaders'." $nl
-"More information on the arcade game can be obtained from " { $url "http://www.mameworld.net/maws/romset/invaders" } "." $nl
-"To play the game you need the ROM files for the arcade game. They should "
-"be placed in a directory called 'invaders' in the location specified by "
-"the variable " { $link rom-root } ". The specific files needed are:"
-{ $list
-  "invaders/invaders.e"
-  "invaders/invaders.f"
-  "invaders/invaders.g"
-  "invaders/invaders.h"
-}
-"These are the same ROM files as used by MAME. To run the game use the " 
-{ $link run-invaders } " word." $nl
-"Keys:" 
-{ $table
-  { "Backspace" "Insert Coin" }
-  { "1" "1 Player" }
-  { "2" "2 Player" }
-  { "Left" "Move Left" }
-  { "Right" "Move Right" }
-  { "Up" "Fire" }
-}
-"If you save the Factor image while a game is running, when you restart "
-"the image the game continues where it left off." ;
-
-ABOUT: { "space-invaders" "space-invaders" } 
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.syntax help.markup cpu.8080.emulator ;
+IN: space-invaders 
+
+HELP: run-invaders
+{ $description 
+"Run the Space Invaders emulator in a new window." $nl
+{ $link rom-root } " must be set to the directory containing the "
+"location of the Space Invaders ROM files. See " 
+{ $link { "space-invaders" "space-invaders" } } "  for details."
+} ;
+
+ARTICLE: { "space-invaders" "space-invaders" } "Space Invaders Emulator"
+"Provides an emulation of the original 8080 Arcade Game 'Space Invaders'." $nl
+"More information on the arcade game can be obtained from " { $url "http://www.mameworld.net/maws/romset/invaders" } "." $nl
+"To play the game you need the ROM files for the arcade game. They should "
+"be placed in a directory called 'invaders' in the location specified by "
+"the variable " { $link rom-root } ". The specific files needed are:"
+{ $list
+  "invaders/invaders.e"
+  "invaders/invaders.f"
+  "invaders/invaders.g"
+  "invaders/invaders.h"
+}
+"These are the same ROM files as used by MAME. To run the game use the " 
+{ $link run-invaders } " word." $nl
+"Keys:" 
+{ $table
+  { "Backspace" "Insert Coin" }
+  { "1" "1 Player" }
+  { "2" "2 Player" }
+  { "Left" "Move Left" }
+  { "Right" "Move Right" }
+  { "Up" "Fire" }
+}
+"If you save the Factor image while a game is running, when you restart "
+"the image the game continues where it left off." ;
+
+ABOUT: { "space-invaders" "space-invaders" } 
diff --git a/extra/space-invaders/space-invaders.factor b/extra/space-invaders/space-invaders.factor
index ef10579cf7..3207bb0ad6 100755
--- a/extra/space-invaders/space-invaders.factor
+++ b/extra/space-invaders/space-invaders.factor
@@ -36,15 +36,15 @@ CONSTANT: game-height 256
     [ [ 1 + ] dip nth ]
     [ [ 2 + ] dip nth ] 2tri 3array ;
 
-CONSTANT: SOUND-SHOT         0 
-CONSTANT: SOUND-UFO          1 
-CONSTANT: SOUND-BASE-HIT     2 
-CONSTANT: SOUND-INVADER-HIT  3 
-CONSTANT: SOUND-WALK1        4 
+CONSTANT: SOUND-SHOT         0
+CONSTANT: SOUND-UFO          1
+CONSTANT: SOUND-BASE-HIT     2
+CONSTANT: SOUND-INVADER-HIT  3
+CONSTANT: SOUND-WALK1        4
 CONSTANT: SOUND-WALK2        5
-CONSTANT: SOUND-WALK3        6 
-CONSTANT: SOUND-WALK4        7 
-CONSTANT: SOUND-UFO-HIT      8 
+CONSTANT: SOUND-WALK3        6
+CONSTANT: SOUND-WALK4        7
+CONSTANT: SOUND-UFO-HIT      8
 
 : init-sound ( index cpu filename  -- )
     absolute-path swapd [ sounds>> nth AL_BUFFER ] dip
@@ -103,8 +103,8 @@ CONSTANT: SOUND-UFO-HIT      8
 
 : read-port3 ( cpu -- byte )
     #! Used to compute a special formula
-    [ port4hi>> 8 shift ] keep 
-    [ port4lo>> bitor ] keep 
+    [ port4hi>> 8 shift ] keep
+    [ port4lo>> bitor ] keep
     port2o>> shift -8 shift 0xFF bitand ;
 
 M: space-invaders read-port
@@ -192,14 +192,14 @@ M: space-invaders reset
     0 >>port3o
     0 >>port4lo
     0 >>port4hi
-    0 >>port5o 
+    0 >>port5o
     drop ;
 
 : gui-step ( cpu -- )
     [ read-instruction ] keep ! n cpu
     over get-cycles over inc-cycles
-    [ swap instructions nth call( cpu -- ) ] keep  
-    [ pc>> 0xFFFF bitand ] keep 
+    [ swap instructions nth call( cpu -- ) ] keep
+    [ pc>> 0xFFFF bitand ] keep
     pc<< ;
 
 : gui-frame/2 ( cpu -- )
@@ -273,7 +273,7 @@ invaders-gadget H{
     { T{ key-up   f f "RIGHT" }     [ cpu>> right-up ] }
 } set-gestures
 
-:  ( cpu -- gadget ) 
+:  ( cpu -- gadget )
     invaders-gadget new
         swap >>cpu
         f >>quit? ;
diff --git a/extra/specialized/specialized.factor b/extra/specialized/specialized.factor
index 0f900f59a3..73fe2f6cf9 100644
--- a/extra/specialized/specialized.factor
+++ b/extra/specialized/specialized.factor
@@ -52,4 +52,3 @@ SYNTAX: specialized
 
 PREDICATE: specialized-word < word
    "specialized-defs" word-prop >boolean ;
-
diff --git a/extra/spheres/spheres.factor b/extra/spheres/spheres.factor
index 53f8717410..0c6c3d134f 100644
--- a/extra/spheres/spheres.factor
+++ b/extra/spheres/spheres.factor
@@ -32,7 +32,7 @@ main()
 {
     float distance_factor = (gl_FragCoord.z * 0.5 + 0.5);
     distance_factor = pow(distance_factor, 500.0)*0.5;
-    
+
     gl_FragColor = checker_color(object_position)
         ? mix(checker_color_1, checker_color_2, distance_factor)
         : mix(checker_color_2, checker_color_1, distance_factor);
@@ -52,9 +52,9 @@ main()
 {
     world_position = gl_ModelViewMatrix * vec4(center, 1);
     sphere_position = gl_Vertex.xyz;
-    
+
     gl_Position = gl_ProjectionMatrix * (world_position + vec4(sphere_position * radius, 0));
-    
+
     vcolor = surface_color;
     vradius = radius;
 }
@@ -73,7 +73,7 @@ sphere_color(vec3 point, vec3 normal)
     vec3 transformed_light_position = (gl_ModelViewMatrix * vec4(light_position, 1)).xyz;
     vec3 direction = normalize(transformed_light_position - point);
     float d = max(0.0, dot(normal, direction));
-    
+
     return ambient * vcolor + diffuse * vec4(d * vcolor.rgb, vcolor.a);
 }
 ;
@@ -176,7 +176,7 @@ M: spheres-world begin-world
     { "GL_EXT_framebuffer_object" } require-gl-extensions
     GL_DEPTH_TEST glEnable
     GL_VERTEX_ARRAY glEnableClientState
-    0.15 0.15 1.0 1.0 glClearColor 
+    0.15 0.15 1.0 1.0 glClearColor
     20.0 10.0 20.0 set-demo-orientation
     (plane-program) >>plane-program
     (solid-sphere-program) >>solid-sphere-program
@@ -200,7 +200,7 @@ M: spheres-world end-world
     program "center" glGetAttribLocation center first3 glVertexAttrib3f
     program "radius" glGetAttribLocation radius glVertexAttrib1f
     { -1.0 -1.0 } { 2.0 2.0 } gl-fill-rect ;
-    
+
 :: (draw-colored-sphere) ( program center radius surfacecolor -- )
     program "surface_color" glGetAttribLocation surfacecolor first4 glVertexAttrib4f
     program center radius (draw-sphere) ;
diff --git a/extra/subrip-subtitles/subrip-subtitles.factor b/extra/subrip-subtitles/subrip-subtitles.factor
index e7d2cb8eb1..57d448b39e 100644
--- a/extra/subrip-subtitles/subrip-subtitles.factor
+++ b/extra/subrip-subtitles/subrip-subtitles.factor
@@ -33,7 +33,7 @@ TUPLE: srt-chunk id begin-time end-time rect text ;
                 first4 swapd [ 2array ] 2dip 2array 2array
             ] if-empty
         ] bi*
-    ] 
+    ]
     [ 2 tail "\n" join ] tri srt-chunk boa ;
 
 : parse-srt-lines ( seq -- seq' )
diff --git a/extra/synth/buffers/buffers.factor b/extra/synth/buffers/buffers.factor
index e71b136940..b117335688 100644
--- a/extra/synth/buffers/buffers.factor
+++ b/extra/synth/buffers/buffers.factor
@@ -77,4 +77,3 @@ CONSTANT: professional-sample-freq 88200
 
 : ?send-buffer ( buffer -- buffer )
     dup id>> [ send-buffer ] unless ;
-
diff --git a/extra/synth/synth.factor b/extra/synth/synth.factor
index 1588a8a02a..8d1299042a 100755
--- a/extra/synth/synth.factor
+++ b/extra/synth/synth.factor
@@ -33,4 +33,3 @@ C:  note
 
 : >note ( harmonics note buffer -- buffer )
     [ [ note-harmonic-data ] 2curry map  ] [ data<< ] [ ] tri ;
-
diff --git a/extra/taxes/usa/federal/federal.factor b/extra/taxes/usa/federal/federal.factor
index 4b6d516369..2af1980942 100644
--- a/extra/taxes/usa/federal/federal.factor
+++ b/extra/taxes/usa/federal/federal.factor
@@ -48,7 +48,7 @@ M: federal withholding* ( salary w4 tax-table entity -- x )
 
 : total-withholding ( salary w4 tax-table -- x )
     dup entity>> dup federal = [
-        withholding* 
+        withholding*
     ] [
         drop
         [ drop  federal withholding* ]
diff --git a/extra/taxes/usa/w4/w4.factor b/extra/taxes/usa/w4/w4.factor
index aad3773220..668d38cebd 100644
--- a/extra/taxes/usa/w4/w4.factor
+++ b/extra/taxes/usa/w4/w4.factor
@@ -10,4 +10,3 @@ C:  w4
 : allowance ( -- x ) 3500 ; inline
 
 : calculate-w4-allowances ( w4 -- x ) allowances>> allowance * ;
-
diff --git a/extra/tc-lisp-talk/tc-lisp-talk.factor b/extra/tc-lisp-talk/tc-lisp-talk.factor
index ac9e46f817..088a3600e2 100644
--- a/extra/tc-lisp-talk/tc-lisp-talk.factor
+++ b/extra/tc-lisp-talk/tc-lisp-talk.factor
@@ -224,7 +224,7 @@ WHERE
         { $code "5 9 [ sq ] bi@" }
     }
     { $slide "Sequence combinators"
-        
+
         { $link each }
         { $code "{ 1 2 3 4 5 } [ sq . ] each" }
         { $link map }
@@ -233,7 +233,7 @@ WHERE
         { $code "{ 1 2 3 4 5 } [ even? ] filter" }
     }
     { $slide "Multiple sequence combinators"
-        
+
         { $link 2each }
         { $code "{ 1 2 3 } { 10 20 30 } [ + . ] 2each" }
         { $link 2map }
diff --git a/extra/terrain/generation/generation.factor b/extra/terrain/generation/generation.factor
index 3ed4af3b1d..f25779df02 100644
--- a/extra/terrain/generation/generation.factor
+++ b/extra/terrain/generation/generation.factor
@@ -13,7 +13,7 @@ CONSTANT: terrain-small-noise-scale float-4{ 0.05 0.05 0.05 0.05 }
 TUPLE: terrain
     { big-noise-table byte-array }
     { small-noise-table byte-array }
-    { tiny-noise-seed integer } ; 
+    { tiny-noise-seed integer } ;
 
 :  ( -- terrain )
      
@@ -24,11 +24,11 @@ TUPLE: terrain
 
 : big-noise-segment ( terrain at -- bytes )
     [ big-noise-table>> terrain-big-noise-scale scale-matrix4 ] dip
-    terrain-segment-size-vector v* translation-matrix4 m4. 
+    terrain-segment-size-vector v* translation-matrix4 m4.
     terrain-segment-size perlin-noise-image bitmap>> ; inline
 : small-noise-segment ( terrain at -- bytes )
     [ small-noise-table>> terrain-small-noise-scale scale-matrix4 ] dip
-    terrain-segment-size-vector v* translation-matrix4 m4. 
+    terrain-segment-size-vector v* translation-matrix4 m4.
     terrain-segment-size perlin-noise-image bitmap>> ; inline
 : tiny-noise-segment ( terrain at -- bytes )
     [ tiny-noise-seed>> ] dip seed-at
diff --git a/extra/terrain/shaders/shaders.factor b/extra/terrain/shaders/shaders.factor
index 9233ab3f36..8e8890b1d0 100644
--- a/extra/terrain/shaders/shaders.factor
+++ b/extra/terrain/shaders/shaders.factor
@@ -13,7 +13,7 @@ void main()
 
     vec4 p = gl_ProjectionMatrixInverse * v;
     p.z = -abs(p.z);
-    
+
     float s = sin(sky_theta), c = cos(sky_theta);
     direction = mat3(1, 0, 0,  0, c, s,  0, -s, c)
         * (gl_ModelViewMatrixInverse * vec4(p.xyz, 0.0)).xyz;
diff --git a/extra/tetris/board/board.factor b/extra/tetris/board/board.factor
index 2346999bcb..b6239348ab 100644
--- a/extra/tetris/board/board.factor
+++ b/extra/tetris/board/board.factor
@@ -18,7 +18,7 @@ TUPLE: board { width integer } { height integer } rows ;
     [ second swap rows>> nth ] keep first swap ;
 
 : set-block ( board block colour -- ) -rot board@block set-nth ;
-  
+
 : block ( board block -- colour ) board@block nth ;
 
 : block-free? ( board block -- ? ) block not ;
@@ -52,4 +52,3 @@ TUPLE: board { width integer } { height integer } rows ;
     #! remove full rows, then add blank ones at the top, returning the number
     #! of rows removed (and added)
     remove-full-rows dup height>> over rows>> length - swap top-up-rows ;
-
diff --git a/extra/tetris/game/game.factor b/extra/tetris/game/game.factor
index d96434fbe1..e2b00d9b56 100644
--- a/extra/tetris/game/game.factor
+++ b/extra/tetris/game/game.factor
@@ -18,7 +18,7 @@ CONSTANT: default-height 20
 :  ( width height -- tetris )
     dupd  swap 
     tetris new swap >>pieces swap >>board ;
-        
+
 :  ( -- tetris ) default-width default-height  ;
 
 :  ( old -- new )
diff --git a/extra/tetris/gl/gl.factor b/extra/tetris/gl/gl.factor
index 8326da3584..788febace7 100644
--- a/extra/tetris/gl/gl.factor
+++ b/extra/tetris/gl/gl.factor
@@ -44,4 +44,4 @@ IN: tetris.gl
             [ next-piece draw-next-piece ]
             [ current-piece draw-piece ]
         } cleave
-    ] do-matrix ;
\ No newline at end of file
+    ] do-matrix ;
diff --git a/extra/tetris/tetris.factor b/extra/tetris/tetris.factor
index 25802a2411..6509988891 100644
--- a/extra/tetris/tetris.factor
+++ b/extra/tetris/tetris.factor
@@ -60,7 +60,7 @@ M: tetris-gadget graft* ( gadget -- )
 M: tetris-gadget ungraft* ( gadget -- )
     [ stop-timer f ] change-timer drop ;
 
-: tetris-window ( -- ) 
+: tetris-window ( -- )
     [
          
         "Tetris" open-status-window
diff --git a/extra/tetris/tetromino/tetromino.factor b/extra/tetris/tetromino/tetromino.factor
index 8eaf1c0426..cec67b9403 100644
--- a/extra/tetris/tetromino/tetromino.factor
+++ b/extra/tetris/tetromino/tetromino.factor
@@ -14,7 +14,7 @@ SYMBOL: tetrominoes
   [
     { {
         { 0 0 } { 1 0 } { 2 0 } { 3 0 }
-      } 
+      }
       { { 0 0 }
         { 0 1 }
         { 0 2 }
@@ -60,7 +60,7 @@ SYMBOL: tetrominoes
       }
     } COLOR: orange
   ] [
-    { 
+    {
       { { 0 0 } { 1 0 } { 2 0 }
                         { 2 1 }
       } {
@@ -111,4 +111,3 @@ SYMBOL: tetrominoes
 
 : blocks-height ( blocks -- height )
     [ second ] blocks-max ;
-
diff --git a/extra/text-to-pdf/text-to-pdf.factor b/extra/text-to-pdf/text-to-pdf.factor
index 13a2538a6c..d4f91b6ce6 100644
--- a/extra/text-to-pdf/text-to-pdf.factor
+++ b/extra/text-to-pdf/text-to-pdf.factor
@@ -138,4 +138,3 @@ PRIVATE>
 : file-to-pdf ( path encoding -- )
     [ file-contents text-to-pdf ]
     [ [ ".pdf" append ] dip set-file-contents ] 2bi ;
-
diff --git a/extra/time/macosx/macosx.factor b/extra/time/macosx/macosx.factor
index 17cc34277a..98521f64ed 100644
--- a/extra/time/macosx/macosx.factor
+++ b/extra/time/macosx/macosx.factor
@@ -13,4 +13,3 @@ M: macosx adjust-time-monotonic
     ] [
         timeval>duration since-1970 now time-
     ] if ;
-
diff --git a/extra/time/windows/windows.factor b/extra/time/windows/windows.factor
index e5d7f918d9..95fc9706e1 100644
--- a/extra/time/windows/windows.factor
+++ b/extra/time/windows/windows.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2010 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: calendar.windows system time windows.errors 
+USING: calendar.windows system time windows.errors
 windows.kernel32 kernel classes.struct calendar ;
 IN: time.windows
 
diff --git a/extra/tnetstrings/tnetstrings.factor b/extra/tnetstrings/tnetstrings.factor
index d9b9f1ccf8..bf0a4c5ef7 100644
--- a/extra/tnetstrings/tnetstrings.factor
+++ b/extra/tnetstrings/tnetstrings.factor
@@ -95,4 +95,3 @@ PRIVATE>
 
 : >tnetstring ( value -- string )
     dump-tnetstring ;
-
diff --git a/extra/tools/cat/cat.factor b/extra/tools/cat/cat.factor
index 0d9ac2927a..ea90e42a38 100644
--- a/extra/tools/cat/cat.factor
+++ b/extra/tools/cat/cat.factor
@@ -24,4 +24,3 @@ IN: tools.cat
     command-line get [ cat-lines ] [ cat-files ] if-empty ;
 
 MAIN: run-cat
-
diff --git a/extra/tools/dns/public/public.factor b/extra/tools/dns/public/public.factor
index ec1ed9950e..fe6102d8f0 100644
--- a/extra/tools/dns/public/public.factor
+++ b/extra/tools/dns/public/public.factor
@@ -19,7 +19,7 @@ CONSTANT: opendns-dns-servers { "208.67.222.222" "208.67.220.220" }
 CONSTANT: norton-dns-servers { "198.153.192.1" "198.153.194.1" }
 : norton-host ( domain -- ) [ norton-dns-servers ] dip dns-host ;
 
-CONSTANT: verizon-dns-servers { 
+CONSTANT: verizon-dns-servers {
     "4.2.2.1"
     "4.2.2.2"
     "4.2.2.3"
diff --git a/extra/trails/trails.factor b/extra/trails/trails.factor
index 704648cb73..b678899db1 100644
--- a/extra/trails/trails.factor
+++ b/extra/trails/trails.factor
@@ -35,7 +35,7 @@ TUPLE: trails-gadget < gadget paused points ;
 
   ! Add a valid point if the mouse is in the gadget
   ! Otherwise, add an "invisible" point
-  
+
   hand-gadget get GADGET =
     [ mouse       GADGET points>> circular-push ]
     [ { -10 -10 } GADGET points>> circular-push ]
diff --git a/extra/trees/avl/avl.factor b/extra/trees/avl/avl.factor
index db131c5ddb..2d55e79f45 100644
--- a/extra/trees/avl/avl.factor
+++ b/extra/trees/avl/avl.factor
@@ -27,11 +27,11 @@ TUPLE: avl-node < node balance ;
     [ node+link ]
     [ node-link ]
     [ set-node+link ] tri
-    [ set-node-link ] keep ;    
+    [ set-node-link ] keep ;
 
 : single-rotate ( node -- node )
     0 >>balance
-    0 over node+link 
+    0 over node+link
     balance<< rotate ;
 
 : pick-balances ( a node -- balance balance )
diff --git a/extra/twitter/prettyprint/prettyprint.factor b/extra/twitter/prettyprint/prettyprint.factor
index 6ba528f9af..614ad56753 100644
--- a/extra/twitter/prettyprint/prettyprint.factor
+++ b/extra/twitter/prettyprint/prettyprint.factor
@@ -11,25 +11,25 @@ MEMO: load-http-image ( url -- image/f )
 : user-image ( user -- image/f )
     profile-image-url>> load-http-image ;
 
-CONSTANT: tweet-table-style 
-    H{ { table-gap { 5 5 } } } 
+CONSTANT: tweet-table-style
+    H{ { table-gap { 5 5 } } }
 
-CONSTANT: tweet-username-style 
+CONSTANT: tweet-username-style
     H{
         { font-style bold }
-    } 
+    }
 
-CONSTANT: tweet-text-style 
+CONSTANT: tweet-text-style
     H{
         { font-name "sans-serif" }
         { font-size 16 }
         { wrap-margin 500 }
-    } 
+    }
 
 CONSTANT: tweet-metadata-style
     H{
         { font-size 10 }
-    } 
+    }
 
 : profile. ( user -- )
     tweet-table-style [
@@ -63,7 +63,7 @@ CONSTANT: tweet-metadata-style
                             dup source>> write
                         ] with-style
                     ] with-style
-                ] with-nesting 
+                ] with-nesting
             ] with-cell
         ] with-row
     ] tabular-output nl
diff --git a/extra/twitter/twitter.factor b/extra/twitter/twitter.factor
index fbdeee4e20..b27122df4f 100644
--- a/extra/twitter/twitter.factor
+++ b/extra/twitter/twitter.factor
@@ -83,7 +83,7 @@ TUPLE: twitter-user
     screen-name
     description
     location
-    profile-image-url 
+    profile-image-url
     url
     protected?
     followers-count ;
@@ -104,7 +104,7 @@ TUPLE: twitter-user
     } twitter-user keys-boa ;
 
 :  ( assoc -- tweet )
-    clone "user" over [  ] change-at 
+    clone "user" over [  ] change-at
     {
         "created_at"
         "id"
diff --git a/extra/ui/gadgets/worlds/null/null.factor b/extra/ui/gadgets/worlds/null/null.factor
index eb0e1c1d5c..8322430323 100644
--- a/extra/ui/gadgets/worlds/null/null.factor
+++ b/extra/ui/gadgets/worlds/null/null.factor
@@ -23,5 +23,3 @@ M: null-world resize-world drop ;
 
 : into-window ( world quot -- world )
     [ dup ] dip with-gl-context ; inline
-
-
diff --git a/extra/ui/render/test/test.factor b/extra/ui/render/test/test.factor
index 209230e451..abf3c31880 100644
--- a/extra/ui/render/test/test.factor
+++ b/extra/ui/render/test/test.factor
@@ -68,7 +68,7 @@ M: take-screenshot draw-boundary
             { 5 5 } >>gap
             COLOR: blue  >>boundary
         add-gadget ;
-    
+
 : ui-render-test ( -- )
      "Test" open-window ;
 
diff --git a/extra/ui/utils/utils.factor b/extra/ui/utils/utils.factor
index 0880139865..87a3bfa171 100644
--- a/extra/ui/utils/utils.factor
+++ b/extra/ui/utils/utils.factor
@@ -3,4 +3,4 @@ IN: ui.utils
 SYMBOLS: width height ;
 : store-dim ( gadget -- ) dim>> [ first width set ] [ second height set ] bi ;
 : with-dim ( gadget quot -- ) '[ _ store-dim @ ] with-scope ; inline
-: with-w/h ( gadget quot -- ) '[ origin get _ with-translation ] with-dim ; inline
\ No newline at end of file
+: with-w/h ( gadget quot -- ) '[ origin get _ with-translation ] with-dim ; inline
diff --git a/extra/units/constants/constants.factor b/extra/units/constants/constants.factor
index 7350cbf03d..eb3cad0e88 100644
--- a/extra/units/constants/constants.factor
+++ b/extra/units/constants/constants.factor
@@ -7,9 +7,8 @@ IN: units.constants
 ! : c 299792458 m/s ;
 ! : c0 299792458 m/s ; ! same as c
 ! : c-vacuum 299792458 m/s ; ! same as c
-! 
+!
 ! ! more to come
-! 
+!
 ! : avogadro
 !     6.02214179e23 { } { mol }  ;
-
diff --git a/extra/units/imperial/imperial.factor b/extra/units/imperial/imperial.factor
index 599a73a51f..e41428073d 100644
--- a/extra/units/imperial/imperial.factor
+++ b/extra/units/imperial/imperial.factor
@@ -138,7 +138,7 @@ DEFER: imperial-fluid-ounces
 : imperial-gill ( n -- dimensioned ) 5 * imperial-fluid-ounces ;
 
 
-: dry-gallons ( n -- dimensioned ) 440488377086/100000000000 * L ; 
+: dry-gallons ( n -- dimensioned ) 440488377086/100000000000 * L ;
 
 : dry-quarts ( n -- dimensioned ) 1/4 * dry-gallons ;
 
diff --git a/extra/update/backup/backup.factor b/extra/update/backup/backup.factor
index 7728003189..76e65f4c65 100644
--- a/extra/update/backup/backup.factor
+++ b/extra/update/backup/backup.factor
@@ -4,7 +4,7 @@ IN: update.backup
 
 : backup-boot-image ( -- )
   my-boot-image-name
-  { "boot." my-arch "-" [ "datestamp" get ] ".image" } to-string  
+  { "boot." my-arch "-" [ "datestamp" get ] ".image" } to-string
   move-file ;
 
 : backup-image ( -- )
diff --git a/extra/update/latest/latest.factor b/extra/update/latest/latest.factor
index 77cd184cdb..88e634743d 100644
--- a/extra/update/latest/latest.factor
+++ b/extra/update/latest/latest.factor
@@ -48,4 +48,4 @@ IN: update.latest
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-MAIN: update-latest
\ No newline at end of file
+MAIN: update-latest
diff --git a/extra/variables/variables.factor b/extra/variables/variables.factor
index 1469b898e2..abd2322d48 100644
--- a/extra/variables/variables.factor
+++ b/extra/variables/variables.factor
@@ -59,7 +59,7 @@ PREDICATE: typed-variable < variable
     } 2cleave (define-variable) ;
 
 SYNTAX: TYPED-VAR:
-    scan-new-word scan-object define-typed-variable ;    
+    scan-new-word scan-object define-typed-variable ;
 
 M: typed-variable definer drop \ TYPED-VAR: f ;
 M: typed-variable definition "variable-type" word-prop 1quotation ;
@@ -95,4 +95,3 @@ SYNTAX: TYPED-GLOBAL:
     scan-new-word scan-object define-typed-global ;
 
 M: typed-global-variable definer drop \ TYPED-GLOBAL: f ;
-
diff --git a/extra/variants/variants.factor b/extra/variants/variants.factor
index 7450f29ff8..e8b50ebffc 100644
--- a/extra/variants/variants.factor
+++ b/extra/variants/variants.factor
@@ -68,4 +68,3 @@ M: object (match-branch)
 MACRO: match ( branches -- )
     [ dup callable? [ first2 (match-branch) 2array ] unless ] map
     [ \ dup \ ?class ] dip \ case [ ] 4sequence ;
-
diff --git a/extra/vocabs/git/git.factor b/extra/vocabs/git/git.factor
index 6411623b8e..8e1c30fae3 100644
--- a/extra/vocabs/git/git.factor
+++ b/extra/vocabs/git/git.factor
@@ -21,7 +21,7 @@ PRIVATE>
 ERROR: git-revision-not-found path ;
 
 : use-vocab-rev ( vocab-name rev -- )
-    [ create-vocab vocab-source-path dup ] dip git-object-id 
+    [ create-vocab vocab-source-path dup ] dip git-object-id
     [ [ input-stream get swap parse-stream call( -- ) ] with-git-object-stream ]
     [ git-revision-not-found ] if* ;
 
diff --git a/extra/webapps/fjsc/fjsc.factor b/extra/webapps/fjsc/fjsc.factor
index 67e27fc63f..3aac0ff732 100644
--- a/extra/webapps/fjsc/fjsc.factor
+++ b/extra/webapps/fjsc/fjsc.factor
@@ -1,5 +1,5 @@
 ! Copyright (C) 2008 Chris Double. All Rights Reserved.
-USING: 
+USING:
     accessors
     fjsc
     furnace
@@ -21,7 +21,7 @@ USING:
     namespaces
     peg
     sequences
-    urls 
+    urls
     validators
 ;
 IN: webapps.fjsc
@@ -29,8 +29,8 @@ IN: webapps.fjsc
 TUPLE: fjsc < dispatcher ;
 
 : absolute-url ( url -- url )
-    "http://" request get "host" header append 
-    over "/" head? [ "/" append ] unless 
+    "http://" request get "host" header append
+    over "/" head? [ "/" append ] unless
     swap append  ;
 
 :  ( body -- content )
@@ -87,7 +87,7 @@ TUPLE: fjsc < dispatcher ;
              "compile" add-responder
              "compile-url" add-responder
             
-                { fjsc "fjsc" } >>template 
+                { fjsc "fjsc" } >>template
          >>default ;
 
 : activate-fjsc ( -- )
diff --git a/extra/webapps/imagebin/imagebin.factor b/extra/webapps/imagebin/imagebin.factor
index 24cd92ca2a..38ef0f9459 100644
--- a/extra/webapps/imagebin/imagebin.factor
+++ b/extra/webapps/imagebin/imagebin.factor
@@ -3,7 +3,7 @@
 USING: accessors furnace.actions furnace.redirection
 html.forms http http.server http.server.dispatchers
 io.directories io.encodings.utf8 io.files io.pathnames
-kernel math.parser multiline namespaces sequences urls 
+kernel math.parser multiline namespaces sequences urls
 math ;
 IN: webapps.imagebin
 
@@ -15,7 +15,7 @@ TUPLE: imagebin < dispatcher path n ;
 
 : next-image-path ( -- path )
     imagebin get
-    [ path>> ] [ [ 1 + ] change-n n>> number>string ] bi append-path ; 
+    [ path>> ] [ [ 1 + ] change-n n>> number>string ] bi append-path ;
 
 M: imagebin call-responder*
     [ imagebin set ] [ call-next-method ] bi ;
diff --git a/extra/webapps/irc-log/irc-log.factor b/extra/webapps/irc-log/irc-log.factor
index 4012f2ae1c..f0a8baa53d 100644
--- a/extra/webapps/irc-log/irc-log.factor
+++ b/extra/webapps/irc-log/irc-log.factor
@@ -7,12 +7,12 @@ IN: webapps.irc-log
 
 TUPLE: irclog-app < dispatcher ;
 
-: irc-link ( channel -- string )   
+: irc-link ( channel -- string )
     gmt -7 hours convert-timezone >date<
     [ unparse 2 tail ] 2dip
     "http://bespin.org/~nef/logs/%s/%02s.%02d.%02d"
     sprintf ;
-    
+
 :  ( -- action )
     
         [ "concatenative" irc-link  ] >>display ;
diff --git a/extra/webapps/site-watcher/spidering/spidering.factor b/extra/webapps/site-watcher/spidering/spidering.factor
index a838c6763a..2aaf7ef20f 100644
--- a/extra/webapps/site-watcher/spidering/spidering.factor
+++ b/extra/webapps/site-watcher/spidering/spidering.factor
@@ -49,4 +49,4 @@ CONSTANT: site-list-url URL" $site-watcher-app/spider-list"
             site-list-url 
         ] >>submit
     
-        "spider sites" >>description ;
\ No newline at end of file
+        "spider sites" >>description ;
diff --git a/extra/webapps/site-watcher/watching/watching.factor b/extra/webapps/site-watcher/watching/watching.factor
index 414595a12a..618099041c 100644
--- a/extra/webapps/site-watcher/watching/watching.factor
+++ b/extra/webapps/site-watcher/watching/watching.factor
@@ -49,4 +49,4 @@ CONSTANT: site-list-url URL" $site-watcher-app/watch-list"
             site-list-url 
         ] >>submit
     
-        "check watched sites" >>description ;
\ No newline at end of file
+        "check watched sites" >>description ;
diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor
index 01ed2402f7..ab9e578308 100644
--- a/extra/webapps/todo/todo.factor
+++ b/extra/webapps/todo/todo.factor
@@ -40,7 +40,7 @@ todo "TODO"
             validate-integer-id
             "id" value  select-tuple from-object
         ] >>init
-        
+
         { todo-list "view-todo" } >>template ;
 
 : validate-todo ( -- )
diff --git a/extra/webapps/wee-url/wee-url.factor b/extra/webapps/wee-url/wee-url.factor
index 8e200a4452..1d9b5e211b 100644
--- a/extra/webapps/wee-url/wee-url.factor
+++ b/extra/webapps/wee-url/wee-url.factor
@@ -1,10 +1,10 @@
 ! Copyright (C) 2007 Doug Coleman.
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: math.ranges sequences random accessors 
+USING: math.ranges sequences random accessors
 kernel namespaces fry db.types db.tuples urls validators
 html.components html.forms http http.server.dispatchers furnace
-furnace.actions furnace.boilerplate furnace.redirection 
+furnace.actions furnace.boilerplate furnace.redirection
 furnace.utilities continuations ;
 IN: webapps.wee-url
 
diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor
index 6e137f75f0..ce3dd31d92 100644
--- a/extra/webapps/wiki/wiki.factor
+++ b/extra/webapps/wiki/wiki.factor
@@ -120,7 +120,7 @@ M: revision feed-entry-url id>> revision-url ;
         ] >>init
 
         { wiki "view" } >>template
-    
+
      ;
 
 :  ( -- action )
@@ -244,7 +244,7 @@ M: revision feed-entry-url id>> revision-url ;
             [ add-revision ]
             [ title>> revisions-url  ] bi
         ] >>submit
-    
+
     
         "rollback wiki articles" >>description ;
 
diff --git a/extra/wordtimer/wordtimer.factor b/extra/wordtimer/wordtimer.factor
index 9100736bda..7f8b57c3c3 100644
--- a/extra/wordtimer/wordtimer.factor
+++ b/extra/wordtimer/wordtimer.factor
@@ -7,7 +7,7 @@ IN: wordtimer
 SYMBOL: *wordtimes*
 SYMBOL: *calling*
 
-: reset-word-timer ( -- ) 
+: reset-word-timer ( -- )
     H{ } clone *wordtimes* set-global
     H{ } clone *calling* set-global ;
 
@@ -38,7 +38,7 @@ SYMBOL: *calling*
     [ timed-call ] [ drop call ] if ; inline
 
 : (add-timer) ( word quot -- quot' )
-    [ swap time-unless-recursing ] 2curry ; 
+    [ swap time-unless-recursing ] 2curry ;
 
 : add-timer ( word -- )
     dup '[ [ _ ] dip (add-timer) ] annotate ;
@@ -59,7 +59,7 @@ SYMBOL: *calling*
     swap [ * - ] keep 2array ;
 
 : (correct-for-timing-overhead) ( timingshash -- timingshash )
-    time-dummy-word [ subtract-overhead ] curry assoc-map ;  
+    time-dummy-word [ subtract-overhead ] curry assoc-map ;
 
 : correct-for-timing-overhead ( -- )
     *wordtimes* [ (correct-for-timing-overhead) ] change-global ;
@@ -68,7 +68,7 @@ SYMBOL: *calling*
     *wordtimes* get-global [ swap suffix ] { } assoc>map natural-sort reverse pprint ;
 
 : wordtimer-call ( quot -- )
-    reset-word-timer 
+    reset-word-timer
     benchmark [
         correct-for-timing-overhead
         "total time:" write
diff --git a/extra/yaml/config/config.factor b/extra/yaml/config/config.factor
index 079f840f02..19de829091 100644
--- a/extra/yaml/config/config.factor
+++ b/extra/yaml/config/config.factor
@@ -14,7 +14,7 @@ SYMBOL: emitter-line-break
 ! Set this value to keep libyaml's default
 SYMBOL: +libyaml-default+
 
-{ 
+{
     emitter-canonical
     emitter-indent
     emitter-width
diff --git a/extra/zoneinfo/zoneinfo.factor b/extra/zoneinfo/zoneinfo.factor
index 45c03ae8e6..89710e7822 100644
--- a/extra/zoneinfo/zoneinfo.factor
+++ b/extra/zoneinfo/zoneinfo.factor
@@ -138,7 +138,7 @@ MEMO: zoneinfo-array ( -- seq )
 
 : raw-zone-map ( -- assoc )
     zoneinfo-array [ raw-zone? ] filter [ name>> ] collect-by ;
-    
+
 GENERIC: zone-matches? ( string rule -- ? )
 
 M: raw-rule zone-matches? name>> = ;
diff --git a/unmaintained/4DNav/4DNav.factor b/unmaintained/4DNav/4DNav.factor
index dd4ea1fcda..8ba0788a6b 100644
--- a/unmaintained/4DNav/4DNav.factor
+++ b/unmaintained/4DNav/4DNav.factor
@@ -1,567 +1,567 @@
-! Copyright (C) 2008 Jeff Bigot
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel 
-namespaces
-accessors
-assocs
-make
-math
-math.functions
-math.trig
-math.parser
-hashtables
-sequences
-combinators
-continuations
-colors
-colors.constants
-prettyprint
-vars
-quotations
-io
-io.directories
-io.pathnames
-help.markup
-io.files
-ui.gadgets.panes
- ui
-       ui.gadgets
-       ui.traverse
-       ui.gadgets.borders
-       ui.gadgets.frames
-       ui.gadgets.tracks
-       ui.gadgets.labels
-       ui.gadgets.labeled       
-       ui.gadgets.lists
-       ui.gadgets.buttons
-       ui.gadgets.packs
-       ui.gadgets.grids
-       ui.gadgets.corners
-       ui.gestures
-       ui.gadgets.scrollers
-splitting
-vectors
-math.vectors
-values
-4DNav.turtle
-4DNav.window3D
-4DNav.deep
-4DNav.space-file-decoder
-models
-fry
-adsoda
-adsoda.tools
-;
-QUALIFIED-WITH: ui.pens.solid s
-QUALIFIED-WITH: ui.gadgets.wrappers w
-
-
-IN: 4DNav
-VALUE: selected-file
-VALUE: translation-step
-VALUE: rotation-step
-
-3 \ translation-step set-value
-5 \ rotation-step set-value
-
-VAR: selected-file-model
-VAR: observer3d 
-VAR: view1 
-VAR: view2
-VAR: view3
-VAR: view4
-VAR: present-space
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! namespace utilities
-
-: closed-quot ( quot -- quot )
-  namestack swap '[ namestack [ _ set-namestack @ ] dip set-namestack ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! waiting for deep-cleave-quots
-
-: 4D-Rxy ( angle -- Rx ) deg>rad
-[ 1.0 , 0.0 , 0.0       , 0.0 ,
-  0.0 , 1.0 , 0.0       , 0.0 ,
-  0.0 , 0.0 , dup cos  , dup sin neg  ,
-  0.0 , 0.0 , dup sin  , dup cos  ,  ] 4 make-matrix nip ;
-
-: 4D-Rxz ( angle -- Ry ) deg>rad
-[ 1.0 , 0.0       , 0.0 , 0.0 ,
-  0.0 , dup cos  , 0.0 , dup sin neg  ,
-  0.0 , 0.0       , 1.0 , 0.0 ,
-  0.0 , dup sin  , 0.0 , dup cos  ,  ] 4 make-matrix nip ;
-
-: 4D-Rxw ( angle -- Rz ) deg>rad
-[ 1.0 , 0.0       , 0.0           , 0.0 ,
-  0.0 , dup cos  , dup sin neg  , 0.0 ,
-  0.0 , dup sin  , dup cos     , 0.0 ,
-  0.0 , 0.0       , 0.0           , 1.0 , ] 4 make-matrix nip ;
-
-: 4D-Ryz ( angle -- Rx ) deg>rad
-[ dup cos  , 0.0 , 0.0 , dup sin neg  ,
-  0.0       , 1.0 , 0.0 , 0.0 ,
-  0.0       , 0.0 , 1.0 , 0.0 ,
-  dup sin  , 0.0 , 0.0 , dup cos  ,   ] 4 make-matrix nip ;
-
-: 4D-Ryw ( angle -- Ry ) deg>rad
-[ dup cos  , 0.0 , dup sin neg  , 0.0 ,
-  0.0       , 1.0 , 0.0           , 0.0 ,
-  dup sin  , 0.0 , dup cos     , 0.0 ,
-  0.0       , 0.0 , 0.0        , 1.0 ,  ] 4 make-matrix nip ;
-
-: 4D-Rzw ( angle -- Rz ) deg>rad
-[ dup cos  , dup sin neg  , 0.0 , 0.0 ,
-  dup sin  , dup cos     , 0.0 , 0.0 ,
-  0.0       , 0.0           , 1.0 , 0.0 ,
-  0.0       , 0.0          , 0.0 , 1.0 ,  ] 4 make-matrix nip ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! UI
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: button* ( string quot -- button ) 
-    closed-quot   ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: model-projection-chooser ( -- gadget )
-   observer3d> projection-mode>>
-   { { 1 "perspective" } { 0 "orthogonal" } } 
-    ;
-
-: collision-detection-chooser ( -- gadget )
-   observer3d> collision-mode>>
-   { { t "on" } { f "off" }  }  ;
-
-: model-projection ( x -- space ) 
-    present-space>  swap space-project ;
-
-: update-observer-projections (  -- )
-    view1> relayout-1 
-    view2> relayout-1 
-    view3> relayout-1 
-    view4> relayout-1 ;
-
-: update-model-projections (  -- )
-    0 model-projection  view1> model<<
-    1 model-projection  view2> model<<
-    2 model-projection  view3> model<<
-    3 model-projection  view4> model<< ;
-
-: camera-action ( quot -- quot ) 
-    '[ drop _ observer3d>  
-    with-self update-observer-projections ] 
-    closed-quot ;
-
-: win3D ( text gadget -- ) 
-    "navigateur 4D : " rot append open-window ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! 4D object manipulation
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: (mvt-4D) ( quot -- )   
-    present-space>  
-        swap call space-ensure-solids 
-    >present-space 
-    update-model-projections 
-    update-observer-projections ; inline
-
-: rotation-4D ( m -- ) 
-    '[ _ [ [ middle-of-space dup vneg ] keep 
-        swap space-translate ] dip
-         space-transform 
-         swap space-translate
-    ] (mvt-4D) ;
-
-: translation-4D ( v -- ) '[ _ space-translate ] (mvt-4D) ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! menu
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: menu-rotations-4D ( -- gadget )
-    3 3 
-        { 1 1 } >>filled-cell
-          1 >>fill
-          "XY +" [ drop rotation-step 4D-Rxy rotation-4D ] 
-                button* add-gadget
-          "XY -" [ drop rotation-step neg 4D-Rxy rotation-4D ] 
-                button* add-gadget 
-       @top-left grid-add    
-         1 >>fill
-          "XZ +" [ drop rotation-step 4D-Rxz rotation-4D ] 
-                button* add-gadget
-          "XZ -" [ drop rotation-step neg 4D-Rxz rotation-4D ] 
-                button* add-gadget 
-       @top grid-add    
-         1 >>fill
-          "YZ +" [ drop rotation-step 4D-Ryz rotation-4D ] 
-                button* add-gadget
-          "YZ -" [ drop rotation-step neg 4D-Ryz rotation-4D ] 
-                button* add-gadget 
-        @center grid-add
-          1 >>fill
-          "XW +" [ drop rotation-step 4D-Rxw rotation-4D ] 
-                button* add-gadget
-          "XW -" [ drop rotation-step neg 4D-Rxw rotation-4D ] 
-                button* add-gadget 
-        @top-right grid-add   
-          1 >>fill
-          "YW +" [ drop rotation-step 4D-Ryw rotation-4D ] 
-                button* add-gadget
-          "YW -" [ drop rotation-step neg 4D-Ryw rotation-4D ] 
-                button* add-gadget 
-       @right grid-add    
-          1 >>fill
-          "ZW +" [ drop rotation-step 4D-Rzw rotation-4D ] 
-                button* add-gadget
-          "ZW -" [ drop rotation-step neg 4D-Rzw rotation-4D ] 
-                button* add-gadget 
-       @bottom-right grid-add    
-;
-
-: menu-translations-4D ( -- gadget )
-    3 3  
-        { 1 1 } >>filled-cell
-         1 >>fill
-             1 >>fill  
-                "X+" [ drop {  1 0 0 0 } translation-step v*n 
-                    translation-4D ] 
-                    button* add-gadget
-                "X-" [ drop { -1 0 0 0 } translation-step v*n 
-                    translation-4D ] 
-                    button* add-gadget 
-            add-gadget
-            "YZW"