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

basis/alien/fortran/fortran-docs.factor

@@ -7,10 +7,10 @@ IN: alien.fortran
 ARTICLE: "alien.fortran-abis" "Fortran ABIs"
 "Fortran does not have a standard ABI like C does. Factor supports the following Fortran ABIs:"
 { $list
-    { { $subsection gfortran-abi } " is used by gfortran, the Fortran compiler included with GCC 4." }
-    { { $subsection f2c-abi } " is used by the F2C Fortran-to-C translator and G77, the Fortran compiler included with GCC 3.x and earlier. It is also used by gfortran when compiling with the -ff2c flag." }
-    { { $subsection intel-unix-abi } " is used by the Intel Fortran Compiler on Linux and Mac OS X." }
-    { { $subsection intel-windows-abi } " is used by the Intel Fortran Compiler on Windows." }
+    { { $link gfortran-abi } " is used by gfortran, the Fortran compiler included with GCC 4." }
+    { { $link f2c-abi } " is used by the F2C Fortran-to-C translator and G77, the Fortran compiler included with GCC 3.x and earlier. It is also used by gfortran when compiling with the -ff2c flag." }
+    { { $link intel-unix-abi } " is used by the Intel Fortran Compiler on Linux and Mac OS X." }
+    { { $link intel-windows-abi } " is used by the Intel Fortran Compiler on Windows." }
 }
 "A library's ABI is specified when that library is opened by the " { $link add-fortran-library } " word." ;
 

basis/math/blas/config/config-docs.factor

@@ -0,0 +1,23 @@
+USING: alien.fortran help.markup help.syntax math.blas.config multiline ;
+IN: math.blas.config
+
+ARTICLE: "math.blas.config" "Configuring the BLAS interface"
+"The " { $link "math.blas-summary" } " chooses the underlying BLAS interface to use based on the values of the following global variables:"
+{ $subsection blas-library }
+{ $subsection blas-fortran-abi }
+"The interface attempts to set default values based on the ones encountered on the Factor project's build machines. If these settings don't work with your system's BLAS, or you wish to use a commercial BLAS, you may change the global values of those variables in your " { $link "factor-rc" } ". For example, to use AMD's ACML library on Windows with " { $snippet "math.blas" } ", your " { $snippet "factor-rc" } " would look like this:"
+{ $code <"
+USING: math.blas.config namespaces ;
+"X:\\path\\to\\acml.dll" blas-library set-global
+intel-windows-abi blas-fortran-abi set-global
+"> }
+"To take effect, the " { $snippet "blas-library" } " and " { $snippet "blas-fortran-abi" } " variables must be set before any other " { $snippet "math.blas" } " vocabularies are loaded."
+;
+
+HELP: blas-library
+{ $description "The name of the shared library containing the BLAS interface to load. The value of this variable must be a valid shared library name that can be passed to " { $link add-fortran-library } ". To take effect, this variable must be set before any other " { $snippet "math.blas" } " vocabularies are loaded. See " { $link "math.blas.config" } " for details and examples." } ;
+
+HELP: blas-fortran-abi
+{ $description "The Fortran ABI used by the BLAS interface specified in the " { $link blas-library } " variable. The value of " { $snippet "blas-fortran-abi" } " must be one of the " { $link "alien.fortran-abis" } " that can be passed to " { $link add-fortran-library } ". To take effect, this variable must be set before any other " { $snippet "math.blas" } " vocabularies are loaded. See " { $link "math.blas.config" } " for details and examples." } ;
+
+ABOUT: "math.blas.config"

basis/math/blas/config/config.factor

@@ -0,0 +1,23 @@
+USING: alien.fortran combinators kernel namespaces system ;
+IN: math.blas.config
+
+SYMBOLS: blas-library blas-fortran-abi ;
+
+blas-library [
+    {
+        { [ os macosx?  ] [ "libblas.dylib" ] }
+        { [ os windows? ] [ "blas.dll"      ] }
+        [ "libblas.so" ]
+    } cond
+] initialize
+
+blas-fortran-abi [
+    {
+        { [ os macosx?                  ] [ intel-unix-abi ] }
+        { [ os windows? cpu x86.32? and ] [ f2c-abi        ] }
+        { [ os windows? cpu x86.64? and ] [ gfortran-abi   ] }
+        { [ os freebsd?                 ] [ gfortran-abi   ] }
+        { [ os linux?   cpu x86.32? and ] [ gfortran-abi   ] }
+        [ f2c-abi ]
+    } cond
+] initialize

basis/math/blas/ffi/ffi.factor

@@ -1,18 +1,9 @@
-USING: alien alien.fortran kernel system combinators
-alien.libraries ;
+USING: alien.fortran kernel math.blas.config namespaces ;
 IN: math.blas.ffi
 
 <<
-"blas" {
-    { [ os macosx? ] [ "libblas.dylib" intel-unix-abi add-fortran-library ] }
-    { [ os windows? cpu x86.32? and ] [ "blas.dll" f2c-abi add-fortran-library ] }
-    { [ os windows? cpu x86.64? and ] [ "blas.dll" gfortran-abi add-fortran-library ] }
-    {
-        [ os [ freebsd? ] [ linux? cpu x86.32? and ] bi or ]
-        [ "libblas.so" gfortran-abi add-fortran-library ]
-    }
-    [ "libblas.so" f2c-abi add-fortran-library ]
-} cond
+"blas" blas-library blas-fortran-abi [ get ] bi@
+add-fortran-library
 >>
 
 LIBRARY: blas

basis/math/blas/matrices/matrices-docs.factor

@@ -2,13 +2,14 @@ USING: alien byte-arrays help.markup help.syntax math math.blas.vectors sequence
 IN: math.blas.matrices
 
 ARTICLE: "math.blas-summary" "Basic Linear Algebra Subroutines (BLAS) interface"
-"Factor provides an interface to high-performance vector and matrix math routines available in the system's BLAS library. A set of specialized types are provided for handling packed, unboxed vector data:"
+"Factor provides an interface to high-performance vector and matrix math routines available in implementations of the BLAS math library. A set of specialized types are provided for handling packed, unboxed vector data:"
 { $subsection "math.blas-types" }
 "Scalar-vector and vector-vector operations are available in the " { $vocab-link "math.blas.vectors" } " vocabulary:"
 { $subsection "math.blas.vectors" }
 "Vector-matrix and matrix-matrix operations are available in the " { $vocab-link "math.blas.matrices" } " vocabulary:"
 { $subsection "math.blas.matrices" }
-"The low-level BLAS Fortran interface can be accessed directly through the " { $vocab-link "math.blas.ffi" } " vocabulary." ;
+"The low-level BLAS Fortran interface can be accessed directly through the " { $vocab-link "math.blas.ffi" } " vocabulary. The BLAS interface can be configured to use different underlying BLAS implementations:"
+{ $subsection "math.blas.config" } ;
 
 ARTICLE: "math.blas-types" "BLAS interface types"
 "BLAS vectors come in single- and double-precision, real and complex flavors:"

basis/ui/gadgets/panes/panes.factor

@@ -75,7 +75,8 @@ M: pane gadget-selection ( pane -- string/f )
 GENERIC: draw-selection ( loc obj -- )
 
 : if-fits ( rect quot -- )
-    [ clip get over contains-rect? ] dip [ drop ] if ; inline
+    [ clip get origin get vneg offset-rect over contains-rect? ] dip
+    [ drop ] if ; inline
 
 M: gadget draw-selection ( loc gadget -- )
     swap offset-rect [

basis/unicode/categories/categories-tests.factor

@@ -12,3 +12,8 @@ IN: unicode.categories.tests
 [ "Lo" ] [ HEX: 3450 category ] unit-test
 [ "Lo" ] [ HEX: 4DB5 category ] unit-test
 [ "Cs" ] [ HEX: DD00 category ] unit-test
+[ t ] [ CHAR: \t blank? ] unit-test
+[ t ] [ CHAR: \s blank? ] unit-test
+[ t ] [ CHAR: \r blank? ] unit-test
+[ t ] [ CHAR: \n blank? ] unit-test
+[ f ] [ CHAR: a blank? ] unit-test

basis/unicode/categories/categories.factor

@@ -3,7 +3,7 @@
 USING: unicode.categories.syntax sequences unicode.data ;
 IN: unicode.categories
 
-CATEGORY: blank Zs Zl Zp | "\r\n" member? ;
+CATEGORY: blank Zs Zl Zp | "\r\n\t" member? ;
 CATEGORY: letter Ll | "Other_Lowercase" property? ;
 CATEGORY: LETTER Lu | "Other_Uppercase" property? ;
 CATEGORY: Letter Lu Ll Lt Lm Lo Nl ;

basis/urls/urls-docs.factor

@@ -65,9 +65,8 @@ HELP: derive-url
 } ;
 
 HELP: ensure-port
-{ $values { "url" url } }
-{ $description "If the URL does not specify a port number, fill in the default for the URL's protocol. If the protocol is unknown, the port number is not changed." }
-{ $side-effects "url" }
+{ $values { "url" url } { "url'" url } }
+{ $description "If the URL does not specify a port number, create a new URL which is equal except the port number is set to the default for the URL's protocol. If the protocol is unknown, outputs an exact copy of the input URL." }
 { $examples
     { $example
         "USING: accessors prettyprint urls ;"

basis/urls/urls.factor

@@ -175,8 +175,8 @@ PRIVATE>
     ] [ protocol>> ] bi
     secure-protocol? [ >secure-addr ] when ;
 
-: ensure-port ( url -- url )
-    dup protocol>> '[ _ protocol-port or ] change-port ;
+: ensure-port ( url -- url' )
+    clone dup protocol>> '[ _ protocol-port or ] change-port ;
 
 ! Literal syntax
 SYNTAX: URL" lexer get skip-blank parse-string >url parsed ;

extra/c/preprocessor/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

extra/c/preprocessor/preprocessor-tests.factor

@@ -0,0 +1,16 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test c.preprocessor kernel accessors ;
+IN: c.preprocessor.tests
+
+[ "vocab:c/tests/test1/test1.c" start-preprocess-file ]
+[ include-nested-too-deeply? ] must-fail-with
+
+[ "yo\n\n\n\nyo4\n" ]
+[ "vocab:c/tests/test2/test2.c" start-preprocess-file nip ] unit-test
+
+[ "vocab:c/tests/test3/test3.c" start-preprocess-file ]
+[ "\"BOO\"" = ] must-fail-with
+
+[ V{ "\"omg\"" "\"lol\"" } ]
+[ "vocab:c/tests/test4/test4.c" start-preprocess-file drop warnings>> ] unit-test

extra/c/preprocessor/preprocessor.factor

@@ -0,0 +1,155 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: html.parser.state io io.encodings.utf8 io.files
+io.streams.string kernel combinators accessors io.pathnames
+fry sequences arrays locals namespaces io.directories
+assocs math splitting make ;
+IN: c.preprocessor
+
+: initial-library-paths ( -- seq )
+    V{ "/usr/include" } clone ;
+
+TUPLE: preprocessor-state library-paths symbol-table
+include-nesting include-nesting-max processing-disabled?
+ifdef-nesting warnings ;
+
+: <preprocessor-state> ( -- preprocessor-state )
+    preprocessor-state new
+        initial-library-paths >>library-paths
+        H{ } clone >>symbol-table
+        0 >>include-nesting
+        200 >>include-nesting-max
+        0 >>ifdef-nesting
+        V{ } clone >>warnings ;
+
+DEFER: preprocess-file
+
+ERROR: unknown-c-preprocessor state-parser name ;
+
+ERROR: bad-include-line line ;
+
+ERROR: header-file-missing path ;
+
+:: read-standard-include ( preprocessor-state path -- )
+    preprocessor-state dup library-paths>>
+    [ path append-path exists? ] find nip
+    [
+        dup [
+            path append-path
+            preprocess-file
+        ] with-directory
+    ] [
+        ! path header-file-missing
+        drop
+    ] if* ;
+
+:: read-local-include ( preprocessor-state path -- )
+    current-directory get path append-path dup :> full-path
+    dup exists? [
+        [ preprocessor-state ] dip preprocess-file
+    ] [
+        ! full-path header-file-missing
+        drop
+    ] if ;
+
+: handle-include ( preprocessor-state state-parser -- )
+    skip-whitespace advance dup previous {
+        { CHAR: < [ CHAR: > take-until-object read-standard-include ] }
+        { CHAR: " [ CHAR: " take-until-object read-local-include ] }
+        [ bad-include-line ]
+    } case ;
+
+: (readlns) ( -- )
+    readln "\\" ?tail [ , ] dip [ (readlns) ] when ;
+
+: readlns ( -- string ) [ (readlns) ] { } make concat ;
+
+: handle-define ( preprocessor-state state-parser -- )
+    [ take-token ] [ take-rest ] bi 
+    "\\" ?tail [ readlns append ] when
+    spin symbol-table>> set-at ;
+
+: handle-undef ( preprocessor-state state-parser -- )
+    take-token swap symbol-table>> delete-at ;
+
+: handle-ifdef ( preprocessor-state state-parser -- )
+    [ [ 1 + ] change-ifdef-nesting ] dip
+    take-token over symbol-table>> key?
+    [ drop ] [ t >>processing-disabled? drop ] if ;
+
+: handle-ifndef ( preprocessor-state state-parser -- )
+    [ [ 1 + ] change-ifdef-nesting ] dip
+    take-token over symbol-table>> key?
+    [ t >>processing-disabled? drop ]
+    [ drop ] if ; 
+
+: handle-endif ( preprocessor-state state-parser -- )
+    drop [ 1 - ] change-ifdef-nesting drop ;
+
+: handle-error ( preprocessor-state state-parser -- )
+    skip-whitespace
+    nip take-rest throw ;
+
+: handle-warning ( preprocessor-state state-parser -- )
+    skip-whitespace
+    take-rest swap warnings>> push ;
+
+: parse-directive ( preprocessor-state state-parser string -- )
+    {
+        { "warning" [ handle-warning ] }
+        { "error" [ handle-error ] }
+        { "include" [ handle-include ] }
+        { "define" [ handle-define ] }
+        { "undef" [ handle-undef ] }
+        { "ifdef" [ handle-ifdef ] }
+        { "ifndef" [ handle-ifndef ] }
+        { "endif" [ handle-endif ] }
+        { "if" [ 2drop ] }
+        { "elif" [ 2drop ] }
+        { "else" [ 2drop ] }
+        { "pragma" [ 2drop ] }
+        { "include_next" [ 2drop ] }
+        [ unknown-c-preprocessor ]
+    } case ;
+
+: parse-directive-line ( preprocessor-state state-parser -- )
+    advance dup take-token
+    pick processing-disabled?>> [
+        "endif" = [
+            drop f >>processing-disabled?
+            [ 1 - ] change-ifdef-nesting
+            drop
+         ] [ 2drop ] if
+    ] [
+        parse-directive
+    ] if ;
+
+: preprocess-line ( preprocessor-state state-parser -- )
+    skip-whitespace dup current CHAR: # =
+    [ parse-directive-line ]
+    [ swap processing-disabled?>> [ drop ] [ write-full nl ] if ] if ;
+
+: preprocess-lines ( preprocessor-state -- )
+    readln 
+    [ <state-parser> [ preprocess-line ] [ drop preprocess-lines ] 2bi ]
+    [ drop ] if* ;
+
+ERROR: include-nested-too-deeply ;
+
+: check-nesting ( preprocessor-state -- preprocessor-state )
+    [ 1 + ] change-include-nesting
+    dup [ include-nesting>> ] [ include-nesting-max>> ] bi > [
+        include-nested-too-deeply
+    ] when ;
+
+: preprocess-file ( preprocessor-state path -- )
+    [ check-nesting ] dip
+    [ utf8 [ preprocess-lines ] with-file-reader ]
+    [ drop [ 1 - ] change-include-nesting drop ] 2bi ;
+
+: start-preprocess-file ( path -- preprocessor-state string )
+    dup parent-directory [
+        [
+            [ <preprocessor-state> dup ] dip preprocess-file
+        ] with-string-writer
+    ] with-directory ;

extra/c/tests/test1/README

@@ -0,0 +1 @@
+Tests if the preprocessor bails on an infinite loop caused by mutually recursive #include lines.

extra/c/tests/test1/hi.h

@@ -0,0 +1 @@
+#include "lo.h"

extra/c/tests/test1/lo.h

@@ -0,0 +1 @@
+#include "hi.h"

extra/c/tests/test1/test1.c

@@ -0,0 +1 @@
+#include "hi.h"

extra/c/tests/test2/README

@@ -0,0 +1 @@
+Tests whether #define and #ifdef/#endif work in the positive case.

extra/c/tests/test2/test2.c

@@ -0,0 +1,17 @@
+#define YO
+#ifdef YO
+yo
+#endif
+
+#define YO2
+#ifndef YO2
+yo2
+#endif
+
+#ifdef YO3
+yo3
+#endif
+
+#ifndef YO4
+yo4
+#endif

extra/c/tests/test3/README

@@ -0,0 +1 @@
+Tests whether #define and #ifdef/#endif work in the positive case.

extra/c/tests/test3/test3.c

@@ -0,0 +1 @@
+#error "BOO"

extra/c/tests/test4/test4.c

@@ -0,0 +1,2 @@
+#warning "omg"
+#warning "lol"

extra/html/parser/parser-tests.factor

@@ -50,7 +50,7 @@ V{
             { "foo" "bar" }
             { "href" "http://factorcode.org/" }
             { "baz" "quux" }
-            { "nofollow" f }
+            { "nofollow" "nofollow" }
         } f f }
 }
 ] [ "<a   href  =    \"http://factorcode.org/\"    nofollow  foo   =  bar baz='quux'a=pirsqd  >" parse-html ] unit-test

extra/html/parser/parser.factor

@@ -85,7 +85,7 @@ SYMBOL: tagstack
 : parse-key/value ( state-parser -- key value )
     [ read-key >lower ]
     [ skip-whitespace "=" take-sequence ]
-    [ swap [ read-value ] [ drop f ] if ] tri ;
+    [ swap [ read-value ] [ drop dup ] if ] tri ;
 
 : (parse-attributes) ( state-parser -- )
     skip-whitespace

extra/html/parser/state/state-tests.factor

@@ -52,3 +52,50 @@ IN: html.parser.state.tests
 
 [ "cd" ]
 [ "abcd" <state-parser> [ "ab" take-sequence drop ] [ "cd" take-sequence ] bi ] unit-test
+
+[ f ]
+[
+    "\"abc\" asdf" <state-parser>
+    [ CHAR: \ CHAR: " take-quoted-string drop ] [ "asdf" take-sequence ] bi
+] unit-test
+
+[ "abc\\\"def" ]
+[
+    "\"abc\\\"def\" asdf" <state-parser>
+    CHAR: \ CHAR: " take-quoted-string
+] unit-test
+
+[ "asdf" ]
+[
+    "\"abc\" asdf" <state-parser>
+    [ CHAR: \ CHAR: " take-quoted-string drop ]
+    [ skip-whitespace "asdf" take-sequence ] bi
+] unit-test
+
+[ f ]
+[
+    "\"abc asdf" <state-parser>
+    CHAR: \ CHAR: " take-quoted-string
+] unit-test
+
+[ "\"abc" ]
+[
+    "\"abc asdf" <state-parser>
+    [ CHAR: \ CHAR: " take-quoted-string drop ]
+    [ "\"abc" take-sequence ] bi
+] unit-test
+
+[ "c" ]
+[ "c" <state-parser> take-token ] unit-test
+
+[ f ]
+[ "" <state-parser> take-token ] unit-test
+
+[ "abcd e \\\"f g" ]
+[ "\"abcd e \\\"f g\"" <state-parser> CHAR: \ CHAR: " take-token* ] unit-test
+
+[ "" ]
+[ "" <state-parser> take-rest ] unit-test
+
+[ "" ]
+[ "abc" <state-parser> dup "abc" take-sequence drop take-rest ] unit-test

extra/html/parser/state/state.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2005, 2009 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces math kernel sequences accessors fry circular
-unicode.case unicode.categories locals ;
+unicode.case unicode.categories locals combinators.short-circuit
+make combinators io splitting ;
 
 IN: html.parser.state
 
@@ -12,21 +13,22 @@ TUPLE: state-parser sequence n ;
         swap >>sequence
         0 >>n ;
 
-: state-parser-nth ( n state-parser -- char/f )
-    sequence>> ?nth ; inline
+: offset  ( state-parser offset -- char/f )
+    swap
+    [ n>> + ] [ sequence>> ?nth ] bi ; inline
 
-: current ( state-parser -- char/f )
-    [ n>> ] keep state-parser-nth ; inline
+: current ( state-parser -- char/f ) 0 offset ; inline
 
-: previous ( state-parser -- char/f )
-    [ n>> 1 - ] keep state-parser-nth ; inline
+: previous ( state-parser -- char/f ) -1 offset ; inline
 
-: peek-next ( state-parser -- char/f )
-    [ n>> 1 + ] keep state-parser-nth ; inline
+: peek-next ( state-parser -- char/f ) 1 offset ; inline
 
 : advance ( state-parser -- state-parser )
     [ 1 + ] change-n ; inline
 
+: advance* ( state-parser -- )
+    advance drop ; inline
+
 : get+increment ( state-parser -- char/f )
     [ current ] [ advance drop ] bi ; inline
 
@@ -35,7 +37,7 @@ TUPLE: state-parser sequence n ;
         state-parser quot call [ state-parser advance quot skip-until ] unless
     ] when ; inline recursive
 
-: state-parse-end? ( state-parser -- ? ) peek-next not ;
+: state-parse-end? ( state-parser -- ? ) current not ;
 
 : take-until ( state-parser quot: ( obj -- ? ) -- sequence/f )
     over state-parse-end? [
@@ -72,11 +74,47 @@ TUPLE: state-parser sequence n ;
 : skip-whitespace ( state-parser -- state-parser )
     [ [ current blank? not ] take-until drop ] keep ;
 
+: take-rest-slice ( state-parser -- sequence/f )
+    [ sequence>> ] [ n>> ] bi
+    2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline
+
 : take-rest ( state-parser -- sequence )
-    [ drop f ] take-until ; inline
+    [ take-rest-slice ] [ sequence>> like ] bi ;
 
 : take-until-object ( state-parser obj -- sequence )
     '[ current _ = ] take-until ;
 
 : state-parse ( sequence quot -- )
     [ <state-parser> ] dip call ; inline
+
+:: take-quoted-string ( state-parser escape-char quote-char -- string )
+    state-parser n>> :> start-n
+    state-parser advance
+    [
+        {
+            [ { [ previous escape-char = ] [ current quote-char = ] } 1&& ]
+            [ current quote-char = not ]
+        } 1||
+    ] take-while :> string
+    state-parser current quote-char = [
+        state-parser advance* string
+    ] [
+        start-n state-parser (>>n) f
+    ] if ;
+
+: (take-token) ( state-parser -- string )
+    skip-whitespace [ current { [ blank? ] [ f = ] } 1|| ] take-until ;
+
+:: take-token* ( state-parser escape-char quote-char -- string/f )
+    state-parser skip-whitespace
+    dup current {
+        { quote-char [ escape-char quote-char take-quoted-string ] }
+        { f [ drop f ] }
+        [ drop (take-token) ]
+    } case ;
+
+: take-token ( state-parser -- string/f )
+    CHAR: \ CHAR: " take-token* ;
+
+: write-full ( state-parser -- ) sequence>> write ;
+: write-rest ( state-parser -- ) take-rest write ;