diff --git a/.gitignore b/.gitignore index 435595f502..22dda8efb4 100644 --- a/.gitignore +++ b/.gitignore @@ -24,3 +24,4 @@ build-support/wordsize *.bak .#* *.swo +checksums.txt diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor old mode 100644 new mode 100755 index 8253d9458c..6a182f8dbf --- a/basis/alien/arrays/arrays.factor +++ b/basis/alien/arrays/arrays.factor @@ -26,7 +26,7 @@ M: array box-return drop "void*" box-return ; M: array stack-size drop "void*" stack-size ; -M: array c-type-boxer-quot drop f ; +M: array c-type-boxer-quot drop [ ] ; M: array c-type-unboxer-quot drop [ >c-ptr ] ; diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor old mode 100644 new mode 100755 index 89b3572daf..a44b5cf2b6 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -4,7 +4,7 @@ USING: byte-arrays arrays assocs kernel kernel.private libc math namespaces make parser sequences strings words assocs splitting math.parser cpu.architecture alien alien.accessors quotations layouts system compiler.units io.files io.encodings.binary -accessors combinators effects continuations fry call ; +accessors combinators effects continuations fry call classes ; IN: alien.c-types DEFER: @@ -13,18 +13,20 @@ DEFER: *char : little-endian? ( -- ? ) 1 *char 1 = ; foldable TUPLE: c-type -class -boxer boxer-quot unboxer unboxer-quot -getter setter -reg-class size align stack-align? ; - -: new-c-type ( class -- type ) - new - int-regs >>reg-class - object >>class ; inline +{ class class initial: object } +boxer +{ boxer-quot callable } +unboxer +{ unboxer-quot callable } +{ getter callable } +{ setter callable } +{ reg-class initial: int-regs } +size +align +stack-align? ; : ( -- type ) - \ c-type new-c-type ; + \ c-type new ; SYMBOL: c-types @@ -185,6 +187,9 @@ M: f byte-length drop 0 ; [ "Cannot read struct fields with this type" throw ] ] unless* ; +: c-type-getter-boxer ( name -- quot ) + [ c-getter ] [ c-type-boxer-quot ] bi append ; + : c-setter ( name -- quot ) c-type-setter [ [ "Cannot write struct fields with this type" throw ] @@ -221,7 +226,7 @@ M: f byte-length drop 0 ; TUPLE: long-long-type < c-type ; : ( -- type ) - long-long-type new-c-type ; + long-long-type new ; M: long-long-type unbox-parameter ( n type -- ) c-type-unboxer %unbox-long-long ; diff --git a/basis/alien/complex/complex-tests.factor b/basis/alien/complex/complex-tests.factor index bfb2c1137c..0bff73b898 100644 --- a/basis/alien/complex/complex-tests.factor +++ b/basis/alien/complex/complex-tests.factor @@ -15,4 +15,4 @@ C-STRUCT: complex-holder C{ 1.0 2.0 } "h" set ] unit-test -[ C{ 1.0 2.0 } ] [ "h" get complex-holder-z ] unit-test \ No newline at end of file +[ C{ 1.0 2.0 } ] [ "h" get complex-holder-z ] unit-test diff --git a/basis/alien/complex/complex.factor b/basis/alien/complex/complex.factor index 60a84b9394..c80ead73f0 100644 --- a/basis/alien/complex/complex.factor +++ b/basis/alien/complex/complex.factor @@ -1,6 +1,13 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.complex.functor sequences kernel ; +USING: alien.c-types alien.structs alien.complex.functor accessors +sequences kernel ; IN: alien.complex -<< { "float" "double" } [ dup "complex-" prepend define-complex-type ] each >> \ No newline at end of file +<< +{ "float" "double" } [ dup "complex-" prepend define-complex-type ] each + +! This overrides the fact that small structures are never returned +! in registers on NetBSD, Linux and Solaris running on 32-bit x86. +"complex-float" c-type t >>return-in-registers? drop + >> diff --git a/basis/alien/complex/functor/functor.factor b/basis/alien/complex/functor/functor.factor index 1d12bb0ff4..31af0291b4 100644 --- a/basis/alien/complex/functor/functor.factor +++ b/basis/alien/complex/functor/functor.factor @@ -12,15 +12,15 @@ T-imaginary DEFINES ${T}-imaginary set-T-real DEFINES set-${T}-real set-T-imaginary DEFINES set-${T}-imaginary ->T DEFINES >${T} -T> DEFINES ${T}> + DEFINES <${T}> +*T DEFINES *${T} WHERE -: >T ( z -- alien ) +: ( z -- alien ) >rect T [ set-T-imaginary ] [ set-T-real ] [ ] tri ; inline -: T> ( alien -- z ) +: *T ( alien -- z ) [ T-real ] [ T-imaginary ] bi rect> ; inline T in get @@ -28,8 +28,8 @@ T in get define-struct T c-type -T> 1quotation >>boxer-quot ->T 1quotation >>unboxer-quot + 1quotation >>unboxer-quot +*T 1quotation >>boxer-quot drop -;FUNCTOR \ No newline at end of file +;FUNCTOR diff --git a/basis/math/blas/cblas/authors.txt b/basis/alien/fortran/authors.txt similarity index 100% rename from basis/math/blas/cblas/authors.txt rename to basis/alien/fortran/authors.txt diff --git a/basis/alien/fortran/fortran-docs.factor b/basis/alien/fortran/fortran-docs.factor new file mode 100644 index 0000000000..c5d124e198 --- /dev/null +++ b/basis/alien/fortran/fortran-docs.factor @@ -0,0 +1,73 @@ +! Copyright (C) 2009 Joe Groff +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax kernel quotations sequences strings words.symbol ; +QUALIFIED-WITH: alien.syntax c +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." } +} +"A library's ABI is specified when that library is opened by the " { $link add-fortran-library } " word." ; + +ARTICLE: "alien.fortran-types" "Fortran types" +"The Fortran FFI recognizes the following Fortran types:" +{ $list + { { $snippet "INTEGER" } " specifies a four-byte integer value. Sized integers can be specified with " { $snippet "INTEGER*1" } ", " { $snippet "INTEGER*2" } ", " { $snippet "INTEGER*4" } ", and " { $snippet "INTEGER*8" } "." } + { { $snippet "LOGICAL" } " specifies a four-byte boolean value. Sized booleans can be specified with " { $snippet "LOGICAL*1" } ", " { $snippet "LOGICAL*2" } ", " { $snippet "LOGICAL*4" } ", and " { $snippet "LOGICAL*8" } "." } + { { $snippet "REAL" } " specifies a single-precision floating-point real value." } + { { $snippet "DOUBLE-PRECISION" } " specifies a double-precision floating-point real value. The alias " { $snippet "REAL*8" } " is also recognized." } + { { $snippet "COMPLEX" } " specifies a single-precision floating-point complex value." } + { { $snippet "DOUBLE-COMPLEX" } " specifies a double-precision floating-point complex value. The alias " { $snippet "COMPLEX*16" } " is also recognized." } + { { $snippet "CHARACTER(n)" } " specifies a character string of length " { $snippet "n" } ". The Fortran 77 syntax " { $snippet "CHARACTER*n" } " is also recognized." } + { "Fortran arrays can be specified by suffixing a comma-separated set of dimensions in parentheses, e.g. " { $snippet "REAL(2,3,4)" } ". Arrays of unspecified length can be specified using " { $snippet "*" } " as a dimension. Arrays are passed in as flat " { $link "specialized-arrays" } "." } + { "Fortran records defined by " { $link POSTPONE: RECORD: } " and C structs defined by " { $link POSTPONE: c:C-STRUCT: } " are also supported as parameter and return types." } +} +"When declaring the parameters of Fortran functions, an output argument can be specified by prefixing an exclamation point to the type name. This will cause the function word to leave the final value of the parameter on the stack." ; + +HELP: FUNCTION: +{ $syntax "FUNCTION: RETURN-TYPE NAME ( [!]ARGUMENT-TYPE NAME, ... ) ;" } +{ $description "Declares a Fortran function binding with the given return type and arguments. See " { $link "alien.fortran-types" } " for a list of supported types." } ; + +HELP: SUBROUTINE: +{ $syntax "SUBROUTINE: NAME ( [!]ARGUMENT-TYPE NAME, ... ) ;" } +{ $description "Declares a Fortran subroutine binding with the given arguments. See " { $link "alien.fortran-types" } " for a list of supported types." } ; + +HELP: LIBRARY: +{ $syntax "LIBRARY: name" } +{ $values { "name" "a logical library name" } } +{ $description "Sets the logical library for subsequent " { $link POSTPONE: FUNCTION: } " and " { $link POSTPONE: SUBROUTINE: } " definitions. The given library name must have been opened with a previous call to " { $link add-fortran-library } "." } ; + +HELP: RECORD: +{ $syntax "RECORD: NAME { \"TYPE\" \"SLOT\" } ... ;" } +{ $description "Defines a Fortran record type with the given slots. The record is defined as the corresponding C struct and can be used as a type for subsequent Fortran or C function declarations." } ; + +HELP: add-fortran-library +{ $values { "name" string } { "soname" string } { "fortran-abi" symbol } } +{ $description "Opens the shared library in the file specified by " { $snippet "soname" } " under the logical name " { $snippet "name" } " so that it may be used in subsequent " { $link POSTPONE: LIBRARY: } " and " { $link fortran-invoke } " calls. Functions and subroutines from the library will be defined using the specified " { $snippet "fortran-abi" } ", which must be one of the supported " { $link "alien.fortran-abis" } "." } +; + +HELP: fortran-invoke +{ $values + { "return" string } { "library" string } { "procedure" string } { "parameters" sequence } +} +{ $description "Invokes the Fortran subroutine or function " { $snippet "procedure" } " in " { $snippet "library" } " with parameters specified by the " { $link "alien.fortran-types" } " specified in the " { $snippet "parameters" } " sequence. If the " { $snippet "return" } " value is " { $link f } ", no return value is expected, otherwise a return value of the specified Fortran type is expected. Input values are taken off the top of the datastack, and output values are left for the return value (if any) and any parameters specified as out parameters by prepending " { $snippet "\"!\"" } "." } +; + +ARTICLE: "alien.fortran" "Fortran FFI" +"The " { $vocab-link "alien.fortran" } " vocabulary provides an interface to code in shared libraries written in Fortran." +{ $subsection "alien.fortran-types" } +{ $subsection "alien.fortran-abis" } +{ $subsection add-fortran-library } +{ $subsection POSTPONE: LIBRARY: } +{ $subsection POSTPONE: FUNCTION: } +{ $subsection POSTPONE: SUBROUTINE: } +{ $subsection POSTPONE: RECORD: } +{ $subsection fortran-invoke } +; + +ABOUT: "alien.fortran" diff --git a/basis/alien/fortran/fortran-tests.factor b/basis/alien/fortran/fortran-tests.factor new file mode 100644 index 0000000000..177d1077c2 --- /dev/null +++ b/basis/alien/fortran/fortran-tests.factor @@ -0,0 +1,381 @@ +! (c) 2009 Joe Groff, see BSD license +USING: accessors alien alien.c-types alien.complex +alien.fortran alien.fortran.private alien.strings alien.structs +arrays assocs byte-arrays combinators fry +generalizations io.encodings.ascii kernel macros +macros.expander namespaces sequences shuffle tools.test ; +IN: alien.fortran.tests + +<< intel-unix-abi "(alien.fortran-tests)" (add-fortran-library) >> +LIBRARY: (alien.fortran-tests) +RECORD: FORTRAN_TEST_RECORD + { "INTEGER" "FOO" } + { "REAL(2)" "BAR" } + { "CHARACTER*4" "BAS" } ; + +intel-unix-abi fortran-abi [ + + ! fortran-name>symbol-name + + [ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test + [ "fun_times_" ] [ "Fun_Times" fortran-name>symbol-name ] unit-test + [ "funtimes__" ] [ "FunTimes_" fortran-name>symbol-name ] unit-test + + ! fortran-type>c-type + + [ "short" ] + [ "integer*2" fortran-type>c-type ] unit-test + + [ "int" ] + [ "integer*4" fortran-type>c-type ] unit-test + + [ "int" ] + [ "INTEGER" fortran-type>c-type ] unit-test + + [ "longlong" ] + [ "iNteger*8" fortran-type>c-type ] unit-test + + [ "int[0]" ] + [ "integer(*)" fortran-type>c-type ] unit-test + + [ "int[0]" ] + [ "integer(3,*)" fortran-type>c-type ] unit-test + + [ "int[3]" ] + [ "integer(3)" fortran-type>c-type ] unit-test + + [ "int[6]" ] + [ "integer(3,2)" fortran-type>c-type ] unit-test + + [ "int[24]" ] + [ "integer(4,3,2)" fortran-type>c-type ] unit-test + + [ "char" ] + [ "character" fortran-type>c-type ] unit-test + + [ "char" ] + [ "character*1" fortran-type>c-type ] unit-test + + [ "char[17]" ] + [ "character*17" fortran-type>c-type ] unit-test + + [ "char[17]" ] + [ "character(17)" fortran-type>c-type ] unit-test + + [ "int" ] + [ "logical" fortran-type>c-type ] unit-test + + [ "float" ] + [ "real" fortran-type>c-type ] unit-test + + [ "double" ] + [ "double-precision" fortran-type>c-type ] unit-test + + [ "float" ] + [ "real*4" fortran-type>c-type ] unit-test + + [ "double" ] + [ "real*8" fortran-type>c-type ] unit-test + + [ "complex-float" ] + [ "complex" fortran-type>c-type ] unit-test + + [ "complex-double" ] + [ "double-complex" fortran-type>c-type ] unit-test + + [ "complex-float" ] + [ "complex*8" fortran-type>c-type ] unit-test + + [ "complex-double" ] + [ "complex*16" fortran-type>c-type ] unit-test + + [ "fortran_test_record" ] + [ "fortran_test_record" fortran-type>c-type ] unit-test + + ! fortran-arg-type>c-type + + [ "int*" { } ] + [ "integer" fortran-arg-type>c-type ] unit-test + + [ "int*" { } ] + [ "integer(3)" fortran-arg-type>c-type ] unit-test + + [ "int*" { } ] + [ "integer(*)" fortran-arg-type>c-type ] unit-test + + [ "fortran_test_record*" { } ] + [ "fortran_test_record" fortran-arg-type>c-type ] unit-test + + [ "char*" { } ] + [ "character" fortran-arg-type>c-type ] unit-test + + [ "char*" { } ] + [ "character(1)" fortran-arg-type>c-type ] unit-test + + [ "char*" { "long" } ] + [ "character(17)" fortran-arg-type>c-type ] unit-test + + ! fortran-ret-type>c-type + + [ "char" { } ] + [ "character(1)" fortran-ret-type>c-type ] unit-test + + [ "void" { "char*" "long" } ] + [ "character(17)" fortran-ret-type>c-type ] unit-test + + [ "int" { } ] + [ "integer" fortran-ret-type>c-type ] unit-test + + [ "int" { } ] + [ "logical" fortran-ret-type>c-type ] unit-test + + [ "float" { } ] + [ "real" fortran-ret-type>c-type ] unit-test + + [ "void" { "float*" } ] + [ "real(*)" fortran-ret-type>c-type ] unit-test + + [ "double" { } ] + [ "double-precision" fortran-ret-type>c-type ] unit-test + + [ "void" { "complex-float*" } ] + [ "complex" fortran-ret-type>c-type ] unit-test + + [ "void" { "complex-double*" } ] + [ "double-complex" fortran-ret-type>c-type ] unit-test + + [ "void" { "int*" } ] + [ "integer(*)" fortran-ret-type>c-type ] unit-test + + [ "void" { "fortran_test_record*" } ] + [ "fortran_test_record" fortran-ret-type>c-type ] unit-test + + ! fortran-sig>c-sig + + [ "float" { "int*" "char*" "float*" "double*" "long" } ] + [ "real" { "integer" "character*17" "real" "real*8" } fortran-sig>c-sig ] + unit-test + + [ "char" { "char*" "char*" "int*" "long" } ] + [ "character(1)" { "character*17" "character" "integer" } fortran-sig>c-sig ] + unit-test + + [ "void" { "char*" "long" "char*" "char*" "int*" "long" } ] + [ "character*18" { "character*17" "character" "integer" } fortran-sig>c-sig ] + unit-test + + [ "void" { "complex-float*" "char*" "char*" "int*" "long" } ] + [ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ] + unit-test + + ! fortran-record>c-struct + + [ { + { "double" "ex" } + { "float" "wye" } + { "int" "zee" } + { "char[20]" "woo" } + } ] [ + { + { "DOUBLE-PRECISION" "EX" } + { "REAL" "WYE" } + { "INTEGER" "ZEE" } + { "CHARACTER(20)" "WOO" } + } fortran-record>c-struct + ] unit-test + + ! RECORD: + + [ 16 ] [ "fortran_test_record" heap-size ] unit-test + [ 0 ] [ "foo" "fortran_test_record" offset-of ] unit-test + [ 4 ] [ "bar" "fortran_test_record" offset-of ] unit-test + [ 12 ] [ "bas" "fortran_test_record" offset-of ] unit-test + + ! (fortran-invoke) + + [ [ + ! [fortran-args>c-args] + { + [ { + [ ascii string>alien ] + [ ] + [ ] + [ ] + [ 1 0 ? ] + } spread ] + [ { [ length ] [ drop ] [ drop ] [ drop ] [ drop ] } spread ] + } 5 ncleave + ! [fortran-invoke] + [ + "void" "funpack" "funtimes_" + { "char*" "longlong*" "float*" "complex-float*" "short*" "long" } + alien-invoke + ] 6 nkeep + ! [fortran-results>] + shuffle( aa ba ca da ea ab -- aa ab ba ca da ea ) + { + [ drop ] + [ drop ] + [ drop ] + [ *float ] + [ drop ] + [ drop ] + } spread + ] ] [ + f "funpack" "FUNTIMES" { "CHARACTER*12" "INTEGER*8" "!REAL" "COMPLEX" "LOGICAL*2" } + (fortran-invoke) + ] unit-test + + [ [ + ! [fortran-args>c-args] + { + [ { [ ] } spread ] + [ { [ drop ] } spread ] + } 1 ncleave + ! [fortran-invoke] + [ "float" "funpack" "fun_times_" { "float*" } alien-invoke ] + 1 nkeep + ! [fortran-results>] + shuffle( reta aa -- reta aa ) + { [ ] [ drop ] } spread + ] ] [ + "REAL" "funpack" "FUN_TIMES" { "REAL(*)" } + (fortran-invoke) + ] unit-test + + [ [ + ! [] + [ "complex-float" ] 1 ndip + ! [fortran-args>c-args] + { [ { [ ] } spread ] [ { [ drop ] } spread ] } 1 ncleave + ! [fortran-invoke] + [ + "void" "funpack" "fun_times_" + { "complex-float*" "float*" } + alien-invoke + ] 2 nkeep + ! [fortran-results>] + shuffle( reta aa -- reta aa ) + { [ *complex-float ] [ drop ] } spread + ] ] [ + "COMPLEX" "funpack" "FUN_TIMES" { "REAL(*)" } + (fortran-invoke) + ] unit-test + + [ [ + ! [] + [ 20 20 ] 0 ndip + ! [fortran-invoke] + [ + "void" "funpack" "fun_times_" + { "char*" "long" } + alien-invoke + ] 2 nkeep + ! [fortran-results>] + shuffle( reta retb -- reta retb ) + { [ ] [ ascii alien>nstring ] } spread + ] ] [ + "CHARACTER*20" "funpack" "FUN_TIMES" { } + (fortran-invoke) + ] unit-test + + [ [ + ! [] + [ 10 10 ] 3 ndip + ! [fortran-args>c-args] + { + [ { + [ ascii string>alien ] + [ ] + [ ascii string>alien ] + } spread ] + [ { [ length ] [ drop ] [ length ] } spread ] + } 3 ncleave + ! [fortran-invoke] + [ + "void" "funpack" "fun_times_" + { "char*" "long" "char*" "float*" "char*" "long" "long" } + alien-invoke + ] 7 nkeep + ! [fortran-results>] + shuffle( reta retb aa ba ca ab cb -- reta retb aa ab ba ca cb ) + { + [ ] + [ ascii alien>nstring ] + [ ] + [ ascii alien>nstring ] + [ *float ] + [ ] + [ ascii alien>nstring ] + } spread + ] ] [ + "CHARACTER*10" "funpack" "FUN_TIMES" { "!CHARACTER*20" "!REAL" "!CHARACTER*30" } + (fortran-invoke) + ] unit-test + +] with-variable ! intel-unix-abi + +intel-windows-abi fortran-abi [ + + [ "FUN" ] [ "FUN" fortran-name>symbol-name ] unit-test + [ "FUN_TIMES" ] [ "Fun_Times" fortran-name>symbol-name ] unit-test + [ "FUNTIMES_" ] [ "FunTimes_" fortran-name>symbol-name ] unit-test + +] with-variable + +f2c-abi fortran-abi [ + + [ "char[1]" ] + [ "character(1)" fortran-type>c-type ] unit-test + + [ "char*" { "long" } ] + [ "character" fortran-arg-type>c-type ] unit-test + + [ "void" { "char*" "long" } ] + [ "character" fortran-ret-type>c-type ] unit-test + + [ "double" { } ] + [ "real" fortran-ret-type>c-type ] unit-test + + [ "void" { "float*" } ] + [ "real(*)" fortran-ret-type>c-type ] unit-test + + [ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test + [ "fun_times__" ] [ "Fun_Times" fortran-name>symbol-name ] unit-test + [ "funtimes___" ] [ "FunTimes_" fortran-name>symbol-name ] unit-test + +] with-variable + +gfortran-abi fortran-abi [ + + [ "float" { } ] + [ "real" fortran-ret-type>c-type ] unit-test + + [ "void" { "float*" } ] + [ "real(*)" fortran-ret-type>c-type ] unit-test + + [ "complex-float" { } ] + [ "complex" fortran-ret-type>c-type ] unit-test + + [ "complex-double" { } ] + [ "double-complex" fortran-ret-type>c-type ] unit-test + + [ "char[1]" ] + [ "character(1)" fortran-type>c-type ] unit-test + + [ "char*" { "long" } ] + [ "character" fortran-arg-type>c-type ] unit-test + + [ "void" { "char*" "long" } ] + [ "character" fortran-ret-type>c-type ] unit-test + + [ "complex-float" { } ] + [ "complex" fortran-ret-type>c-type ] unit-test + + [ "complex-double" { } ] + [ "double-complex" fortran-ret-type>c-type ] unit-test + + [ "void" { "complex-double*" } ] + [ "double-complex(3)" fortran-ret-type>c-type ] unit-test + +] with-variable diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor new file mode 100644 index 0000000000..915b7d3d4f --- /dev/null +++ b/basis/alien/fortran/fortran.factor @@ -0,0 +1,452 @@ +! (c) 2009 Joe Groff, see BSD license +USING: accessors alien alien.c-types alien.complex alien.parser +alien.strings alien.structs alien.syntax arrays ascii assocs +byte-arrays combinators combinators.short-circuit fry generalizations +kernel lexer macros math math.parser namespaces parser sequences +splitting stack-checker vectors vocabs.parser words locals +io.encodings.ascii io.encodings.string shuffle effects math.ranges +math.order sorting strings system ; +IN: alien.fortran + +SINGLETONS: f2c-abi gfortran-abi intel-unix-abi intel-windows-abi ; + +<< +: add-f2c-libraries ( -- ) + "I77" "libI77.so" "cdecl" add-library + "F77" "libF77.so" "cdecl" add-library ; + +os netbsd? [ add-f2c-libraries ] when +>> + +: alien>nstring ( alien len encoding -- string ) + [ memory>byte-array ] dip decode ; + +ERROR: invalid-fortran-type type ; + +DEFER: fortran-sig>c-sig +DEFER: fortran-ret-type>c-type +DEFER: fortran-arg-type>c-type +DEFER: fortran-name>symbol-name + +SYMBOL: library-fortran-abis +SYMBOL: fortran-abi +library-fortran-abis [ H{ } clone ] initialize + +lower "_" append ; +: lowercase-name-with-extra-underscore ( name -- name' ) + >lower CHAR: _ over member? + [ "__" append ] [ "_" append ] if ; + +HOOK: fortran-c-abi fortran-abi ( -- abi ) +M: f2c-abi fortran-c-abi "cdecl" ; +M: gfortran-abi fortran-c-abi "cdecl" ; +M: intel-unix-abi fortran-c-abi "cdecl" ; +M: intel-windows-abi fortran-c-abi "cdecl" ; + +HOOK: real-functions-return-double? fortran-abi ( -- ? ) +M: f2c-abi real-functions-return-double? t ; +M: gfortran-abi real-functions-return-double? f ; +M: intel-unix-abi real-functions-return-double? f ; +M: intel-windows-abi real-functions-return-double? f ; + +HOOK: complex-functions-return-by-value? fortran-abi ( -- ? ) +M: f2c-abi complex-functions-return-by-value? f ; +M: gfortran-abi complex-functions-return-by-value? t ; +M: intel-unix-abi complex-functions-return-by-value? f ; +M: intel-windows-abi complex-functions-return-by-value? f ; + +HOOK: character(1)-maps-to-char? fortran-abi ( -- ? ) +M: f2c-abi character(1)-maps-to-char? f ; +M: gfortran-abi character(1)-maps-to-char? f ; +M: intel-unix-abi character(1)-maps-to-char? t ; +M: intel-windows-abi character(1)-maps-to-char? t ; + +HOOK: mangle-name fortran-abi ( name -- name' ) +M: f2c-abi mangle-name lowercase-name-with-extra-underscore ; +M: gfortran-abi mangle-name lowercase-name-with-underscore ; +M: intel-unix-abi mangle-name lowercase-name-with-underscore ; +M: intel-windows-abi mangle-name >upper ; + +TUPLE: fortran-type dims size out? ; + +TUPLE: number-type < fortran-type ; +TUPLE: integer-type < number-type ; +TUPLE: logical-type < integer-type ; +TUPLE: real-type < number-type ; +TUPLE: double-precision-type < number-type ; + +TUPLE: character-type < fortran-type ; +TUPLE: misc-type < fortran-type name ; + +TUPLE: complex-type < number-type ; +TUPLE: real-complex-type < complex-type ; +TUPLE: double-complex-type < complex-type ; + +CONSTANT: fortran>c-types H{ + { "character" character-type } + { "integer" integer-type } + { "logical" logical-type } + { "real" real-type } + { "double-precision" double-precision-type } + { "complex" real-complex-type } + { "double-complex" double-complex-type } +} + +: append-dimensions ( base-c-type type -- c-type ) + dims>> + [ product number>string "[" "]" surround append ] when* ; + +MACRO: size-case-type ( cases -- ) + [ invalid-fortran-type ] suffix + '[ [ size>> _ case ] [ append-dimensions ] bi ] ; + +: simple-type ( type base-c-type -- c-type ) + swap + [ dup size>> [ invalid-fortran-type ] [ drop ] if ] + [ append-dimensions ] bi ; + +: new-fortran-type ( out? dims size class -- type ) + new [ [ (>>size) ] [ (>>dims) ] [ (>>out?) ] tri ] keep ; + +GENERIC: (fortran-type>c-type) ( type -- c-type ) + +M: f (fortran-type>c-type) drop "void" ; + +M: integer-type (fortran-type>c-type) + { + { f [ "int" ] } + { 1 [ "char" ] } + { 2 [ "short" ] } + { 4 [ "int" ] } + { 8 [ "longlong" ] } + } size-case-type ; +M: real-type (fortran-type>c-type) + { + { f [ "float" ] } + { 4 [ "float" ] } + { 8 [ "double" ] } + } size-case-type ; +M: real-complex-type (fortran-type>c-type) + { + { f [ "complex-float" ] } + { 8 [ "complex-float" ] } + { 16 [ "complex-double" ] } + } size-case-type ; + +M: double-precision-type (fortran-type>c-type) + "double" simple-type ; +M: double-complex-type (fortran-type>c-type) + "complex-double" simple-type ; +M: misc-type (fortran-type>c-type) + dup name>> simple-type ; + +: single-char? ( character-type -- ? ) + { [ drop character(1)-maps-to-char? ] [ dims>> product 1 = ] } 1&& ; + +: fix-character-type ( character-type -- character-type' ) + clone dup size>> + [ dup dims>> [ invalid-fortran-type ] [ dup size>> 1array >>dims f >>size ] if ] + [ dup dims>> [ ] [ f >>dims ] if ] if + dup single-char? [ f >>dims ] when ; + +M: character-type (fortran-type>c-type) + fix-character-type "char" simple-type ; + +: dimension>number ( string -- number ) + dup "*" = [ drop 0 ] [ string>number ] if ; + +: parse-out ( string -- string' out? ) + "!" ?head ; + +: parse-dims ( string -- string' dim ) + "(" split1 dup + [ ")" ?tail drop "," split [ [ blank? ] trim dimension>number ] map ] when ; + +: parse-size ( string -- string' size ) + "*" split1 dup [ string>number ] when ; + +: (parse-fortran-type) ( fortran-type-string -- type ) + parse-out swap parse-dims swap parse-size swap + dup >lower fortran>c-types at* + [ nip new-fortran-type ] [ drop misc-type boa ] if ; + +: parse-fortran-type ( fortran-type-string/f -- type/f ) + dup [ (parse-fortran-type) ] when ; + +: c-type>pointer ( c-type -- c-type* ) + "[" split1 drop "*" append ; + +GENERIC: added-c-args ( type -- args ) + +M: fortran-type added-c-args drop { } ; +M: character-type added-c-args fix-character-type single-char? [ { } ] [ { "long" } ] if ; + +GENERIC: returns-by-value? ( type -- ? ) + +M: f returns-by-value? drop t ; +M: fortran-type returns-by-value? drop f ; +M: number-type returns-by-value? dims>> not ; +M: character-type returns-by-value? fix-character-type single-char? ; +M: complex-type returns-by-value? + { [ drop complex-functions-return-by-value? ] [ dims>> not ] } 1&& ; + +GENERIC: (fortran-ret-type>c-type) ( type -- c-type ) + +M: f (fortran-ret-type>c-type) drop "void" ; +M: fortran-type (fortran-ret-type>c-type) (fortran-type>c-type) ; +M: real-type (fortran-ret-type>c-type) + drop real-functions-return-double? [ "double" ] [ "float" ] if ; + +: suffix! ( seq elt -- seq ) over push ; inline +: append! ( seq-a seq-b -- seq-a ) over push-all ; inline + +GENERIC: (fortran-arg>c-args) ( type -- main-quot added-quot ) + +: args?dims ( type quot -- main-quot added-quot ) + [ dup dims>> [ drop [ ] [ drop ] ] ] dip if ; inline + +M: integer-type (fortran-arg>c-args) + [ + size>> { + { f [ [ ] [ drop ] ] } + { 1 [ [ ] [ drop ] ] } + { 2 [ [ ] [ drop ] ] } + { 4 [ [ ] [ drop ] ] } + { 8 [ [ ] [ drop ] ] } + [ invalid-fortran-type ] + } case + ] args?dims ; + +M: logical-type (fortran-arg>c-args) + [ call-next-method [ [ 1 0 ? ] prepend ] dip ] args?dims ; + +M: real-type (fortran-arg>c-args) + [ + size>> { + { f [ [ ] [ drop ] ] } + { 4 [ [ ] [ drop ] ] } + { 8 [ [ ] [ drop ] ] } + [ invalid-fortran-type ] + } case + ] args?dims ; + +M: real-complex-type (fortran-arg>c-args) + [ + size>> { + { f [ [ ] [ drop ] ] } + { 8 [ [ ] [ drop ] ] } + { 16 [ [ ] [ drop ] ] } + [ invalid-fortran-type ] + } case + ] args?dims ; + +M: double-precision-type (fortran-arg>c-args) + [ drop [ ] [ drop ] ] args?dims ; + +M: double-complex-type (fortran-arg>c-args) + [ drop [ ] [ drop ] ] args?dims ; + +M: character-type (fortran-arg>c-args) + fix-character-type single-char? + [ [ first ] [ drop ] ] + [ [ ascii string>alien ] [ length ] ] if ; + +M: misc-type (fortran-arg>c-args) + drop [ ] [ drop ] ; + +GENERIC: (fortran-result>) ( type -- quots ) + +: result?dims ( type quot -- quot ) + [ dup dims>> [ drop { [ ] } ] ] dip if ; inline + +M: integer-type (fortran-result>) + [ size>> { + { f [ { [ *int ] } ] } + { 1 [ { [ *char ] } ] } + { 2 [ { [ *short ] } ] } + { 4 [ { [ *int ] } ] } + { 8 [ { [ *longlong ] } ] } + [ invalid-fortran-type ] + } case ] result?dims ; + +M: logical-type (fortran-result>) + [ call-next-method first [ zero? not ] append 1array ] result?dims ; + +M: real-type (fortran-result>) + [ size>> { + { f [ { [ *float ] } ] } + { 4 [ { [ *float ] } ] } + { 8 [ { [ *double ] } ] } + [ invalid-fortran-type ] + } case ] result?dims ; + +M: real-complex-type (fortran-result>) + [ size>> { + { f [ { [ *complex-float ] } ] } + { 8 [ { [ *complex-float ] } ] } + { 16 [ { [ *complex-double ] } ] } + [ invalid-fortran-type ] + } case ] result?dims ; + +M: double-precision-type (fortran-result>) + [ drop { [ *double ] } ] result?dims ; + +M: double-complex-type (fortran-result>) + [ drop { [ *complex-double ] } ] result?dims ; + +M: character-type (fortran-result>) + fix-character-type single-char? + [ { [ *char 1string ] } ] + [ { [ ] [ ascii alien>nstring ] } ] if ; + +M: misc-type (fortran-result>) + drop { [ ] } ; + +GENERIC: () ( type -- quot ) + +M: fortran-type () + (fortran-type>c-type) \ [ ] 2sequence ; + +M: character-type () + fix-character-type dims>> product dup + [ \ ] dip [ ] 3sequence ; + +: [] ( return parameters -- quot ) + [ parse-fortran-type ] dip + over returns-by-value? + [ 2drop [ ] ] + [ [ () ] [ length \ ndip [ ] 3sequence ] bi* ] if ; + +: [fortran-args>c-args] ( parameters -- quot ) + [ [ ] ] [ + [ parse-fortran-type (fortran-arg>c-args) 2array ] map flip first2 + [ [ \ spread [ ] 2sequence ] bi@ 2array ] [ length ] bi + \ ncleave [ ] 3sequence + ] if-empty ; + +:: [fortran-invoke] ( [args>args] return library function parameters -- [args>args] quot ) + return parameters fortran-sig>c-sig :> c-parameters :> c-return + function fortran-name>symbol-name :> c-function + [args>args] + c-return library c-function c-parameters \ alien-invoke + 5 [ ] nsequence + c-parameters length \ nkeep + [ ] 3sequence ; + +: [fortran-out-param>] ( parameter -- quot ) + parse-fortran-type + [ (fortran-result>) ] [ out?>> ] bi + [ ] [ [ drop [ drop ] ] map ] if ; + +: [fortran-return>] ( return -- quot ) + parse-fortran-type { + { [ dup not ] [ drop { } ] } + { [ dup returns-by-value? ] [ drop { [ ] } ] } + [ (fortran-result>) ] + } cond ; + +: letters ( -- seq ) CHAR: a CHAR: z [a,b] ; + +: (shuffle-map) ( return parameters -- ret par ) + [ + fortran-ret-type>c-type length swap "void" = [ 1+ ] unless + letters swap head [ "ret" swap suffix ] map + ] [ + [ fortran-arg-type>c-type nip length 1+ ] map letters swap zip + [ first2 letters swap head [ "" 2sequence ] with map ] map concat + ] bi* ; + +: (fortran-in-shuffle) ( ret par -- seq ) + [ [ second ] bi@ <=> ] sort append ; + +: (fortran-out-shuffle) ( ret par -- seq ) + append ; + +: [fortran-result-shuffle] ( return parameters -- quot ) + (shuffle-map) [ (fortran-in-shuffle) ] [ (fortran-out-shuffle) ] 2bi + \ shuffle-effect [ ] 2sequence ; + +: [fortran-results>] ( return parameters -- quot ) + [ [fortran-result-shuffle] ] + [ drop [fortran-return>] ] + [ nip [ [fortran-out-param>] ] map concat ] 2tri + append + \ spread [ ] 2sequence append ; + +: (add-fortran-library) ( fortran-abi name -- ) + library-fortran-abis get-global set-at ; + +PRIVATE> + +: add-fortran-library ( name soname fortran-abi -- ) + [ fortran-abi [ fortran-c-abi ] with-variable add-library ] + [ nip swap (add-fortran-library) ] 3bi ; + +: fortran-name>symbol-name ( fortran-name -- c-name ) + mangle-name ; + +: fortran-type>c-type ( fortran-type -- c-type ) + parse-fortran-type (fortran-type>c-type) ; + +: fortran-arg-type>c-type ( fortran-type -- c-type added-args ) + parse-fortran-type + [ (fortran-type>c-type) c-type>pointer ] + [ added-c-args ] bi ; +: fortran-ret-type>c-type ( fortran-type -- c-type added-args ) + parse-fortran-type dup returns-by-value? + [ (fortran-ret-type>c-type) { } ] [ + "void" swap + [ added-c-args ] [ (fortran-type>c-type) c-type>pointer ] bi prefix + ] if ; + +: fortran-arg-types>c-types ( fortran-types -- c-types ) + [ length 1 ] keep + [ fortran-arg-type>c-type swapd [ suffix! ] [ append! ] 2bi* ] each + append >array ; + +: fortran-sig>c-sig ( fortran-return fortran-args -- c-return c-args ) + [ fortran-ret-type>c-type ] [ fortran-arg-types>c-types ] bi* append ; + +: fortran-record>c-struct ( record -- struct ) + [ first2 [ fortran-type>c-type ] [ >lower ] bi* 2array ] map ; + +: define-fortran-record ( name vocab fields -- ) + [ >lower ] [ ] [ fortran-record>c-struct ] tri* define-struct ; + +: RECORD: scan in get parse-definition define-fortran-record ; parsing + +: set-fortran-abi ( library -- ) + library-fortran-abis get-global at fortran-abi set ; + +: (fortran-invoke) ( return library function parameters -- quot ) + { + [ 2nip [] ] + [ nip nip nip [fortran-args>c-args] ] + [ [fortran-invoke] ] + [ 2nip [fortran-results>] ] + } 4 ncleave 4 nappend ; + +MACRO: fortran-invoke ( return library function parameters -- ) + { [ 2drop nip set-fortran-abi ] [ (fortran-invoke) ] } 4 ncleave ; + +:: define-fortran-function ( return library function parameters -- ) + function create-in dup reset-generic + return library function parameters return [ "void" ] unless* parse-arglist + [ \ fortran-invoke 5 [ ] nsequence ] dip define-declared ; + +: SUBROUTINE: + f "c-library" get scan ";" parse-tokens + [ "()" subseq? not ] filter define-fortran-function ; parsing + +: FUNCTION: + scan "c-library" get scan ";" parse-tokens + [ "()" subseq? not ] filter define-fortran-function ; parsing + +: LIBRARY: + scan + [ "c-library" set ] + [ set-fortran-abi ] bi ; parsing + diff --git a/basis/alien/fortran/summary.txt b/basis/alien/fortran/summary.txt new file mode 100644 index 0000000000..8ed8b0ca00 --- /dev/null +++ b/basis/alien/fortran/summary.txt @@ -0,0 +1 @@ +GNU Fortran/G77/F2C alien interface diff --git a/basis/alien/fortran/tags.txt b/basis/alien/fortran/tags.txt new file mode 100644 index 0000000000..2a9b5def7a --- /dev/null +++ b/basis/alien/fortran/tags.txt @@ -0,0 +1,2 @@ +fortran +ffi diff --git a/basis/alien/structs/fields/fields.factor b/basis/alien/structs/fields/fields.factor index f5537fa239..0477683442 100644 --- a/basis/alien/structs/fields/fields.factor +++ b/basis/alien/structs/fields/fields.factor @@ -58,10 +58,7 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ; : define-getter ( type spec -- ) [ set-reader-props ] keep [ reader>> ] - [ - type>> - [ c-getter ] [ c-type-boxer-quot ] bi append - ] + [ type>> c-type-getter-boxer ] [ ] tri (( c-ptr -- value )) define-struct-slot-word ; diff --git a/basis/alien/structs/structs-tests.factor b/basis/alien/structs/structs-tests.factor old mode 100644 new mode 100755 index ec0c01c2e7..8bc570c448 --- a/basis/alien/structs/structs-tests.factor +++ b/basis/alien/structs/structs-tests.factor @@ -42,3 +42,18 @@ C-UNION: barx [ ] [ \ foox-x "help" get execute ] unit-test [ ] [ \ set-foox-x "help" get execute ] unit-test ] when + +C-STRUCT: nested + { "int" "x" } ; + +C-STRUCT: nested-2 + { "nested" "y" } ; + +[ 4 ] [ + "nested-2" + "nested" + 4 over set-nested-x + over set-nested-2-y + nested-2-y + nested-x +] unit-test diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor old mode 100644 new mode 100755 index d9ed53d0c6..ec9080690a --- a/basis/alien/structs/structs.factor +++ b/basis/alien/structs/structs.factor @@ -1,15 +1,26 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays generic hashtables kernel kernel.private +USING: accessors arrays assocs generic hashtables kernel kernel.private math namespaces parser sequences strings words libc fry -alien.c-types alien.structs.fields cpu.architecture math.order ; +alien.c-types alien.structs.fields cpu.architecture math.order +quotations byte-arrays ; IN: alien.structs -TUPLE: struct-type size align fields boxer-quot unboxer-quot getter setter ; +TUPLE: struct-type +size +align +fields +{ boxer-quot callable } +{ unboxer-quot callable } +{ getter callable } +{ setter callable } +return-in-registers? ; + +M: struct-type c-type ; M: struct-type heap-size size>> ; -M: struct-type c-type-class drop object ; +M: struct-type c-type-class drop byte-array ; M: struct-type c-type-align align>> ; @@ -29,7 +40,7 @@ M: struct-type box-parameter [ %box-large-struct ] [ box-parameter ] if-value-struct ; : if-small-struct ( c-type true false -- ? ) - [ dup struct-small-enough? ] 2dip '[ f swap @ ] if ; inline + [ dup return-struct-in-registers? ] 2dip '[ f swap @ ] if ; inline M: struct-type unbox-return [ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ; @@ -68,3 +79,8 @@ M: struct-type stack-size [ expand-constants ] map [ [ heap-size ] [ max ] map-reduce ] keep compute-struct-align f (define-struct) ; + +: offset-of ( field struct -- offset ) + c-types get at fields>> + [ name>> = ] with find nip offset>> ; + diff --git a/basis/bit-arrays/bit-arrays.factor b/basis/bit-arrays/bit-arrays.factor index f1ba71ce1e..3da22e09d6 100644 --- a/basis/bit-arrays/bit-arrays.factor +++ b/basis/bit-arrays/bit-arrays.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types accessors math alien.accessors kernel -kernel.private locals sequences sequences.private byte-arrays +kernel.private sequences sequences.private byte-arrays parser prettyprint.custom fry ; IN: bit-arrays @@ -70,16 +70,15 @@ M: bit-array byte-length length 7 + -3 shift ; : ?{ \ } [ >bit-array ] parse-literal ; parsing -:: integer>bit-array ( n -- bit-array ) - n zero? [ 0 ] [ - [let | out [ n log2 1+ ] i! [ 0 ] n'! [ n ] | - [ n' zero? ] [ - n' out underlying>> i set-alien-unsigned-1 - n' -8 shift n'! - i 1+ i! - ] [ ] until - out - ] +: integer>bit-array ( n -- bit-array ) + dup 0 = [ + + ] [ + [ log2 1+ 0 ] keep + [ dup 0 = ] [ + [ pick underlying>> pick set-alien-unsigned-1 ] keep + [ 1+ ] [ -8 shift ] bi* + ] [ ] until 2drop ] if ; : bit-array>integer ( bit-array -- n ) diff --git a/basis/bitstreams/authors.txt b/basis/bitstreams/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/bitstreams/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/bitstreams/bitstreams-tests.factor b/basis/bitstreams/bitstreams-tests.factor new file mode 100644 index 0000000000..d55910b131 --- /dev/null +++ b/basis/bitstreams/bitstreams-tests.factor @@ -0,0 +1,27 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors bitstreams io io.streams.string kernel tools.test +grouping compression.lzw multiline byte-arrays io.encodings.binary +io.streams.byte-array ; +IN: bitstreams.tests + +[ 1 t ] +[ B{ 254 } read-bit ] unit-test + +[ 254 8 t ] +[ B{ 254 } 8 swap read-bits ] unit-test + +[ 4095 12 t ] +[ B{ 255 255 } 12 swap read-bits ] unit-test + +[ B{ 254 } ] +[ + 254 8 rot + [ write-bits ] keep stream>> >byte-array +] unit-test + +[ 255 8 t ] +[ B{ 255 } binary 8 swap read-bits ] unit-test + +[ 255 8 f ] +[ B{ 255 } binary 9 swap read-bits ] unit-test diff --git a/basis/bitstreams/bitstreams.factor b/basis/bitstreams/bitstreams.factor new file mode 100644 index 0000000000..7113b650fd --- /dev/null +++ b/basis/bitstreams/bitstreams.factor @@ -0,0 +1,96 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors byte-arrays destructors fry io kernel locals +math sequences ; +IN: bitstreams + +TUPLE: bitstream stream end-of-stream? current-bits #bits disposed ; +TUPLE: bitstream-reader < bitstream ; + +: reset-bitstream ( stream -- stream ) + 0 >>#bits 0 >>current-bits ; inline + +: new-bitstream ( stream class -- bitstream ) + new + swap >>stream + reset-bitstream ; inline + +M: bitstream-reader dispose ( stream -- ) + stream>> dispose ; + +: ( stream -- bitstream ) + bitstream-reader new-bitstream ; inline + +: read-next-byte ( bitstream -- bitstream ) + dup stream>> stream-read1 [ + >>current-bits 8 >>#bits + ] [ + 0 >>#bits + t >>end-of-stream? + ] if* ; + +: maybe-read-next-byte ( bitstream -- bitstream ) + dup #bits>> 0 = [ read-next-byte ] when ; inline + +: shift-one-bit ( bitstream -- n ) + [ current-bits>> ] [ #bits>> ] bi 1- neg shift 1 bitand ; inline + +: next-bit ( bitstream -- n/f ? ) + maybe-read-next-byte + dup end-of-stream?>> [ + drop f + ] [ + [ shift-one-bit ] + [ [ 1- ] change-#bits maybe-read-next-byte drop ] bi + ] if dup >boolean ; + +: read-bit ( bitstream -- n ? ) + dup #bits>> 1 = [ + [ current-bits>> 1 bitand ] + [ read-next-byte drop ] bi t + ] [ + next-bit + ] if ; inline + +: bits>integer ( seq -- n ) + 0 [ [ 1 shift ] dip bitor ] reduce ; inline + +: read-bits ( width bitstream -- n width ? ) + [ + '[ _ read-bit drop ] replicate + [ f = ] trim-tail + [ bits>integer ] [ length ] bi + ] 2keep drop over = ; + +TUPLE: bitstream-writer < bitstream ; + +: ( stream -- bitstream ) + bitstream-writer new-bitstream ; inline + +: write-bit ( n bitstream -- ) + [ 1 shift bitor ] change-current-bits + [ 1+ ] change-#bits + dup #bits>> 8 = [ + [ [ current-bits>> ] [ stream>> stream-write1 ] bi ] + [ reset-bitstream drop ] bi + ] [ + drop + ] if ; inline + +ERROR: invalid-bit-width n ; + +:: write-bits ( n width bitstream -- ) + n 0 < [ n invalid-bit-width ] when + n 0 = [ + width [ 0 bitstream write-bit ] times + ] [ + width n log2 1+ dup :> n-length - [ 0 bitstream write-bit ] times + n-length [ + n-length swap - 1- neg n swap shift 1 bitand + bitstream write-bit + ] each + ] if ; + +: flush-bits ( bitstream -- ) stream>> stream-flush ; + +: bitstream-output ( bitstream -- bytes ) stream>> >byte-array ; diff --git a/basis/bootstrap/image/image-docs.factor b/basis/bootstrap/image/image-docs.factor index 3856382ffb..835c39c171 100644 --- a/basis/bootstrap/image/image-docs.factor +++ b/basis/bootstrap/image/image-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax io io.files io.pathnames ; +USING: help.markup help.syntax io io.files io.pathnames strings ; IN: bootstrap.image ARTICLE: "bootstrap.image" "Bootstrapping new images" @@ -14,7 +14,7 @@ $nl ABOUT: "bootstrap.image" HELP: make-image -{ $values { "arch" "a string" } } +{ $values { "arch" string } } { $description "Creates a bootstrap image from sources, where " { $snippet "architecture" } " is one of the following:" -{ $code "x86.32" "x86.64" "ppc" "arm" } +{ $code "x86.32" "unix-x86.64" "winnt-x86.64" "macosx-ppc" "linux-ppc" } "The new image file is written to the " { $link resource-path } " and is named " { $snippet "boot." { $emphasis "architecture" } ".image" } "." } ; diff --git a/basis/cocoa/cocoa.factor b/basis/cocoa/cocoa.factor index 44252a3b19..01f134e283 100644 --- a/basis/cocoa/cocoa.factor +++ b/basis/cocoa/cocoa.factor @@ -29,7 +29,7 @@ SYMBOL: super-sent-messages SYMBOL: frameworks -frameworks global [ V{ } clone or ] change-at +frameworks [ V{ } clone ] initialize [ frameworks get [ load-framework ] each ] "cocoa.messages" add-init-hook diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index 60bdde262c..ce66467203 100644 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -19,8 +19,8 @@ IN: cocoa.messages SYMBOL: message-senders SYMBOL: super-message-senders -message-senders global [ H{ } assoc-like ] change-at -super-message-senders global [ H{ } assoc-like ] change-at +message-senders [ H{ } clone ] initialize +super-message-senders [ H{ } clone ] initialize : cache-stub ( method function hash -- ) [ @@ -53,7 +53,7 @@ MEMO: ( name -- sel ) f \ selector boa ; SYMBOL: objc-methods -objc-methods global [ H{ } assoc-like ] change-at +objc-methods [ H{ } clone ] initialize : lookup-method ( selector -- method ) dup objc-methods get at @@ -79,7 +79,7 @@ MACRO: (send) ( selector super? -- quot ) ! Runtime introspection SYMBOL: class-init-hooks -class-init-hooks global [ H{ } clone or ] change-at +class-init-hooks [ H{ } clone ] initialize : (objc-class) ( name word -- class ) 2dup execute dup [ 2nip ] [ diff --git a/basis/combinators/smart/smart-tests.factor b/basis/combinators/smart/smart-tests.factor index 69a3a821e5..1cca697dde 100644 --- a/basis/combinators/smart/smart-tests.factor +++ b/basis/combinators/smart/smart-tests.factor @@ -44,4 +44,6 @@ IN: combinators.smart.tests \ nested-smart-combo-test must-infer -[ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test \ No newline at end of file +[ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test + +[ 14 ] [ [ 1 2 3 ] [ sq ] [ + ] map-reduce-outputs ] unit-test \ No newline at end of file diff --git a/basis/combinators/smart/smart.factor b/basis/combinators/smart/smart.factor index e93d84e394..e7bdd75ced 100644 --- a/basis/combinators/smart/smart.factor +++ b/basis/combinators/smart/smart.factor @@ -21,6 +21,12 @@ MACRO: reduce-outputs ( quot operation -- newquot ) : sum-outputs ( quot -- n ) [ + ] reduce-outputs ; inline +MACRO: map-reduce-outputs ( quot mapper reducer -- newquot ) + [ dup infer out>> ] 2dip + [ swap '[ _ _ napply ] ] + [ [ 1 [-] ] dip n*quot ] bi-curry* bi + '[ @ @ @ ] ; + MACRO: append-outputs-as ( quot exemplar -- newquot ) [ dup infer out>> ] dip '[ @ _ _ nappend-as ] ; diff --git a/basis/compiler/alien/alien.factor b/basis/compiler/alien/alien.factor index 4a41014ab2..59901cf79a 100644 --- a/basis/compiler/alien/alien.factor +++ b/basis/compiler/alien/alien.factor @@ -5,7 +5,7 @@ alien.c-types alien.structs cpu.architecture ; IN: compiler.alien : large-struct? ( ctype -- ? ) - dup c-struct? [ struct-small-enough? not ] [ drop f ] if ; + dup c-struct? [ return-struct-in-registers? not ] [ drop f ] if ; : alien-parameters ( params -- seq ) dup parameters>> diff --git a/basis/compiler/utilities/utilities.factor b/basis/compiler/utilities/utilities.factor index ec4ced8c9f..31faaef480 100644 --- a/basis/compiler/utilities/utilities.factor +++ b/basis/compiler/utilities/utilities.factor @@ -24,4 +24,4 @@ IN: compiler.utilities SYMBOL: yield-hook -yield-hook global [ [ ] or ] change-at +yield-hook [ [ ] ] initialize diff --git a/basis/compression/lzw/authors.txt b/basis/compression/lzw/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/compression/lzw/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/compression/lzw/lzw-tests.factor b/basis/compression/lzw/lzw-tests.factor new file mode 100644 index 0000000000..698e35d87e --- /dev/null +++ b/basis/compression/lzw/lzw-tests.factor @@ -0,0 +1,4 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors tools.test compression.lzw ; +IN: compression.lzw.tests diff --git a/basis/compression/lzw/lzw.factor b/basis/compression/lzw/lzw.factor new file mode 100644 index 0000000000..67248474d3 --- /dev/null +++ b/basis/compression/lzw/lzw.factor @@ -0,0 +1,204 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs bitstreams byte-vectors combinators io +io.encodings.binary io.streams.byte-array kernel math sequences +vectors ; +IN: compression.lzw + +CONSTANT: clear-code 256 +CONSTANT: end-of-information 257 + +TUPLE: lzw input output end-of-input? table count k omega omega-k #bits +code old-code ; + +SYMBOL: table-full + +ERROR: index-too-big n ; + +: lzw-bit-width ( n -- n' ) + { + { [ dup 510 <= ] [ drop 9 ] } + { [ dup 1022 <= ] [ drop 10 ] } + { [ dup 2046 <= ] [ drop 11 ] } + { [ dup 4094 <= ] [ drop 12 ] } + [ drop table-full ] + } cond ; + +: lzw-bit-width-compress ( lzw -- n ) + count>> lzw-bit-width ; + +: lzw-bit-width-uncompress ( lzw -- n ) + table>> length lzw-bit-width ; + +: initial-compress-table ( -- assoc ) + 258 iota [ [ 1vector ] keep ] H{ } map>assoc ; + +: initial-uncompress-table ( -- seq ) + 258 iota [ 1vector ] V{ } map-as ; + +: reset-lzw ( lzw -- lzw ) + 257 >>count + V{ } clone >>omega + V{ } clone >>omega-k + 9 >>#bits ; + +: reset-lzw-compress ( lzw -- lzw ) + f >>k + initial-compress-table >>table reset-lzw ; + +: reset-lzw-uncompress ( lzw -- lzw ) + initial-uncompress-table >>table reset-lzw ; + +: ( input -- obj ) + lzw new + swap >>input + binary >>output + reset-lzw-compress ; + +: ( input -- obj ) + lzw new + swap >>input + BV{ } clone >>output + reset-lzw-uncompress ; + +: push-k ( lzw -- lzw ) + [ ] + [ k>> ] + [ omega>> clone [ push ] keep ] tri >>omega-k ; + +: omega-k-in-table? ( lzw -- ? ) + [ omega-k>> ] [ table>> ] bi key? ; + +ERROR: not-in-table ; + +: write-output ( lzw -- ) + [ + [ omega>> ] [ table>> ] bi at* [ not-in-table ] unless + ] [ + [ lzw-bit-width-compress ] + [ output>> write-bits ] bi + ] bi ; + +: omega-k>omega ( lzw -- lzw ) + dup omega-k>> clone >>omega ; + +: k>omega ( lzw -- lzw ) + dup k>> 1vector >>omega ; + +: add-omega-k ( lzw -- ) + [ [ 1+ ] change-count count>> ] + [ omega-k>> clone ] + [ table>> ] tri set-at ; + +: lzw-compress-char ( lzw k -- ) + >>k push-k dup omega-k-in-table? [ + omega-k>omega drop + ] [ + [ write-output ] + [ add-omega-k ] + [ k>omega drop ] tri + ] if ; + +: (lzw-compress-chars) ( lzw -- ) + dup lzw-bit-width-compress table-full = [ + drop + ] [ + dup input>> stream-read1 + [ [ lzw-compress-char ] [ drop (lzw-compress-chars) ] 2bi ] + [ t >>end-of-input? drop ] if* + ] if ; + +: lzw-compress-chars ( lzw -- ) + { + ! [ [ clear-code lzw-compress-char ] [ drop ] bi ] ! reset-lzw-compress drop ] bi ] + [ + [ clear-code ] dip + [ lzw-bit-width-compress ] + [ output>> write-bits ] bi + ] + [ (lzw-compress-chars) ] + [ + [ k>> ] + [ lzw-bit-width-compress ] + [ output>> write-bits ] tri + ] + [ + [ end-of-information ] dip + [ lzw-bit-width-compress ] + [ output>> write-bits ] bi + ] + [ ] + } cleave dup end-of-input?>> [ drop ] [ lzw-compress-chars ] if ; + +: lzw-compress ( byte-array -- seq ) + binary + [ lzw-compress-chars ] [ output>> stream>> ] bi ; + +: lookup-old-code ( lzw -- vector ) + [ old-code>> ] [ table>> ] bi nth ; + +: lookup-code ( lzw -- vector ) + [ code>> ] [ table>> ] bi nth ; + +: code-in-table? ( lzw -- ? ) + [ code>> ] [ table>> length ] bi < ; + +: code>old-code ( lzw -- lzw ) + dup code>> >>old-code ; + +: write-code ( lzw -- ) + [ lookup-code ] [ output>> ] bi push-all ; + +: add-to-table ( seq lzw -- ) table>> push ; + +: lzw-read ( lzw -- lzw n ) + [ ] [ lzw-bit-width-uncompress ] [ input>> ] tri read-bits 2drop ; + +DEFER: lzw-uncompress-char +: handle-clear-code ( lzw -- ) + reset-lzw-uncompress + lzw-read dup end-of-information = [ + 2drop + ] [ + >>code + [ write-code ] + [ code>old-code ] bi + lzw-uncompress-char + ] if ; + +: handle-uncompress-code ( lzw -- lzw ) + dup code-in-table? [ + [ write-code ] + [ + [ + [ lookup-old-code ] + [ lookup-code first ] bi suffix + ] [ add-to-table ] bi + ] [ code>old-code ] tri + ] [ + [ + [ lookup-old-code dup first suffix ] keep + [ output>> push-all ] [ add-to-table ] 2bi + ] [ code>old-code ] bi + ] if ; + +: lzw-uncompress-char ( lzw -- ) + lzw-read [ + >>code + dup code>> end-of-information = [ + drop + ] [ + dup code>> clear-code = [ + handle-clear-code + ] [ + handle-uncompress-code + lzw-uncompress-char + ] if + ] if + ] [ + drop + ] if* ; + +: lzw-uncompress ( seq -- byte-array ) + binary + [ lzw-uncompress-char ] [ output>> ] bi ; diff --git a/basis/zlib/authors.txt b/basis/compression/zlib/authors.txt similarity index 100% rename from basis/zlib/authors.txt rename to basis/compression/zlib/authors.txt diff --git a/basis/zlib/ffi/authors.txt b/basis/compression/zlib/ffi/authors.txt similarity index 100% rename from basis/zlib/ffi/authors.txt rename to basis/compression/zlib/ffi/authors.txt diff --git a/basis/zlib/ffi/ffi.factor b/basis/compression/zlib/ffi/ffi.factor similarity index 97% rename from basis/zlib/ffi/ffi.factor rename to basis/compression/zlib/ffi/ffi.factor index bda2809f56..d369c22e4c 100755 --- a/basis/zlib/ffi/ffi.factor +++ b/basis/compression/zlib/ffi/ffi.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.syntax combinators system ; -IN: zlib.ffi +IN: compression.zlib.ffi << "zlib" { { [ os winnt? ] [ "zlib1.dll" ] } diff --git a/basis/zlib/zlib-tests.factor b/basis/compression/zlib/zlib-tests.factor similarity index 77% rename from basis/zlib/zlib-tests.factor rename to basis/compression/zlib/zlib-tests.factor index 0ac77277dc..1baeba73d9 100755 --- a/basis/zlib/zlib-tests.factor +++ b/basis/compression/zlib/zlib-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel tools.test zlib classes ; -IN: zlib.tests +USING: kernel tools.test compression.zlib classes ; +IN: compression.zlib.tests : compress-me ( -- byte-array ) B{ 1 2 3 4 5 } ; diff --git a/basis/zlib/zlib.factor b/basis/compression/zlib/zlib.factor similarity index 78% rename from basis/zlib/zlib.factor rename to basis/compression/zlib/zlib.factor index b40d9c2a98..7818173498 100755 --- a/basis/zlib/zlib.factor +++ b/basis/compression/zlib/zlib.factor @@ -3,8 +3,8 @@ USING: alien alien.c-types alien.syntax byte-arrays combinators kernel math math.functions sequences system accessors libc ; -QUALIFIED: zlib.ffi -IN: zlib +QUALIFIED: compression.zlib.ffi +IN: compression.zlib TUPLE: compressed data length ; @@ -16,7 +16,7 @@ TUPLE: compressed data length ; ERROR: zlib-failed n string ; : zlib-error-message ( n -- * ) - dup zlib.ffi:Z_ERRNO = [ + dup compression.zlib.ffi:Z_ERRNO = [ drop errno "native libc error" ] [ dup { @@ -27,7 +27,7 @@ ERROR: zlib-failed n string ; ] if zlib-failed ; : zlib-error ( n -- ) - dup zlib.ffi:Z_OK = [ drop ] [ dup zlib-error-message zlib-failed ] if ; + dup compression.zlib.ffi:Z_OK = [ drop ] [ dup zlib-error-message zlib-failed ] if ; : compressed-size ( byte-array -- n ) length 1001/1000 * ceiling 12 + ; @@ -35,7 +35,7 @@ ERROR: zlib-failed n string ; : compress ( byte-array -- compressed ) [ [ compressed-size dup length ] keep [ - dup length zlib.ffi:compress zlib-error + dup length compression.zlib.ffi:compress zlib-error ] 3keep drop *ulong head ] keep length ; @@ -44,5 +44,5 @@ ERROR: zlib-failed n string ; length>> [ ] keep 2dup ] [ data>> dup length - zlib.ffi:uncompress zlib-error + compression.zlib.ffi:uncompress zlib-error ] bi *ulong head ; diff --git a/basis/concurrency/messaging/messaging.factor b/basis/concurrency/messaging/messaging.factor index 61a3c38991..ce7f7d6110 100644 --- a/basis/concurrency/messaging/messaging.factor +++ b/basis/concurrency/messaging/messaging.factor @@ -85,4 +85,4 @@ PRIVATE> : get-process ( name -- process ) dup registered-processes at [ ] [ thread ] ?if ; -\ registered-processes global [ H{ } assoc-like ] change-at +\ registered-processes [ H{ } clone ] initialize diff --git a/extra/constructors/authors.txt b/basis/constructors/authors.txt similarity index 100% rename from extra/constructors/authors.txt rename to basis/constructors/authors.txt diff --git a/extra/constructors/constructors-tests.factor b/basis/constructors/constructors-tests.factor similarity index 100% rename from extra/constructors/constructors-tests.factor rename to basis/constructors/constructors-tests.factor diff --git a/extra/constructors/constructors.factor b/basis/constructors/constructors.factor similarity index 100% rename from extra/constructors/constructors.factor rename to basis/constructors/constructors.factor diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 5670110f04..2c9675426b 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -152,7 +152,7 @@ HOOK: %loop-entry cpu ( -- ) HOOK: small-enough? cpu ( n -- ? ) ! Is this structure small enough to be returned in registers? -HOOK: struct-small-enough? cpu ( c-type -- ? ) +HOOK: return-struct-in-registers? cpu ( c-type -- ? ) ! Do we pass this struct by value or hidden reference? HOOK: value-struct? cpu ( c-type -- ? ) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index b177c71d77..f245bcb7e1 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -659,7 +659,7 @@ M: ppc %callback-value ( ctype -- ) M: ppc small-enough? ( n -- ? ) -32768 32767 between? ; -M: ppc struct-small-enough? ( size -- ? ) drop f ; +M: ppc return-struct-in-registers? ( c-type -- ? ) drop f ; M: ppc %box-small-struct drop "No small structs" throw ; diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index affd39ffc5..f881792ac6 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -48,9 +48,12 @@ M: x86.32 %alien-invoke (CALL) rel-dlsym ; M: x86.32 %alien-invoke-tail (JMP) rel-dlsym ; -M: x86.32 struct-small-enough? ( size -- ? ) - heap-size { 1 2 4 8 } member? - os { linux netbsd solaris } member? not and ; +M: x86.32 return-struct-in-registers? ( c-type -- ? ) + c-type + [ return-in-registers?>> ] + [ heap-size { 1 2 4 8 } member? ] bi + os { linux netbsd solaris } member? not + and or ; : struct-return@ ( n -- operand ) [ next-stack@ ] [ stack-frame get params>> stack@ ] if* ; diff --git a/basis/cpu/x86/64/unix/unix.factor b/basis/cpu/x86/64/unix/unix.factor index f5fb5b9640..eea960d03d 100644 --- a/basis/cpu/x86/64/unix/unix.factor +++ b/basis/cpu/x86/64/unix/unix.factor @@ -44,7 +44,7 @@ M: struct-type flatten-value-type ( type -- seq ) flatten-small-struct ] if ; -M: x86.64 struct-small-enough? ( size -- ? ) +M: x86.64 return-struct-in-registers? ( c-type -- ? ) heap-size 2 cells <= ; M: x86.64 dummy-stack-params? f ; diff --git a/basis/cpu/x86/64/winnt/winnt.factor b/basis/cpu/x86/64/winnt/winnt.factor index 4c6af6c1e7..8091be65ae 100644 --- a/basis/cpu/x86/64/winnt/winnt.factor +++ b/basis/cpu/x86/64/winnt/winnt.factor @@ -10,7 +10,8 @@ M: float-regs param-regs drop { XMM0 XMM1 XMM2 XMM3 } ; M: x86.64 reserved-area-size 4 cells ; -M: x86.64 struct-small-enough? heap-size { 1 2 4 8 } member? ; +M: x86.64 return-struct-in-registers? ( c-type -- ? ) + heap-size { 1 2 4 8 } member? ; M: x86.64 value-struct? heap-size { 1 2 4 8 } member? ; diff --git a/basis/csv/csv-tests.factor b/basis/csv/csv-tests.factor index 4d78c2af86..6ba8e2d5b8 100644 --- a/basis/csv/csv-tests.factor +++ b/basis/csv/csv-tests.factor @@ -1,14 +1,11 @@ -USING: io.streams.string csv tools.test shuffle kernel strings +USING: io.streams.string csv tools.test kernel strings io.pathnames io.files.unique io.encodings.utf8 io.files io.directories ; IN: csv.tests ! I like to name my unit tests : named-unit-test ( name output input -- ) - nipd unit-test ; inline - -! tests nicked from the wikipedia csv article -! http://en.wikipedia.org/wiki/Comma-separated_values + unit-test drop ; inline "Fields are separated by commas" [ { { "1997" "Ford" "E350" } } ] @@ -90,3 +87,5 @@ IN: csv.tests { { "writing,some,csv,tests" } } dup "csv-test2-" unique-file utf8 [ csv>file ] [ file>csv ] 2bi = ] unit-test + +[ { { "hello" "" "" "" "goodbye" "" } } ] [ "hello,,\"\",,goodbye," csv ] unit-test diff --git a/basis/csv/csv.factor b/basis/csv/csv.factor index 152b3dcbba..5902999a76 100755 --- a/basis/csv/csv.factor +++ b/basis/csv/csv.factor @@ -46,13 +46,15 @@ DEFER: quoted-field ( -- endchar ) : (row) ( -- sep ) field , - dup delimiter get = [ drop (row) ] when ; + dup delimiter> = [ drop (row) ] when ; : row ( -- eof? array[string] ) [ (row) ] { } make ; : (csv) ( -- ) - row harvest [ , ] unless-empty [ (csv) ] when ; + row + dup [ empty? ] all? [ drop ] [ , ] if + [ (csv) ] when ; PRIVATE> @@ -60,7 +62,8 @@ PRIVATE> [ row nip ] with-input-stream ; : csv ( stream -- rows ) - [ [ (csv) ] { } make ] with-input-stream ; + [ [ (csv) ] { } make ] with-input-stream + dup peek { "" } = [ but-last ] when ; : file>csv ( path encoding -- csv ) csv ; diff --git a/basis/db/postgresql/ffi/ffi.factor b/basis/db/postgresql/ffi/ffi.factor index 4358d7f3de..fc407b06bd 100644 --- a/basis/db/postgresql/ffi/ffi.factor +++ b/basis/db/postgresql/ffi/ffi.factor @@ -11,46 +11,46 @@ IN: db.postgresql.ffi } cond "cdecl" add-library >> ! ConnSatusType -: CONNECTION_OK HEX: 0 ; inline -: CONNECTION_BAD HEX: 1 ; inline -: CONNECTION_STARTED HEX: 2 ; inline -: CONNECTION_MADE HEX: 3 ; inline -: CONNECTION_AWAITING_RESPONSE HEX: 4 ; inline -: CONNECTION_AUTH_OK HEX: 5 ; inline -: CONNECTION_SETENV HEX: 6 ; inline -: CONNECTION_SSL_STARTUP HEX: 7 ; inline -: CONNECTION_NEEDED HEX: 8 ; inline +CONSTANT: CONNECTION_OK HEX: 0 +CONSTANT: CONNECTION_BAD HEX: 1 +CONSTANT: CONNECTION_STARTED HEX: 2 +CONSTANT: CONNECTION_MADE HEX: 3 +CONSTANT: CONNECTION_AWAITING_RESPONSE HEX: 4 +CONSTANT: CONNECTION_AUTH_OK HEX: 5 +CONSTANT: CONNECTION_SETENV HEX: 6 +CONSTANT: CONNECTION_SSL_STARTUP HEX: 7 +CONSTANT: CONNECTION_NEEDED HEX: 8 ! PostgresPollingStatusType -: PGRES_POLLING_FAILED HEX: 0 ; inline -: PGRES_POLLING_READING HEX: 1 ; inline -: PGRES_POLLING_WRITING HEX: 2 ; inline -: PGRES_POLLING_OK HEX: 3 ; inline -: PGRES_POLLING_ACTIVE HEX: 4 ; inline +CONSTANT: PGRES_POLLING_FAILED HEX: 0 +CONSTANT: PGRES_POLLING_READING HEX: 1 +CONSTANT: PGRES_POLLING_WRITING HEX: 2 +CONSTANT: PGRES_POLLING_OK HEX: 3 +CONSTANT: PGRES_POLLING_ACTIVE HEX: 4 ! ExecStatusType; -: PGRES_EMPTY_QUERY HEX: 0 ; inline -: PGRES_COMMAND_OK HEX: 1 ; inline -: PGRES_TUPLES_OK HEX: 2 ; inline -: PGRES_COPY_OUT HEX: 3 ; inline -: PGRES_COPY_IN HEX: 4 ; inline -: PGRES_BAD_RESPONSE HEX: 5 ; inline -: PGRES_NONFATAL_ERROR HEX: 6 ; inline -: PGRES_FATAL_ERROR HEX: 7 ; inline +CONSTANT: PGRES_EMPTY_QUERY HEX: 0 +CONSTANT: PGRES_COMMAND_OK HEX: 1 +CONSTANT: PGRES_TUPLES_OK HEX: 2 +CONSTANT: PGRES_COPY_OUT HEX: 3 +CONSTANT: PGRES_COPY_IN HEX: 4 +CONSTANT: PGRES_BAD_RESPONSE HEX: 5 +CONSTANT: PGRES_NONFATAL_ERROR HEX: 6 +CONSTANT: PGRES_FATAL_ERROR HEX: 7 ! PGTransactionStatusType; -: PQTRANS_IDLE HEX: 0 ; inline -: PQTRANS_ACTIVE HEX: 1 ; inline -: PQTRANS_INTRANS HEX: 2 ; inline -: PQTRANS_INERROR HEX: 3 ; inline -: PQTRANS_UNKNOWN HEX: 4 ; inline +CONSTANT: PQTRANS_IDLE HEX: 0 +CONSTANT: PQTRANS_ACTIVE HEX: 1 +CONSTANT: PQTRANS_INTRANS HEX: 2 +CONSTANT: PQTRANS_INERROR HEX: 3 +CONSTANT: PQTRANS_UNKNOWN HEX: 4 ! PGVerbosity; -: PQERRORS_TERSE HEX: 0 ; inline -: PQERRORS_DEFAULT HEX: 1 ; inline -: PQERRORS_VERBOSE HEX: 2 ; inline +CONSTANT: PQERRORS_TERSE HEX: 0 +CONSTANT: PQERRORS_DEFAULT HEX: 1 +CONSTANT: PQERRORS_VERBOSE HEX: 2 -: InvalidOid 0 ; inline +CONSTANT: InvalidOid 0 TYPEDEF: int ConnStatusType TYPEDEF: int ExecStatusType @@ -348,21 +348,21 @@ FUNCTION: int PQdsplen ( uchar* s, int encoding ) ; FUNCTION: int PQenv2encoding ( ) ; ! From git, include/catalog/pg_type.h -: BOOL-OID 16 ; inline -: BYTEA-OID 17 ; inline -: CHAR-OID 18 ; inline -: NAME-OID 19 ; inline -: INT8-OID 20 ; inline -: INT2-OID 21 ; inline -: INT4-OID 23 ; inline -: TEXT-OID 23 ; inline -: OID-OID 26 ; inline -: FLOAT4-OID 700 ; inline -: FLOAT8-OID 701 ; inline -: VARCHAR-OID 1043 ; inline -: DATE-OID 1082 ; inline -: TIME-OID 1083 ; inline -: TIMESTAMP-OID 1114 ; inline -: TIMESTAMPTZ-OID 1184 ; inline -: INTERVAL-OID 1186 ; inline -: NUMERIC-OID 1700 ; inline +CONSTANT: BOOL-OID 16 +CONSTANT: BYTEA-OID 17 +CONSTANT: CHAR-OID 18 +CONSTANT: NAME-OID 19 +CONSTANT: INT8-OID 20 +CONSTANT: INT2-OID 21 +CONSTANT: INT4-OID 23 +CONSTANT: TEXT-OID 23 +CONSTANT: OID-OID 26 +CONSTANT: FLOAT4-OID 700 +CONSTANT: FLOAT8-OID 701 +CONSTANT: VARCHAR-OID 1043 +CONSTANT: DATE-OID 1082 +CONSTANT: TIME-OID 1083 +CONSTANT: TIMESTAMP-OID 1114 +CONSTANT: TIMESTAMPTZ-OID 1184 +CONSTANT: INTERVAL-OID 1186 +CONSTANT: NUMERIC-OID 1700 diff --git a/basis/db/postgresql/lib/lib.factor b/basis/db/postgresql/lib/lib.factor index 05114a4deb..0d50d1ab2c 100644 --- a/basis/db/postgresql/lib/lib.factor +++ b/basis/db/postgresql/lib/lib.factor @@ -3,7 +3,7 @@ USING: arrays continuations db io kernel math namespaces quotations sequences db.postgresql.ffi alien alien.c-types db.types tools.walker ascii splitting math.parser combinators -libc shuffle calendar.format byte-arrays destructors prettyprint +libc calendar.format byte-arrays destructors prettyprint accessors strings serialize io.encodings.binary io.encodings.utf8 alien.strings io.streams.byte-array summary present urls specialized-arrays.uint specialized-arrays.alien db.private ; @@ -117,7 +117,7 @@ M: postgresql-result-null summary ( obj -- str ) : pq-get-string ( handle row column -- obj ) 3dup PQgetvalue utf8 alien>string - dup empty? [ [ pq-get-is-null f ] dip ? ] [ 3nip ] if ; + dup empty? [ [ pq-get-is-null f ] dip ? ] [ [ 3drop ] dip ] if ; : pq-get-number ( handle row column -- obj ) pq-get-string dup [ string>number ] when ; @@ -134,7 +134,7 @@ M: postgresql-malloc-destructor dispose ( obj -- ) : pq-get-blob ( handle row column -- obj/f ) [ PQgetvalue ] 3keep 3dup PQgetlength dup 0 > [ - 3nip + [ 3drop ] dip [ memory>byte-array >string 0 diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor index 495c25ea68..2730340bfc 100755 --- a/basis/db/queries/queries.factor +++ b/basis/db/queries/queries.factor @@ -44,11 +44,11 @@ M: retryable execute-statement* ( statement type -- ) ] bi attempt-all drop ; : sql-props ( class -- columns table ) - [ db-columns ] [ db-table ] bi ; + [ db-columns ] [ db-table-name ] bi ; : query-make ( class quot -- statements ) #! query, input, outputs, secondary queries - over unparse "table" set + over db-table-name "table-name" set [ sql-props ] dip [ 0 sql-counter rot with-variable ] curry { "" { } { } { } } nmake diff --git a/basis/db/sqlite/ffi/ffi.factor b/basis/db/sqlite/ffi/ffi.factor index 9f033a1d3c..341995634e 100644 --- a/basis/db/sqlite/ffi/ffi.factor +++ b/basis/db/sqlite/ffi/ffi.factor @@ -13,33 +13,33 @@ IN: db.sqlite.ffi } cond "cdecl" add-library >> ! Return values from sqlite functions -: SQLITE_OK 0 ; inline ! Successful result -: SQLITE_ERROR 1 ; inline ! SQL error or missing database -: SQLITE_INTERNAL 2 ; inline ! An internal logic error in SQLite -: SQLITE_PERM 3 ; inline ! Access permission denied -: SQLITE_ABORT 4 ; inline ! Callback routine requested an abort -: SQLITE_BUSY 5 ; inline ! The database file is locked -: SQLITE_LOCKED 6 ; inline ! A table in the database is locked -: SQLITE_NOMEM 7 ; inline ! A malloc() failed -: SQLITE_READONLY 8 ; inline ! Attempt to write a readonly database -: SQLITE_INTERRUPT 9 ; inline ! Operation terminated by sqlite_interrupt() -: SQLITE_IOERR 10 ; inline ! Some kind of disk I/O error occurred -: SQLITE_CORRUPT 11 ; inline ! The database disk image is malformed -: SQLITE_NOTFOUND 12 ; inline ! (Internal Only) Table or record not found -: SQLITE_FULL 13 ; inline ! Insertion failed because database is full -: SQLITE_CANTOPEN 14 ; inline ! Unable to open the database file -: SQLITE_PROTOCOL 15 ; inline ! Database lock protocol error -: SQLITE_EMPTY 16 ; inline ! (Internal Only) Database table is empty -: SQLITE_SCHEMA 17 ; inline ! The database schema changed -: SQLITE_TOOBIG 18 ; inline ! Too much data for one row of a table -: SQLITE_CONSTRAINT 19 ; inline ! Abort due to contraint violation -: SQLITE_MISMATCH 20 ; inline ! Data type mismatch -: SQLITE_MISUSE 21 ; inline ! Library used incorrectly -: SQLITE_NOLFS 22 ; inline ! Uses OS features not supported on host -: SQLITE_AUTH 23 ; inline ! Authorization denied -: SQLITE_FORMAT 24 ; inline ! Auxiliary database format error -: SQLITE_RANGE 25 ; inline ! 2nd parameter to sqlite3_bind out of range -: SQLITE_NOTADB 26 ; inline ! File opened that is not a database file +CONSTANT: SQLITE_OK 0 ! Successful result +CONSTANT: SQLITE_ERROR 1 ! SQL error or missing database +CONSTANT: SQLITE_INTERNAL 2 ! An internal logic error in SQLite +CONSTANT: SQLITE_PERM 3 ! Access permission denied +CONSTANT: SQLITE_ABORT 4 ! Callback routine requested an abort +CONSTANT: SQLITE_BUSY 5 ! The database file is locked +CONSTANT: SQLITE_LOCKED 6 ! A table in the database is locked +CONSTANT: SQLITE_NOMEM 7 ! A malloc() failed +CONSTANT: SQLITE_READONLY 8 ! Attempt to write a readonly database +CONSTANT: SQLITE_INTERRUPT 9 ! Operation terminated by sqlite_interrupt() +CONSTANT: SQLITE_IOERR 10 ! Some kind of disk I/O error occurred +CONSTANT: SQLITE_CORRUPT 11 ! The database disk image is malformed +CONSTANT: SQLITE_NOTFOUND 12 ! (Internal Only) Table or record not found +CONSTANT: SQLITE_FULL 13 ! Insertion failed because database is full +CONSTANT: SQLITE_CANTOPEN 14 ! Unable to open the database file +CONSTANT: SQLITE_PROTOCOL 15 ! Database lock protocol error +CONSTANT: SQLITE_EMPTY 16 ! (Internal Only) Database table is empty +CONSTANT: SQLITE_SCHEMA 17 ! The database schema changed +CONSTANT: SQLITE_TOOBIG 18 ! Too much data for one row of a table +CONSTANT: SQLITE_CONSTRAINT 19 ! Abort due to contraint violation +CONSTANT: SQLITE_MISMATCH 20 ! Data type mismatch +CONSTANT: SQLITE_MISUSE 21 ! Library used incorrectly +CONSTANT: SQLITE_NOLFS 22 ! Uses OS features not supported on host +CONSTANT: SQLITE_AUTH 23 ! Authorization denied +CONSTANT: SQLITE_FORMAT 24 ! Auxiliary database format error +CONSTANT: SQLITE_RANGE 25 ! 2nd parameter to sqlite3_bind out of range +CONSTANT: SQLITE_NOTADB 26 ! File opened that is not a database file : sqlite-error-messages ( -- seq ) { "Successful result" @@ -72,32 +72,32 @@ IN: db.sqlite.ffi } ; ! Return values from sqlite3_step -: SQLITE_ROW 100 ; inline -: SQLITE_DONE 101 ; inline +CONSTANT: SQLITE_ROW 100 +CONSTANT: SQLITE_DONE 101 ! Return values from the sqlite3_column_type function -: SQLITE_INTEGER 1 ; inline -: SQLITE_FLOAT 2 ; inline -: SQLITE_TEXT 3 ; inline -: SQLITE_BLOB 4 ; inline -: SQLITE_NULL 5 ; inline +CONSTANT: SQLITE_INTEGER 1 +CONSTANT: SQLITE_FLOAT 2 +CONSTANT: SQLITE_TEXT 3 +CONSTANT: SQLITE_BLOB 4 +CONSTANT: SQLITE_NULL 5 ! Values for the 'destructor' parameter of the 'bind' routines. -: SQLITE_STATIC 0 ; inline -: SQLITE_TRANSIENT -1 ; inline +CONSTANT: SQLITE_STATIC 0 +CONSTANT: SQLITE_TRANSIENT -1 -: SQLITE_OPEN_READONLY HEX: 00000001 ; inline -: SQLITE_OPEN_READWRITE HEX: 00000002 ; inline -: SQLITE_OPEN_CREATE HEX: 00000004 ; inline -: SQLITE_OPEN_DELETEONCLOSE HEX: 00000008 ; inline -: SQLITE_OPEN_EXCLUSIVE HEX: 00000010 ; inline -: SQLITE_OPEN_MAIN_DB HEX: 00000100 ; inline -: SQLITE_OPEN_TEMP_DB HEX: 00000200 ; inline -: SQLITE_OPEN_TRANSIENT_DB HEX: 00000400 ; inline -: SQLITE_OPEN_MAIN_JOURNAL HEX: 00000800 ; inline -: SQLITE_OPEN_TEMP_JOURNAL HEX: 00001000 ; inline -: SQLITE_OPEN_SUBJOURNAL HEX: 00002000 ; inline -: SQLITE_OPEN_MASTER_JOURNAL HEX: 00004000 ; inline +CONSTANT: SQLITE_OPEN_READONLY HEX: 00000001 +CONSTANT: SQLITE_OPEN_READWRITE HEX: 00000002 +CONSTANT: SQLITE_OPEN_CREATE HEX: 00000004 +CONSTANT: SQLITE_OPEN_DELETEONCLOSE HEX: 00000008 +CONSTANT: SQLITE_OPEN_EXCLUSIVE HEX: 00000010 +CONSTANT: SQLITE_OPEN_MAIN_DB HEX: 00000100 +CONSTANT: SQLITE_OPEN_TEMP_DB HEX: 00000200 +CONSTANT: SQLITE_OPEN_TRANSIENT_DB HEX: 00000400 +CONSTANT: SQLITE_OPEN_MAIN_JOURNAL HEX: 00000800 +CONSTANT: SQLITE_OPEN_TEMP_JOURNAL HEX: 00001000 +CONSTANT: SQLITE_OPEN_SUBJOURNAL HEX: 00002000 +CONSTANT: SQLITE_OPEN_MASTER_JOURNAL HEX: 00004000 TYPEDEF: void sqlite3 TYPEDEF: void sqlite3_stmt diff --git a/basis/db/sqlite/sqlite-tests.factor b/basis/db/sqlite/sqlite-tests.factor index 6fb1cd19ad..5ad4b0c889 100644 --- a/basis/db/sqlite/sqlite-tests.factor +++ b/basis/db/sqlite/sqlite-tests.factor @@ -73,3 +73,95 @@ IN: db.sqlite.tests "select * from person" sql-query length ] with-db ] unit-test + +! You don't need a primary key +USING: accessors arrays sorting ; +TUPLE: things one two ; + +things "THINGS" { + { "one" "ONE" INTEGER +not-null+ } + { "two" "TWO" INTEGER +not-null+ } +} define-persistent + +[ { { 0 0 } { 0 1 } { 1 0 } { 1 1 } } ] [ + test.db [ + things create-table + 0 0 things boa insert-tuple + 0 1 things boa insert-tuple + 1 1 things boa insert-tuple + 1 0 things boa insert-tuple + f f things boa select-tuples + [ [ one>> ] [ two>> ] bi 2array ] map natural-sort + things drop-table + ] with-db +] unit-test + +! Tables can have different names than the name of the tuple +TUPLE: foo slot ; +C: foo +foo "BAR" { { "slot" "SOMETHING" INTEGER +not-null+ } } define-persistent + +TUPLE: hi bye try ; +C: hi +hi "HELLO" { + { "bye" "BUHBYE" INTEGER { +foreign-id+ foo "SOMETHING" } } + { "try" "RETHROW" INTEGER { +foreign-id+ foo "SOMETHING" } } +} define-persistent + +[ T{ foo { slot 1 } } T{ hi { bye 1 } { try 1 } } ] [ + test.db [ + foo create-table + hi create-table + 1 insert-tuple + f select-tuple + 1 1 insert-tuple + f select-tuple + hi drop-table + foo drop-table + ] with-db +] unit-test + +[ ] [ + test.db [ + hi create-table + hi drop-table + ] with-db +] unit-test + +TUPLE: show id ; +TUPLE: user username data ; +TUPLE: watch show user ; + +user "USER" { + { "username" "USERNAME" TEXT +not-null+ +user-assigned-id+ } + { "data" "DATA" TEXT } +} define-persistent + +show "SHOW" { + { "id" "ID" +db-assigned-id+ } +} define-persistent + +watch "WATCH" { + { "user" "USER" TEXT +not-null+ + { +foreign-id+ user "USERNAME" } +user-assigned-id+ } + { "show" "SHOW" BIG-INTEGER +not-null+ + { +foreign-id+ show "ID" } +user-assigned-id+ } +} define-persistent + +[ T{ user { username "littledan" } { data "foo" } } ] [ + test.db [ + user create-table + show create-table + watch create-table + "littledan" "foo" user boa insert-tuple + "mark" "bar" user boa insert-tuple + show new insert-tuple + show new select-tuple + "littledan" f user boa select-tuple + watch boa insert-tuple + watch new select-tuple + user>> f user boa select-tuple + ] with-db +] unit-test + +[ \ swap ensure-table ] must-fail diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor index fe3bb64d45..d006145ea8 100755 --- a/basis/db/sqlite/sqlite.factor +++ b/basis/db/sqlite/sqlite.factor @@ -138,11 +138,13 @@ M: sqlite-db-connection create-sql-statement ( class -- statement ) modifiers 0% ] interleave - ", " 0% - find-primary-key - "primary key(" 0% - [ "," 0% ] [ column-name>> 0% ] interleave - "));" 0% + find-primary-key [ + ", " 0% + "primary key(" 0% + [ "," 0% ] [ column-name>> 0% ] interleave + ")" 0% + ] unless-empty + ");" 0% ] query-make ; M: sqlite-db-connection drop-sql-statement ( class -- statement ) @@ -223,11 +225,11 @@ M: sqlite-db-connection persistent-table ( -- assoc ) : insert-trigger ( -- string ) [ <" - CREATE TRIGGER fki_${table}_${foreign-table}_id - BEFORE INSERT ON ${table} + CREATE TRIGGER fki_${table-name}_${foreign-table-name}_id + BEFORE INSERT ON ${table-name} FOR EACH ROW BEGIN - SELECT RAISE(ROLLBACK, 'insert on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"') - WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; + SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"') + WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; END; "> interpolate ] with-string-writer ; @@ -235,12 +237,12 @@ M: sqlite-db-connection persistent-table ( -- assoc ) : insert-trigger-not-null ( -- string ) [ <" - CREATE TRIGGER fki_${table}_${foreign-table}_id - BEFORE INSERT ON ${table} + CREATE TRIGGER fki_${table-name}_${foreign-table-name}_id + BEFORE INSERT ON ${table-name} FOR EACH ROW BEGIN - SELECT RAISE(ROLLBACK, 'insert on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"') + SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"') WHERE NEW.${foreign-table-id} IS NOT NULL - AND (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; + AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; END; "> interpolate ] with-string-writer ; @@ -248,11 +250,11 @@ M: sqlite-db-connection persistent-table ( -- assoc ) : update-trigger ( -- string ) [ <" - CREATE TRIGGER fku_${table}_${foreign-table}_id - BEFORE UPDATE ON ${table} + CREATE TRIGGER fku_${table-name}_${foreign-table-name}_id + BEFORE UPDATE ON ${table-name} FOR EACH ROW BEGIN - SELECT RAISE(ROLLBACK, 'update on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"') - WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; + SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"') + WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; END; "> interpolate ] with-string-writer ; @@ -260,12 +262,12 @@ M: sqlite-db-connection persistent-table ( -- assoc ) : update-trigger-not-null ( -- string ) [ <" - CREATE TRIGGER fku_${table}_${foreign-table}_id - BEFORE UPDATE ON ${table} + CREATE TRIGGER fku_${table-name}_${foreign-table-name}_id + BEFORE UPDATE ON ${table-name} FOR EACH ROW BEGIN - SELECT RAISE(ROLLBACK, 'update on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"') + SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"') WHERE NEW.${foreign-table-id} IS NOT NULL - AND (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; + AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; END; "> interpolate ] with-string-writer ; @@ -273,11 +275,11 @@ M: sqlite-db-connection persistent-table ( -- assoc ) : delete-trigger-restrict ( -- string ) [ <" - CREATE TRIGGER fkd_${table}_${foreign-table}_id - BEFORE DELETE ON ${foreign-table} + CREATE TRIGGER fkd_${table-name}_${foreign-table-name}_id + BEFORE DELETE ON ${foreign-table-name} FOR EACH ROW BEGIN - SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table}" violates foreign key constraint "fk_${foreign-table}_id"') - WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL; + SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"') + WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL; END; "> interpolate ] with-string-writer ; @@ -285,10 +287,10 @@ M: sqlite-db-connection persistent-table ( -- assoc ) : delete-trigger-cascade ( -- string ) [ <" - CREATE TRIGGER fkd_${table}_${foreign-table}_id - BEFORE DELETE ON ${foreign-table} + CREATE TRIGGER fkd_${table-name}_${foreign-table-name}_id + BEFORE DELETE ON ${foreign-table-name} FOR EACH ROW BEGIN - DELETE from ${table} WHERE ${table-id} = OLD.${foreign-table-id}; + DELETE from ${table-name} WHERE ${table-id} = OLD.${foreign-table-id}; END; "> interpolate ] with-string-writer ; @@ -321,7 +323,7 @@ M: sqlite-db-connection compound ( string seq -- new-string ) { "default" [ first number>string " " glue ] } { "references" [ [ >reference-string ] keep - first2 [ "foreign-table" set ] + first2 [ db-table-name "foreign-table-name" set ] [ "foreign-table-id" set ] bi* create-sqlite-triggers ] } diff --git a/basis/db/types/types.factor b/basis/db/types/types.factor index b5a7db987a..e39a5977ef 100755 --- a/basis/db/types/types.factor +++ b/basis/db/types/types.factor @@ -49,7 +49,7 @@ ERROR: no-slot ; ERROR: not-persistent class ; -: db-table ( class -- object ) +: db-table-name ( class -- object ) dup "db-table" word-prop [ ] [ not-persistent ] ?if ; : db-columns ( class -- object ) @@ -165,7 +165,7 @@ ERROR: no-column column ; : >reference-string ( string pair -- string ) first2 - [ [ unparse " " glue ] [ db-columns ] bi ] dip + [ [ db-table-name " " glue ] [ db-columns ] bi ] dip swap [ column-name>> = ] with find nip [ no-column ] unless* column-name>> "(" ")" surround append ; diff --git a/basis/editors/editors.factor b/basis/editors/editors.factor index 53887bd353..d060a3dfe6 100644 --- a/basis/editors/editors.factor +++ b/basis/editors/editors.factor @@ -1,9 +1,10 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: parser lexer kernel namespaces sequences definitions io.files io.backend io.pathnames io summary continuations tools.crossref tools.vocabs prettyprint source-files assocs -vocabs vocabs.loader splitting accessors ; +vocabs vocabs.loader splitting accessors debugger prettyprint +help.topics ; IN: editors TUPLE: no-edit-hook ; @@ -29,11 +30,21 @@ SYMBOL: edit-hook [ (normalize-path) ] dip edit-hook get-global [ call ] [ no-edit-hook edit-location ] if* ; +ERROR: cannot-find-source definition ; + +M: cannot-find-source error. + "Cannot find source for ``" write + definition>> pprint-short + "''" print ; + : edit ( defspec -- ) - where [ first2 edit-location ] when* ; + dup where + [ first2 edit-location ] + [ dup word-link? [ name>> edit ] [ cannot-find-source ] if ] + ?if ; : edit-vocab ( name -- ) - vocab-source-path 1 edit-location ; + >vocab-link edit ; GENERIC: error-file ( error -- file ) diff --git a/basis/endian/endian.factor b/basis/endian/endian.factor index a832d6c0a2..4928458543 100755 --- a/basis/endian/endian.factor +++ b/basis/endian/endian.factor @@ -1,39 +1,36 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types namespaces io.binary fry -kernel math ; +kernel math grouping sequences math.bitwise ; IN: endian SINGLETONS: big-endian little-endian ; -: native-endianness ( -- class ) +: compute-native-endianness ( -- class ) 1 *char 0 = big-endian little-endian ? ; -: >signed ( x n -- y ) - 2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ; - -native-endianness \ native-endianness set-global +SYMBOL: native-endianness +native-endianness [ compute-native-endianness ] initialize SYMBOL: endianness +endianness [ native-endianness get-global ] initialize -\ native-endianness get-global endianness set-global - -HOOK: >native-endian native-endianness ( obj n -- str ) +HOOK: >native-endian native-endianness ( obj n -- bytes ) M: big-endian >native-endian >be ; M: little-endian >native-endian >le ; -HOOK: unsigned-native-endian> native-endianness ( obj -- str ) +HOOK: unsigned-native-endian> native-endianness ( obj -- bytes ) M: big-endian unsigned-native-endian> be> ; M: little-endian unsigned-native-endian> le> ; -: signed-native-endian> ( obj n -- str ) +: signed-native-endian> ( obj n -- n' ) [ unsigned-native-endian> ] dip >signed ; -HOOK: >endian endianness ( obj n -- str ) +HOOK: >endian endianness ( obj n -- bytes ) M: big-endian >endian >be ; @@ -45,13 +42,13 @@ M: big-endian endian> be> ; M: little-endian endian> le> ; -HOOK: unsigned-endian> endianness ( obj -- str ) +HOOK: unsigned-endian> endianness ( obj -- bytes ) M: big-endian unsigned-endian> be> ; M: little-endian unsigned-endian> le> ; -: signed-endian> ( obj n -- str ) +: signed-endian> ( obj n -- bytes ) [ unsigned-endian> ] dip >signed ; : with-endianness ( endian quot -- ) @@ -65,3 +62,15 @@ M: little-endian unsigned-endian> le> ; : with-native-endian ( quot -- ) \ native-endianness get-global swap with-endianness ; inline + +: seq>native-endianness ( seq n -- seq' ) + native-endianness get-global dup endianness get = [ + 2drop + ] [ + [ [ ] keep ] dip + little-endian = [ + '[ be> _ >le ] map + ] [ + '[ le> _ >be ] map + ] if concat + ] if ; inline diff --git a/basis/furnace/chloe-tags/chloe-tags.factor b/basis/furnace/chloe-tags/chloe-tags.factor index d7d9ae9ebb..562fe5a614 100644 --- a/basis/furnace/chloe-tags/chloe-tags.factor +++ b/basis/furnace/chloe-tags/chloe-tags.factor @@ -81,11 +81,18 @@ CHLOE: a CHLOE: base compile-a-url [ [XML /> XML] ] [xml-code] ; +: hidden-nested-fields ( -- xml ) + nested-forms get " " join f like nested-forms-key + hidden-form-field ; + +: render-hidden ( for -- xml ) + [ "," split [ hidden render>xml ] map ] [ f ] if* ; + : compile-hidden-form-fields ( for -- ) '[ - _ [ "," split [ hidden render>xml ] map ] [ f ] if* - nested-forms get " " join f like nested-forms-key hidden-form-field>xml - [ [ modify-form ] each-responder ] with-string-writer + _ render-hidden + hidden-nested-fields + form-modifications [XML
<-><-><->
XML] ] [code] ; diff --git a/basis/furnace/furnace-tests.factor b/basis/furnace/furnace-tests.factor index f01260c68b..c591b848ec 100644 --- a/basis/furnace/furnace-tests.factor +++ b/basis/furnace/furnace-tests.factor @@ -1,7 +1,7 @@ IN: furnace.tests USING: http http.server.dispatchers http.server.responses http.server furnace furnace.utilities tools.test kernel -namespaces accessors io.streams.string urls ; +namespaces accessors io.streams.string urls xml.writer ; TUPLE: funny-dispatcher < dispatcher ; : funny-dispatcher new-dispatcher ; @@ -31,7 +31,7 @@ M: base-path-check-responder call-responder* ] unit-test [ "" ] -[ [ "&&&" "foo" hidden-form-field ] with-string-writer ] +[ "&&&" "foo" hidden-form-field xml>string ] unit-test [ f ] [ request [ referrer ] with-variable ] unit-test diff --git a/basis/furnace/utilities/utilities-docs.factor b/basis/furnace/utilities/utilities-docs.factor index 3a0d8804ef..e7fdaf64d6 100644 --- a/basis/furnace/utilities/utilities-docs.factor +++ b/basis/furnace/utilities/utilities-docs.factor @@ -20,13 +20,13 @@ HELP: each-responder { $description "Applies the quotation to each responder involved in processing the current request." } ; HELP: hidden-form-field -{ $values { "value" string } { "name" string } } -{ $description "Renders an HTML hidden form field tag." } +{ $values { "value" string } { "name" string } { "xml" "an XML chunk" } } +{ $description "Renders an HTML hidden form field tag as XML." } { $notes "This word is used by session management, conversation scope and asides." } { $examples { $example - "USING: furnace.utilities io ;" - "\"bar\" \"foo\" hidden-form-field nl" + "USING: furnace.utilities io xml.writer ;" + "\"bar\" \"foo\" hidden-form-field write-xml nl" "" } } ; @@ -38,7 +38,7 @@ HELP: link-attr { $examples "Conversation scope adds attributes to link tags." } ; HELP: modify-form -{ $values { "responder" "a responder" } } +{ $values { "responder" "a responder" } { "xml/f" "an XML chunk or f" } } { $contract "Emits hidden form fields using " { $link hidden-form-field } "." } { $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." } { $examples "Session management, conversation scope and asides use hidden form fields to pass state." } ; diff --git a/basis/furnace/utilities/utilities.factor b/basis/furnace/utilities/utilities.factor index a2d4c4d996..4fc68f7735 100755 --- a/basis/furnace/utilities/utilities.factor +++ b/basis/furnace/utilities/utilities.factor @@ -77,18 +77,18 @@ GENERIC: link-attr ( tag responder -- ) M: object link-attr 2drop ; -GENERIC: modify-form ( responder -- ) +GENERIC: modify-form ( responder -- xml/f ) -M: object modify-form drop ; +M: object modify-form drop f ; -: hidden-form-field>xml ( value name -- xml ) +: form-modifications ( -- xml ) + [ [ modify-form [ , ] when* ] each-responder ] { } make ; + +: hidden-form-field ( value name -- xml ) over [ [XML name=<->/> XML] ] [ drop ] if ; -: hidden-form-field ( value name -- ) - hidden-form-field>xml write-xml ; - : nested-forms-key "__n" ; : request-params ( request -- assoc ) diff --git a/basis/generalizations/generalizations-docs.factor b/basis/generalizations/generalizations-docs.factor index ac8e14c05a..376ae5bed2 100644 --- a/basis/generalizations/generalizations-docs.factor +++ b/basis/generalizations/generalizations-docs.factor @@ -58,7 +58,7 @@ HELP: npick "placed on the top of the stack." } { $examples - { $example "USING: prettyprint generalizations ;" "1 2 3 4 4 npick .s" "1\n2\n3\n4\n1" } + { $example "USING: kernel prettyprint generalizations ;" "1 2 3 4 4 npick .s clear" "1\n2\n3\n4\n1" } "Some core words expressed in terms of " { $link npick } ":" { $table { { $link dup } { $snippet "1 npick" } } @@ -75,7 +75,7 @@ HELP: ndup "placed on the top of the stack." } { $examples - { $example "USING: prettyprint generalizations ;" "1 2 3 4 4 ndup .s" "1\n2\n3\n4\n1\n2\n3\n4" } + { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 4 ndup .s clear" "1\n2\n3\n4\n1\n2\n3\n4" } "Some core words expressed in terms of " { $link ndup } ":" { $table { { $link dup } { $snippet "1 ndup" } } @@ -91,7 +91,7 @@ HELP: nnip "for any number of items." } { $examples - { $example "USING: prettyprint generalizations ;" "1 2 3 4 3 nnip .s" "4" } + { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 3 nnip .s clear" "4" } "Some core words expressed in terms of " { $link nnip } ":" { $table { { $link nip } { $snippet "1 nnip" } } @@ -106,7 +106,7 @@ HELP: ndrop "for any number of items." } { $examples - { $example "USING: prettyprint generalizations ;" "1 2 3 4 3 ndrop .s" "1" } + { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 3 ndrop .s clear" "1" } "Some core words expressed in terms of " { $link ndrop } ":" { $table { { $link drop } { $snippet "1 ndrop" } } @@ -121,7 +121,7 @@ HELP: nrot "number of items on the stack. " } { $examples - { $example "USING: prettyprint generalizations ;" "1 2 3 4 4 nrot .s" "2\n3\n4\n1" } + { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 4 nrot .s clear" "2\n3\n4\n1" } "Some core words expressed in terms of " { $link nrot } ":" { $table { { $link swap } { $snippet "1 nrot" } } @@ -135,7 +135,7 @@ HELP: -nrot "number of items on the stack. " } { $examples - { $example "USING: prettyprint generalizations ;" "1 2 3 4 4 -nrot .s" "4\n1\n2\n3" } + { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 4 -nrot .s clear" "4\n1\n2\n3" } "Some core words expressed in terms of " { $link -nrot } ":" { $table { { $link swap } { $snippet "1 -nrot" } } @@ -151,8 +151,8 @@ HELP: ndip "stack. The quotation can consume and produce any number of items." } { $examples - { $example "USING: generalizations kernel prettyprint ;" "1 2 [ dup ] 1 ndip .s" "1\n1\n2" } - { $example "USING: generalizations kernel prettyprint ;" "1 2 3 [ drop ] 2 ndip .s" "2\n3" } + { $example "USING: generalizations kernel prettyprint kernel ;" "1 2 [ dup ] 1 ndip .s clear" "1\n1\n2" } + { $example "USING: generalizations kernel prettyprint kernel ;" "1 2 3 [ drop ] 2 ndip .s clear" "2\n3" } "Some core words expressed in terms of " { $link ndip } ":" { $table { { $link dip } { $snippet "1 ndip" } } @@ -168,7 +168,7 @@ HELP: nslip "removed from the stack, the quotation called, and the items restored." } { $examples - { $example "USING: generalizations prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip .s" "99\n1\n2\n3\n4\n5" } + { $example "USING: generalizations kernel prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip .s clear" "99\n1\n2\n3\n4\n5" } "Some core words expressed in terms of " { $link nslip } ":" { $table { { $link slip } { $snippet "1 nslip" } } @@ -184,7 +184,7 @@ HELP: nkeep "saved, the quotation called, and the items restored." } { $examples - { $example "USING: generalizations kernel prettyprint ;" "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep .s" "99\n1\n2\n3\n4\n5" } + { $example "USING: generalizations kernel prettyprint ;" "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep .s clear" "99\n1\n2\n3\n4\n5" } "Some core words expressed in terms of " { $link nkeep } ":" { $table { { $link keep } { $snippet "1 nkeep" } } diff --git a/basis/help/help.factor b/basis/help/help.factor index 272bdc1db3..f980032a8b 100644 --- a/basis/help/help.factor +++ b/basis/help/help.factor @@ -118,7 +118,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ; SYMBOL: help-hook -help-hook global [ [ print-topic ] or ] change-at +help-hook [ [ print-topic ] ] initialize : help ( topic -- ) help-hook get call ; diff --git a/basis/help/topics/topics.factor b/basis/help/topics/topics.factor index e6b19d5baa..8c687eb1d5 100644 --- a/basis/help/topics/topics.factor +++ b/basis/help/topics/topics.factor @@ -27,11 +27,11 @@ M: link summary ! Help articles SYMBOL: articles -articles global [ H{ } assoc-like ] change-at +articles [ H{ } clone ] initialize SYMBOL: article-xref -article-xref global [ H{ } assoc-like ] change-at +article-xref [ H{ } clone ] initialize GENERIC: article-name ( topic -- string ) GENERIC: article-title ( topic -- string ) diff --git a/basis/html/components/components-docs.factor b/basis/html/components/components-docs.factor index b432cc0cc6..37dbeba6c1 100644 --- a/basis/html/components/components-docs.factor +++ b/basis/html/components/components-docs.factor @@ -57,7 +57,10 @@ HELP: hidden { $description "Hidden components render as a hidden form field. For example, a page for editing a weblog post might contain a hidden field with the post ID." } ; HELP: html -{ $description "HTML components render HTML verbatim, without any escaping. Care must be taken to only render trusted input, to avoid cross-site scripting attacks." } ; +{ $description "HTML components render HTML verbatim from a string, without any escaping. Care must be taken to only render trusted input, to avoid cross-site scripting attacks." } ; + +HELP: xml +{ $description "XML components render XML verbatim, from an XML chunk. Care must be taken to only render trusted input, to avoid cross-site scripting attacks." } ; HELP: inspector { $description "Inspector components render an arbitrary object by passing it to the " { $link describe } " word." } ; @@ -90,6 +93,7 @@ $nl { $subsection inspector } { $subsection comparison } { $subsection html } +{ $subsection xml } "Tuple components:" { $subsection field } { $subsection password } diff --git a/basis/html/components/components.factor b/basis/html/components/components.factor index 2b18e28351..9dddb85619 100644 --- a/basis/html/components/components.factor +++ b/basis/html/components/components.factor @@ -171,3 +171,8 @@ M: comparison render* SINGLETON: html M: html render* 2drop ; + +! XML component +SINGLETON: xml + +M: xml render* 2drop ; diff --git a/basis/html/html-docs.factor b/basis/html/html-docs.factor new file mode 100644 index 0000000000..83fe4d3a63 --- /dev/null +++ b/basis/html/html-docs.factor @@ -0,0 +1,7 @@ +USING: help.markup help.syntax strings xml.data ; +IN: html + +HELP: simple-page +{ $values { "title" string } { "head" "XML data" } { "body" "XML data" } +{ "xml" xml } } +{ $description "Constructs a simple XHTML page with a " { $snippet "head" } " and " { $snippet "body" } " tag. The given XML data is spliced into the two child tags, and a title is also added to the head tag." } ; diff --git a/basis/html/html.factor b/basis/html/html.factor index e86b4917d7..e446c66d8c 100644 --- a/basis/html/html.factor +++ b/basis/html/html.factor @@ -15,7 +15,7 @@ IN: html <-> - XML> ; inline + XML> ; : render-error ( message -- xml ) [XML <-> XML] ; diff --git a/basis/html/templates/chloe/chloe-docs.factor b/basis/html/templates/chloe/chloe-docs.factor index 18e6db66f6..fcfd454478 100644 --- a/basis/html/templates/chloe/chloe-docs.factor +++ b/basis/html/templates/chloe/chloe-docs.factor @@ -1,8 +1,8 @@ IN: html.templates.chloe -USING: help.markup help.syntax html.components html.forms +USING: xml.data help.markup help.syntax html.components html.forms html.templates html.templates.chloe.syntax html.templates.chloe.compiler html.templates.chloe.components -math xml.data strings quotations namespaces ; +math strings quotations namespaces ; HELP: { $values { "path" "a pathname string without the trailing " { $snippet ".xml" } " extension" } { "chloe" chloe } } @@ -70,6 +70,7 @@ ARTICLE: "html.templates.chloe.tags.component" "Component Chloe tags" { { $snippet "t:field" } { $link field } } { { $snippet "t:hidden" } { $link hidden } } { { $snippet "t:html" } { $link html } } + { { $snippet "t:xml" } { $link xml } } { { $snippet "t:inspector" } { $link inspector } } { { $snippet "t:label" } { $link label } } { { $snippet "t:link" } { $link link } } diff --git a/basis/html/templates/chloe/chloe.factor b/basis/html/templates/chloe/chloe.factor index eafa3c3a5d..439b207063 100644 --- a/basis/html/templates/chloe/chloe.factor +++ b/basis/html/templates/chloe/chloe.factor @@ -95,6 +95,7 @@ COMPONENT: password COMPONENT: choice COMPONENT: checkbox COMPONENT: code +COMPONENT: xml SYMBOL: template-cache diff --git a/basis/html/templates/chloe/syntax/syntax.factor b/basis/html/templates/chloe/syntax/syntax.factor index f149c3fe47..faf8bed66b 100644 --- a/basis/html/templates/chloe/syntax/syntax.factor +++ b/basis/html/templates/chloe/syntax/syntax.factor @@ -11,7 +11,7 @@ html.templates ; SYMBOL: tags -tags global [ H{ } clone or ] change-at +tags [ H{ } clone ] initialize : define-chloe-tag ( name quot -- ) swap tags get set-at ; diff --git a/basis/http/client/client-docs.factor b/basis/http/client/client-docs.factor index 9a8aa48738..0d7f7851e2 100644 --- a/basis/http/client/client-docs.factor +++ b/basis/http/client/client-docs.factor @@ -56,8 +56,7 @@ HELP: http-request HELP: with-http-request { $values { "request" request } { "quot" { $quotation "( chunk -- )" } } { "response" response } } -{ $description "Sends an HTTP request to an HTTP server, and reads the response incrementally. Chunks of data are passed to the quotation as they are read." } -{ $errors "Throws an error if the HTTP request fails." } ; +{ $description "Sends an HTTP request to an HTTP server, and reads the response incrementally. Chunks of data are passed to the quotation as they are read. Does not throw an error if the HTTP request fails; to do so, call " { $link check-response } " on the " { $snippet "response" } "." } ; ARTICLE: "http.client.get" "GET requests with the HTTP client" "Basic usage involves passing a " { $link url } " and getting a " { $link response } " and data back:" diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor index cc1c67c31e..4099e3d84c 100644 --- a/basis/http/client/client.factor +++ b/basis/http/client/client.factor @@ -141,12 +141,15 @@ ERROR: download-failed response ; : check-response ( response -- response ) dup code>> success? [ download-failed ] unless ; +: check-response-with-body ( response body -- response body ) + [ >>body check-response ] keep ; + : with-http-request ( request quot -- response ) - [ (with-http-request) check-response ] with-destructors ; inline + [ (with-http-request) ] with-destructors ; inline : http-request ( request -- response data ) [ [ % ] with-http-request ] B{ } make - over content-charset>> decode ; + over content-charset>> decode check-response-with-body ; : ( url -- request ) "GET" ; diff --git a/basis/http/http-docs.factor b/basis/http/http-docs.factor index fc3f65fa56..210066176f 100644 --- a/basis/http/http-docs.factor +++ b/basis/http/http-docs.factor @@ -113,6 +113,12 @@ HELP: set-header { $notes "This word always returns the same object that was input. This allows for a “pipeline” coding style, where several header parameters are set in a row." } { $side-effects "request/response" } ; +HELP: set-basic-auth +{ $values { "request" request } { "username" string } { "password" string } } +{ $description "Sets the " { $snippet "Authorization" } " header of " { $snippet "request" } " to perform HTTP Basic authentication with the given " { $snippet "username" } " and " { $snippet "password" } "." } +{ $notes "This word always returns the same object that was input. This allows for a “pipeline” coding style, where several header parameters are set in a row." } +{ $side-effects "request" } ; + ARTICLE: "http.cookies" "HTTP cookies" "Every " { $link request } " and " { $link response } " instance can contain cookies." $nl diff --git a/basis/http/http-tests.factor b/basis/http/http-tests.factor index 49acdb639c..4f685945aa 100644 --- a/basis/http/http-tests.factor +++ b/basis/http/http-tests.factor @@ -359,3 +359,8 @@ SYMBOL: a ! Test cloning [ f ] [ <404> dup clone "b" "a" set-header drop "a" header ] unit-test [ f ] [ <404> dup clone "b" "a" put-cookie drop "a" get-cookie ] unit-test + +! Test basic auth +[ "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==" ] [ "Aladdin" "open sesame" set-basic-auth "Authorization" header ] unit-test + + diff --git a/basis/http/http.factor b/basis/http/http.factor index 2b5414b299..d4acd282f8 100755 --- a/basis/http/http.factor +++ b/basis/http/http.factor @@ -7,7 +7,8 @@ calendar.format present urls fry io io.encodings io.encodings.iana io.encodings.binary io.encodings.8-bit io.crlf unicode.case unicode.categories -http.parsers ; +http.parsers +base64 ; IN: http : (read-header) ( -- alist ) @@ -142,6 +143,9 @@ cookies ; : set-header ( request/response value key -- request/response ) pick header>> set-at ; +: set-basic-auth ( request username password -- request ) + ":" glue >base64 "Basic " prepend "Authorization" set-header ; + : ( -- request ) request new "1.1" >>version @@ -156,6 +160,7 @@ cookies ; : header ( request/response key -- value ) swap header>> at ; + TUPLE: response version code diff --git a/basis/http/server/server.factor b/basis/http/server/server.factor index b6ee70057b..f2f3deead2 100755 --- a/basis/http/server/server.factor +++ b/basis/http/server/server.factor @@ -161,7 +161,7 @@ C: trivial-responder M: trivial-responder call-responder* nip response>> clone ; -main-responder global [ <404> or ] change-at +main-responder [ <404> ] initialize : invert-slice ( slice -- slice' ) dup slice? [ [ seq>> ] [ from>> ] bi head-slice ] [ drop { } ] if ; diff --git a/basis/http/server/static/static-docs.factor b/basis/http/server/static/static-docs.factor index fbe20b5fcd..bbad56a6f1 100644 --- a/basis/http/server/static/static-docs.factor +++ b/basis/http/server/static/static-docs.factor @@ -38,7 +38,7 @@ $nl "If all you want to do is serve files from a directory, the following phrase does the trick:" { $code "USING: namespaces http.server http.server.static ;" - "/var/www/mysite.com/ main-responder set" + "\"/var/www/mysite.com/\" main-responder set" "8080 httpd" } { $subsection "http.server.static.extend" } ; diff --git a/basis/http/server/static/static.factor b/basis/http/server/static/static.factor index 53d3d4f917..5d5ad7d2b8 100644 --- a/basis/http/server/static/static.factor +++ b/basis/http/server/static/static.factor @@ -45,9 +45,8 @@ TUPLE: file-responder root hook special allow-listings ; [ file-responder get hook>> call ] [ 2drop <304> ] if ; : serving-path ( filename -- filename ) - file-responder get root>> trim-tail-separators - "/" - rot "" or trim-head-separators 3append ; + [ file-responder get root>> trim-tail-separators "/" ] dip + "" or trim-head-separators 3append ; : serve-file ( filename -- response ) dup mime-type diff --git a/basis/images/authors.txt b/basis/images/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/images/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/graphics/authors.txt b/basis/images/bitmap/authors.txt old mode 100644 new mode 100755 similarity index 100% rename from extra/graphics/authors.txt rename to basis/images/bitmap/authors.txt diff --git a/basis/images/bitmap/bitmap-tests.factor b/basis/images/bitmap/bitmap-tests.factor new file mode 100644 index 0000000000..102c13c295 --- /dev/null +++ b/basis/images/bitmap/bitmap-tests.factor @@ -0,0 +1,24 @@ +USING: images.bitmap images.viewer io.encodings.binary +io.files io.files.unique kernel tools.test ; +IN: images.bitmap.tests + +: test-bitmap24 ( -- path ) + "resource:basis/images/test-images/thiswayup24.bmp" ; + +: test-bitmap8 ( -- path ) + "resource:basis/images/test-images/rgb8bit.bmp" ; + +: test-bitmap4 ( -- path ) + "resource:basis/images/test-images/rgb4bit.bmp" ; + +: test-bitmap1 ( -- path ) + "resource:basis/images/test-images/1bit.bmp" ; + +[ t ] +[ + test-bitmap24 + [ binary file-contents ] [ load-bitmap ] bi + + "test-bitmap24" unique-file + [ save-bitmap ] [ binary file-contents ] bi = +] unit-test diff --git a/extra/graphics/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor similarity index 71% rename from extra/graphics/bitmap/bitmap.factor rename to basis/images/bitmap/bitmap.factor index f8008dc7c1..9005776e40 100755 --- a/extra/graphics/bitmap/bitmap.factor +++ b/basis/images/bitmap/bitmap.factor @@ -1,11 +1,12 @@ ! Copyright (C) 2007, 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien alien.c-types arrays byte-arrays columns -combinators fry grouping io io.binary io.encodings.binary -io.files kernel libc macros math math.bitwise math.functions -namespaces opengl opengl.gl prettyprint sequences strings -summary ui ui.gadgets.panes ; -IN: graphics.bitmap +combinators fry grouping io io.binary io.encodings.binary io.files +kernel macros math math.bitwise math.functions namespaces sequences +strings images endian summary ; +IN: images.bitmap + +TUPLE: bitmap-image < image ; ! Currently can only handle 24/32bit bitmaps. ! Handles row-reversed bitmaps (their height is negative) @@ -13,41 +14,24 @@ IN: graphics.bitmap TUPLE: bitmap magic size reserved offset header-length width height planes bit-count compression size-image x-pels y-pels color-used color-important rgb-quads color-index -alpha-channel-zero? -array ; +buffer ; : array-copy ( bitmap array -- bitmap array' ) over size-image>> abs memory>byte-array ; -MACRO: (nbits>bitmap) ( bits -- ) - [ -3 shift ] keep '[ - bitmap new - 2over * _ * >>size-image - swap >>height - swap >>width - swap array-copy [ >>array ] [ >>color-index ] bi - _ >>bit-count - ] ; - -: bgr>bitmap ( array height width -- bitmap ) - 24 (nbits>bitmap) ; - -: bgra>bitmap ( array height width -- bitmap ) - 32 (nbits>bitmap) ; - -: 8bit>array ( bitmap -- array ) +: 8bit>buffer ( bitmap -- array ) [ rgb-quads>> 4 [ 3 head-slice ] map ] [ color-index>> >array ] bi [ swap nth ] with map concat ; ERROR: bmp-not-supported n ; -: raw-bitmap>array ( bitmap -- array ) +: raw-bitmap>buffer ( bitmap -- array ) dup bit-count>> { { 32 [ color-index>> ] } { 24 [ color-index>> ] } { 16 [ bmp-not-supported ] } - { 8 [ 8bit>array ] } + { 8 [ 8bit>buffer ] } { 4 [ bmp-not-supported ] } { 2 [ bmp-not-supported ] } { 1 [ bmp-not-supported ] } @@ -95,19 +79,58 @@ M: bitmap-magic summary dup rgb-quads-length read >>rgb-quads dup color-index-length read >>color-index ; -: (load-bitmap) ( path -- bitmap ) +: load-bitmap-data ( path -- bitmap ) binary [ bitmap new parse-file-header parse-bitmap-header parse-bitmap ] with-file-reader ; -: alpha-channel-zero? ( bitmap -- ? ) - array>> 4 3 [ 0 = ] all? ; +: process-bitmap-data ( bitmap -- bitmap ) + dup raw-bitmap>buffer >>buffer ; : load-bitmap ( path -- bitmap ) - (load-bitmap) - dup raw-bitmap>array >>array - dup alpha-channel-zero? >>alpha-channel-zero? ; + load-bitmap-data process-bitmap-data ; + +ERROR: unknown-component-order bitmap ; + +: bitmap>component-order ( bitmap -- object ) + bit-count>> { + { 32 [ BGRA ] } + { 24 [ BGR ] } + { 8 [ BGR ] } + [ unknown-component-order ] + } case ; + +: >image ( bitmap -- bitmap-image ) + { + [ [ width>> ] [ height>> ] bi 2array ] + [ bitmap>component-order ] + [ buffer>> ] + } cleave bitmap-image boa ; + +M: bitmap-image load-image* ( path bitmap -- bitmap-image ) + drop load-bitmap >image ; + +M: bitmap-image normalize-scan-line-order + dup dim>> '[ + _ first 4 * reverse concat + ] change-bitmap ; + +MACRO: (nbits>bitmap) ( bits -- ) + [ -3 shift ] keep '[ + bitmap new + 2over * _ * >>size-image + swap >>height + swap >>width + swap array-copy [ >>buffer ] [ >>color-index ] bi + _ >>bit-count >image + ] ; + +: bgr>bitmap ( array height width -- bitmap ) + 24 (nbits>bitmap) ; + +: bgra>bitmap ( array height width -- bitmap ) + 32 (nbits>bitmap) ; : write2 ( n -- ) 2 >le write ; : write4 ( n -- ) 4 >le write ; @@ -116,7 +139,7 @@ M: bitmap-magic summary binary [ B{ CHAR: B CHAR: M } write [ - array>> length 14 + 40 + write4 + buffer>> length 14 + 40 + write4 0 write4 54 write4 40 write4 diff --git a/basis/images/images.factor b/basis/images/images.factor new file mode 100644 index 0000000000..c2dc33608e --- /dev/null +++ b/basis/images/images.factor @@ -0,0 +1,66 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors grouping sequences combinators +math specialized-arrays.direct.uint byte-arrays +specialized-arrays.direct.ushort specialized-arrays.uint +specialized-arrays.ushort specialized-arrays.float ; +IN: images + +SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR +R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ; + +TUPLE: image dim component-order bitmap ; + +: ( -- image ) image new ; inline + +GENERIC: load-image* ( path tuple -- image ) + +: add-dummy-alpha ( seq -- seq' ) + 3 + [ 255 suffix ] map concat ; + +: normalize-floats ( byte-array -- byte-array ) + byte-array>float-array [ 255.0 * >integer ] B{ } map-as ; + +: normalize-component-order ( image -- image ) + dup component-order>> + { + { RGBA [ ] } + { R32G32B32A32 [ + [ normalize-floats ] change-bitmap + ] } + { R32G32B32 [ + [ normalize-floats add-dummy-alpha ] change-bitmap + ] } + { R16G16B16A16 [ + [ byte-array>ushort-array [ -8 shift ] B{ } map-as ] change-bitmap + ] } + { R16G16B16 [ + [ + byte-array>ushort-array [ -8 shift ] B{ } map-as add-dummy-alpha + ] change-bitmap + ] } + { BGRA [ + [ + 4 dup [ 3 head-slice reverse-here ] each + ] change-bitmap + ] } + { RGB [ [ add-dummy-alpha ] change-bitmap ] } + { BGR [ + [ + 3 + [ [ 3 head-slice reverse-here ] each ] + [ add-dummy-alpha ] bi + ] change-bitmap + ] } + } case + RGBA >>component-order ; + +GENERIC: normalize-scan-line-order ( image -- image ) + +M: image normalize-scan-line-order ; + +: normalize-image ( image -- image ) + [ >byte-array ] change-bitmap + normalize-component-order + normalize-scan-line-order ; diff --git a/extra/graphics/bitmap/authors.txt b/basis/images/loader/authors.txt old mode 100755 new mode 100644 similarity index 100% rename from extra/graphics/bitmap/authors.txt rename to basis/images/loader/authors.txt diff --git a/basis/images/loader/loader.factor b/basis/images/loader/loader.factor new file mode 100644 index 0000000000..6f2ae47c61 --- /dev/null +++ b/basis/images/loader/loader.factor @@ -0,0 +1,19 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: constructors kernel splitting unicode.case combinators +accessors images.bitmap images.tiff images io.backend +io.pathnames ; +IN: images.loader + +ERROR: unknown-image-extension extension ; + +: image-class ( path -- class ) + file-extension >lower { + { "bmp" [ bitmap-image ] } + { "tif" [ tiff-image ] } + { "tiff" [ tiff-image ] } + [ unknown-image-extension ] + } case ; + +: load-image ( path -- image ) + dup image-class new load-image* normalize-image ; diff --git a/extra/graphics/tags.txt b/basis/images/tags.txt similarity index 100% rename from extra/graphics/tags.txt rename to basis/images/tags.txt diff --git a/extra/graphics/bitmap/test-images/1bit.bmp b/basis/images/test-images/1bit.bmp similarity index 100% rename from extra/graphics/bitmap/test-images/1bit.bmp rename to basis/images/test-images/1bit.bmp diff --git a/basis/images/test-images/octagon.tiff b/basis/images/test-images/octagon.tiff new file mode 100644 index 0000000000..2b4ba3950d Binary files /dev/null and b/basis/images/test-images/octagon.tiff differ diff --git a/extra/graphics/tiff/rgb.tiff b/basis/images/test-images/rgb.tiff similarity index 100% rename from extra/graphics/tiff/rgb.tiff rename to basis/images/test-images/rgb.tiff diff --git a/extra/graphics/bitmap/test-images/rgb4bit.bmp b/basis/images/test-images/rgb4bit.bmp similarity index 100% rename from extra/graphics/bitmap/test-images/rgb4bit.bmp rename to basis/images/test-images/rgb4bit.bmp diff --git a/extra/graphics/bitmap/test-images/rgb8bit.bmp b/basis/images/test-images/rgb8bit.bmp similarity index 100% rename from extra/graphics/bitmap/test-images/rgb8bit.bmp rename to basis/images/test-images/rgb8bit.bmp diff --git a/extra/graphics/bitmap/test-images/thiswayup24.bmp b/basis/images/test-images/thiswayup24.bmp similarity index 100% rename from extra/graphics/bitmap/test-images/thiswayup24.bmp rename to basis/images/test-images/thiswayup24.bmp diff --git a/extra/graphics/tiff/authors.txt b/basis/images/tiff/authors.txt similarity index 100% rename from extra/graphics/tiff/authors.txt rename to basis/images/tiff/authors.txt diff --git a/basis/images/tiff/tiff-tests.factor b/basis/images/tiff/tiff-tests.factor new file mode 100755 index 0000000000..9905e7ad79 --- /dev/null +++ b/basis/images/tiff/tiff-tests.factor @@ -0,0 +1,10 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test images.tiff ; +IN: images.tiff.tests + +: tiff-test-path ( -- path ) + "resource:extra/images/test-images/rgb.tiff" ; + +: tiff-test-path2 ( -- path ) + "resource:extra/images/test-images/octagon.tiff" ; diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor new file mode 100755 index 0000000000..c91edbae39 --- /dev/null +++ b/basis/images/tiff/tiff.factor @@ -0,0 +1,374 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs byte-arrays classes combinators +compression.lzw constructors endian fry grouping images io +io.binary io.encodings.ascii io.encodings.binary +io.encodings.string io.encodings.utf8 io.files kernel math +math.bitwise math.order math.parser pack prettyprint sequences +strings math.vectors ; +IN: images.tiff + +TUPLE: tiff-image < image ; + +TUPLE: parsed-tiff endianness the-answer ifd-offset ifds ; +CONSTRUCTOR: parsed-tiff ( -- tiff ) V{ } clone >>ifds ; + +TUPLE: ifd count ifd-entries next +processed-tags strips bitmap ; +CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ; + +TUPLE: ifd-entry tag type count offset/value ; +CONSTRUCTOR: ifd-entry ( tag type count offset/value -- ifd-entry ) ; + +SINGLETONS: photometric-interpretation +photometric-interpretation-white-is-zero +photometric-interpretation-black-is-zero +photometric-interpretation-rgb +photometric-interpretation-palette-color ; +ERROR: bad-photometric-interpretation n ; +: lookup-photometric-interpretation ( n -- singleton ) + { + { 0 [ photometric-interpretation-white-is-zero ] } + { 1 [ photometric-interpretation-black-is-zero ] } + { 2 [ photometric-interpretation-rgb ] } + { 3 [ photometric-interpretation-palette-color ] } + [ bad-photometric-interpretation ] + } case ; + +SINGLETONS: compression +compression-none +compression-CCITT-2 +compression-lzw +compression-pack-bits ; +ERROR: bad-compression n ; +: lookup-compression ( n -- compression ) + { + { 1 [ compression-none ] } + { 2 [ compression-CCITT-2 ] } + { 5 [ compression-lzw ] } + { 32773 [ compression-pack-bits ] } + [ bad-compression ] + } case ; + +SINGLETONS: resolution-unit +resolution-unit-none +resolution-unit-inch +resolution-unit-centimeter ; +ERROR: bad-resolution-unit n ; +: lookup-resolution-unit ( n -- object ) + { + { 1 [ resolution-unit-none ] } + { 2 [ resolution-unit-inch ] } + { 3 [ resolution-unit-centimeter ] } + [ bad-resolution-unit ] + } case ; + +SINGLETONS: predictor +predictor-none +predictor-horizontal-differencing ; +ERROR: bad-predictor n ; +: lookup-predictor ( n -- object ) + { + { 1 [ predictor-none ] } + { 2 [ predictor-horizontal-differencing ] } + [ bad-predictor ] + } case ; + +SINGLETONS: planar-configuration +planar-configuration-chunky +planar-configuration-planar ; +ERROR: bad-planar-configuration n ; +: lookup-planar-configuration ( n -- object ) + { + { 1 [ planar-configuration-chunky ] } + { 2 [ planar-configuration-planar ] } + [ bad-planar-configuration ] + } case ; + +SINGLETONS: sample-format +sample-format-unsigned-integer +sample-format-signed-integer +sample-format-ieee-float +sample-format-undefined-data ; +ERROR: bad-sample-format n ; +: lookup-sample-format ( sequence -- object ) + [ + { + { 1 [ sample-format-unsigned-integer ] } + { 2 [ sample-format-signed-integer ] } + { 3 [ sample-format-ieee-float ] } + { 4 [ sample-format-undefined-data ] } + [ bad-sample-format ] + } case + ] map ; + +SINGLETONS: extra-samples +extra-samples-unspecified-alpha-data +extra-samples-associated-alpha-data +extra-samples-unassociated-alpha-data ; +ERROR: bad-extra-samples n ; +: lookup-extra-samples ( sequence -- object ) + { + { 0 [ extra-samples-unspecified-alpha-data ] } + { 1 [ extra-samples-associated-alpha-data ] } + { 2 [ extra-samples-unassociated-alpha-data ] } + [ bad-extra-samples ] + } case ; + +SINGLETONS: image-length image-width x-resolution y-resolution +rows-per-strip strip-offsets strip-byte-counts bits-per-sample +samples-per-pixel new-subfile-type orientation software +date-time photoshop exif-ifd sub-ifd inter-color-profile +xmp iptc fill-order document-name page-number page-name +x-position y-position +unhandled-ifd-entry ; + +ERROR: bad-tiff-magic bytes ; +: tiff-endianness ( byte-array -- ? ) + { + { B{ CHAR: M CHAR: M } [ big-endian ] } + { B{ CHAR: I CHAR: I } [ little-endian ] } + [ bad-tiff-magic ] + } case ; + +: read-header ( tiff -- tiff ) + 2 read tiff-endianness [ >>endianness ] keep + [ + 2 read endian> >>the-answer + 4 read endian> >>ifd-offset + ] with-endianness ; + +: push-ifd ( tiff ifd -- tiff ) over ifds>> push ; + +: read-ifd ( -- ifd ) + 2 read endian> + 2 read endian> + 4 read endian> + 4 read endian> ; + +: read-ifds ( tiff -- tiff ) + dup ifd-offset>> seek-absolute seek-input + 2 read endian> + dup [ read-ifd ] replicate + 4 read endian> + [ push-ifd ] [ 0 = [ read-ifds ] unless ] bi ; + +ERROR: no-tag class ; + +: ?at ( key assoc -- value/key ? ) + dupd at* [ nip t ] [ drop f ] if ; inline + +: find-tag ( idf class -- tag ) + swap processed-tags>> ?at [ no-tag ] unless ; + +: tag? ( idf class -- tag ) + swap processed-tags>> key? ; + +: read-strips ( ifd -- ifd ) + dup + [ strip-byte-counts find-tag ] + [ strip-offsets find-tag ] bi + 2dup [ integer? ] both? [ + seek-absolute seek-input read 1array + ] [ + [ seek-absolute seek-input read ] { } 2map-as + ] if >>strips ; + +ERROR: unknown-ifd-type n ; + +: bytes>bits ( n/byte-array -- n ) + dup byte-array? [ byte-array>bignum ] when ; + +: value-length ( ifd-entry -- n ) + [ count>> ] [ type>> ] bi { + { 1 [ ] } + { 2 [ ] } + { 3 [ 2 * ] } + { 4 [ 4 * ] } + { 5 [ 8 * ] } + { 6 [ ] } + { 7 [ ] } + { 8 [ 2 * ] } + { 9 [ 4 * ] } + { 10 [ 8 * ] } + { 11 [ 4 * ] } + { 12 [ 8 * ] } + { 13 [ 4 * ] } + [ unknown-ifd-type ] + } case ; + +ERROR: bad-small-ifd-type n ; + +: adjust-offset/value ( ifd-entry -- obj ) + [ offset/value>> 4 >endian ] [ type>> ] bi + { + { 1 [ 1 head endian> ] } + { 3 [ 2 head endian> ] } + { 4 [ endian> ] } + { 6 [ 1 head endian> 8 >signed ] } + { 8 [ 2 head endian> 16 >signed ] } + { 9 [ endian> 32 >signed ] } + { 11 [ endian> bits>float ] } + { 13 [ endian> 32 >signed ] } + [ bad-small-ifd-type ] + } case ; + +: offset-bytes>obj ( bytes type -- obj ) + { + { 1 [ ] } ! blank + { 2 [ ] } ! read c strings here + { 3 [ 2 [ endian> ] map ] } + { 4 [ 4 [ endian> ] map ] } + { 5 [ 8 [ "II" unpack first2 / ] map ] } + { 6 [ [ 8 >signed ] map ] } + { 7 [ ] } ! blank + { 8 [ 2 [ endian> 16 >signed ] map ] } + { 9 [ 4 [ endian> 32 >signed ] map ] } + { 10 [ 8 group [ "ii" unpack first2 / ] map ] } + { 11 [ 4 group [ "f" unpack ] map ] } + { 12 [ 8 group [ "d" unpack ] map ] } + [ unknown-ifd-type ] + } case ; + +: ifd-entry-value ( ifd-entry -- n ) + dup value-length 4 <= [ + adjust-offset/value + ] [ + [ offset/value>> seek-absolute seek-input ] + [ value-length read ] + [ type>> ] tri offset-bytes>obj + ] if ; + +: process-ifd-entry ( ifd-entry -- value class ) + [ ifd-entry-value ] [ tag>> ] bi { + { 254 [ new-subfile-type ] } + { 256 [ image-width ] } + { 257 [ image-length ] } + { 258 [ bits-per-sample ] } + { 259 [ lookup-compression compression ] } + { 262 [ lookup-photometric-interpretation photometric-interpretation ] } + { 266 [ fill-order ] } + { 269 [ ascii decode document-name ] } + { 273 [ strip-offsets ] } + { 274 [ orientation ] } + { 277 [ samples-per-pixel ] } + { 278 [ rows-per-strip ] } + { 279 [ strip-byte-counts ] } + { 282 [ first x-resolution ] } + { 283 [ first y-resolution ] } + { 284 [ planar-configuration ] } + { 285 [ page-name ] } + { 286 [ x-position ] } + { 287 [ y-position ] } + { 296 [ lookup-resolution-unit resolution-unit ] } + { 297 [ page-number ] } + { 305 [ ascii decode software ] } + { 306 [ ascii decode date-time ] } + { 317 [ lookup-predictor predictor ] } + { 330 [ sub-ifd ] } + { 338 [ lookup-extra-samples extra-samples ] } + { 339 [ lookup-sample-format sample-format ] } + { 700 [ utf8 decode xmp ] } + { 34377 [ photoshop ] } + { 34665 [ exif-ifd ] } + { 33723 [ iptc ] } + { 34675 [ inter-color-profile ] } + [ nip unhandled-ifd-entry swap ] + } case ; + +: process-ifd ( ifd -- ifd ) + dup ifd-entries>> + [ process-ifd-entry swap ] H{ } map>assoc >>processed-tags ; + +ERROR: unhandled-compression compression ; + +: (uncompress-strips) ( strips compression -- uncompressed-strips ) + { + { compression-none [ ] } + { compression-lzw [ [ lzw-uncompress ] map ] } + [ unhandled-compression ] + } case ; + +: uncompress-strips ( ifd -- ifd ) + dup '[ + _ compression find-tag (uncompress-strips) + ] change-strips ; + +: strips>bitmap ( ifd -- ifd ) + dup strips>> concat >>bitmap ; + +: (strips-predictor) ( ifd -- ifd ) + [ ] + [ image-width find-tag ] + [ samples-per-pixel find-tag ] tri + [ * ] keep + '[ + _ group [ _ group [ rest ] [ first ] bi + [ v+ ] accumulate swap suffix concat ] map + concat >byte-array + ] change-bitmap ; + +: strips-predictor ( ifd -- ifd ) + dup predictor tag? [ + dup predictor find-tag + { + { predictor-none [ ] } + { predictor-horizontal-differencing [ (strips-predictor) ] } + [ bad-predictor ] + } case + ] when ; + +ERROR: unknown-component-order ifd ; + +: fix-bitmap-endianness ( ifd -- ifd ) + dup [ bitmap>> ] [ bits-per-sample find-tag ] bi + { + { { 32 32 32 32 } [ 4 seq>native-endianness ] } + { { 32 32 32 } [ 4 seq>native-endianness ] } + { { 16 16 16 16 } [ 2 seq>native-endianness ] } + { { 16 16 16 } [ 2 seq>native-endianness ] } + { { 8 8 8 8 } [ ] } + { { 8 8 8 } [ ] } + [ unknown-component-order ] + } case >>bitmap ; + +: ifd-component-order ( ifd -- byte-order ) + bits-per-sample find-tag { + { { 32 32 32 32 } [ R32G32B32A32 ] } + { { 32 32 32 } [ R32G32B32 ] } + { { 16 16 16 16 } [ R16G16B16A16 ] } + { { 16 16 16 } [ R16G16B16 ] } + { { 8 8 8 8 } [ RGBA ] } + { { 8 8 8 } [ RGB ] } + [ unknown-component-order ] + } case ; + +: ifd>image ( ifd -- image ) + { + [ [ image-width find-tag ] [ image-length find-tag ] bi 2array ] + [ ifd-component-order ] + [ bitmap>> ] + } cleave tiff-image boa ; + +: tiff>image ( image -- image ) + ifds>> [ ifd>image ] map first ; + +: load-tiff ( path -- parsed-tiff ) + binary [ + + read-header dup endianness>> [ + read-ifds + dup ifds>> [ + process-ifd read-strips + uncompress-strips + strips>bitmap + fix-bitmap-endianness + strips-predictor + drop + ] each + ] with-endianness + ] with-file-reader ; + +! tiff files can store several images -- we just take the first for now +M: tiff-image load-image* ( path tiff-image -- image ) + drop load-tiff tiff>image ; diff --git a/basis/io/encodings/iana/iana.factor b/basis/io/encodings/iana/iana.factor index a56bd1194b..6afae92429 100644 --- a/basis/io/encodings/iana/iana.factor +++ b/basis/io/encodings/iana/iana.factor @@ -47,8 +47,8 @@ PRIVATE> "resource:basis/io/encodings/iana/character-sets" utf8 make-aliases aliases set-global -n>e-table global [ initial-n>e or ] change-at -e>n-table global [ initial-e>n or ] change-at +n>e-table [ initial-n>e ] initialize +e>n-table [ initial-e>n ] initialize : register-encoding ( descriptor name -- ) [ diff --git a/basis/io/launcher/windows/nt/nt-tests.factor b/basis/io/launcher/windows/nt/nt-tests.factor old mode 100644 new mode 100755 index 4dd0eebed3..04202365fd --- a/basis/io/launcher/windows/nt/nt-tests.factor +++ b/basis/io/launcher/windows/nt/nt-tests.factor @@ -37,11 +37,12 @@ IN: io.launcher.windows.nt.tests "out.txt" temp-file ascii file-lines first ] unit-test -[ ] [ +[ "( scratchpad ) " ] [ console-vm "-run=listener" 2array >>command +closed+ >>stdin - try-process + +stdout+ >>stderr + ascii [ input-stream get contents ] with-process-reader ] unit-test : launcher-test-path ( -- str ) @@ -162,3 +163,5 @@ IN: io.launcher.windows.nt.tests "append-test" temp-file ascii file-contents ] unit-test + + diff --git a/basis/lists/lazy/lazy-docs.factor b/basis/lists/lazy/lazy-docs.factor index c402cdf15b..08fe3bbcba 100644 --- a/basis/lists/lazy/lazy-docs.factor +++ b/basis/lists/lazy/lazy-docs.factor @@ -1,11 +1,54 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. - USING: help.markup help.syntax sequences strings lists ; IN: lists.lazy +ABOUT: "lists.lazy" + +ARTICLE: "lists.lazy" "Lazy lists" +"The " { $vocab-link "lists.lazy" } " vocabulary implements lazy lists and standard operations to manipulate them." +{ $subsection { "lists.lazy" "construction" } } +{ $subsection { "lists.lazy" "manipulation" } } +{ $subsection { "lists.lazy" "combinators" } } +{ $subsection { "lists.lazy" "io" } } ; + +ARTICLE: { "lists.lazy" "combinators" } "Combinators for manipulating lazy lists" +"The following combinators create lazy lists from other lazy lists:" +{ $subsection lmap } +{ $subsection lfilter } +{ $subsection luntil } +{ $subsection lwhile } +{ $subsection lfrom-by } +{ $subsection lcomp } +{ $subsection lcomp* } ; + +ARTICLE: { "lists.lazy" "io" } "Lazy list I/O" +"Input from a stream can be read through a lazy list, using the following words:" +{ $subsection lcontents } +{ $subsection llines } ; + +ARTICLE: { "lists.lazy" "construction" } "Constructing lazy lists" +"Words for constructing lazy lists:" +{ $subsection lazy-cons } +{ $subsection 1lazy-list } +{ $subsection 2lazy-list } +{ $subsection 3lazy-list } +{ $subsection seq>list } +{ $subsection >list } +{ $subsection lfrom } ; + +ARTICLE: { "lists.lazy" "manipulation" } "Manipulating lazy lists" +"To make new lazy lists from old ones:" +{ $subsection } +{ $subsection lappend } +{ $subsection lconcat } +{ $subsection lcartesian-product } +{ $subsection lcartesian-product* } +{ $subsection lmerge } +{ $subsection ltake } ; + HELP: lazy-cons -{ $values { "car" { $quotation "( -- X )" } } { "cdr" { $quotation "( -- cons )" } } { "promise" "the resulting cons object" } } +{ $values { "car" { $quotation "( -- elt )" } } { "cdr" { $quotation "( -- cons )" } } { "promise" "the resulting cons object" } } { $description "Constructs a cons object for a lazy list from two quotations. The " { $snippet "car" } " quotation should return the head of the list, and the " { $snippet "cons" } " quotation the tail when called. When " { $link cons } " or " { $link cdr } " are called on the lazy-cons object then the appropriate quotation is called." } { $see-also cons car cdr nil nil? } ; @@ -28,16 +71,12 @@ HELP: { $description "Constructs a cons object that wraps an existing cons object. Requests for the car, cdr and nil? will be remembered after the first call, and the previous result returned on subsequent calls." } { $see-also cons car cdr nil nil? } ; -{ lazy-map lazy-map-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words +{ lazy-map ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words HELP: lazy-map { $values { "list" "a cons object" } { "quot" { $quotation "( obj -- X )" } } { "result" "resulting cons object" } } { $description "Perform a similar functionality to that of the " { $link map } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ; -HELP: lazy-map-with -{ $values { "value" "an object" } { "list" "a cons object" } { "quot" { $quotation "( obj elt -- X )" } } { "result" "resulting cons object" } } -{ $description "Variant of " { $link lazy-map } " which pushes a retained object on each invocation of the quotation." } ; - HELP: ltake { $values { "n" "a non negative integer" } { "list" "a cons object" } { "result" "resulting cons object" } } { $description "Outputs a lazy list containing the first n items in the list. This is done a lazy manner. No evaluation of the list elements occurs initially but a " { $link } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ; @@ -86,7 +125,7 @@ HELP: >list { $description "Convert the object into a list. Existing lists are passed through intact, sequences are converted using " { $link seq>list } " and other objects cause an error to be thrown." } { $see-also seq>list } ; -{ leach foldl lazy-map lazy-map-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words +{ leach foldl lazy-map ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words HELP: lconcat { $values { "list" "a list of lists" } { "result" "a list" } } diff --git a/basis/lists/lazy/lazy-tests.factor b/basis/lists/lazy/lazy-tests.factor index 03221841c1..f4e55cba19 100644 --- a/basis/lists/lazy/lazy-tests.factor +++ b/basis/lists/lazy/lazy-tests.factor @@ -24,7 +24,7 @@ IN: lists.lazy.tests ] unit-test [ { 4 5 6 } ] [ - 3 { 1 2 3 } >list [ + ] lazy-map-with list>array + 3 { 1 2 3 } >list [ + ] with lazy-map list>array ] unit-test [ [ ] lmap ] must-infer diff --git a/basis/lists/lazy/lazy.factor b/basis/lists/lazy/lazy.factor index 213285e643..d3b08a11fb 100644 --- a/basis/lists/lazy/lazy.factor +++ b/basis/lists/lazy/lazy.factor @@ -90,9 +90,6 @@ M: lazy-map cdr ( lazy-map -- cdr ) M: lazy-map nil? ( lazy-map -- bool ) cons>> nil? ; -: lazy-map-with ( value list quot -- result ) - with lazy-map ; - TUPLE: lazy-take n cons ; C: lazy-take @@ -125,7 +122,7 @@ M: lazy-until car ( lazy-until -- car ) cons>> car ; M: lazy-until cdr ( lazy-until -- cdr ) - [ cons>> uncons ] keep quot>> tuck call( elt -- ? ) + [ cons>> unswons ] keep quot>> tuck call( elt -- ? ) [ 2drop nil ] [ luntil ] if ; M: lazy-until nil? ( lazy-until -- bool ) @@ -284,7 +281,7 @@ DEFER: lconcat dup nil? [ drop nil ] [ - uncons swap (lconcat) + uncons (lconcat) ] if ; M: lazy-concat car ( lazy-concat -- car ) @@ -301,14 +298,14 @@ M: lazy-concat nil? ( lazy-concat -- bool ) ] if ; : lcartesian-product ( list1 list2 -- result ) - swap [ swap [ 2array ] lazy-map-with ] lazy-map-with lconcat ; + swap [ swap [ 2array ] with lazy-map ] with lazy-map lconcat ; : lcartesian-product* ( lists -- result ) dup nil? [ drop nil ] [ [ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [ - swap [ swap [ suffix ] lazy-map-with ] lazy-map-with lconcat + swap [ swap [ suffix ] with lazy-map ] with lazy-map lconcat ] reduce ] if ; diff --git a/basis/lists/lists-docs.factor b/basis/lists/lists-docs.factor index 8807c8cf8a..8494d7c352 100644 --- a/basis/lists/lists-docs.factor +++ b/basis/lists/lists-docs.factor @@ -1,15 +1,68 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel help.markup help.syntax ; - +USING: kernel help.markup help.syntax arrays sequences math quotations ; IN: lists -{ car cons cdr nil nil? list? uncons } related-words +ABOUT: "lists" + +ARTICLE: "lists" "Lists" +"The " { $vocab-link "lists" } " vocabulary implements linked lists. There are simple strict linked lists, but a generic list protocol allows the implementation of lazy lists as well." +{ $subsection { "lists" "protocol" } } +{ $subsection { "lists" "strict" } } +{ $subsection { "lists" "manipulation" } } +{ $subsection { "lists" "combinators" } } +{ $vocab-subsection "Lazy lists" "lists.lazy" } ; + +ARTICLE: { "lists" "protocol" } "The list protocol" +"Lists are instances of a mixin class" +{ $subsection list } +"Instances of the mixin must implement the following words:" +{ $subsection car } +{ $subsection cdr } +{ $subsection nil? } ; + +ARTICLE: { "lists" "strict" } "Strict lists" +"Strict lists are simply cons cells where the car and cdr have already been evaluated. These are the lists of Lisp. To construct a strict list, the following words are provided:" +{ $subsection cons } +{ $subsection swons } +{ $subsection sequence>cons } +{ $subsection deep-sequence>cons } +{ $subsection 1list } +{ $subsection 2list } +{ $subsection 3list } ; + +ARTICLE: { "lists" "combinators" } "Combinators for lists" +"Several combinators exist for list traversal." +{ $subsection leach } +{ $subsection lmap } +{ $subsection foldl } +{ $subsection foldr } +{ $subsection lmap>array } +{ $subsection lmap-as } +{ $subsection traverse } ; + +ARTICLE: { "lists" "manipulation" } "Manipulating lists" +"To get at the contents of a list:" +{ $subsection uncons } +{ $subsection unswons } +{ $subsection lnth } +{ $subsection cadr } +{ $subsection llength } +"To get a new list from an old one:" +{ $subsection lreverse } +{ $subsection lappend } +{ $subsection lcut } ; HELP: cons -{ $values { "car" "the head of the lazy list" } { "cdr" "the tail of the lazy list" } { "cons" "a cons object" } } +{ $values { "car" "the head of the list cell" } { "cdr" "the tail of the list cell" } { "cons" "a cons object" } } { $description "Constructs a cons cell." } ; +HELP: swons +{ $values { "cdr" "the tail of the list cell" } { "car" "the head of the list cell" } { "cons" "a cons object" } } +{ $description "Constructs a cons cell." } ; + +{ cons swons uncons unswons } related-words + HELP: car { $values { "cons" "a cons object" } { "car" "the first item in the list" } } { $description "Returns the first item in the list." } ; @@ -17,7 +70,9 @@ HELP: car HELP: cdr { $values { "cons" "a cons object" } { "cdr" "a cons object" } } { $description "Returns the tail of the list." } ; - + +{ car cdr } related-words + HELP: nil { $values { "symbol" "The empty cons (+nil+)" } } { $description "Returns a symbol representing the empty list" } ; @@ -26,6 +81,8 @@ HELP: nil? { $values { "object" object } { "?" "a boolean" } } { $description "Return true if the cons object is the nil cons." } ; +{ nil nil? } related-words + HELP: list? ( object -- ? ) { $values { "object" "an object" } { "?" "a boolean" } } { $description "Returns true if the object conforms to the list protocol." } ; @@ -43,7 +100,7 @@ HELP: 2list HELP: 3list { $values { "a" "an object" } { "b" "an object" } { "c" "an object" } { "cons" "a cons object" } } { $description "Create a list with 3 elements." } ; - + HELP: lnth { $values { "n" "an integer index" } { "list" "a cons object" } { "elt" "the element at the nth index" } } { $description "Outputs the nth element of the list." } @@ -55,7 +112,11 @@ HELP: llength { $see-also lnth cons car cdr } ; HELP: uncons -{ $values { "cons" "a cons object" } { "cdr" "the tail of the list" } { "car" "the head of the list" } } +{ $values { "cons" "a cons object" } { "car" "the head of the list" } { "cdr" "the tail of the list" } } +{ $description "Put the head and tail of the list on the stack." } ; + +HELP: unswons +{ $values { "cons" "a cons object" } { "car" "the head of the list" } { "cdr" "the tail of the list" } } { $description "Put the head and tail of the list on the stack." } ; { leach foldl lmap>array } related-words @@ -75,30 +136,52 @@ HELP: foldr HELP: lmap { $values { "list" "a cons object" } { "quot" { $quotation "( old -- new )" } } { "result" "the final result" } } { $description "Applies the quotation to each element of the list in order, collecting the new elements into a new list." } ; - + HELP: lreverse -{ $values { "list" "a cons object" } { "newlist" "a new cons object" } } -{ $description "Reverses the input list, outputing a new, reversed list" } ; - -HELP: list>seq -{ $values { "list" "a cons object" } { "array" "an array object" } } +{ $values { "list" list } { "newlist" list } } +{ $description "Reverses the input list, outputing a new, reversed list. The output is a strict cons list." } ; + +HELP: list>array +{ $values { "list" "a cons object" } { "array" array } } { $description "Turns the given cons object into an array, maintaing order." } ; - -HELP: seq>list -{ $values { "seq" "a sequence" } { "list" "a cons object" } } + +HELP: sequence>cons +{ $values { "sequence" sequence } { "list" cons } } { $description "Turns the given array into a cons object, maintaing order." } ; - -HELP: cons>seq -{ $values { "cons" "a cons object" } { "array" "an array object" } } + +HELP: deep-list>array +{ $values { "list" list } { "array" array } } { $description "Recursively turns the given cons object into an array, maintaing order and also converting nested lists." } ; - -HELP: seq>cons -{ $values { "seq" "a sequence object" } { "cons" "a cons object" } } + +HELP: deep-sequence>cons +{ $values { "sequence" sequence } { "cons" cons } } { $description "Recursively turns the given sequence into a cons object, maintaing order and also converting nested lists." } ; - + HELP: traverse { $values { "list" "a cons object" } { "pred" { $quotation "( list/elt -- ? )" } } { "quot" { $quotation "( list/elt -- result)" } } { "result" "a new cons object" } } { $description "Recursively traverses the list object, replacing any elements (which can themselves be sublists) that pred" - " returns true for with the result of applying quot to." } ; - + " returns true for with the result of applying quot to." } ; + +HELP: list +{ $class-description "The class of lists. All lists are expected to conform to " { $link { "lists" "protocol" } } "." } ; + +HELP: cadr +{ $values { "list" list } { "elt" object } } +{ $description "Returns the second element of the list, ie the car of the cdr." } ; + +HELP: lappend +{ $values { "list1" list } { "list2" list } { "newlist" list } } +{ $description "Appends the two lists to form a new list. The first list must be finite. The result is a strict cons cell, and the first list is exausted." } ; + +HELP: lcut +{ $values { "list" list } { "index" integer } { "before" cons } { "after" cons } } +{ $description "Analogous to " { $link cut } ", this word cuts a list into two pieces at the given index." } ; + +HELP: lmap>array +{ $values { "list" list } { "quot" quotation } { "array" array } } +{ $description "Executes the quotation on each element of the list, collecting the results in an array." } ; + +HELP: lmap-as +{ $values { "list" list } { "quot" quotation } { "exemplar" sequence } { "sequence" sequence } } +{ $description "Executes the quotation on each element of the list, collecting the results in a sequence of the type given by the exemplar." } ; diff --git a/basis/lists/lists-tests.factor b/basis/lists/lists-tests.factor index 4a08a4d1e3..13d2e03e0f 100644 --- a/basis/lists/lists-tests.factor +++ b/basis/lists/lists-tests.factor @@ -1,11 +1,10 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test lists math ; - +USING: tools.test lists math kernel ; IN: lists.tests { { 3 4 5 6 7 } } [ - { 1 2 3 4 5 } seq>list [ 2 + ] lmap list>seq + { 1 2 3 4 5 } sequence>cons [ 2 + ] lmap list>array ] unit-test { { 3 4 5 6 } } [ @@ -38,33 +37,35 @@ IN: lists.tests +nil+ } } } +nil+ } } } } [ - { 1 2 { 3 4 { 5 } } } seq>cons + { 1 2 { 3 4 { 5 } } } deep-sequence>cons ] unit-test { { 1 2 { 3 4 { 5 } } } } [ - { 1 2 { 3 4 { 5 } } } seq>cons cons>seq + { 1 2 { 3 4 { 5 } } } deep-sequence>cons deep-list>array ] unit-test { T{ cons f 2 T{ cons f 3 T{ cons f 4 T{ cons f 5 +nil+ } } } } } [ - { 1 2 3 4 } seq>cons [ 1+ ] lmap + { 1 2 3 4 } sequence>cons [ 1+ ] lmap ] unit-test { 15 } [ - { 1 2 3 4 5 } seq>list 0 [ + ] foldr + { 1 2 3 4 5 } sequence>cons 0 [ + ] foldr ] unit-test { { 5 4 3 2 1 } } [ - { 1 2 3 4 5 } seq>list lreverse list>seq + { 1 2 3 4 5 } sequence>cons lreverse list>array ] unit-test { 5 } [ - { 1 2 3 4 5 } seq>list llength + { 1 2 3 4 5 } sequence>cons llength ] unit-test { { 3 4 { 5 6 { 7 } } } } [ - { 1 2 { 3 4 { 5 } } } seq>cons [ atom? ] [ 2 + ] traverse cons>seq + { 1 2 { 3 4 { 5 } } } deep-sequence>cons [ atom? ] [ 2 + ] traverse deep-list>array ] unit-test { { 1 2 3 4 5 6 } } [ - { 1 2 3 } seq>list { 4 5 6 } seq>list lappend list>seq -] unit-test \ No newline at end of file + { 1 2 3 } sequence>cons { 4 5 6 } sequence>cons lappend list>array +] unit-test + +[ { 1 } { 2 } ] [ { 1 2 } sequence>cons 1 lcut [ list>array ] bi@ ] unit-test diff --git a/basis/lists/lists.factor b/basis/lists/lists.factor index 5568b9d53e..4b0abb7f2d 100644 --- a/basis/lists/lists.factor +++ b/basis/lists/lists.factor @@ -1,15 +1,16 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences accessors math arrays vectors classes words locals ; +USING: kernel sequences accessors math arrays vectors classes words +combinators.short-circuit combinators locals ; IN: lists ! List Protocol MIXIN: list -GENERIC: car ( cons -- car ) -GENERIC: cdr ( cons -- cdr ) -GENERIC: nil? ( object -- ? ) +GENERIC: car ( cons -- car ) +GENERIC: cdr ( cons -- cdr ) +GENERIC: nil? ( object -- ? ) -TUPLE: cons car cdr ; +TUPLE: cons { car read-only } { cdr read-only } ; C: cons cons @@ -18,41 +19,53 @@ M: cons car ( cons -- car ) M: cons cdr ( cons -- cdr ) cdr>> ; - -SYMBOL: +nil+ -M: word nil? +nil+ eq? ; + +SINGLETON: +nil+ +M: +nil+ nil? drop t ; M: object nil? drop f ; - -: atom? ( obj -- ? ) [ list? ] [ nil? ] bi or not ; + +: atom? ( obj -- ? ) + list? not ; : nil ( -- symbol ) +nil+ ; - -: uncons ( cons -- cdr car ) - [ cdr ] [ car ] bi ; - + +: uncons ( cons -- car cdr ) + [ car ] [ cdr ] bi ; + +: swons ( cdr car -- cons ) + swap cons ; + +: unswons ( cons -- cdr car ) + uncons swap ; + : 1list ( obj -- cons ) nil cons ; - + +: 1list? ( list -- ? ) + { [ nil? not ] [ cdr nil? ] } 1&& ; + : 2list ( a b -- cons ) nil cons cons ; : 3list ( a b c -- cons ) nil cons cons cons ; - -: cadr ( cons -- elt ) + +: cadr ( list -- elt ) cdr car ; - -: 2car ( cons -- car caar ) + +: 2car ( list -- car caar ) [ car ] [ cdr car ] bi ; - -: 3car ( cons -- car cadr caddr ) + +: 3car ( list -- car cadr caddr ) [ car ] [ cdr car ] [ cdr cdr car ] tri ; : lnth ( n list -- elt ) swap [ cdr ] times car ; - + + : leach ( list quot: ( elt -- ) -- ) over nil? [ 2drop ] [ (leach) leach ] if ; inline recursive @@ -63,49 +76,72 @@ M: object nil? drop f ; : foldl ( list identity quot: ( obj1 obj2 -- obj ) -- result ) swapd leach ; inline -: foldr ( list identity quot: ( obj1 obj2 -- obj ) -- result ) - pick nil? [ [ drop ] [ ] [ drop ] tri* ] [ - [ [ cdr ] 2dip foldr ] [ nip [ car ] dip ] 3bi - call +:: foldr ( list identity quot: ( obj1 obj2 -- obj ) -- result ) + list nil? [ identity ] [ + list cdr identity quot foldr + list car quot call ] if ; inline recursive : llength ( list -- n ) 0 [ drop 1+ ] foldl ; - + : lreverse ( list -- newlist ) nil [ swap cons ] foldl ; - + : lappend ( list1 list2 -- newlist ) [ lreverse ] dip [ swap cons ] foldl ; - -: seq>list ( seq -- list ) + +: lcut ( list index -- before after ) + [ nil ] dip + [ [ [ cdr ] [ car ] bi ] dip cons ] times + lreverse swap ; + +: sequence>cons ( sequence -- list ) nil [ swap cons ] reduce ; - + +cons ( seq -- cons ) - [ ] keep nil [ tuck same? [ seq>cons ] when f cons swap >>cdr ] with reduce ; - -: (lmap>array) ( acc cons quot: ( elt -- elt' ) -- newcons ) - over nil? [ 2drop ] - [ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (lmap>array) ] if ; - inline recursive - -: lmap>array ( cons quot -- newcons ) - { } -rot (lmap>array) ; inline - -: lmap-as ( cons quot exemplar -- seq ) - [ lmap>array ] dip like ; - -: cons>seq ( cons -- array ) - [ dup cons? [ cons>seq ] when dup nil? [ drop { } ] when ] lmap>array ; - -: list>seq ( list -- array ) +PRIVATE> + +: deep-sequence>cons ( sequence -- cons ) + [ ] keep nil + [ tuck same? [ deep-sequence>cons ] when swons ] with reduce ; + +vector) ( acc list quot: ( elt -- elt' ) -- acc ) + list nil? [ acc ] [ + list car quot call acc push + acc list cdr quot (lmap>vector) + ] if ; inline recursive + +: lmap>vector ( list quot -- array ) + [ V{ } clone ] 2dip (lmap>vector) ; inline +PRIVATE> + +: lmap-as ( list quot exemplar -- sequence ) + [ lmap>vector ] dip like ; inline + +: lmap>array ( list quot -- array ) + { } lmap-as ; inline + +: deep-list>array ( list -- array ) + [ + { + { [ dup nil? ] [ drop { } ] } + { [ dup list? ] [ deep-list>array ] } + [ ] + } cond + ] lmap>array ; + +: list>array ( list -- array ) [ ] lmap>array ; - -: traverse ( list pred quot: ( list/elt -- result ) -- result ) - [ 2over call [ tuck [ call ] 2dip ] when - pick list? [ traverse ] [ 2drop ] if ] 2curry lmap ; inline recursive - + +:: traverse ( list pred quot: ( list/elt -- result ) -- result ) + list [| elt | + elt dup pred call [ quot call ] when + dup list? [ pred quot traverse ] when + ] lmap ; inline recursive + INSTANCE: cons list +INSTANCE: +nil+ list diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor index e60815bf60..339703c0a6 100755 --- a/basis/math/bitwise/bitwise.factor +++ b/basis/math/bitwise/bitwise.factor @@ -102,3 +102,7 @@ PRIVATE> : signed-be> ( bytes -- x ) signed-le> ; + +: >signed ( x n -- y ) + 2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ; + diff --git a/basis/math/blas/cblas/cblas.factor b/basis/math/blas/cblas/cblas.factor deleted file mode 100644 index 2a2e9e3a72..0000000000 --- a/basis/math/blas/cblas/cblas.factor +++ /dev/null @@ -1,574 +0,0 @@ -USING: alien alien.c-types alien.syntax kernel system -combinators ; -IN: math.blas.cblas - -<< -: load-atlas ( -- ) - "atlas" "libatlas.so" "cdecl" add-library ; -: load-fortran ( -- ) - "I77" "libI77.so" "cdecl" add-library - "F77" "libF77.so" "cdecl" add-library ; -: load-blas ( -- ) - "blas" "libblas.so" "cdecl" add-library ; - -"cblas" { - { [ os macosx? ] [ "libblas.dylib" "cdecl" add-library ] } - { [ os windows? ] [ "blas.dll" "cdecl" add-library ] } - { [ os openbsd? ] [ "libcblas.so" "cdecl" add-library load-blas ] } - { [ os netbsd? ] [ - load-fortran load-blas - "/usr/local/lib/libcblas.so" "cdecl" add-library - ] } - { [ os freebsd? ] [ "libcblas.so" "cdecl" add-library load-atlas ] } - [ "libblas.so" "cdecl" add-library ] -} cond ->> - -LIBRARY: cblas - -TYPEDEF: int CBLAS_ORDER -CONSTANT: CblasRowMajor 101 -CONSTANT: CblasColMajor 102 - -TYPEDEF: int CBLAS_TRANSPOSE -CONSTANT: CblasNoTrans 111 -CONSTANT: CblasTrans 112 -CONSTANT: CblasConjTrans 113 - -TYPEDEF: int CBLAS_UPLO -CONSTANT: CblasUpper 121 -CONSTANT: CblasLower 122 - -TYPEDEF: int CBLAS_DIAG -CONSTANT: CblasNonUnit 131 -CONSTANT: CblasUnit 132 - -TYPEDEF: int CBLAS_SIDE -CONSTANT: CblasLeft 141 -CONSTANT: CblasRight 142 - -TYPEDEF: int CBLAS_INDEX - -C-STRUCT: float-complex - { "float" "real" } - { "float" "imag" } ; -C-STRUCT: double-complex - { "double" "real" } - { "double" "imag" } ; - -! Level 1 BLAS (scalar-vector and vector-vector) - -FUNCTION: float cblas_sdsdot - ( int N, float alpha, float* X, int incX, float* Y, int incY ) ; -FUNCTION: double cblas_dsdot - ( int N, float* X, int incX, float* Y, int incY ) ; -FUNCTION: float cblas_sdot - ( int N, float* X, int incX, float* Y, int incY ) ; -FUNCTION: double cblas_ddot - ( int N, double* X, int incX, double* Y, int incY ) ; - -FUNCTION: void cblas_cdotu_sub - ( int N, void* X, int incX, void* Y, int incY, void* dotu ) ; -FUNCTION: void cblas_cdotc_sub - ( int N, void* X, int incX, void* Y, int incY, void* dotc ) ; - -FUNCTION: void cblas_zdotu_sub - ( int N, void* X, int incX, void* Y, int incY, void* dotu ) ; -FUNCTION: void cblas_zdotc_sub - ( int N, void* X, int incX, void* Y, int incY, void* dotc ) ; - -FUNCTION: float cblas_snrm2 - ( int N, float* X, int incX ) ; -FUNCTION: float cblas_sasum - ( int N, float* X, int incX ) ; - -FUNCTION: double cblas_dnrm2 - ( int N, double* X, int incX ) ; -FUNCTION: double cblas_dasum - ( int N, double* X, int incX ) ; - -FUNCTION: float cblas_scnrm2 - ( int N, void* X, int incX ) ; -FUNCTION: float cblas_scasum - ( int N, void* X, int incX ) ; - -FUNCTION: double cblas_dznrm2 - ( int N, void* X, int incX ) ; -FUNCTION: double cblas_dzasum - ( int N, void* X, int incX ) ; - -FUNCTION: CBLAS_INDEX cblas_isamax - ( int N, float* X, int incX ) ; -FUNCTION: CBLAS_INDEX cblas_idamax - ( int N, double* X, int incX ) ; -FUNCTION: CBLAS_INDEX cblas_icamax - ( int N, void* X, int incX ) ; -FUNCTION: CBLAS_INDEX cblas_izamax - ( int N, void* X, int incX ) ; - -FUNCTION: void cblas_sswap - ( int N, float* X, int incX, float* Y, int incY ) ; -FUNCTION: void cblas_scopy - ( int N, float* X, int incX, float* Y, int incY ) ; -FUNCTION: void cblas_saxpy - ( int N, float alpha, float* X, int incX, float* Y, int incY ) ; - -FUNCTION: void cblas_dswap - ( int N, double* X, int incX, double* Y, int incY ) ; -FUNCTION: void cblas_dcopy - ( int N, double* X, int incX, double* Y, int incY ) ; -FUNCTION: void cblas_daxpy - ( int N, double alpha, double* X, int incX, double* Y, int incY ) ; - -FUNCTION: void cblas_cswap - ( int N, void* X, int incX, void* Y, int incY ) ; -FUNCTION: void cblas_ccopy - ( int N, void* X, int incX, void* Y, int incY ) ; -FUNCTION: void cblas_caxpy - ( int N, void* alpha, void* X, int incX, void* Y, int incY ) ; - -FUNCTION: void cblas_zswap - ( int N, void* X, int incX, void* Y, int incY ) ; -FUNCTION: void cblas_zcopy - ( int N, void* X, int incX, void* Y, int incY ) ; -FUNCTION: void cblas_zaxpy - ( int N, void* alpha, void* X, int incX, void* Y, int incY ) ; - -FUNCTION: void cblas_sscal - ( int N, float alpha, float* X, int incX ) ; -FUNCTION: void cblas_dscal - ( int N, double alpha, double* X, int incX ) ; -FUNCTION: void cblas_cscal - ( int N, void* alpha, void* X, int incX ) ; -FUNCTION: void cblas_zscal - ( int N, void* alpha, void* X, int incX ) ; -FUNCTION: void cblas_csscal - ( int N, float alpha, void* X, int incX ) ; -FUNCTION: void cblas_zdscal - ( int N, double alpha, void* X, int incX ) ; - -FUNCTION: void cblas_srotg - ( float* a, float* b, float* c, float* s ) ; -FUNCTION: void cblas_srotmg - ( float* d1, float* d2, float* b1, float b2, float* P ) ; -FUNCTION: void cblas_srot - ( int N, float* X, int incX, float* Y, int incY, float c, float s ) ; -FUNCTION: void cblas_srotm - ( int N, float* X, int incX, float* Y, int incY, float* P ) ; - -FUNCTION: void cblas_drotg - ( double* a, double* b, double* c, double* s ) ; -FUNCTION: void cblas_drotmg - ( double* d1, double* d2, double* b1, double b2, double* P ) ; -FUNCTION: void cblas_drot - ( int N, double* X, int incX, double* Y, int incY, double c, double s ) ; -FUNCTION: void cblas_drotm - ( int N, double* X, int incX, double* Y, int incY, double* P ) ; - -! Level 2 BLAS (matrix-vector) - -FUNCTION: void cblas_sgemv ( CBLAS_ORDER Order, - CBLAS_TRANSPOSE TransA, int M, int N, - float alpha, float* A, int lda, - float* X, int incX, float beta, - float* Y, int incY ) ; -FUNCTION: void cblas_sgbmv ( CBLAS_ORDER Order, - CBLAS_TRANSPOSE TransA, int M, int N, - int KL, int KU, float alpha, - float* A, int lda, float* X, - int incX, float beta, float* Y, int incY ) ; -FUNCTION: void cblas_strmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, float* A, int lda, - float* X, int incX ) ; -FUNCTION: void cblas_stbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, int K, float* A, int lda, - float* X, int incX ) ; -FUNCTION: void cblas_stpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, float* Ap, float* X, int incX ) ; -FUNCTION: void cblas_strsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, float* A, int lda, float* X, - int incX ) ; -FUNCTION: void cblas_stbsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, int K, float* A, int lda, - float* X, int incX ) ; -FUNCTION: void cblas_stpsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, float* Ap, float* X, int incX ) ; - -FUNCTION: void cblas_dgemv ( CBLAS_ORDER Order, - CBLAS_TRANSPOSE TransA, int M, int N, - double alpha, double* A, int lda, - double* X, int incX, double beta, - double* Y, int incY ) ; -FUNCTION: void cblas_dgbmv ( CBLAS_ORDER Order, - CBLAS_TRANSPOSE TransA, int M, int N, - int KL, int KU, double alpha, - double* A, int lda, double* X, - int incX, double beta, double* Y, int incY ) ; -FUNCTION: void cblas_dtrmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, double* A, int lda, - double* X, int incX ) ; -FUNCTION: void cblas_dtbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, int K, double* A, int lda, - double* X, int incX ) ; -FUNCTION: void cblas_dtpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, double* Ap, double* X, int incX ) ; -FUNCTION: void cblas_dtrsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, double* A, int lda, double* X, - int incX ) ; -FUNCTION: void cblas_dtbsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, int K, double* A, int lda, - double* X, int incX ) ; -FUNCTION: void cblas_dtpsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, double* Ap, double* X, int incX ) ; - -FUNCTION: void cblas_cgemv ( CBLAS_ORDER Order, - CBLAS_TRANSPOSE TransA, int M, int N, - void* alpha, void* A, int lda, - void* X, int incX, void* beta, - void* Y, int incY ) ; -FUNCTION: void cblas_cgbmv ( CBLAS_ORDER Order, - CBLAS_TRANSPOSE TransA, int M, int N, - int KL, int KU, void* alpha, - void* A, int lda, void* X, - int incX, void* beta, void* Y, int incY ) ; -FUNCTION: void cblas_ctrmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, void* A, int lda, - void* X, int incX ) ; -FUNCTION: void cblas_ctbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, int K, void* A, int lda, - void* X, int incX ) ; -FUNCTION: void cblas_ctpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, void* Ap, void* X, int incX ) ; -FUNCTION: void cblas_ctrsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, void* A, int lda, void* X, - int incX ) ; -FUNCTION: void cblas_ctbsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, int K, void* A, int lda, - void* X, int incX ) ; -FUNCTION: void cblas_ctpsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, void* Ap, void* X, int incX ) ; - -FUNCTION: void cblas_zgemv ( CBLAS_ORDER Order, - CBLAS_TRANSPOSE TransA, int M, int N, - void* alpha, void* A, int lda, - void* X, int incX, void* beta, - void* Y, int incY ) ; -FUNCTION: void cblas_zgbmv ( CBLAS_ORDER Order, - CBLAS_TRANSPOSE TransA, int M, int N, - int KL, int KU, void* alpha, - void* A, int lda, void* X, - int incX, void* beta, void* Y, int incY ) ; -FUNCTION: void cblas_ztrmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, void* A, int lda, - void* X, int incX ) ; -FUNCTION: void cblas_ztbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, int K, void* A, int lda, - void* X, int incX ) ; -FUNCTION: void cblas_ztpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, void* Ap, void* X, int incX ) ; -FUNCTION: void cblas_ztrsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, void* A, int lda, void* X, - int incX ) ; -FUNCTION: void cblas_ztbsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, int K, void* A, int lda, - void* X, int incX ) ; -FUNCTION: void cblas_ztpsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, void* Ap, void* X, int incX ) ; - - -FUNCTION: void cblas_ssymv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, float alpha, float* A, - int lda, float* X, int incX, - float beta, float* Y, int incY ) ; -FUNCTION: void cblas_ssbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, int K, float alpha, float* A, - int lda, float* X, int incX, - float beta, float* Y, int incY ) ; -FUNCTION: void cblas_sspmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, float alpha, float* Ap, - float* X, int incX, - float beta, float* Y, int incY ) ; -FUNCTION: void cblas_sger ( CBLAS_ORDER Order, int M, int N, - float alpha, float* X, int incX, - float* Y, int incY, float* A, int lda ) ; -FUNCTION: void cblas_ssyr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, float alpha, float* X, - int incX, float* A, int lda ) ; -FUNCTION: void cblas_sspr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, float alpha, float* X, - int incX, float* Ap ) ; -FUNCTION: void cblas_ssyr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, float alpha, float* X, - int incX, float* Y, int incY, float* A, - int lda ) ; -FUNCTION: void cblas_sspr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, float alpha, float* X, - int incX, float* Y, int incY, float* A ) ; - -FUNCTION: void cblas_dsymv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, double alpha, double* A, - int lda, double* X, int incX, - double beta, double* Y, int incY ) ; -FUNCTION: void cblas_dsbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, int K, double alpha, double* A, - int lda, double* X, int incX, - double beta, double* Y, int incY ) ; -FUNCTION: void cblas_dspmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, double alpha, double* Ap, - double* X, int incX, - double beta, double* Y, int incY ) ; -FUNCTION: void cblas_dger ( CBLAS_ORDER Order, int M, int N, - double alpha, double* X, int incX, - double* Y, int incY, double* A, int lda ) ; -FUNCTION: void cblas_dsyr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, double alpha, double* X, - int incX, double* A, int lda ) ; -FUNCTION: void cblas_dspr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, double alpha, double* X, - int incX, double* Ap ) ; -FUNCTION: void cblas_dsyr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, double alpha, double* X, - int incX, double* Y, int incY, double* A, - int lda ) ; -FUNCTION: void cblas_dspr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, double alpha, double* X, - int incX, double* Y, int incY, double* A ) ; - - -FUNCTION: void cblas_chemv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, void* alpha, void* A, - int lda, void* X, int incX, - void* beta, void* Y, int incY ) ; -FUNCTION: void cblas_chbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, int K, void* alpha, void* A, - int lda, void* X, int incX, - void* beta, void* Y, int incY ) ; -FUNCTION: void cblas_chpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, void* alpha, void* Ap, - void* X, int incX, - void* beta, void* Y, int incY ) ; -FUNCTION: void cblas_cgeru ( CBLAS_ORDER Order, int M, int N, - void* alpha, void* X, int incX, - void* Y, int incY, void* A, int lda ) ; -FUNCTION: void cblas_cgerc ( CBLAS_ORDER Order, int M, int N, - void* alpha, void* X, int incX, - void* Y, int incY, void* A, int lda ) ; -FUNCTION: void cblas_cher ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, float alpha, void* X, int incX, - void* A, int lda ) ; -FUNCTION: void cblas_chpr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, float alpha, void* X, - int incX, void* A ) ; -FUNCTION: void cblas_cher2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, int N, - void* alpha, void* X, int incX, - void* Y, int incY, void* A, int lda ) ; -FUNCTION: void cblas_chpr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, int N, - void* alpha, void* X, int incX, - void* Y, int incY, void* Ap ) ; - -FUNCTION: void cblas_zhemv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, void* alpha, void* A, - int lda, void* X, int incX, - void* beta, void* Y, int incY ) ; -FUNCTION: void cblas_zhbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, int K, void* alpha, void* A, - int lda, void* X, int incX, - void* beta, void* Y, int incY ) ; -FUNCTION: void cblas_zhpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, void* alpha, void* Ap, - void* X, int incX, - void* beta, void* Y, int incY ) ; -FUNCTION: void cblas_zgeru ( CBLAS_ORDER Order, int M, int N, - void* alpha, void* X, int incX, - void* Y, int incY, void* A, int lda ) ; -FUNCTION: void cblas_zgerc ( CBLAS_ORDER Order, int M, int N, - void* alpha, void* X, int incX, - void* Y, int incY, void* A, int lda ) ; -FUNCTION: void cblas_zher ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, double alpha, void* X, int incX, - void* A, int lda ) ; -FUNCTION: void cblas_zhpr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, double alpha, void* X, - int incX, void* A ) ; -FUNCTION: void cblas_zher2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, int N, - void* alpha, void* X, int incX, - void* Y, int incY, void* A, int lda ) ; -FUNCTION: void cblas_zhpr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, int N, - void* alpha, void* X, int incX, - void* Y, int incY, void* Ap ) ; - -! Level 3 BLAS (matrix-matrix) - -FUNCTION: void cblas_sgemm ( CBLAS_ORDER Order, CBLAS_TRANSPOSE TransA, - CBLAS_TRANSPOSE TransB, int M, int N, - int K, float alpha, float* A, - int lda, float* B, int ldb, - float beta, float* C, int ldc ) ; -FUNCTION: void cblas_ssymm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, int M, int N, - float alpha, float* A, int lda, - float* B, int ldb, float beta, - float* C, int ldc ) ; -FUNCTION: void cblas_ssyrk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - float alpha, float* A, int lda, - float beta, float* C, int ldc ) ; -FUNCTION: void cblas_ssyr2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - float alpha, float* A, int lda, - float* B, int ldb, float beta, - float* C, int ldc ) ; -FUNCTION: void cblas_strmm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, - CBLAS_DIAG Diag, int M, int N, - float alpha, float* A, int lda, - float* B, int ldb ) ; -FUNCTION: void cblas_strsm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, - CBLAS_DIAG Diag, int M, int N, - float alpha, float* A, int lda, - float* B, int ldb ) ; - -FUNCTION: void cblas_dgemm ( CBLAS_ORDER Order, CBLAS_TRANSPOSE TransA, - CBLAS_TRANSPOSE TransB, int M, int N, - int K, double alpha, double* A, - int lda, double* B, int ldb, - double beta, double* C, int ldc ) ; -FUNCTION: void cblas_dsymm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, int M, int N, - double alpha, double* A, int lda, - double* B, int ldb, double beta, - double* C, int ldc ) ; -FUNCTION: void cblas_dsyrk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - double alpha, double* A, int lda, - double beta, double* C, int ldc ) ; -FUNCTION: void cblas_dsyr2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - double alpha, double* A, int lda, - double* B, int ldb, double beta, - double* C, int ldc ) ; -FUNCTION: void cblas_dtrmm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, - CBLAS_DIAG Diag, int M, int N, - double alpha, double* A, int lda, - double* B, int ldb ) ; -FUNCTION: void cblas_dtrsm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, - CBLAS_DIAG Diag, int M, int N, - double alpha, double* A, int lda, - double* B, int ldb ) ; - -FUNCTION: void cblas_cgemm ( CBLAS_ORDER Order, CBLAS_TRANSPOSE TransA, - CBLAS_TRANSPOSE TransB, int M, int N, - int K, void* alpha, void* A, - int lda, void* B, int ldb, - void* beta, void* C, int ldc ) ; -FUNCTION: void cblas_csymm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, int M, int N, - void* alpha, void* A, int lda, - void* B, int ldb, void* beta, - void* C, int ldc ) ; -FUNCTION: void cblas_csyrk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - void* alpha, void* A, int lda, - void* beta, void* C, int ldc ) ; -FUNCTION: void cblas_csyr2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - void* alpha, void* A, int lda, - void* B, int ldb, void* beta, - void* C, int ldc ) ; -FUNCTION: void cblas_ctrmm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, - CBLAS_DIAG Diag, int M, int N, - void* alpha, void* A, int lda, - void* B, int ldb ) ; -FUNCTION: void cblas_ctrsm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, - CBLAS_DIAG Diag, int M, int N, - void* alpha, void* A, int lda, - void* B, int ldb ) ; - -FUNCTION: void cblas_zgemm ( CBLAS_ORDER Order, CBLAS_TRANSPOSE TransA, - CBLAS_TRANSPOSE TransB, int M, int N, - int K, void* alpha, void* A, - int lda, void* B, int ldb, - void* beta, void* C, int ldc ) ; -FUNCTION: void cblas_zsymm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, int M, int N, - void* alpha, void* A, int lda, - void* B, int ldb, void* beta, - void* C, int ldc ) ; -FUNCTION: void cblas_zsyrk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - void* alpha, void* A, int lda, - void* beta, void* C, int ldc ) ; -FUNCTION: void cblas_zsyr2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - void* alpha, void* A, int lda, - void* B, int ldb, void* beta, - void* C, int ldc ) ; -FUNCTION: void cblas_ztrmm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, - CBLAS_DIAG Diag, int M, int N, - void* alpha, void* A, int lda, - void* B, int ldb ) ; -FUNCTION: void cblas_ztrsm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, - CBLAS_DIAG Diag, int M, int N, - void* alpha, void* A, int lda, - void* B, int ldb ) ; - -FUNCTION: void cblas_chemm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, int M, int N, - void* alpha, void* A, int lda, - void* B, int ldb, void* beta, - void* C, int ldc ) ; -FUNCTION: void cblas_cherk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - float alpha, void* A, int lda, - float beta, void* C, int ldc ) ; -FUNCTION: void cblas_cher2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - void* alpha, void* A, int lda, - void* B, int ldb, float beta, - void* C, int ldc ) ; -FUNCTION: void cblas_zhemm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, int M, int N, - void* alpha, void* A, int lda, - void* B, int ldb, void* beta, - void* C, int ldc ) ; -FUNCTION: void cblas_zherk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - double alpha, void* A, int lda, - double beta, void* C, int ldc ) ; -FUNCTION: void cblas_zher2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - void* alpha, void* A, int lda, - void* B, int ldb, double beta, - void* C, int ldc ) ; - diff --git a/basis/math/blas/cblas/summary.txt b/basis/math/blas/cblas/summary.txt deleted file mode 100644 index c72e78eb0d..0000000000 --- a/basis/math/blas/cblas/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Low-level bindings to the C Basic Linear Algebra Subroutines (BLAS) library diff --git a/basis/math/blas/ffi/authors.txt b/basis/math/blas/ffi/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/basis/math/blas/ffi/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/basis/math/blas/ffi/ffi.factor b/basis/math/blas/ffi/ffi.factor new file mode 100644 index 0000000000..1749103ce4 --- /dev/null +++ b/basis/math/blas/ffi/ffi.factor @@ -0,0 +1,522 @@ +USING: alien alien.fortran kernel system combinators ; +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? ] [ "libblas.so" gfortran-abi add-fortran-library ] } + [ "libblas.so" f2c-abi add-fortran-library ] +} cond +>> + +LIBRARY: blas + +! Level 1 BLAS (scalar-vector and vector-vector) + +FUNCTION: REAL SDSDOT + ( INTEGER N, REAL ALPHA, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ; +FUNCTION: DOUBLE-PRECISION DSDOT + ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ; +FUNCTION: REAL SDOT + ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ; +FUNCTION: DOUBLE-PRECISION DDOT + ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ; + +FUNCTION: COMPLEX CDOTU + ( INTEGER N, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ; +FUNCTION: COMPLEX CDOTC + ( INTEGER N, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ; + +FUNCTION: DOUBLE-COMPLEX ZDOTU + ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; +FUNCTION: DOUBLE-COMPLEX ZDOTC + ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; + +FUNCTION: REAL SNRM2 + ( INTEGER N, REAL(*) X, INTEGER INCX ) ; +FUNCTION: REAL SASUM + ( INTEGER N, REAL(*) X, INTEGER INCX ) ; + +FUNCTION: DOUBLE-PRECISION DNRM2 + ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX ) ; +FUNCTION: DOUBLE-PRECISION DASUM + ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX ) ; + +FUNCTION: REAL SCNRM2 + ( INTEGER N, COMPLEX(*) X, INTEGER INCX ) ; +FUNCTION: REAL SCASUM + ( INTEGER N, COMPLEX(*) X, INTEGER INCX ) ; + +FUNCTION: DOUBLE-PRECISION DZNRM2 + ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ; +FUNCTION: DOUBLE-PRECISION DZASUM + ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ; + +FUNCTION: INTEGER ISAMAX + ( INTEGER N, REAL(*) X, INTEGER INCX ) ; +FUNCTION: INTEGER IDAMAX + ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX ) ; +FUNCTION: INTEGER ICAMAX + ( INTEGER N, COMPLEX(*) X, INTEGER INCX ) ; +FUNCTION: INTEGER IZAMAX + ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ; + +SUBROUTINE: SSWAP + ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ; +SUBROUTINE: SCOPY + ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ; +SUBROUTINE: SAXPY + ( INTEGER N, REAL ALPHA, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ; + +SUBROUTINE: DSWAP + ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ; +SUBROUTINE: DCOPY + ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ; +SUBROUTINE: DAXPY + ( INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ; + +SUBROUTINE: CSWAP + ( INTEGER N, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: CCOPY + ( INTEGER N, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: CAXPY + ( INTEGER N, COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ; + +SUBROUTINE: ZSWAP + ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: ZCOPY + ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: ZAXPY + ( INTEGER N, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; + +SUBROUTINE: SSCAL + ( INTEGER N, REAL ALPHA, REAL(*) X, INTEGER INCX ) ; +SUBROUTINE: DSCAL + ( INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X, INTEGER INCX ) ; +SUBROUTINE: CSCAL + ( INTEGER N, COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: ZSCAL + ( INTEGER N, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: CSSCAL + ( INTEGER N, REAL ALPHA, COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: ZDSCAL + ( INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ; + +SUBROUTINE: SROTG + ( REAL(*) A, REAL(*) B, REAL(*) C, REAL(*) S ) ; +SUBROUTINE: SROTMG + ( REAL(*) D1, REAL(*) D2, REAL(*) B1, REAL B2, REAL(*) P ) ; +SUBROUTINE: SROT + ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY, REAL C, REAL S ) ; +SUBROUTINE: SROTM + ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY, REAL(*) P ) ; + +SUBROUTINE: DROTG + ( DOUBLE-PRECISION(*) A, DOUBLE-PRECISION(*) B, DOUBLE-PRECISION(*) C, DOUBLE-PRECISION(*) S ) ; +SUBROUTINE: DROTMG + ( DOUBLE-PRECISION(*) D1, DOUBLE-PRECISION(*) D2, DOUBLE-PRECISION(*) B1, DOUBLE-PRECISION B2, DOUBLE-PRECISION(*) P ) ; +SUBROUTINE: DROT + ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION C, DOUBLE-PRECISION S ) ; +SUBROUTINE: DROTM + ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION(*) P ) ; + +! LEVEL 2 BLAS (MATRIX-VECTOR) + +SUBROUTINE: SGEMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N, + REAL ALPHA, REAL(*) A, INTEGER LDA, + REAL(*) X, INTEGER INCX, REAL BETA, + REAL(*) Y, INTEGER INCY ) ; +SUBROUTINE: SGBMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N, + INTEGER KL, INTEGER KU, REAL ALPHA, + REAL(*) A, INTEGER LDA, REAL(*) X, + INTEGER INCX, REAL BETA, REAL(*) Y, INTEGER INCY ) ; +SUBROUTINE: STRMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, REAL(*) A, INTEGER LDA, + REAL(*) X, INTEGER INCX ) ; +SUBROUTINE: STBMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, INTEGER K, REAL(*) A, INTEGER LDA, + REAL(*) X, INTEGER INCX ) ; +SUBROUTINE: STPMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, REAL(*) AP, REAL(*) X, INTEGER INCX ) ; +SUBROUTINE: STRSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, REAL(*) A, INTEGER LDA, REAL(*) X, + INTEGER INCX ) ; +SUBROUTINE: STBSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, INTEGER K, REAL(*) A, INTEGER LDA, + REAL(*) X, INTEGER INCX ) ; +SUBROUTINE: STPSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, REAL(*) AP, REAL(*) X, INTEGER INCX ) ; + +SUBROUTINE: DGEMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N, + DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA, + DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION BETA, + DOUBLE-PRECISION(*) Y, INTEGER INCY ) ; +SUBROUTINE: DGBMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N, + INTEGER KL, INTEGER KU, DOUBLE-PRECISION ALPHA, + DOUBLE-PRECISION(*) A, INTEGER LDA, DOUBLE-PRECISION(*) X, + INTEGER INCX, DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ; +SUBROUTINE: DTRMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, DOUBLE-PRECISION(*) A, INTEGER LDA, + DOUBLE-PRECISION(*) X, INTEGER INCX ) ; +SUBROUTINE: DTBMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, INTEGER K, DOUBLE-PRECISION(*) A, INTEGER LDA, + DOUBLE-PRECISION(*) X, INTEGER INCX ) ; +SUBROUTINE: DTPMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, DOUBLE-PRECISION(*) AP, DOUBLE-PRECISION(*) X, INTEGER INCX ) ; +SUBROUTINE: DTRSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, DOUBLE-PRECISION(*) A, INTEGER LDA, DOUBLE-PRECISION(*) X, + INTEGER INCX ) ; +SUBROUTINE: DTBSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, INTEGER K, DOUBLE-PRECISION(*) A, INTEGER LDA, + DOUBLE-PRECISION(*) X, INTEGER INCX ) ; +SUBROUTINE: DTPSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, DOUBLE-PRECISION(*) AP, DOUBLE-PRECISION(*) X, INTEGER INCX ) ; + +SUBROUTINE: CGEMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N, + COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA, + COMPLEX(*) X, INTEGER INCX, COMPLEX BETA, + COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: CGBMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N, + INTEGER KL, INTEGER KU, COMPLEX ALPHA, + COMPLEX(*) A, INTEGER LDA, COMPLEX(*) X, + INTEGER INCX, COMPLEX BETA, COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: CTRMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, COMPLEX(*) A, INTEGER LDA, + COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: CTBMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, INTEGER K, COMPLEX(*) A, INTEGER LDA, + COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: CTPMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, COMPLEX(*) AP, COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: CTRSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, COMPLEX(*) A, INTEGER LDA, COMPLEX(*) X, + INTEGER INCX ) ; +SUBROUTINE: CTBSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, INTEGER K, COMPLEX(*) A, INTEGER LDA, + COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: CTPSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, COMPLEX(*) AP, COMPLEX(*) X, INTEGER INCX ) ; + +SUBROUTINE: ZGEMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX BETA, + DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: ZGBMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N, + INTEGER KL, INTEGER KU, DOUBLE-COMPLEX ALPHA, + DOUBLE-COMPLEX(*) A, INTEGER LDA, DOUBLE-COMPLEX(*) X, + INTEGER INCX, DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: ZTRMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: ZTBMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, INTEGER K, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: ZTPMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, DOUBLE-COMPLEX(*) AP, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: ZTRSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, DOUBLE-COMPLEX(*) A, INTEGER LDA, DOUBLE-COMPLEX(*) X, + INTEGER INCX ) ; +SUBROUTINE: ZTBSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, INTEGER K, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: ZTPSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, DOUBLE-COMPLEX(*) AP, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ; + + +SUBROUTINE: SSYMV ( CHARACTER*1 UPLO, + INTEGER N, REAL ALPHA, REAL(*) A, + INTEGER LDA, REAL(*) X, INTEGER INCX, + REAL BETA, REAL(*) Y, INTEGER INCY ) ; +SUBROUTINE: SSBMV ( CHARACTER*1 UPLO, + INTEGER N, INTEGER K, REAL ALPHA, REAL(*) A, + INTEGER LDA, REAL(*) X, INTEGER INCX, + REAL BETA, REAL(*) Y, INTEGER INCY ) ; +SUBROUTINE: SSPMV ( CHARACTER*1 UPLO, + INTEGER N, REAL ALPHA, REAL(*) AP, + REAL(*) X, INTEGER INCX, + REAL BETA, REAL(*) Y, INTEGER INCY ) ; +SUBROUTINE: SGER ( INTEGER M, INTEGER N, + REAL ALPHA, REAL(*) X, INTEGER INCX, + REAL(*) Y, INTEGER INCY, REAL(*) A, INTEGER LDA ) ; +SUBROUTINE: SSYR ( CHARACTER*1 UPLO, + INTEGER N, REAL ALPHA, REAL(*) X, + INTEGER INCX, REAL(*) A, INTEGER LDA ) ; +SUBROUTINE: SSPR ( CHARACTER*1 UPLO, + INTEGER N, REAL ALPHA, REAL(*) X, + INTEGER INCX, REAL(*) AP ) ; +SUBROUTINE: SSYR2 ( CHARACTER*1 UPLO, + INTEGER N, REAL ALPHA, REAL(*) X, + INTEGER INCX, REAL(*) Y, INTEGER INCY, REAL(*) A, + INTEGER LDA ) ; +SUBROUTINE: SSPR2 ( CHARACTER*1 UPLO, + INTEGER N, REAL ALPHA, REAL(*) X, + INTEGER INCX, REAL(*) Y, INTEGER INCY, REAL(*) A ) ; + +SUBROUTINE: DSYMV ( CHARACTER*1 UPLO, + INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, + INTEGER LDA, DOUBLE-PRECISION(*) X, INTEGER INCX, + DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ; +SUBROUTINE: DSBMV ( CHARACTER*1 UPLO, + INTEGER N, INTEGER K, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, + INTEGER LDA, DOUBLE-PRECISION(*) X, INTEGER INCX, + DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ; +SUBROUTINE: DSPMV ( CHARACTER*1 UPLO, + INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) AP, + DOUBLE-PRECISION(*) X, INTEGER INCX, + DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ; +SUBROUTINE: DGER ( INTEGER M, INTEGER N, + DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X, INTEGER INCX, + DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION(*) A, INTEGER LDA ) ; +SUBROUTINE: DSYR ( CHARACTER*1 UPLO, + INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X, + INTEGER INCX, DOUBLE-PRECISION(*) A, INTEGER LDA ) ; +SUBROUTINE: DSPR ( CHARACTER*1 UPLO, + INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X, + INTEGER INCX, DOUBLE-PRECISION(*) AP ) ; +SUBROUTINE: DSYR2 ( CHARACTER*1 UPLO, + INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X, + INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION(*) A, + INTEGER LDA ) ; +SUBROUTINE: DSPR2 ( CHARACTER*1 UPLO, + INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X, + INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION(*) A ) ; + + +SUBROUTINE: CHEMV ( CHARACTER*1 UPLO, + INTEGER N, COMPLEX ALPHA, COMPLEX(*) A, + INTEGER LDA, COMPLEX(*) X, INTEGER INCX, + COMPLEX BETA, COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: CHBMV ( CHARACTER*1 UPLO, + INTEGER N, INTEGER K, COMPLEX ALPHA, COMPLEX(*) A, + INTEGER LDA, COMPLEX(*) X, INTEGER INCX, + COMPLEX BETA, COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: CHPMV ( CHARACTER*1 UPLO, + INTEGER N, COMPLEX ALPHA, COMPLEX(*) AP, + COMPLEX(*) X, INTEGER INCX, + COMPLEX BETA, COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: CGERU ( INTEGER M, INTEGER N, + COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX, + COMPLEX(*) Y, INTEGER INCY, COMPLEX(*) A, INTEGER LDA ) ; +SUBROUTINE: CGERC ( INTEGER M, INTEGER N, + COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX, + COMPLEX(*) Y, INTEGER INCY, COMPLEX(*) A, INTEGER LDA ) ; +SUBROUTINE: CHER ( CHARACTER*1 UPLO, + INTEGER N, REAL ALPHA, COMPLEX(*) X, INTEGER INCX, + COMPLEX(*) A, INTEGER LDA ) ; +SUBROUTINE: CHPR ( CHARACTER*1 UPLO, + INTEGER N, REAL ALPHA, COMPLEX(*) X, + INTEGER INCX, COMPLEX(*) A ) ; +SUBROUTINE: CHER2 ( CHARACTER*1 UPLO, INTEGER N, + COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX, + COMPLEX(*) Y, INTEGER INCY, COMPLEX(*) A, INTEGER LDA ) ; +SUBROUTINE: CHPR2 ( CHARACTER*1 UPLO, INTEGER N, + COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX, + COMPLEX(*) Y, INTEGER INCY, COMPLEX(*) AP ) ; + +SUBROUTINE: ZHEMV ( CHARACTER*1 UPLO, + INTEGER N, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, + INTEGER LDA, DOUBLE-COMPLEX(*) X, INTEGER INCX, + DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: ZHBMV ( CHARACTER*1 UPLO, + INTEGER N, INTEGER K, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, + INTEGER LDA, DOUBLE-COMPLEX(*) X, INTEGER INCX, + DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: ZHPMV ( CHARACTER*1 UPLO, + INTEGER N, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) AP, + DOUBLE-COMPLEX(*) X, INTEGER INCX, + DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: ZGERU ( INTEGER M, INTEGER N, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX, + DOUBLE-COMPLEX(*) Y, INTEGER INCY, DOUBLE-COMPLEX(*) A, INTEGER LDA ) ; +SUBROUTINE: ZGERC ( INTEGER M, INTEGER N, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX, + DOUBLE-COMPLEX(*) Y, INTEGER INCY, DOUBLE-COMPLEX(*) A, INTEGER LDA ) ; +SUBROUTINE: ZHER ( CHARACTER*1 UPLO, + INTEGER N, REAL ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX, + DOUBLE-COMPLEX(*) A, INTEGER LDA ) ; +SUBROUTINE: ZHPR ( CHARACTER*1 UPLO, + INTEGER N, REAL ALPHA, DOUBLE-COMPLEX(*) X, + INTEGER INCX, DOUBLE-COMPLEX(*) A ) ; +SUBROUTINE: ZHER2 ( CHARACTER*1 UPLO, INTEGER N, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX, + DOUBLE-COMPLEX(*) Y, INTEGER INCY, DOUBLE-COMPLEX(*) A, INTEGER LDA ) ; +SUBROUTINE: ZHPR2 ( CHARACTER*1 UPLO, INTEGER N, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX, + DOUBLE-COMPLEX(*) Y, INTEGER INCY, DOUBLE-COMPLEX(*) AP ) ; + +! LEVEL 3 BLAS (MATRIX-MATRIX) + +SUBROUTINE: SGEMM ( CHARACTER*1 TRANSA, + CHARACTER*1 TRANSB, INTEGER M, INTEGER N, + INTEGER K, REAL ALPHA, REAL(*) A, + INTEGER LDA, REAL(*) B, INTEGER LDB, + REAL BETA, REAL(*) C, INTEGER LDC ) ; +SUBROUTINE: SSYMM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, INTEGER M, INTEGER N, + REAL ALPHA, REAL(*) A, INTEGER LDA, + REAL(*) B, INTEGER LDB, REAL BETA, + REAL(*) C, INTEGER LDC ) ; +SUBROUTINE: SSYRK ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + REAL ALPHA, REAL(*) A, INTEGER LDA, + REAL BETA, REAL(*) C, INTEGER LDC ) ; +SUBROUTINE: SSYR2K ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + REAL ALPHA, REAL(*) A, INTEGER LDA, + REAL(*) B, INTEGER LDB, REAL BETA, + REAL(*) C, INTEGER LDC ) ; +SUBROUTINE: STRMM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, CHARACTER*1 TRANSA, + CHARACTER*1 DIAG, INTEGER M, INTEGER N, + REAL ALPHA, REAL(*) A, INTEGER LDA, + REAL(*) B, INTEGER LDB ) ; +SUBROUTINE: STRSM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, CHARACTER*1 TRANSA, + CHARACTER*1 DIAG, INTEGER M, INTEGER N, + REAL ALPHA, REAL(*) A, INTEGER LDA, + REAL(*) B, INTEGER LDB ) ; + +SUBROUTINE: DGEMM ( CHARACTER*1 TRANSA, + CHARACTER*1 TRANSB, INTEGER M, INTEGER N, + INTEGER K, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, + INTEGER LDA, DOUBLE-PRECISION(*) B, INTEGER LDB, + DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) C, INTEGER LDC ) ; +SUBROUTINE: DSYMM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, INTEGER M, INTEGER N, + DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA, + DOUBLE-PRECISION(*) B, INTEGER LDB, DOUBLE-PRECISION BETA, + DOUBLE-PRECISION(*) C, INTEGER LDC ) ; +SUBROUTINE: DSYRK ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA, + DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) C, INTEGER LDC ) ; +SUBROUTINE: DSYR2K ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA, + DOUBLE-PRECISION(*) B, INTEGER LDB, DOUBLE-PRECISION BETA, + DOUBLE-PRECISION(*) C, INTEGER LDC ) ; +SUBROUTINE: DTRMM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, CHARACTER*1 TRANSA, + CHARACTER*1 DIAG, INTEGER M, INTEGER N, + DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA, + DOUBLE-PRECISION(*) B, INTEGER LDB ) ; +SUBROUTINE: DTRSM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, CHARACTER*1 TRANSA, + CHARACTER*1 DIAG, INTEGER M, INTEGER N, + DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA, + DOUBLE-PRECISION(*) B, INTEGER LDB ) ; + +SUBROUTINE: CGEMM ( CHARACTER*1 TRANSA, + CHARACTER*1 TRANSB, INTEGER M, INTEGER N, + INTEGER K, COMPLEX ALPHA, COMPLEX(*) A, + INTEGER LDA, COMPLEX(*) B, INTEGER LDB, + COMPLEX BETA, COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: CSYMM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, INTEGER M, INTEGER N, + COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA, + COMPLEX(*) B, INTEGER LDB, COMPLEX BETA, + COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: CSYRK ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA, + COMPLEX BETA, COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: CSYR2K ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA, + COMPLEX(*) B, INTEGER LDB, COMPLEX BETA, + COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: CTRMM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, CHARACTER*1 TRANSA, + CHARACTER*1 DIAG, INTEGER M, INTEGER N, + COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA, + COMPLEX(*) B, INTEGER LDB ) ; +SUBROUTINE: CTRSM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, CHARACTER*1 TRANSA, + CHARACTER*1 DIAG, INTEGER M, INTEGER N, + COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA, + COMPLEX(*) B, INTEGER LDB ) ; + +SUBROUTINE: ZGEMM ( CHARACTER*1 TRANSA, + CHARACTER*1 TRANSB, INTEGER M, INTEGER N, + INTEGER K, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, + INTEGER LDA, DOUBLE-COMPLEX(*) B, INTEGER LDB, + DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: ZSYMM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, INTEGER M, INTEGER N, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX(*) B, INTEGER LDB, DOUBLE-COMPLEX BETA, + DOUBLE-COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: ZSYRK ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: ZSYR2K ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX(*) B, INTEGER LDB, DOUBLE-COMPLEX BETA, + DOUBLE-COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: ZTRMM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, CHARACTER*1 TRANSA, + CHARACTER*1 DIAG, INTEGER M, INTEGER N, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX(*) B, INTEGER LDB ) ; +SUBROUTINE: ZTRSM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, CHARACTER*1 TRANSA, + CHARACTER*1 DIAG, INTEGER M, INTEGER N, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX(*) B, INTEGER LDB ) ; + +SUBROUTINE: CHEMM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, INTEGER M, INTEGER N, + COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA, + COMPLEX(*) B, INTEGER LDB, COMPLEX BETA, + COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: CHERK ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + REAL ALPHA, COMPLEX(*) A, INTEGER LDA, + REAL BETA, COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: CHER2K ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA, + COMPLEX(*) B, INTEGER LDB, REAL BETA, + COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: ZHEMM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, INTEGER M, INTEGER N, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX(*) B, INTEGER LDB, DOUBLE-COMPLEX BETA, + DOUBLE-COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: ZHERK ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + REAL ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA, + REAL BETA, DOUBLE-COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: ZHER2K ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX(*) B, INTEGER LDB, REAL BETA, + DOUBLE-COMPLEX(*) C, INTEGER LDC ) ; diff --git a/basis/math/blas/ffi/summary.txt b/basis/math/blas/ffi/summary.txt new file mode 100644 index 0000000000..8c0106b173 --- /dev/null +++ b/basis/math/blas/ffi/summary.txt @@ -0,0 +1 @@ +Low-level bindings to the Basic Linear Algebra Subroutines (BLAS) library diff --git a/basis/math/blas/cblas/tags.txt b/basis/math/blas/ffi/tags.txt similarity index 63% rename from basis/math/blas/cblas/tags.txt rename to basis/math/blas/ffi/tags.txt index 241ec1ecda..f468a9989d 100644 --- a/basis/math/blas/cblas/tags.txt +++ b/basis/math/blas/ffi/tags.txt @@ -1,2 +1,3 @@ math bindings +fortran diff --git a/basis/math/blas/matrices/matrices-docs.factor b/basis/math/blas/matrices/matrices-docs.factor index f20a565e1f..17d2f9ccd1 100644 --- a/basis/math/blas/matrices/matrices-docs.factor +++ b/basis/math/blas/matrices/matrices-docs.factor @@ -8,40 +8,40 @@ ARTICLE: "math.blas-summary" "Basic Linear Algebra Subroutines (BLAS) interface" { $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 C interface can be accessed directly through the " { $vocab-link "math.blas.cblas" } " vocabulary." ; +"The low-level BLAS Fortran interface can be accessed directly through the " { $vocab-link "math.blas.ffi" } " vocabulary." ; ARTICLE: "math.blas-types" "BLAS interface types" "BLAS vectors come in single- and double-precision, real and complex flavors:" { $subsection float-blas-vector } { $subsection double-blas-vector } -{ $subsection float-complex-blas-vector } -{ $subsection double-complex-blas-vector } +{ $subsection complex-float-blas-vector } +{ $subsection complex-double-blas-vector } "These vector types all follow the " { $link sequence } " protocol. In addition, there are corresponding types for matrix data:" { $subsection float-blas-matrix } { $subsection double-blas-matrix } -{ $subsection float-complex-blas-matrix } -{ $subsection double-complex-blas-matrix } +{ $subsection complex-float-blas-matrix } +{ $subsection complex-double-blas-matrix } "There are BOA constructors for all vector and matrix types, which provide the most flexibility in specifying memory layout:" { $subsection } { $subsection } -{ $subsection } -{ $subsection } +{ $subsection } +{ $subsection } { $subsection } { $subsection } -{ $subsection } -{ $subsection } +{ $subsection } +{ $subsection } "For the simple case of creating a dense, zero-filled vector or matrix, simple empty object constructors are provided:" { $subsection } { $subsection } "BLAS vectors and matrices can also be constructed from other Factor sequences:" { $subsection >float-blas-vector } { $subsection >double-blas-vector } -{ $subsection >float-complex-blas-vector } -{ $subsection >double-complex-blas-vector } +{ $subsection >complex-float-blas-vector } +{ $subsection >complex-double-blas-vector } { $subsection >float-blas-matrix } { $subsection >double-blas-matrix } -{ $subsection >float-complex-blas-matrix } -{ $subsection >double-complex-blas-matrix } ; +{ $subsection >complex-float-blas-matrix } +{ $subsection >complex-double-blas-matrix } ; ARTICLE: "math.blas.matrices" "BLAS interface matrix operations" "Transposing and slicing matrices:" @@ -87,8 +87,8 @@ HELP: blas-matrix-base { $list { { $link float-blas-matrix } } { { $link double-blas-matrix } } - { { $link float-complex-blas-matrix } } - { { $link double-complex-blas-matrix } } + { { $link complex-float-blas-matrix } } + { { $link complex-double-blas-matrix } } } "All of these subclasses share the same tuple layout:" { $list @@ -104,14 +104,14 @@ HELP: float-blas-matrix { $class-description "A matrix of single-precision floating-point values. For details on the tuple layout, see " { $link blas-matrix-base } "." } ; HELP: double-blas-matrix { $class-description "A matrix of double-precision floating-point values. For details on the tuple layout, see " { $link blas-matrix-base } "." } ; -HELP: float-complex-blas-matrix +HELP: complex-float-blas-matrix { $class-description "A matrix of single-precision floating-point complex values. Complex values are stored in memory as two consecutive float values, real part then imaginary part. For details on the tuple layout, see " { $link blas-matrix-base } "." } ; -HELP: double-complex-blas-matrix +HELP: complex-double-blas-matrix { $class-description "A matrix of double-precision floating-point complex values. Complex values are stored in memory as two consecutive float values, real part then imaginary part. For details on the tuple layout, see " { $link blas-matrix-base } "." } ; { - float-blas-matrix double-blas-matrix float-complex-blas-matrix double-complex-blas-matrix - float-blas-vector double-blas-vector float-complex-blas-vector double-complex-blas-vector + float-blas-matrix double-blas-matrix complex-float-blas-matrix complex-double-blas-matrix + float-blas-vector double-blas-vector complex-float-blas-vector complex-double-blas-vector } related-words HELP: Mwidth @@ -272,7 +272,7 @@ HELP: cmatrix{ { 0.0 0.0 -1.0 3.0 } { 0.0 0.0 0.0 C{ 0.0 -1.0 } } } "> } -{ $description "Construct a literal " { $link float-complex-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ; +{ $description "Construct a literal " { $link complex-float-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ; HELP: zmatrix{ { $syntax <" zmatrix{ @@ -281,7 +281,7 @@ HELP: zmatrix{ { 0.0 0.0 -1.0 3.0 } { 0.0 0.0 0.0 C{ 0.0 -1.0 } } } "> } -{ $description "Construct a literal " { $link double-complex-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ; +{ $description "Construct a literal " { $link complex-double-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ; { POSTPONE: smatrix{ POSTPONE: dmatrix{ diff --git a/basis/math/blas/matrices/matrices.factor b/basis/math/blas/matrices/matrices.factor index d9653fca6f..6fad545501 100755 --- a/basis/math/blas/matrices/matrices.factor +++ b/basis/math/blas/matrices/matrices.factor @@ -1,11 +1,13 @@ USING: accessors alien alien.c-types arrays byte-arrays combinators combinators.short-circuit fry kernel locals macros -math math.blas.cblas math.blas.vectors math.blas.vectors.private +math math.blas.ffi math.blas.vectors math.blas.vectors.private math.complex math.functions math.order functors words sequences sequences.merged sequences.private shuffle specialized-arrays.direct.float specialized-arrays.direct.double specialized-arrays.float specialized-arrays.double -parser prettyprint.backend prettyprint.custom ; +specialized-arrays.direct.complex-float specialized-arrays.direct.complex-double +specialized-arrays.complex-float specialized-arrays.complex-double +parser prettyprint.backend prettyprint.custom ascii ; IN: math.blas.matrices TUPLE: blas-matrix-base underlying ld rows cols transpose ; @@ -25,7 +27,7 @@ GENERIC: n*M.M+n*M! ( alpha A B beta C -- C=alpha*A.B+beta*C ) > [ CblasTrans ] [ CblasNoTrans ] if ; + transpose>> [ "T" ] [ "N" ] if ; GENERIC: (blas-matrix-like) ( data ld rows cols transpose exemplar -- matrix ) @@ -38,73 +40,70 @@ GENERIC: (blas-matrix-like) ( data ld rows cols transpose exemplar -- matrix ) unless ; :: (prepare-gemv) - ( alpha A x beta y >c-arg -- order A-trans m n alpha A-data A-ld x-data x-inc beta y-data y-inc - y ) + ( alpha A x beta y -- A-trans m n alpha A-data A-ld x-data x-inc beta y-data y-inc + y ) A x y (validate-gemv) - CblasColMajor A (blas-transpose) A rows>> A cols>> - alpha >c-arg call - A underlying>> + alpha + A A ld>> - x underlying>> + x x inc>> - beta >c-arg call - y underlying>> + beta + y y inc>> y ; inline : (validate-ger) ( x y A -- ) { - [ nip [ length>> ] [ Mheight ] bi* = ] - [ nipd [ length>> ] [ Mwidth ] bi* = ] + [ [ length>> ] [ drop ] [ Mheight ] tri* = ] + [ [ drop ] [ length>> ] [ Mwidth ] tri* = ] } 3&& [ "Mismatched vertices and matrix in vector outer product" throw ] unless ; :: (prepare-ger) - ( alpha x y A >c-arg -- order m n alpha x-data x-inc y-data y-inc A-data A-ld - A ) + ( alpha x y A -- m n alpha x-data x-inc y-data y-inc A-data A-ld + A ) x y A (validate-ger) - CblasColMajor A rows>> A cols>> - alpha >c-arg call - x underlying>> + alpha + x x inc>> - y underlying>> + y y inc>> - A underlying>> + A A ld>> A f >>transpose ; inline : (validate-gemm) ( A B C -- ) { - [ drop [ Mwidth ] [ Mheight ] bi* = ] - [ nip [ Mheight ] bi@ = ] - [ nipd [ Mwidth ] bi@ = ] + [ [ Mwidth ] [ Mheight ] [ drop ] tri* = ] + [ [ Mheight ] [ drop ] [ Mheight ] tri* = ] + [ [ drop ] [ Mwidth ] [ Mwidth ] tri* = ] } 3&& [ "Mismatched matrices in matrix multiplication" throw ] unless ; :: (prepare-gemm) - ( alpha A B beta C >c-arg -- order A-trans B-trans m n k alpha A-data A-ld B-data B-ld beta C-data C-ld - C ) + ( alpha A B beta C -- A-trans B-trans m n k alpha A-data A-ld B-data B-ld beta C-data C-ld + C ) A B C (validate-gemm) - CblasColMajor A (blas-transpose) B (blas-transpose) C rows>> C cols>> A Mwidth - alpha >c-arg call - A underlying>> + alpha + A A ld>> - B underlying>> + B B ld>> - beta >c-arg call - C underlying>> + beta + C C ld>> C f >>transpose ; inline @@ -250,16 +249,18 @@ FUNCTOR: (define-blas-matrix) ( TYPE T U C -- ) VECTOR IS ${TYPE}-blas-vector IS <${TYPE}-blas-vector> >ARRAY IS >${TYPE}-array -TYPE>ARG IS ${TYPE}>arg -XGEMV IS cblas_${T}gemv -XGEMM IS cblas_${T}gemm -XGERU IS cblas_${T}ger${U} -XGERC IS cblas_${T}ger${C} +XGEMV IS ${T}GEMV +XGEMM IS ${T}GEMM +XGERU IS ${T}GER${U} +XGERC IS ${T}GER${C} MATRIX DEFINES-CLASS ${TYPE}-blas-matrix DEFINES <${TYPE}-blas-matrix> >MATRIX DEFINES >${TYPE}-blas-matrix -XMATRIX{ DEFINES ${T}matrix{ + +t [ T >lower ] + +XMATRIX{ DEFINES ${t}matrix{ WHERE @@ -277,21 +278,16 @@ M: MATRIX (blas-vector-like) drop ; : >MATRIX ( arrays -- matrix ) - [ >ARRAY underlying>> ] (>matrix) - ; + [ >ARRAY underlying>> ] (>matrix) ; M: VECTOR n*M.V+n*V! - [ TYPE>ARG ] (prepare-gemv) - [ XGEMV ] dip ; + (prepare-gemv) [ XGEMV ] dip ; M: MATRIX n*M.M+n*M! - [ TYPE>ARG ] (prepare-gemm) - [ XGEMM ] dip ; + (prepare-gemm) [ XGEMM ] dip ; M: MATRIX n*V(*)V+M! - [ TYPE>ARG ] (prepare-ger) - [ XGERU ] dip ; + (prepare-ger) [ XGERU ] dip ; M: MATRIX n*V(*)Vconj+M! - [ TYPE>ARG ] (prepare-ger) - [ XGERC ] dip ; + (prepare-ger) [ XGERC ] dip ; : XMATRIX{ \ } [ >MATRIX ] parse-literal ; parsing @@ -304,12 +300,12 @@ M: MATRIX pprint-delims : define-real-blas-matrix ( TYPE T -- ) "" "" (define-blas-matrix) ; : define-complex-blas-matrix ( TYPE T -- ) - "u" "c" (define-blas-matrix) ; + "U" "C" (define-blas-matrix) ; -"float" "s" define-real-blas-matrix -"double" "d" define-real-blas-matrix -"float-complex" "c" define-complex-blas-matrix -"double-complex" "z" define-complex-blas-matrix +"float" "S" define-real-blas-matrix +"double" "D" define-real-blas-matrix +"complex-float" "C" define-complex-blas-matrix +"complex-double" "Z" define-complex-blas-matrix >> diff --git a/basis/math/blas/vectors/tags.txt b/basis/math/blas/vectors/tags.txt index ede10ab61b..241ec1ecda 100644 --- a/basis/math/blas/vectors/tags.txt +++ b/basis/math/blas/vectors/tags.txt @@ -1 +1,2 @@ math +bindings diff --git a/basis/math/blas/vectors/vectors-docs.factor b/basis/math/blas/vectors/vectors-docs.factor index b37a4b966e..badc317189 100644 --- a/basis/math/blas/vectors/vectors-docs.factor +++ b/basis/math/blas/vectors/vectors-docs.factor @@ -37,8 +37,8 @@ HELP: blas-vector-base { $list { { $link float-blas-vector } } { { $link double-blas-vector } } - { { $link float-complex-blas-vector } } - { { $link double-complex-blas-vector } } + { { $link complex-float-blas-vector } } + { { $link complex-double-blas-vector } } } "All of these subclasses share the same tuple layout:" { $list @@ -51,10 +51,10 @@ HELP: float-blas-vector { $class-description "A vector of single-precision floating-point values. For details on the tuple layout, see " { $link blas-vector-base } "." } ; HELP: double-blas-vector { $class-description "A vector of double-precision floating-point values. For details on the tuple layout, see " { $link blas-vector-base } "." } ; -HELP: float-complex-blas-vector -{ $class-description "A vector of single-precision floating-point complex values. Complex values are stored in memory as two consecutive float values, real part then imaginary part. For details on the tuple layout, see " { $link blas-vector-base } "." } ; -HELP: double-complex-blas-vector -{ $class-description "A vector of single-precision floating-point complex values. Complex values are stored in memory as two consecutive float values, real part then imaginary part. For details on the tuple layout, see " { $link blas-vector-base } "." } ; +HELP: complex-float-blas-vector +{ $class-description "A vector of single-precision floating-point complex values. For details on the tuple layout, see " { $link blas-vector-base } "." } ; +HELP: complex-double-blas-vector +{ $class-description "A vector of double-precision floating-point complex values. For details on the tuple layout, see " { $link blas-vector-base } "." } ; HELP: n*V+V! { $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "y=alpha*x+y" blas-vector-base } } @@ -93,7 +93,7 @@ HELP: Viamax HELP: Vamax { $values { "x" blas-vector-base } { "max" number } } -{ $description "Return the value of the element in " { $snippet "x" } " with the largest norm-1. If more than one element has the same norm-1, returns the first element. Corresponds to the IxAMAX routines in BLAS." } ; +{ $description "Return the value of the element in " { $snippet "x" } " with the largest norm-1. If more than one element has the same norm-1, returns the element closest to the beginning. Corresponds to the IxAMAX routines in BLAS." } ; { Viamax Vamax } related-words @@ -145,11 +145,11 @@ HELP: dvector{ HELP: cvector{ { $syntax "cvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" } -{ $description "Construct a literal " { $link float-complex-blas-vector } "." } ; +{ $description "Construct a literal " { $link complex-float-blas-vector } "." } ; HELP: zvector{ { $syntax "dvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" } -{ $description "Construct a literal " { $link double-complex-blas-vector } "." } ; +{ $description "Construct a literal " { $link complex-double-blas-vector } "." } ; { POSTPONE: svector{ POSTPONE: dvector{ diff --git a/basis/math/blas/vectors/vectors-tests.factor b/basis/math/blas/vectors/vectors-tests.factor index da271a4fc7..ef2f7ad6f9 100644 --- a/basis/math/blas/vectors/vectors-tests.factor +++ b/basis/math/blas/vectors/vectors-tests.factor @@ -1,4 +1,4 @@ -USING: kernel math.blas.vectors sequences tools.test ; +USING: kernel math.blas.vectors math.functions sequences tools.test ; IN: math.blas.vectors.tests ! clone @@ -126,11 +126,11 @@ unit-test ! Vnorm -[ 5.0 ] [ svector{ 3.0 4.0 } Vnorm ] unit-test -[ 5.0 ] [ dvector{ 3.0 4.0 } Vnorm ] unit-test +[ t ] [ svector{ 3.0 4.0 } Vnorm 5.0 0.000001 ~ ] unit-test +[ t ] [ dvector{ 3.0 4.0 } Vnorm 5.0 0.000001 ~ ] unit-test -[ 13.0 ] [ cvector{ C{ 3.0 4.0 } 12.0 } Vnorm ] unit-test -[ 13.0 ] [ zvector{ C{ 3.0 4.0 } 12.0 } Vnorm ] unit-test +[ t ] [ cvector{ C{ 3.0 4.0 } 12.0 } Vnorm 13.0 0.000001 ~ ] unit-test +[ t ] [ zvector{ C{ 3.0 4.0 } 12.0 } Vnorm 13.0 0.000001 ~ ] unit-test ! Vasum diff --git a/basis/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor index 4e61f4478e..84b5fd9e6f 100755 --- a/basis/math/blas/vectors/vectors.factor +++ b/basis/math/blas/vectors/vectors.factor @@ -1,10 +1,12 @@ -USING: accessors alien alien.c-types arrays byte-arrays combinators -combinators.short-circuit fry kernel math math.blas.cblas -math.complex math.functions math.order sequences.complex -sequences.complex-components sequences sequences.private +USING: accessors alien alien.c-types arrays ascii byte-arrays combinators +combinators.short-circuit fry kernel math math.blas.ffi +math.complex math.functions math.order sequences sequences.private functors words locals parser prettyprint.backend prettyprint.custom specialized-arrays.float specialized-arrays.double -specialized-arrays.direct.float specialized-arrays.direct.double ; +specialized-arrays.direct.float specialized-arrays.direct.double +specialized-arrays.complex-float specialized-arrays.complex-double +specialized-arrays.direct.complex-float +specialized-arrays.direct.complex-double ; IN: math.blas.vectors TUPLE: blas-vector-base underlying length inc ; @@ -31,7 +33,7 @@ GENERIC: (blas-direct-array) ( blas-vector -- direct-array ) : shorter-length ( v1 v2 -- length ) [ length>> ] bi@ min ; inline : data-and-inc ( v -- data inc ) - [ underlying>> ] [ inc>> ] bi ; inline + [ ] [ inc>> ] bi ; inline : datas-and-incs ( v1 v2 -- v1-data v1-inc v2-data v2-inc ) [ data-and-inc ] bi@ ; inline @@ -130,15 +132,20 @@ FUNCTOR: (define-blas-vector) ( TYPE T -- ) IS >ARRAY IS >${TYPE}-array -XCOPY IS cblas_${T}copy -XSWAP IS cblas_${T}swap -IXAMAX IS cblas_i${T}amax +XCOPY IS ${T}COPY +XSWAP IS ${T}SWAP +IXAMAX IS I${T}AMAX VECTOR DEFINES-CLASS ${TYPE}-blas-vector DEFINES <${TYPE}-blas-vector> >VECTOR DEFINES >${TYPE}-blas-vector -XVECTOR{ DEFINES ${T}vector{ +t [ T >lower ] + +XVECTOR{ DEFINES ${t}vector{ + +XAXPY IS ${T}AXPY +XSCAL IS ${T}SCAL WHERE @@ -157,7 +164,7 @@ M: VECTOR element-type M: VECTOR Vswap (prepare-swap) [ XSWAP ] 2dip ; M: VECTOR Viamax - (prepare-nrm2) IXAMAX ; + (prepare-nrm2) IXAMAX 1- ; M: VECTOR (blas-vector-like) drop ; @@ -167,6 +174,11 @@ M: VECTOR (blas-direct-array) [ [ length>> ] [ inc>> ] bi * ] bi ; +M: VECTOR n*V+V! + (prepare-axpy) [ XAXPY ] dip ; +M: VECTOR n*V! + (prepare-scal) [ XSCAL ] dip ; + : XVECTOR{ \ } [ >VECTOR ] parse-literal ; parsing M: VECTOR pprint-delims @@ -178,11 +190,9 @@ M: VECTOR pprint-delims FUNCTOR: (define-real-blas-vector) ( TYPE T -- ) VECTOR IS ${TYPE}-blas-vector -XDOT IS cblas_${T}dot -XNRM2 IS cblas_${T}nrm2 -XASUM IS cblas_${T}asum -XAXPY IS cblas_${T}axpy -XSCAL IS cblas_${T}scal +XDOT IS ${T}DOT +XNRM2 IS ${T}NRM2 +XASUM IS ${T}ASUM WHERE @@ -194,33 +204,6 @@ M: VECTOR Vnorm (prepare-nrm2) XNRM2 ; M: VECTOR Vasum (prepare-nrm2) XASUM ; -M: VECTOR n*V+V! - (prepare-axpy) [ XAXPY ] dip ; -M: VECTOR n*V! - (prepare-scal) [ XSCAL ] dip ; - -;FUNCTOR - - -FUNCTOR: (define-complex-helpers) ( TYPE -- ) - - DEFINES ->COMPLEX-ARRAY DEFINES >${TYPE}-complex-array -ARG>COMPLEX DEFINES arg>${TYPE}-complex -COMPLEX>ARG DEFINES ${TYPE}-complex>arg - IS ->ARRAY IS >${TYPE}-array - -WHERE - -: ( alien len -- sequence ) - 1 shift ; -: >COMPLEX-ARRAY ( sequence -- sequence ) - >ARRAY ; -: COMPLEX>ARG ( complex -- alien ) - >rect 2array >ARRAY underlying>> ; -: ARG>COMPLEX ( alien -- complex ) - 2 first2 rect> ; ;FUNCTOR @@ -228,35 +211,21 @@ WHERE FUNCTOR: (define-complex-blas-vector) ( TYPE C S -- ) VECTOR IS ${TYPE}-blas-vector -XDOTU_SUB IS cblas_${C}dotu_sub -XDOTC_SUB IS cblas_${C}dotc_sub -XXNRM2 IS cblas_${S}${C}nrm2 -XXASUM IS cblas_${S}${C}asum -XAXPY IS cblas_${C}axpy -XSCAL IS cblas_${C}scal -TYPE>ARG IS ${TYPE}>arg -ARG>TYPE IS arg>${TYPE} +XDOTU IS ${C}DOTU +XDOTC IS ${C}DOTC +XXNRM2 IS ${S}${C}NRM2 +XXASUM IS ${S}${C}ASUM WHERE M: VECTOR V. - (prepare-dot) TYPE - [ XDOTU_SUB ] keep - ARG>TYPE ; + (prepare-dot) XDOTU ; M: VECTOR V.conj - (prepare-dot) TYPE - [ XDOTC_SUB ] keep - ARG>TYPE ; + (prepare-dot) XDOTC ; M: VECTOR Vnorm (prepare-nrm2) XXNRM2 ; M: VECTOR Vasum (prepare-nrm2) XXASUM ; -M: VECTOR n*V+V! - [ TYPE>ARG ] 2dip - (prepare-axpy) [ XAXPY ] dip ; -M: VECTOR n*V! - [ TYPE>ARG ] dip - (prepare-scal) [ XSCAL ] dip ; ;FUNCTOR @@ -264,16 +233,14 @@ M: VECTOR n*V! : define-real-blas-vector ( TYPE T -- ) [ (define-blas-vector) ] [ (define-real-blas-vector) ] 2bi ; -:: define-complex-blas-vector ( TYPE C S -- ) - TYPE (define-complex-helpers) - TYPE "-complex" append - [ C (define-blas-vector) ] - [ C S (define-complex-blas-vector) ] bi ; +: define-complex-blas-vector ( TYPE C S -- ) + [ drop (define-blas-vector) ] + [ (define-complex-blas-vector) ] 3bi ; -"float" "s" define-real-blas-vector -"double" "d" define-real-blas-vector -"float" "c" "s" define-complex-blas-vector -"double" "z" "d" define-complex-blas-vector +"float" "S" define-real-blas-vector +"double" "D" define-real-blas-vector +"complex-float" "C" "S" define-complex-blas-vector +"complex-double" "Z" "D" define-complex-blas-vector >> diff --git a/basis/math/polynomials/polynomials.factor b/basis/math/polynomials/polynomials.factor index 1ece3d915e..749bde3a10 100644 --- a/basis/math/polynomials/polynomials.factor +++ b/basis/math/polynomials/polynomials.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel make math math.order math.vectors sequences shuffle +USING: arrays kernel make math math.order math.vectors sequences splitting vectors ; IN: math.polynomials @@ -75,7 +75,7 @@ PRIVATE> PRIVATE> : pgcd ( p q -- a d ) - swap V{ 0 } clone V{ 1 } clone 2swap (pgcd) [ >array ] bi@ ; + [ V{ 0 } clone V{ 1 } clone ] 2dip swap (pgcd) [ >array ] bi@ ; : pdiff ( p -- p' ) dup length v* { 0 } ?head drop ; diff --git a/basis/pack/pack.factor b/basis/pack/pack.factor index 9078817206..27cba6d6e7 100755 --- a/basis/pack/pack.factor +++ b/basis/pack/pack.factor @@ -87,12 +87,12 @@ CONSTANT: packed-length-table { CHAR: D 8 } } +PRIVATE> + MACRO: pack ( str -- quot ) [ pack-table at '[ _ execute ] ] { } map-as '[ [ [ _ spread ] input - : ch>packed-length ( ch -- n ) packed-length-table at ; inline @@ -113,14 +113,14 @@ PRIVATE> : start/end ( seq -- seq1 seq2 ) [ 0 [ + ] accumulate nip dup ] keep v+ ; inline +PRIVATE> + MACRO: unpack ( str -- quot ) [ [ ch>packed-length ] { } map-as start/end ] [ [ unpack-table at '[ @ ] ] { } map-as ] bi [ '[ [ _ _ ] dip @ ] ] 3map '[ [ _ cleave ] output>array ] ; -PRIVATE> - : unpack-native ( seq str -- seq ) '[ _ _ unpack ] with-native-endian ; inline diff --git a/basis/persistent/deques/deques-docs.factor b/basis/persistent/deques/deques-docs.factor index 43018bed16..f1027d107b 100644 --- a/basis/persistent/deques/deques-docs.factor +++ b/basis/persistent/deques/deques-docs.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2008 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax kernel sequences ; IN: persistent.deques diff --git a/basis/persistent/deques/deques.factor b/basis/persistent/deques/deques.factor index ece1cda772..8f93ae1ab8 100644 --- a/basis/persistent/deques/deques.factor +++ b/basis/persistent/deques/deques.factor @@ -1,7 +1,6 @@ -! Copyback (C) 2008 Daniel Ehrenberg +! Copyright (C) 2008 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors math lists ; -QUALIFIED: sequences +USING: kernel accessors math lists sequences combinators.short-circuit ; IN: persistent.deques ! Amortized O(1) push/pop on both ends for single-threaded access @@ -9,30 +8,13 @@ IN: persistent.deques ! same source, it could take O(m) amortized time per update. TUPLE: deque { front read-only } { back read-only } ; -: ( -- deque ) T{ deque } ; +: ( -- deque ) + T{ deque f +nil+ +nil+ } ; : deque-empty? ( deque -- ? ) - [ front>> ] [ back>> ] bi or not ; + { [ front>> nil? ] [ back>> nil? ] } 1&& ; [ front>> car ] [ [ front>> cdr ] [ back>> ] bi deque boa ] bi ; inline : transfer ( deque -- item newdeque ) - back>> [ split-reverse deque boa remove ] - [ "Popping from an empty deque" throw ] if* ; inline + back>> dup nil? + [ "Popping from an empty deque" throw ] + [ split-reverse deque boa remove ] if ; inline : pop ( deque -- item newdeque ) - dup front>> [ remove ] [ transfer ] if ; inline + dup front>> nil? [ transfer ] [ remove ] if ; inline PRIVATE> : pop-front ( deque -- item newdeque ) @@ -74,12 +57,14 @@ PRIVATE> : pop-back ( deque -- item newdeque ) [ pop ] flipped ; -: peek-front ( deque -- item ) pop-front drop ; +: peek-front ( deque -- item ) + pop-front drop ; -: peek-back ( deque -- item ) pop-back drop ; +: peek-back ( deque -- item ) + pop-back drop ; : sequence>deque ( sequence -- deque ) - [ push-back ] sequences:reduce ; + [ push-back ] reduce ; : deque>sequence ( deque -- sequence ) - [ dup deque-empty? not ] [ pop-front swap ] [ ] sequences:produce nip ; + [ dup deque-empty? not ] [ pop-front swap ] [ ] produce nip ; diff --git a/basis/regexp/traversal/traversal.factor b/basis/regexp/traversal/traversal.factor index d8c25eda18..104a6c2ce1 100644 --- a/basis/regexp/traversal/traversal.factor +++ b/basis/regexp/traversal/traversal.factor @@ -2,8 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs combinators kernel math quotations sequences regexp.parser regexp.classes fry arrays -combinators.short-circuit regexp.utils prettyprint regexp.nfa -shuffle ; +combinators.short-circuit regexp.utils prettyprint regexp.nfa ; IN: regexp.traversal TUPLE: dfa-traverser @@ -170,7 +169,7 @@ M: capture-group-off flag-action ( dfa-traverser flag -- ) ] [ drop ] if ; : match-default ( transition from-state table -- to-state/f ) - nipd transitions>> at t swap at ; + [ drop ] 2dip transitions>> at t swap at ; : match-transition ( obj from-state dfa -- to-state/f ) { [ match-literal ] [ match-class ] [ match-default ] } 3|| ; diff --git a/basis/shuffle/shuffle-tests.factor b/basis/shuffle/shuffle-tests.factor index f190544e19..e091af2d06 100644 --- a/basis/shuffle/shuffle-tests.factor +++ b/basis/shuffle/shuffle-tests.factor @@ -1,5 +1,5 @@ USING: shuffle tools.test ; -[ 8 ] [ 5 6 7 8 3nip ] unit-test -[ 3 1 2 3 ] [ 1 2 3 tuckd ] unit-test [ 1 2 3 4 ] [ 3 4 1 2 2swap ] unit-test + +[ 4 2 3 ] [ 1 2 3 4 shuffle( a b c d -- d b c ) ] unit-test diff --git a/basis/shuffle/shuffle.factor b/basis/shuffle/shuffle.factor index b195e4abf9..6cae048d27 100644 --- a/basis/shuffle/shuffle.factor +++ b/basis/shuffle/shuffle.factor @@ -1,19 +1,29 @@ ! Copyright (C) 2007 Chris Double, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel generalizations ; - +USING: accessors assocs combinators effects.parser generalizations +hashtables kernel locals locals.backend macros make math +parser sequences ; IN: shuffle +index-assoc ( sequence -- assoc ) + dup length zip >hashtable ; + +PRIVATE> + +MACRO: shuffle-effect ( effect -- ) + [ out>> ] [ in>> >index-assoc ] bi + [ + [ nip assoc-size , \ narray , ] + [ [ at \ swap \ nth [ ] 3sequence ] curry map , \ cleave , ] 2bi + ] [ ] make ; + +: shuffle( + ")" parse-effect parsed \ shuffle-effect parsed ; parsing + : 2swap ( x y z t -- z t x y ) 2 2 mnswap ; inline -: nipd ( a b c -- b c ) rot drop ; inline - -: 3nip ( a b c d -- d ) 3 nnip ; inline - -: 4nip ( a b c d e -- e ) 4 nnip ; inline - : 4dup ( a b c d -- a b c d a b c d ) 4 ndup ; inline : 4drop ( a b c d -- ) 3drop drop ; inline - -: tuckd ( x y z -- z x y z ) 2 ntuck ; inline diff --git a/basis/specialized-arrays/complex-double/complex-double-tests.factor b/basis/specialized-arrays/complex-double/complex-double-tests.factor new file mode 100644 index 0000000000..9f2bcc99b7 --- /dev/null +++ b/basis/specialized-arrays/complex-double/complex-double-tests.factor @@ -0,0 +1,13 @@ +USING: kernel sequences specialized-arrays.complex-double tools.test ; +IN: specialized-arrays.complex-double.tests + +[ C{ 3.0 2.0 } ] +[ complex-double-array{ 1.0 C{ 3.0 2.0 } 5.0 } second ] unit-test + +[ C{ 1.0 0.0 } ] +[ complex-double-array{ 1.0 C{ 3.0 2.0 } 5.0 } first ] unit-test + +[ complex-double-array{ 1.0 C{ 6.0 -7.0 } 5.0 } ] [ + complex-double-array{ 1.0 C{ 3.0 2.0 } 5.0 } + dup [ C{ 6.0 -7.0 } 1 ] dip set-nth +] unit-test diff --git a/basis/specialized-arrays/complex-double/complex-double.factor b/basis/specialized-arrays/complex-double/complex-double.factor new file mode 100644 index 0000000000..00b07fb9b3 --- /dev/null +++ b/basis/specialized-arrays/complex-double/complex-double.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-arrays.complex-double + +<< "complex-double" define-array >> diff --git a/basis/specialized-arrays/complex-float/complex-float.factor b/basis/specialized-arrays/complex-float/complex-float.factor new file mode 100644 index 0000000000..5348343bae --- /dev/null +++ b/basis/specialized-arrays/complex-float/complex-float.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-arrays.complex-float + +<< "complex-float" define-array >> diff --git a/basis/specialized-arrays/direct/complex-double/complex-double.factor b/basis/specialized-arrays/direct/complex-double/complex-double.factor new file mode 100644 index 0000000000..ae8d2b5fb3 --- /dev/null +++ b/basis/specialized-arrays/direct/complex-double/complex-double.factor @@ -0,0 +1,4 @@ +USING: specialized-arrays.complex-double specialized-arrays.direct.functor ; +IN: specialized-arrays.direct.complex-double + +<< "complex-double" define-direct-array >> diff --git a/basis/specialized-arrays/direct/complex-float/complex-float.factor b/basis/specialized-arrays/direct/complex-float/complex-float.factor new file mode 100644 index 0000000000..8971196297 --- /dev/null +++ b/basis/specialized-arrays/direct/complex-float/complex-float.factor @@ -0,0 +1,4 @@ +USING: specialized-arrays.complex-float specialized-arrays.direct.functor ; +IN: specialized-arrays.direct.complex-float + +<< "complex-float" define-direct-array >> diff --git a/basis/specialized-arrays/direct/functor/functor.factor b/basis/specialized-arrays/direct/functor/functor.factor index 0c3999db44..e7e891fede 100755 --- a/basis/specialized-arrays/direct/functor/functor.factor +++ b/basis/specialized-arrays/direct/functor/functor.factor @@ -14,7 +14,7 @@ A' IS ${T}-array A DEFINES-CLASS direct-${T}-array DEFINES <${A}> -NTH [ T dup c-getter array-accessor ] +NTH [ T dup c-type-getter-boxer array-accessor ] SET-NTH [ T dup c-setter array-accessor ] WHERE diff --git a/basis/specialized-arrays/functor/functor.factor b/basis/specialized-arrays/functor/functor.factor index 3c2c53db31..09433a3b51 100644 --- a/basis/specialized-arrays/functor/functor.factor +++ b/basis/specialized-arrays/functor/functor.factor @@ -22,7 +22,7 @@ A DEFINES-CLASS ${T}-array byte-array>A DEFINES byte-array>${A} A{ DEFINES ${A}{ -NTH [ T dup c-getter array-accessor ] +NTH [ T dup c-type-getter-boxer array-accessor ] SET-NTH [ T dup c-setter array-accessor ] WHERE diff --git a/basis/specialized-arrays/specialized-arrays-docs.factor b/basis/specialized-arrays/specialized-arrays-docs.factor index 1c1b3dbc59..9015cccd8f 100644 --- a/basis/specialized-arrays/specialized-arrays-docs.factor +++ b/basis/specialized-arrays/specialized-arrays-docs.factor @@ -28,6 +28,8 @@ $nl { $snippet "ulonglong" } { $snippet "float" } { $snippet "double" } + { $snippet "complex-float" } + { $snippet "complex-double" } { $snippet "void*" } { $snippet "bool" } } diff --git a/basis/tools/annotations/annotations.factor b/basis/tools/annotations/annotations.factor index ecf3ba0a76..b436be5163 100644 --- a/basis/tools/annotations/annotations.factor +++ b/basis/tools/annotations/annotations.factor @@ -87,7 +87,7 @@ M: word annotate-methods SYMBOL: word-timing -word-timing global [ H{ } clone or ] change-at +word-timing [ H{ } clone ] initialize : reset-word-timing ( -- ) word-timing get clear-assoc ; diff --git a/basis/tools/deploy/backend/backend.factor b/basis/tools/deploy/backend/backend.factor old mode 100644 new mode 100755 index 636e44062e..ff851edce6 --- a/basis/tools/deploy/backend/backend.factor +++ b/basis/tools/deploy/backend/backend.factor @@ -11,8 +11,8 @@ tools.deploy.config.editor bootstrap.image io.encodings.utf8 destructors accessors ; IN: tools.deploy.backend -: copy-vm ( executable bundle-name extension -- vm ) - [ prepend-path ] dip append vm over copy-file ; +: copy-vm ( executable bundle-name -- vm ) + prepend-path vm over copy-file ; : copy-fonts ( name dir -- ) deploy-ui? get [ diff --git a/basis/tools/deploy/macosx/macosx.factor b/basis/tools/deploy/macosx/macosx.factor old mode 100644 new mode 100755 index 91b4d603af..8fe31ac6cc --- a/basis/tools/deploy/macosx/macosx.factor +++ b/basis/tools/deploy/macosx/macosx.factor @@ -54,7 +54,7 @@ IN: tools.deploy.macosx } cleave ] [ create-app-plist ] - [ "Contents/MacOS/" append-path "" copy-vm ] 2tri + [ "Contents/MacOS/" append-path copy-vm ] 2tri dup OCT: 755 set-file-permissions ; : deploy.app-image ( vocab bundle-name -- str ) diff --git a/basis/tools/deploy/unix/unix.factor b/basis/tools/deploy/unix/unix.factor old mode 100644 new mode 100755 index 9e0bb8ac68..c9bf308357 --- a/basis/tools/deploy/unix/unix.factor +++ b/basis/tools/deploy/unix/unix.factor @@ -8,7 +8,7 @@ IN: tools.deploy.unix : create-app-dir ( vocab bundle-name -- vm ) dup "" copy-fonts - "" copy-vm + copy-vm dup OCT: 755 set-file-permissions ; : bundle-name ( -- str ) diff --git a/basis/tools/deploy/windows/windows.factor b/basis/tools/deploy/windows/windows.factor index 7ce635b1ba..0e9146b26e 100755 --- a/basis/tools/deploy/windows/windows.factor +++ b/basis/tools/deploy/windows/windows.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2007, 2008 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io io.files io.directories kernel namespaces sequences system -tools.deploy.backend tools.deploy.config -tools.deploy.config.editor assocs hashtables prettyprint -combinators windows.shell32 windows.user32 ; +USING: io io.files io.pathnames io.directories kernel namespaces +sequences locals system splitting tools.deploy.backend +tools.deploy.config tools.deploy.config.editor assocs hashtables +prettyprint combinators windows.shell32 windows.user32 ; IN: tools.deploy.windows : copy-dll ( bundle-name -- ) @@ -15,13 +15,18 @@ IN: tools.deploy.windows "resource:zlib1.dll" } swap copy-files-into ; +:: copy-vm ( executable bundle-name extension -- vm ) + vm "." split1-last drop extension append + bundle-name executable ".exe" append append-path + [ copy-file ] keep ; + : create-exe-dir ( vocab bundle-name -- vm ) dup copy-dll deploy-ui? get [ - dup copy-freetype - dup "" copy-fonts - ] when - ".exe" copy-vm ; + [ copy-freetype ] + [ "" copy-fonts ] + [ ".exe" copy-vm ] tri + ] [ ".com" copy-vm ] if ; M: winnt deploy* "resource:" [ diff --git a/basis/tools/hexdump/hexdump.factor b/basis/tools/hexdump/hexdump.factor index b646760889..63b55729fb 100644 --- a/basis/tools/hexdump/hexdump.factor +++ b/basis/tools/hexdump/hexdump.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays io io.streams.string kernel math math.parser -namespaces sequences splitting grouping strings ascii byte-arrays ; +namespaces sequences splitting grouping strings ascii +byte-arrays byte-vectors ; IN: tools.hexdump hex-digits write ] [ >ascii write ] bi nl ; +: hexdump-bytes ( bytes -- ) + [ length write-header ] + [ 16 [ write-hex-line ] each-index ] bi ; + PRIVATE> GENERIC: hexdump. ( byte-array -- ) -M: byte-array hexdump. - [ length write-header ] - [ 16 [ write-hex-line ] each-index ] bi ; +M: byte-array hexdump. hexdump-bytes ; + +M: byte-vector hexdump. hexdump-bytes ; : hexdump ( byte-array -- str ) [ hexdump. ] with-string-writer ; diff --git a/basis/ui/cocoa/cocoa.factor b/basis/ui/cocoa/cocoa.factor index 331c0a698c..2fc8856b26 100755 --- a/basis/ui/cocoa/cocoa.factor +++ b/basis/ui/cocoa/cocoa.factor @@ -141,9 +141,9 @@ CLASS: { SYMBOL: cocoa-init-hook -cocoa-init-hook global [ - [ "MiniFactor.nib" load-nib install-app-delegate ] or -] change-at +cocoa-init-hook [ + [ "MiniFactor.nib" load-nib install-app-delegate ] +] initialize M: cocoa-ui-backend ui "UI" assert.app [ diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index 732a438203..f57fb60bcd 100644 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -81,7 +81,7 @@ SYMBOL: ui-error-hook : ui-error ( error -- ) ui-error-hook get [ call ] [ die ] if* ; -ui-error-hook global [ [ rethrow ] or ] change-at +ui-error-hook [ [ rethrow ] ] initialize : draw-world ( world -- ) dup draw-world? [ diff --git a/basis/urls/urls-docs.factor b/basis/urls/urls-docs.factor index f6c25980ea..437a9419e3 100644 --- a/basis/urls/urls-docs.factor +++ b/basis/urls/urls-docs.factor @@ -82,8 +82,8 @@ HELP: parse-host { $notes "This word is used by " { $link >url } ". It can also be used directly to parse " { $snippet "host:port" } " strings which are not full URLs." } { $examples { $example - "USING: prettyprint urls ;" - "\"sbcl.org:80\" parse-host .s" + "USING: prettyprint urls kernel ;" + "\"sbcl.org:80\" parse-host .s 2drop" "\"sbcl.org\"\n80" } } ; diff --git a/basis/wrap/strings/strings-tests.factor b/basis/wrap/strings/strings-tests.factor index 0bea9b5d32..e66572dc1b 100644 --- a/basis/wrap/strings/strings-tests.factor +++ b/basis/wrap/strings/strings-tests.factor @@ -27,7 +27,7 @@ word wrap."> " " wrap-indented-string ] unit-test -[ "this text\nhas lots\nof spaces" ] +[ "this text\nhas lots of\nspaces" ] [ "this text has lots of spaces" 12 wrap-string ] unit-test [ "hello\nhow\nare\nyou\ntoday?" ] @@ -39,3 +39,5 @@ word wrap."> [ "aaa bb\nccccccc\nddddddd" ] [ "aaa bb ccccccc ddddddd" 6 wrap-string ] unit-test \ wrap-string must-infer + +[ "a b c d e f\ng h" ] [ "a b c d e f g h" 11 wrap-string ] unit-test diff --git a/basis/wrap/words/words.factor b/basis/wrap/words/words.factor index 00f257a5cf..bcf4460170 100644 --- a/basis/wrap/words/words.factor +++ b/basis/wrap/words/words.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: sequences kernel splitting.monotonic accessors wrap grouping ; +USING: sequences kernel splitting.monotonic accessors grouping wrap ; IN: wrap.words TUPLE: word key width break? ; diff --git a/basis/wrap/wrap.factor b/basis/wrap/wrap.factor index 55fe10283a..0b7f869141 100644 --- a/basis/wrap/wrap.factor +++ b/basis/wrap/wrap.factor @@ -12,18 +12,6 @@ C: element : element-length ( element -- n ) [ black>> ] [ white>> ] bi + ; -: swons ( cdr car -- cons ) - swap cons ; - -: unswons ( cons -- cdr car ) - [ cdr ] [ car ] bi ; - -: 1list? ( list -- ? ) - { [ ] [ cdr +nil+ = ] } 1&& ; - -: lists>arrays ( lists -- arrays ) - [ list>seq ] lmap>array ; - TUPLE: paragraph lines head-width tail-cost ; C: paragraph @@ -48,8 +36,10 @@ SYMBOL: line-ideal ] each drop ; inline : paragraph-cost ( paragraph -- cost ) - [ head-width>> deviation ] - [ tail-cost>> ] bi + ; + dup lines>> 1list? [ drop 0 ] [ + [ head-width>> deviation ] + [ tail-cost>> ] bi + + ] if ; : min-cost ( paragraphs -- paragraph ) [ paragraph-cost ] min-by ; @@ -78,7 +68,7 @@ SYMBOL: line-ideal 0 ; : post-process ( paragraph -- array ) - lines>> lists>arrays + lines>> deep-list>array [ [ contents>> ] map ] map ; : initialize ( elements -- elements paragraph ) diff --git a/basis/xml-rpc/xml-rpc.factor b/basis/xml-rpc/xml-rpc.factor index 9632cbb1ac..690ebe94f8 100644 --- a/basis/xml-rpc/xml-rpc.factor +++ b/basis/xml-rpc/xml-rpc.factor @@ -126,11 +126,11 @@ TAG: int xml>item children>number ; TAG: double xml>item children>number ; TAG: boolean xml>item - dup children>string { - { [ dup "1" = ] [ 2drop t ] } - { [ "0" = ] [ drop f ] } + children>string { + { "1" [ t ] } + { "0" [ f ] } [ "Bad boolean" server-error ] - } cond ; + } case ; : unstruct-member ( tag -- ) children-tags first2 diff --git a/basis/xml/syntax/syntax.factor b/basis/xml/syntax/syntax.factor index 8e6bebfe6b..067bb9ec11 100644 --- a/basis/xml/syntax/syntax.factor +++ b/basis/xml/syntax/syntax.factor @@ -174,6 +174,8 @@ PRIVATE> : [XML "XML]" [ string>chunk ] parse-def ; parsing +enum ] ; \ interpolate-xml 1 [ undo-xml ] define-pop-inverse + +PRIVATE> diff --git a/basis/xml/tests/test.factor b/basis/xml/tests/test.factor index b1f6cf002f..0372132736 100644 --- a/basis/xml/tests/test.factor +++ b/basis/xml/tests/test.factor @@ -3,7 +3,7 @@ IN: xml.tests USING: kernel xml tools.test io namespaces make sequences xml.errors xml.entities.html parser strings xml.data io.files -xml.traversal continuations assocs +xml.traversal continuations assocs io.encodings.binary sequences.deep accessors io.streams.string ; ! This is insufficient @@ -12,8 +12,14 @@ sequences.deep accessors io.streams.string ; \ string>xml must-infer SYMBOL: xml-file -[ ] [ "resource:basis/xml/tests/test.xml" - [ file>xml ] with-html-entities xml-file set ] unit-test +[ ] [ + "resource:basis/xml/tests/test.xml" + [ file>xml ] with-html-entities xml-file set +] unit-test +[ t ] [ + "resource:basis/xml/tests/test.xml" binary file-contents + [ bytes>xml ] with-html-entities xml-file get = +] unit-test [ "1.0" ] [ xml-file get prolog>> version>> ] unit-test [ f ] [ xml-file get prolog>> standalone>> ] unit-test [ "a" ] [ xml-file get space>> ] unit-test diff --git a/basis/xml/xml-docs.factor b/basis/xml/xml-docs.factor index 024b086ef9..77969c55cd 100644 --- a/basis/xml/xml-docs.factor +++ b/basis/xml/xml-docs.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax xml.data io strings ; +USING: help.markup help.syntax xml.data io strings byte-arrays ; IN: xml HELP: string>xml @@ -16,7 +16,11 @@ 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." } ; -{ string>xml read-xml file>xml } related-words +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" } } @@ -68,6 +72,7 @@ ARTICLE: { "xml" "reading" } "Reading XML" { $subsection read-xml-chunk } { $subsection string>xml-chunk } { $subsection file>xml } + { $subsection bytes>xml } "To read a DTD:" { $subsection read-dtd } { $subsection file>dtd } diff --git a/basis/xml/xml.factor b/basis/xml/xml.factor index 57c1b6dbd3..073f46cbae 100755 --- a/basis/xml/xml.factor +++ b/basis/xml/xml.factor @@ -4,7 +4,7 @@ USING: accessors arrays io io.encodings.binary io.files io.streams.string kernel namespaces sequences strings io.encodings.utf8 xml.data xml.errors xml.elements ascii xml.entities xml.writer xml.state xml.autoencoding assocs xml.tokenize -combinators.short-circuit xml.name splitting ; +combinators.short-circuit xml.name splitting io.streams.byte-array ; IN: xml : file>xml ( filename -- xml ) binary read-xml ; +: bytes>xml ( byte-array -- xml ) + binary read-xml ; + : read-dtd ( stream -- dtd ) [ H{ } clone extra-entities set diff --git a/core/alien/alien.factor b/core/alien/alien.factor index 93d1a8e306..52e9cd0f30 100644 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -51,7 +51,7 @@ M: alien equal? SYMBOL: libraries -libraries global [ H{ } assoc-like ] change-at +libraries [ H{ } clone ] initialize TUPLE: library path abi dll ; diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 561d0962ff..0469f3564a 100644 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -241,7 +241,7 @@ ARTICLE: "tuple-examples" "Tuple examples" } "An example of using a changer:" { $code - ": positions" + ": positions ( -- seq )" " {" " \"junior programmer\"" " \"senior programmer\"" diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor index 1a73e22e31..beb50f1162 100644 --- a/core/combinators/combinators-tests.factor +++ b/core/combinators/combinators-tests.factor @@ -323,4 +323,18 @@ DEFER: corner-case-1 [ t ] [ \ corner-case-1 optimized>> ] unit-test [ 4 ] [ 2 corner-case-1 ] unit-test -[ 4 ] [ 2 2 [ + ] curry 1array case ] unit-test \ No newline at end of file +[ 4 ] [ 2 2 [ + ] curry 1array case ] unit-test + +: test-case-8 ( n -- ) + { + { 1 [ "foo" ] } + } case ; + +[ 3 test-case-8 ] +[ object>> 3 = ] must-fail-with + +[ + 3 { + { 1 [ "foo" ] } + } case +] [ object>> 3 = ] must-fail-with diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index e356a6d246..daf247d678 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -49,7 +49,7 @@ ERROR: no-cond ; reverse [ no-cond ] swap alist>quot ; ! case -ERROR: no-case ; +ERROR: no-case object ; : case-find ( obj assoc -- obj' ) [ @@ -66,7 +66,7 @@ ERROR: no-case ; case-find { { [ dup array? ] [ nip second call ] } { [ dup callable? ] [ call ] } - { [ dup not ] [ no-case ] } + { [ dup not ] [ drop no-case ] } } cond ; : linear-case-quot ( default assoc -- quot ) diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index 999b783c48..ac3e99e24c 100644 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -178,6 +178,4 @@ SYMBOL: remake-generics-hook : default-recompile-hook ( words -- alist ) [ f ] { } map>assoc ; -recompile-hook global -[ [ default-recompile-hook ] or ] -change-at +recompile-hook [ [ default-recompile-hook ] ] initialize diff --git a/core/io/backend/backend.factor b/core/io/backend/backend.factor index fd5567cfa2..2f0bb1063f 100644 --- a/core/io/backend/backend.factor +++ b/core/io/backend/backend.factor @@ -8,7 +8,7 @@ SYMBOL: io-backend SINGLETON: c-io-backend -io-backend global [ c-io-backend or ] change-at +io-backend [ c-io-backend ] initialize HOOK: init-io io-backend ( -- ) diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 71183093ee..b8191004db 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -658,7 +658,7 @@ HELP: loop "hi hi hi" } "A fun loop:" { $example "USING: kernel prettyprint math ; " - "3 [ dup . 7 + 11 mod dup 3 = not ] loop" + "3 [ dup . 7 + 11 mod dup 3 = not ] loop drop" "3\n10\n6\n2\n9\n5\n1\n8\n4\n0\n7" } } ; diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index be1de76650..06fe289281 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel.private slots.private math.private classes.tuple.private ; @@ -51,7 +51,7 @@ DEFER: if ! Default : ?if ( default cond true false -- ) - pick [ roll 2drop call ] [ 2nip call ] if ; inline + pick [ drop [ drop ] 2dip call ] [ 2nip call ] if ; inline ! Slippers and dippers. ! Not declared inline because the compiler special-cases them @@ -138,6 +138,69 @@ DEFER: if : 2tri@ ( u v w y x z quot -- ) dup dup 2tri* ; inline +! Quotation building +: 2curry ( obj1 obj2 quot -- curry ) + curry curry ; inline + +: 3curry ( obj1 obj2 obj3 quot -- curry ) + curry curry curry ; inline + +: with ( param obj quot -- obj curry ) + swapd [ swapd call ] 2curry ; inline + +: prepose ( quot1 quot2 -- compose ) + swap compose ; inline + +! Curried cleavers + + +: bi-curry ( x p q -- p' q' ) [ [curry] ] bi@ bi ; inline + +: tri-curry ( x p q r -- p' q' r' ) [ [curry] ] tri@ tri ; inline + +: bi-curry* ( x y p q -- p' q' ) [ [curry] ] bi@ bi* ; inline + +: tri-curry* ( x y z p q r -- p' q' r' ) [ [curry] ] tri@ tri* ; inline + +: bi-curry@ ( x y q -- p' q' ) [curry] bi@ ; inline + +: tri-curry@ ( x y z q -- p' q' r' ) [curry] tri@ ; inline + +! Booleans +: not ( obj -- ? ) [ f ] [ t ] if ; inline + +: and ( obj1 obj2 -- ? ) over ? ; inline + +: >boolean ( obj -- ? ) [ t ] [ f ] if ; inline + +: or ( obj1 obj2 -- ? ) dupd ? ; inline + +: xor ( obj1 obj2 -- ? ) [ f swap ? ] when* ; inline + +: both? ( x y quot -- ? ) bi@ and ; inline + +: either? ( x y quot -- ? ) bi@ or ; inline + +: most ( x y quot -- z ) + [ 2dup ] dip call [ drop ] [ nip ] if ; inline + +! Loops +: loop ( pred: ( -- ? ) -- ) + [ call ] keep [ loop ] curry when ; inline recursive + +: do ( pred body tail -- pred body tail ) + over 3dip ; inline + +: while ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- ) + [ pick 3dip [ do while ] 3curry ] keep if ; inline recursive + +: until ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- ) + [ [ not ] compose ] 2dip while ; inline + ! Object protocol GENERIC: hashcode* ( depth obj -- code ) @@ -171,50 +234,6 @@ GENERIC: new ( class -- tuple ) GENERIC: boa ( ... class -- tuple ) -! Quotation building -: 2curry ( obj1 obj2 quot -- curry ) - curry curry ; inline - -: 3curry ( obj1 obj2 obj3 quot -- curry ) - curry curry curry ; inline - -: with ( param obj quot -- obj curry ) - swapd [ swapd call ] 2curry ; inline - -: prepose ( quot1 quot2 -- compose ) - swap compose ; inline - -! Booleans -: not ( obj -- ? ) [ f ] [ t ] if ; inline - -: and ( obj1 obj2 -- ? ) over ? ; inline - -: >boolean ( obj -- ? ) [ t ] [ f ] if ; inline - -: or ( obj1 obj2 -- ? ) dupd ? ; inline - -: xor ( obj1 obj2 -- ? ) [ f swap ? ] when* ; inline - -: both? ( x y quot -- ? ) bi@ and ; inline - -: either? ( x y quot -- ? ) bi@ or ; inline - -: most ( x y quot -- z ) - [ 2dup ] dip call [ drop ] [ nip ] if ; inline - -! Loops -: loop ( pred: ( -- ? ) -- ) - dup slip swap [ loop ] [ drop ] if ; inline recursive - -: do ( pred body tail -- pred body tail ) - over 3dip ; inline - -: while ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- ) - [ pick 3dip [ do while ] 3curry ] keep if ; inline recursive - -: until ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- ) - [ [ not ] compose ] 2dip while ; inline - ! Error handling -- defined early so that other files can ! throw errors before continuations are loaded : throw ( error -- * ) 5 getenv [ die ] or 1 (throw) ; diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index 7d0666328f..94ff2c1f29 100644 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -254,7 +254,7 @@ HELP: fp-infinity? { $description "Tests if " { $snippet "x" } " is an IEEE Infinity value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } { $examples { $example "USING: math prettyprint ;" "1/0. fp-infinity? ." "t" } - { $example "USING: io kernel math ;" "-1/0. [ fp-infinity? ] [ 0 < ] bi [ \"negative infinity\" print ] when" "negative infinity" } + { $example "USING: io kernel math ;" "-1/0. [ fp-infinity? ] [ 0 < ] bi and [ \"negative infinity\" print ] when" "negative infinity" } } ; { fp-nan? fp-infinity? } related-words diff --git a/core/namespaces/namespaces-docs.factor b/core/namespaces/namespaces-docs.factor index 1cc3d86e98..ff0542a7b8 100644 --- a/core/namespaces/namespaces-docs.factor +++ b/core/namespaces/namespaces-docs.factor @@ -1,6 +1,6 @@ USING: help.markup help.syntax kernel kernel.private sequences words namespaces.private quotations vectors -math.parser math ; +math.parser math words.symbol ; IN: namespaces ARTICLE: "namespaces-combinators" "Namespace combinators" @@ -20,7 +20,8 @@ ARTICLE: "namespaces-global" "Global variables" { $subsection namespace } { $subsection global } { $subsection get-global } -{ $subsection set-global } ; +{ $subsection set-global } +{ $subsection initialize } ; ARTICLE: "namespaces.private" "Namespace implementation details" "The namestack holds namespaces." @@ -159,3 +160,7 @@ HELP: ndrop HELP: init-namespaces { $description "Resets the name stack to its initial state, holding a single copy of the global namespace." } $low-level-note ; + +HELP: initialize +{ $values { "variable" symbol } { "quot" quotation } } +{ $description "If " { $snippet "variable" } " does not have a value in the global namespace, calls " { $snippet "quot" } " and assigns the result to " { $snippet "variable" } " in the global namespace." } ; diff --git a/core/namespaces/namespaces-tests.factor b/core/namespaces/namespaces-tests.factor index 4c11e2389f..616ddef7fc 100644 --- a/core/namespaces/namespaces-tests.factor +++ b/core/namespaces/namespaces-tests.factor @@ -12,3 +12,14 @@ H{ } clone "test-namespace" set [ f ] [ H{ } clone [ f "some-global" set "some-global" get ] bind ] unit-test + +SYMBOL: test-initialize +test-initialize [ 1 ] initialize +test-initialize [ 2 ] initialize + +[ 1 ] [ test-initialize get-global ] unit-test + +f test-initialize set-global +test-initialize [ 5 ] initialize + +[ 5 ] [ test-initialize get-global ] unit-test diff --git a/core/namespaces/namespaces.factor b/core/namespaces/namespaces.factor index 36559095cb..24095fd382 100644 --- a/core/namespaces/namespaces.factor +++ b/core/namespaces/namespaces.factor @@ -37,4 +37,7 @@ PRIVATE> H{ } clone >n call ndrop ; inline : with-variable ( value key quot -- ) - [ associate >n ] dip call ndrop ; inline + [ associate >n ] dip call ndrop ; inline + +: initialize ( variable quot -- ) + [ global ] [ [ unless* ] curry ] bi* change-at ; diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 4be7cfa891..971ba245dd 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -200,7 +200,7 @@ SYMBOL: interactive-vocabs SYMBOL: print-use-hook -print-use-hook global [ [ ] or ] change-at +print-use-hook [ [ ] ] initialize : parse-fresh ( lines -- quot ) [ diff --git a/core/quotations/quotations-docs.factor b/core/quotations/quotations-docs.factor index f2629a36c4..2a03b7c74f 100644 --- a/core/quotations/quotations-docs.factor +++ b/core/quotations/quotations-docs.factor @@ -7,6 +7,9 @@ ARTICLE: "quotations" "Quotations" $nl "Concretely, a quotation is an immutable sequence of objects, some of which may be words, together with a block of machine code which may be executed to achieve the effect of evaluating the quotation. The machine code is generated by a fast non-optimizing quotation compiler which is always running and is transparent to the developer." $nl +"Quotations form a class of objects, however in most cases, methods should dispatch on " { $link callable } " instead, so that " { $link curry } " and " { $link compose } " values can participate." +{ $subsection quotation } +{ $subsection quotation? } "Quotations evaluate sequentially from beginning to end. Literals are pushed on the stack and words are executed. Details can be found in " { $link "evaluator" } "." $nl "Quotation literal syntax is documented in " { $link "syntax-quots" } "." diff --git a/core/slots/slots.factor b/core/slots/slots.factor old mode 100644 new mode 100755 index f166378d9d..24ff1b0f8b --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -151,6 +151,7 @@ M: class initial-value* no-initial-value ; { [ array bootstrap-word over class<= ] [ { } ] } { [ byte-array bootstrap-word over class<= ] [ B{ } ] } { [ simple-alien bootstrap-word over class<= ] [ ] } + { [ quotation bootstrap-word over class<= ] [ [ ] ] } [ dup initial-value* ] } cond nip ; diff --git a/core/strings/parser/parser.factor b/core/strings/parser/parser.factor index 4062e16e3d..8c9d0b5557 100644 --- a/core/strings/parser/parser.factor +++ b/core/strings/parser/parser.factor @@ -22,9 +22,9 @@ ERROR: bad-escape ; SYMBOL: name>char-hook -name>char-hook global [ - [ "Unicode support not available" throw ] or -] change-at +name>char-hook [ + [ "Unicode support not available" throw ] +] initialize : unicode-escape ( str -- ch str' ) "{" ?head-slice [ diff --git a/core/words/words.factor b/core/words/words.factor index 3197d0a6f6..8648664031 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -96,11 +96,11 @@ M: word uses ( word -- seq ) SYMBOL: compiled-crossref -compiled-crossref global [ H{ } assoc-like ] change-at +compiled-crossref [ H{ } clone ] initialize SYMBOL: compiled-generic-crossref -compiled-generic-crossref global [ H{ } assoc-like ] change-at +compiled-generic-crossref [ H{ } clone ] initialize : (compiled-xref) ( word dependencies word-prop variable -- ) [ [ set-word-prop ] curry ] diff --git a/extra/annotations/annotations-docs.factor b/extra/annotations/annotations-docs.factor new file mode 100644 index 0000000000..c340554119 --- /dev/null +++ b/extra/annotations/annotations-docs.factor @@ -0,0 +1,42 @@ +USING: accessors arrays combinators definitions generalizations +help help.markup help.topics kernel sequences sorting vocabs +words ; +IN: annotations + + + +"Code annotations" +{ + "The " { $vocab-link "annotations" } " vocabulary provides syntax for comment-like annotations that can be looked up with Factor's " { $link usage } " mechanism." +} +annotation-tags natural-sort +[ + [ \ $subsection swap comment-word 2array ] map append + "To look up annotations:" suffix +] [ + [ \ $subsection swap comment-usage.-word 2array ] map append +] bi +
"annotations" add-article + +"annotations" vocab "annotations" >>help drop + +annotation-tags [ + { + [ [ \ $syntax ] dip "!" " your comment here" surround 2array ] + [ [ \ $description "Treats the rest of the line after the exclamation point as a code annotation that can be looked up with the " \ $link ] dip comment-usage.-word 2array " word." 4array ] + [ [ \ $unchecked-example ] dip ": foo ( x y z -- w )\n !" " --w-ó()ò-w-- kilroy was here\n + * ;" surround 2array 3array ] + [ comment-word set-word-help ] + + [ [ \ $description "Displays a list of words, help articles, and vocabularies that contain " \ $link ] dip comment-word 2array " annotations." 4array 1array ] + [ comment-usage.-word set-word-help ] + + [ [ { $values { "usages" sequence } } \ $description "Returns a list of words, help articles, and vocabularies that contain " \ $link ] dip [ comment-word 2array " annotations. For a more user-friendly display, use the " \ $link ] [ comment-usage.-word 2array " word." 6 narray 2array ] bi ] + [ comment-usage-word set-word-help ] + + [ [ comment-word ] [ comment-usage-word ] [ comment-usage.-word ] tri 3array related-words ] + } cleave +] each diff --git a/extra/annotations/annotations-tests.factor b/extra/annotations/annotations-tests.factor new file mode 100644 index 0000000000..d5a13e48d8 --- /dev/null +++ b/extra/annotations/annotations-tests.factor @@ -0,0 +1,27 @@ +USING: accessors annotations combinators.short-circuit +io.pathnames kernel math sequences sorting tools.test ; +IN: annotations.tests + +!NOTE testing toplevel form + +: three ( -- x ) + !BROKEN english plz + "þrij" ; + +: four ( -- x ) + !BROKEN this code is broken + 2 2 + 1+ ; + +: five ( -- x ) + !TODO return 5 + f ; + +[ t ] [ + NOTEs { + [ length 1 = ] + [ first string>> file-name "annotations-tests.factor" = ] + } 1&& +] unit-test + +[ { four three } ] [ BROKENs natural-sort ] unit-test +[ { five } ] [ TODOs ] unit-test diff --git a/extra/annotations/annotations.factor b/extra/annotations/annotations.factor new file mode 100644 index 0000000000..6685e4e036 --- /dev/null +++ b/extra/annotations/annotations.factor @@ -0,0 +1,43 @@ +! (c)2009 Joe Groff, Doug Coleman. see BSD license +USING: accessors combinators.short-circuit definitions functors +kernel lexer namespaces parser prettyprint sequences words ; +IN: annotations + +<< + +: (parse-annotation) ( accum -- accum ) + lexer get [ line-text>> parsed ] [ next-line ] bi ; + +: (non-annotation-usage) ( word -- usages ) + smart-usage + [ { [ word? ] [ vocabulary>> "annotations" = ] } 1&& not ] + filter ; + +FUNCTOR: define-annotation ( NAME -- ) + +(NAME) DEFINES (${NAME}) +!NAME DEFINES !${NAME} +NAMEs DEFINES ${NAME}s +NAMEs. DEFINES ${NAME}s. + +WHERE + +: (NAME) ( str -- ) drop ; inline +: !NAME (parse-annotation) \ (NAME) parsed ; parsing + +: NAMEs ( -- usages ) + \ (NAME) (non-annotation-usage) ; +: NAMEs. ( -- ) + NAMEs sorted-definitions. ; + +;FUNCTOR + +CONSTANT: annotation-tags { + "XXX" "TODO" "FIXME" "BUG" "REVIEW" "LICENSE" + "AUTHOR" "BROKEN" "HACK" "LOL" "NOTE" +} + +annotation-tags [ define-annotation ] each + +>> + diff --git a/extra/annotations/authors.txt b/extra/annotations/authors.txt new file mode 100644 index 0000000000..0bc3c5ad4d --- /dev/null +++ b/extra/annotations/authors.txt @@ -0,0 +1,2 @@ +Joe Groff +Doug Coleman diff --git a/extra/annotations/summary.txt b/extra/annotations/summary.txt new file mode 100644 index 0000000000..732ed6f988 --- /dev/null +++ b/extra/annotations/summary.txt @@ -0,0 +1 @@ +Code annotation comment syntax diff --git a/extra/annotations/tags.txt b/extra/annotations/tags.txt new file mode 100644 index 0000000000..278296de5e --- /dev/null +++ b/extra/annotations/tags.txt @@ -0,0 +1,2 @@ +comments +annotation diff --git a/extra/cap/cap.factor b/extra/cap/cap.factor index 716435775d..1f62441028 100644 --- a/extra/cap/cap.factor +++ b/extra/cap/cap.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman, Joe Groff. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays byte-arrays kernel math namespaces -opengl.gl sequences math.vectors ui graphics.bitmap graphics.viewer +opengl.gl sequences math.vectors ui images.bitmap images.viewer models ui.gadgets.worlds ui.gadgets fry alien.syntax ; IN: cap @@ -27,4 +27,4 @@ IN: cap [ screenshot ] dip save-bitmap ; : screenshot. ( window -- ) - [ screenshot ] [ title>> ] bi open-window ; + [ screenshot ] [ title>> ] bi open-window ; diff --git a/extra/graphics/bitmap/bitmap-tests.factor b/extra/graphics/bitmap/bitmap-tests.factor deleted file mode 100644 index f8a125e855..0000000000 --- a/extra/graphics/bitmap/bitmap-tests.factor +++ /dev/null @@ -1,30 +0,0 @@ -USING: graphics.bitmap graphics.viewer io.encodings.binary -io.files io.files.unique kernel tools.test ; -IN: graphics.bitmap.tests - -: test-bitmap32-alpha ( -- path ) - "resource:extra/graphics/bitmap/test-images/32alpha.bmp" ; - -: test-bitmap24 ( -- path ) - "resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" ; - -: test-bitmap16 ( -- path ) - "resource:extra/graphics/bitmap/test-images/rgb16bit.bmp" ; - -: test-bitmap8 ( -- path ) - "resource:extra/graphics/bitmap/test-images/rgb8bit.bmp" ; - -: test-bitmap4 ( -- path ) - "resource:extra/graphics/bitmap/test-images/rgb4bit.bmp" ; - -: test-bitmap1 ( -- path ) - "resource:extra/graphics/bitmap/test-images/1bit.bmp" ; - -[ t ] -[ - test-bitmap24 - [ binary file-contents ] [ load-bitmap ] bi - - "test-bitmap24" unique-file - [ save-bitmap ] [ binary file-contents ] bi = -] unit-test diff --git a/extra/graphics/tiff/tiff-tests.factor b/extra/graphics/tiff/tiff-tests.factor deleted file mode 100755 index daee9a5d9e..0000000000 --- a/extra/graphics/tiff/tiff-tests.factor +++ /dev/null @@ -1,9 +0,0 @@ -! Copyright (C) 2009 Your name. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test graphics.tiff ; -IN: graphics.tiff.tests - -: tiff-test-path ( -- path ) - "resource:extra/graphics/tiff/rgb.tiff" ; - - diff --git a/extra/graphics/tiff/tiff.factor b/extra/graphics/tiff/tiff.factor deleted file mode 100755 index f0b3f9337e..0000000000 --- a/extra/graphics/tiff/tiff.factor +++ /dev/null @@ -1,227 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors combinators io io.encodings.binary io.files -kernel pack endian tools.hexdump constructors sequences arrays -sorting.slots math.order math.parser prettyprint classes ; -IN: graphics.tiff - -TUPLE: tiff -endianness -the-answer -ifd-offset -ifds ; - -CONSTRUCTOR: tiff ( -- tiff ) - V{ } clone >>ifds ; - -TUPLE: ifd count ifd-entries next processed-tags strips ; - -CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ; - -TUPLE: ifd-entry tag type count offset ; - -CONSTRUCTOR: ifd-entry ( tag type count offset -- ifd-entry ) ; - - -TUPLE: photometric-interpretation color ; - -CONSTRUCTOR: photometric-interpretation ( color -- object ) ; - -SINGLETONS: white-is-zero black-is-zero rgb palette-color ; - -ERROR: bad-photometric-interpretation n ; - -: lookup-photometric-interpretation ( n -- singleton ) - { - { 0 [ white-is-zero ] } - { 1 [ black-is-zero ] } - { 2 [ rgb ] } - { 3 [ palette-color ] } - [ bad-photometric-interpretation ] - } case ; - - -TUPLE: compression method ; - -CONSTRUCTOR: compression ( method -- object ) ; - -SINGLETONS: no-compression CCITT-2 pack-bits lzw ; - -ERROR: bad-compression n ; - -: lookup-compression ( n -- compression ) - { - { 1 [ no-compression ] } - { 2 [ CCITT-2 ] } - { 5 [ lzw ] } - { 32773 [ pack-bits ] } - [ bad-compression ] - } case ; - -TUPLE: image-length n ; -CONSTRUCTOR: image-length ( n -- object ) ; - -TUPLE: image-width n ; -CONSTRUCTOR: image-width ( n -- object ) ; - -TUPLE: x-resolution n ; -CONSTRUCTOR: x-resolution ( n -- object ) ; - -TUPLE: y-resolution n ; -CONSTRUCTOR: y-resolution ( n -- object ) ; - -TUPLE: rows-per-strip n ; -CONSTRUCTOR: rows-per-strip ( n -- object ) ; - -TUPLE: strip-offsets n ; -CONSTRUCTOR: strip-offsets ( n -- object ) ; - -TUPLE: strip-byte-counts n ; -CONSTRUCTOR: strip-byte-counts ( n -- object ) ; - -TUPLE: bits-per-sample n ; -CONSTRUCTOR: bits-per-sample ( n -- object ) ; - -TUPLE: samples-per-pixel n ; -CONSTRUCTOR: samples-per-pixel ( n -- object ) ; - -SINGLETONS: no-resolution-unit -inch-resolution-unit -centimeter-resolution-unit ; - -TUPLE: resolution-unit type ; -CONSTRUCTOR: resolution-unit ( type -- object ) ; - -ERROR: bad-resolution-unit n ; - -: lookup-resolution-unit ( n -- object ) - { - { 1 [ no-resolution-unit ] } - { 2 [ inch-resolution-unit ] } - { 3 [ centimeter-resolution-unit ] } - [ bad-resolution-unit ] - } case ; - - -TUPLE: predictor type ; -CONSTRUCTOR: predictor ( type -- object ) ; - -SINGLETONS: no-predictor horizontal-differencing-predictor ; - -ERROR: bad-predictor n ; - -: lookup-predictor ( n -- object ) - { - { 1 [ no-predictor ] } - { 2 [ horizontal-differencing-predictor ] } - [ bad-predictor ] - } case ; - - -TUPLE: planar-configuration type ; -CONSTRUCTOR: planar-configuration ( type -- object ) ; - -SINGLETONS: chunky planar ; - -ERROR: bad-planar-configuration n ; - -: lookup-planar-configuration ( n -- object ) - { - { 1 [ no-predictor ] } - { 2 [ horizontal-differencing-predictor ] } - [ bad-predictor ] - } case ; - - -TUPLE: new-subfile-type n ; -CONSTRUCTOR: new-subfile-type ( n -- object ) ; - -ERROR: bad-tiff-magic bytes ; - -: tiff-endianness ( byte-array -- ? ) - { - { B{ CHAR: M CHAR: M } [ big-endian ] } - { B{ CHAR: I CHAR: I } [ little-endian ] } - [ bad-tiff-magic ] - } case ; - -: with-tiff-endianness ( tiff quot -- tiff ) - [ dup endianness>> ] dip with-endianness ; inline - -: read-header ( tiff -- tiff ) - 2 read tiff-endianness [ >>endianness ] keep - [ - 2 read endian> >>the-answer - 4 read endian> >>ifd-offset - ] with-endianness ; - -: push-ifd ( tiff ifd -- tiff ) - over ifds>> push ; - -: read-ifd ( -- ifd ) - 2 read endian> - 2 read endian> - 4 read endian> - 4 read endian> ; - -: read-ifds ( tiff -- tiff ) - [ - dup ifd-offset>> seek-absolute seek-input - 2 read endian> - dup [ read-ifd ] replicate - 4 read endian> - [ push-ifd ] [ 0 = [ read-ifds ] unless ] bi - ] with-tiff-endianness ; - -: read-strips ( ifd -- ifd ) - dup processed-tags>> - [ [ strip-byte-counts instance? ] find nip n>> ] - [ [ strip-offsets instance? ] find nip n>> ] bi - [ seek-absolute seek-input read ] { } 2map-as >>strips ; - -! ERROR: unhandled-ifd-entry data n ; - -: unhandled-ifd-entry ; - -: ifd-entry-value ( ifd-entry -- n ) - dup count>> 1 = [ - offset>> - ] [ - [ offset>> seek-absolute seek-input ] [ count>> read ] bi - ] if ; - -: process-ifd-entry ( ifd-entry -- object ) - [ ifd-entry-value ] [ tag>> ] bi { - { 254 [ ] } - { 256 [ ] } - { 257 [ ] } - { 258 [ ] } - { 259 [ lookup-compression ] } - { 262 [ lookup-photometric-interpretation ] } - { 273 [ ] } - { 277 [ ] } - { 278 [ ] } - { 279 [ ] } - { 282 [ ] } - { 283 [ ] } - { 284 [ ] } - { 296 [ lookup-resolution-unit ] } - { 317 [ lookup-predictor ] } - [ unhandled-ifd-entry swap 2array ] - } case ; - -: process-ifd ( ifd -- ifd ) - dup ifd-entries>> [ process-ifd-entry ] map >>processed-tags ; - -: (load-tiff) ( path -- tiff ) - binary [ - - read-header - read-ifds - dup ifds>> [ process-ifd read-strips drop ] each - ] with-file-reader ; - -: load-tiff ( path -- tiff ) - (load-tiff) ; - -! TODO: duplicate ifds = error, seeking out of bounds = error diff --git a/extra/graphics/viewer/viewer.factor b/extra/graphics/viewer/viewer.factor deleted file mode 100644 index 8e0b1ec43c..0000000000 --- a/extra/graphics/viewer/viewer.factor +++ /dev/null @@ -1,50 +0,0 @@ -! Copyright (C) 2007 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays combinators graphics.bitmap kernel math -math.functions namespaces opengl opengl.gl ui ui.gadgets -ui.gadgets.panes ui.render ; -IN: graphics.viewer - -TUPLE: graphics-gadget < gadget image ; - -GENERIC: draw-image ( image -- ) -GENERIC: width ( image -- w ) -GENERIC: height ( image -- h ) - -M: graphics-gadget pref-dim* - image>> [ width ] keep height abs 2array ; - -M: graphics-gadget draw-gadget* ( gadget -- ) - origin get [ image>> draw-image ] with-translation ; - -: ( bitmap -- gadget ) - \ graphics-gadget new-gadget - swap >>image ; - -M: bitmap draw-image ( bitmap -- ) - dup height>> 0 < [ - 0 0 glRasterPos2i - 1.0 -1.0 glPixelZoom - ] [ - 0 over height>> abs glRasterPos2i - 1.0 1.0 glPixelZoom - ] if - [ width>> ] keep - [ - [ height>> abs ] keep - bit-count>> { - { 32 [ GL_BGRA GL_UNSIGNED_BYTE ] } - { 24 [ GL_BGR GL_UNSIGNED_BYTE ] } - { 8 [ GL_BGR GL_UNSIGNED_BYTE ] } - { 4 [ GL_BGR GL_UNSIGNED_BYTE ] } - } case - ] keep array>> glDrawPixels ; - -M: bitmap width ( bitmap -- ) width>> ; -M: bitmap height ( bitmap -- ) height>> ; - -: bitmap. ( path -- ) - load-bitmap gadget. ; - -: bitmap-window ( path -- gadget ) - load-bitmap [ "bitmap" open-window ] keep ; diff --git a/extra/id3/authors.txt b/extra/id3/authors.txt new file mode 100644 index 0000000000..ece617b969 --- /dev/null +++ b/extra/id3/authors.txt @@ -0,0 +1,2 @@ +Tim Wawrzynczak + diff --git a/extra/id3/id3-docs.factor b/extra/id3/id3-docs.factor new file mode 100644 index 0000000000..da69c2ced3 --- /dev/null +++ b/extra/id3/id3-docs.factor @@ -0,0 +1,17 @@ +! Copyright (C) 2008 Tim Wawrzynczak +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax sequences kernel ; +IN: id3 + +HELP: file-id3-tags +{ $values + { "path" "a path string" } + { "object/f" "a tuple storing ID3 metadata or f" } } +{ $description "Return a tuple containing the ID3 information parsed out of the MP3 file, or " { $link f } " if no metadata is present." } ; + +ARTICLE: "id3" "ID3 tags" +"The " { $vocab-link "id3" } " vocabulary contains words for parsing " { $emphasis "ID3" } " tags, which are textual fields storing an MP3's title, artist, and other metadata." $nl +"Parsing ID3 tags from an MP3 file:" +{ $subsection file-id3-tags } ; + +ABOUT: "id3" diff --git a/extra/id3/id3-tests.factor b/extra/id3/id3-tests.factor new file mode 100644 index 0000000000..b9d45b1b04 --- /dev/null +++ b/extra/id3/id3-tests.factor @@ -0,0 +1,182 @@ +! Copyright (C) 2009 Tim Wawrzynczak +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test id3 ; +IN: id3.tests + +[ T{ mp3v2-file + { header T{ header f t 0 502 } } + { frames + { + T{ frame + { frame-id "COMM" } + { flags B{ 0 0 } } + { size 19 } + { data "eng, AG# 08E1C12E" } + } + T{ frame + { frame-id "TIT2" } + { flags B{ 0 0 } } + { size 15 } + { data "Stormy Weather" } + } + T{ frame + { frame-id "TRCK" } + { flags B{ 0 0 } } + { size 3 } + { data "32" } + } + T{ frame + { frame-id "TCON" } + { flags B{ 0 0 } } + { size 5 } + { data "(96)" } + } + T{ frame + { frame-id "TALB" } + { flags B{ 0 0 } } + { size 28 } + { data "Night and Day Frank Sinatra" } + } + T{ frame + { frame-id "PRIV" } + { flags B{ 0 0 } } + { size 39 } + { data "WM/MediaClassPrimaryID�}`�#��K�H�*(D" } + } + T{ frame + { frame-id "PRIV" } + { flags B{ 0 0 } } + { size 41 } + { data "WM/MediaClassSecondaryID" } + } + T{ frame + { frame-id "TPE1" } + { flags B{ 0 0 } } + { size 14 } + { data "Frank Sinatra" } + } + } + } +} +] [ "resource:extra/id3/tests/blah3.mp3" file-id3-tags ] unit-test + +[ + T{ mp3v2-file + { header + T{ header { version t } { flags 0 } { size 1405 } } + } + { frames + { + T{ frame + { frame-id "TIT2" } + { flags B{ 0 0 } } + { size 22 } + { data "Anthem of the Trinity" } + } + T{ frame + { frame-id "TPE1" } + { flags B{ 0 0 } } + { size 12 } + { data "Terry Riley" } + } + T{ frame + { frame-id "TALB" } + { flags B{ 0 0 } } + { size 11 } + { data "Shri Camel" } + } + T{ frame + { frame-id "TCON" } + { flags B{ 0 0 } } + { size 10 } + { data "Classical" } + } + T{ frame + { frame-id "UFID" } + { flags B{ 0 0 } } + { size 23 } + { data "http://musicbrainz.org" } + } + T{ frame + { frame-id "TXXX" } + { flags B{ 0 0 } } + { size 23 } + { data "MusicBrainz Artist Id" } + } + T{ frame + { frame-id "TXXX" } + { flags B{ 0 0 } } + { size 22 } + { data "musicbrainz_artistid" } + } + T{ frame + { frame-id "TRCK" } + { flags B{ 0 0 } } + { size 2 } + { data "1" } + } + T{ frame + { frame-id "TXXX" } + { flags B{ 0 0 } } + { size 22 } + { data "MusicBrainz Album Id" } + } + T{ frame + { frame-id "TXXX" } + { flags B{ 0 0 } } + { size 21 } + { data "musicbrainz_albumid" } + } + T{ frame + { frame-id "TXXX" } + { flags B{ 0 0 } } + { size 29 } + { data "MusicBrainz Album Artist Id" } + } + T{ frame + { frame-id "TXXX" } + { flags B{ 0 0 } } + { size 27 } + { data "musicbrainz_albumartistid" } + } + T{ frame + { frame-id "TPOS" } + { flags B{ 0 0 } } + { size 2 } + { data "1" } + } + T{ frame + { frame-id "TSOP" } + { flags B{ 0 0 } } + { size 1 } + } + T{ frame + { frame-id "TMED" } + { flags B{ 0 0 } } + { size 4 } + { data "DIG" } + } + } + } +} +] [ "resource:extra/id3/tests/blah2.mp3" file-id3-tags ] unit-test + +[ + T{ mp3v1-file + { title + "BLAH\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0" + } + { artist + "ARTIST\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0" + } + { album + "ALBUM\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0" + } + { year "2009" } + { comment + "COMMENT\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0" + } + { genre 89 } + } +] [ "resource:extra/id3/tests/blah.mp3" file-id3-tags ] unit-test + diff --git a/extra/id3/id3.factor b/extra/id3/id3.factor new file mode 100644 index 0000000000..64e1ff1d10 --- /dev/null +++ b/extra/id3/id3.factor @@ -0,0 +1,154 @@ +! Copyright (C) 2009 Tim Wawrzynczak +! See http://factorcode.org/license.txt for BSD license. +USING: sequences io io.encodings.binary io.files io.pathnames strings kernel math io.mmap io.mmap.uchar accessors syntax combinators math.ranges unicode.categories byte-arrays prettyprint io.encodings.string io.encodings.ascii ; +IN: id3 + +! tuples + +TUPLE: header version flags size ; + +TUPLE: frame frame-id flags size data ; + +TUPLE: mp3v2-file header frames ; + +TUPLE: mp3v1-file title artist album year comment genre ; + +: ( -- object ) mp3v1-file new ; + +: ( header frames -- object ) mp3v2-file boa ; + +:
( -- object ) header new ; + +: ( -- object ) frame new ; + +28bitword ( seq -- int ) + 0 [ swap 7 shift bitor ] reduce ; + +: filter-text-data ( data -- filtered ) + [ printable? ] filter ; + +! frame details stuff + +: valid-frame-id? ( id -- ? ) + [ [ digit? ] [ LETTER? ] bi or ] all? ; + +: read-frame-id ( mmap -- id ) + 4 head-slice ; + +: read-frame-size ( mmap -- size ) + [ 4 8 ] dip subseq ; + +: read-frame-flags ( mmap -- flags ) + [ 8 10 ] dip subseq ; + +: read-frame-data ( frame mmap -- frame data ) + [ 10 over size>> 10 + ] dip filter-text-data ; + +! read whole frames + +: (read-frame) ( mmap -- frame ) + [ ] dip + { + [ read-frame-id ascii decode >>frame-id ] + [ read-frame-flags >byte-array >>flags ] + [ read-frame-size >28bitword >>size ] + [ read-frame-data ascii decode >>data ] + } cleave ; + +: read-frame ( mmap -- frame/f ) + dup read-frame-id valid-frame-id? [ (read-frame) ] [ drop f ] if ; + +: remove-frame ( mmap frame -- mmap ) + size>> 10 + tail-slice ; + +: read-frames ( mmap -- frames ) + [ dup read-frame dup ] + [ [ remove-frame ] keep ] + [ drop ] produce nip ; + +! header stuff + +: read-header-supported-version? ( mmap -- ? ) + 3 tail-slice [ { 4 } head? ] [ { 3 } head? ] bi or ; + +: read-header-flags ( mmap -- flags ) + 5 swap nth ; + +: read-header-size ( mmap -- size ) + [ 6 10 ] dip >28bitword ; + +: read-v2-header ( mmap -- id3header ) + [
] dip + { + [ read-header-supported-version? >>version ] + [ read-header-flags >>flags ] + [ read-header-size >>size ] + } cleave ; + +: drop-header ( mmap -- seq1 seq2 ) + dup 10 tail-slice swap ; + +: read-v2-tag-data ( seq -- mp3v2-file ) + drop-header read-v2-header swap read-frames ; + +! v1 information + +: skip-to-v1-data ( seq -- seq ) + 125 tail-slice* ; + +: read-title ( seq -- title ) + 30 head-slice ; + +: read-artist ( seq -- title ) + [ 30 60 ] dip subseq ; + +: read-album ( seq -- album ) + [ 60 90 ] dip subseq ; + +: read-year ( seq -- year ) + [ 90 94 ] dip subseq ; + +: read-comment ( seq -- comment ) + [ 94 124 ] dip subseq ; + +: read-genre ( seq -- genre ) + [ 124 ] dip nth ; + +: (read-v1-tag-data) ( seq -- mp3-file ) + [ ] dip + { + [ read-title ascii decode >>title ] + [ read-artist ascii decode >>artist ] + [ read-album ascii decode >>album ] + [ read-year ascii decode >>year ] + [ read-comment ascii decode >>comment ] + [ read-genre >fixnum >>genre ] + } cleave ; + +: read-v1-tag-data ( seq -- mp3-file ) + skip-to-v1-data (read-v1-tag-data) ; + +PRIVATE> + +! main stuff + +: file-id3-tags ( path -- object/f ) + [ + { + { [ dup id3v2? ] [ read-v2-tag-data ] } ! ( ? -- mp3v2-file ) + { [ dup id3v1? ] [ read-v1-tag-data ] } ! ( ? -- mp3v1-file ) + [ drop f ] ! ( mmap -- f ) + } cond + ] with-mapped-uchar-file ; + +! end diff --git a/extra/id3/tests/blah.mp3 b/extra/id3/tests/blah.mp3 new file mode 100644 index 0000000000..3a60bffd34 Binary files /dev/null and b/extra/id3/tests/blah.mp3 differ diff --git a/extra/id3/tests/blah2.mp3 b/extra/id3/tests/blah2.mp3 new file mode 100644 index 0000000000..5d27429982 Binary files /dev/null and b/extra/id3/tests/blah2.mp3 differ diff --git a/extra/id3/tests/blah3.mp3 b/extra/id3/tests/blah3.mp3 new file mode 100644 index 0000000000..19aaa94dc6 Binary files /dev/null and b/extra/id3/tests/blah3.mp3 differ diff --git a/extra/graphics/viewer/authors.txt b/extra/images/viewer/authors.txt similarity index 100% rename from extra/graphics/viewer/authors.txt rename to extra/images/viewer/authors.txt diff --git a/extra/images/viewer/viewer.factor b/extra/images/viewer/viewer.factor new file mode 100644 index 0000000000..06e4c686f3 --- /dev/null +++ b/extra/images/viewer/viewer.factor @@ -0,0 +1,37 @@ +! Copyright (C) 2007 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors images images.loader io.pathnames kernel +namespaces opengl opengl.gl sequences strings ui ui.gadgets +ui.gadgets.panes ui.render ; +IN: images.viewer + +TUPLE: image-gadget < gadget { image image } ; + +M: image-gadget pref-dim* + image>> dim>> ; + +: draw-image ( tiff -- ) + 0 0 glRasterPos2i 1.0 -1.0 glPixelZoom + [ dim>> first2 GL_RGBA GL_UNSIGNED_BYTE ] + [ bitmap>> ] bi glDrawPixels ; + +M: image-gadget draw-gadget* ( gadget -- ) + origin get [ image>> draw-image ] with-translation ; + +: ( image -- gadget ) + \ image-gadget new-gadget + swap >>image ; + +: image-window ( path -- gadget ) + [ load-image dup ] [ open-window ] bi ; + +GENERIC: image. ( object -- ) + +: default-image. ( path -- ) + gadget. ; + +M: string image. ( image -- ) load-image default-image. ; + +M: pathname image. ( image -- ) load-image default-image. ; + +M: image image. ( image -- ) default-image. ; diff --git a/extra/infix/ast/ast.factor b/extra/infix/ast/ast.factor index 0bc22feeb7..1908b3d39b 100644 --- a/extra/infix/ast/ast.factor +++ b/extra/infix/ast/ast.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2009 Philipp Brüschweiler +! See http://factorcode.org/license.txt for BSD license. IN: infix.ast TUPLE: ast-number value ; diff --git a/extra/infix/authors.txt b/extra/infix/authors.txt new file mode 100644 index 0000000000..156a81af57 --- /dev/null +++ b/extra/infix/authors.txt @@ -0,0 +1 @@ +Philipp Brüschweiler diff --git a/extra/infix/infix-docs.factor b/extra/infix/infix-docs.factor index 7a4febb514..4a2ec963ee 100644 --- a/extra/infix/infix-docs.factor +++ b/extra/infix/infix-docs.factor @@ -1,4 +1,6 @@ -USING: help.syntax help.markup prettyprint locals ; +! Copyright (C) 2009 Philipp Brüschweiler +! See http://factorcode.org/license.txt for BSD license. +USING: help.syntax help.markup math prettyprint locals sequences ; IN: infix HELP: [infix @@ -36,3 +38,54 @@ HELP: [infix| } ; { POSTPONE: [infix POSTPONE: [infix| } related-words + +ARTICLE: "infix" "Infix notation" +"The " { $vocab-link "infix" } " vocabulary implements support for infix notation in Factor source code." +{ $subsection POSTPONE: [infix } +{ $subsection POSTPONE: [infix| } +$nl +"The usual infix math operators are supported:" +{ $list + { $link + } + { $link - } + { $link * } + { $link / } + { { $snippet "%" } ", which is the infix operator for " { $link mod } "." } +} +"The standard precedence rules apply: Grouping with parentheses before " { $snippet "*" } ", " { $snippet "/" } "and " { $snippet "%" } " before " { $snippet "+" } " and " { $snippet "-" } "." +{ $example + "USING: infix prettyprint ;" + "[infix 5-40/10*2 infix] ." + "-3" +} +$nl +"You can call Factor words in infix expressions just as you would in C. There are some restrictions on which words are legal to use though:" +{ $list + "The word must return exactly one value." + "The word name must consist of the letters a-z, A-Z, _ or 0-9, and the first character can't be a number." +} +{ $example + "USING: infix locals math math.functions prettyprint ;" + ":: binary_entropy ( p -- h )" + " [infix -(p*log(p) + (1-p)*log(1-p)) / log(2) infix] ;" + "[infix binary_entropy( sqrt(0.25) ) infix] ." + "1.0" +} +$nl +"You can access " { $vocab-link "sequences" } " inside infix expressions with the familiar " { $snippet "arr[index]" } " notation." +{ $example + "USING: arrays infix prettyprint ;" + "[infix| myarr [ { 1 2 3 4 } ] | myarr[4/2]*3 infix] ." + "9" +} +"Please note: in Factor " { $emphasis "fixnums are sequences too." } " If you are not careful with sequence accesses you may introduce subtle bugs:" +{ $example + "USING: arrays infix locals prettyprint ;" + ":: add-2nd-element ( x y -- res )" + " [infix x[1] + y[1] infix] ;" + "{ 1 2 3 } 5 add-2nd-element ." + "3" +} +; + +ABOUT: "infix" diff --git a/extra/infix/infix-tests.factor b/extra/infix/infix-tests.factor index 5ee6468131..7e8e2dfcc9 100644 --- a/extra/infix/infix-tests.factor +++ b/extra/infix/infix-tests.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2009 Philipp Brüschweiler +! See http://factorcode.org/license.txt for BSD license. USING: infix infix.private kernel locals math math.functions tools.test ; IN: infix.tests diff --git a/extra/infix/infix.factor b/extra/infix/infix.factor index 31cd1cbe1f..3e2ba49e3c 100644 --- a/extra/infix/infix.factor +++ b/extra/infix/infix.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2009 Philipp Brüschweiler +! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs combinators combinators.short-circuit effects fry infix.parser infix.ast kernel locals.parser locals.types math multiline namespaces parser quotations diff --git a/extra/infix/parser/parser-tests.factor b/extra/infix/parser/parser-tests.factor index 0a0288c41b..d6b5d0559c 100644 --- a/extra/infix/parser/parser-tests.factor +++ b/extra/infix/parser/parser-tests.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2009 Philipp Brüschweiler +! See http://factorcode.org/license.txt for BSD license. USING: infix.ast infix.parser infix.tokenizer tools.test ; IN: infix.parser.tests diff --git a/extra/infix/parser/parser.factor b/extra/infix/parser/parser.factor index beaf3c335d..2f9ab03d18 100644 --- a/extra/infix/parser/parser.factor +++ b/extra/infix/parser/parser.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2009 Philipp Brüschweiler +! See http://factorcode.org/license.txt for BSD license. USING: infix.ast infix.tokenizer kernel math peg.ebnf sequences strings vectors ; IN: infix.parser diff --git a/extra/infix/summary.txt b/extra/infix/summary.txt new file mode 100644 index 0000000000..63d366d203 --- /dev/null +++ b/extra/infix/summary.txt @@ -0,0 +1 @@ +Support for infix notation in Factor programs diff --git a/extra/infix/tags.txt b/extra/infix/tags.txt new file mode 100644 index 0000000000..f4274299b1 --- /dev/null +++ b/extra/infix/tags.txt @@ -0,0 +1 @@ +extensions diff --git a/extra/infix/tokenizer/tokenizer-tests.factor b/extra/infix/tokenizer/tokenizer-tests.factor index 7e1fb005ef..f9c908414a 100644 --- a/extra/infix/tokenizer/tokenizer-tests.factor +++ b/extra/infix/tokenizer/tokenizer-tests.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2009 Philipp Brüschweiler +! See http://factorcode.org/license.txt for BSD license. USING: infix.ast infix.tokenizer tools.test ; IN: infix.tokenizer.tests diff --git a/extra/infix/tokenizer/tokenizer.factor b/extra/infix/tokenizer/tokenizer.factor index 8c1a1b4a18..f5bce4b6d7 100644 --- a/extra/infix/tokenizer/tokenizer.factor +++ b/extra/infix/tokenizer/tokenizer.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2009 Philipp Brüschweiler +! See http://factorcode.org/license.txt for BSD license. USING: infix.ast kernel peg peg.ebnf math.parser sequences strings ; IN: infix.tokenizer diff --git a/extra/mason/config/config.factor b/extra/mason/config/config.factor index b1739d85fa..51b09543f4 100644 --- a/extra/mason/config/config.factor +++ b/extra/mason/config/config.factor @@ -81,7 +81,7 @@ SYMBOL: upload-directory ! Optional: override ssh and scp command names SYMBOL: scp-command -scp-command global [ "scp" or ] change-at +scp-command [ "scp" ] initialize SYMBOL: ssh-command -ssh-command global [ "ssh" or ] change-at +ssh-command [ "ssh" ] initialize diff --git a/extra/parser-combinators/parser-combinators.factor b/extra/parser-combinators/parser-combinators.factor index 8afbb2d03b..99e8099f38 100755 --- a/extra/parser-combinators/parser-combinators.factor +++ b/extra/parser-combinators/parser-combinators.factor @@ -17,7 +17,7 @@ ERROR: cannot-parse input ; : parse-1 ( input parser -- result ) dupd parse dup nil? [ - rot cannot-parse + swap cannot-parse ] [ nip car parsed>> ] if ; @@ -149,8 +149,8 @@ TUPLE: and-parser parsers ; [ parsed>> ] dip [ parsed>> 2array ] keep unparsed>> - ] lazy-map-with - ] lazy-map-with lconcat ; + ] with lazy-map + ] with lazy-map lconcat ; M: and-parser parse ( input parser -- list ) #! Parse 'input' by sequentially combining the @@ -173,7 +173,7 @@ M: or-parser parse ( input parser1 -- list ) #! of parser1 and parser2 being applied to the same #! input. This implements the choice parsing operator. parsers>> 0 swap seq>list - [ parse ] lazy-map-with lconcat ; + [ parse ] with lazy-map lconcat ; : trim-head-slice ( string -- string ) #! Return a new string without any leading whitespace @@ -218,7 +218,7 @@ M: apply-parser parse ( input parser -- result ) -rot parse [ [ parsed>> swap call ] keep unparsed>> - ] lazy-map-with ; + ] with lazy-map ; TUPLE: some-parser p1 ; diff --git a/extra/project-euler/002/002.factor b/extra/project-euler/002/002.factor index da20c874b5..9c462b6b2e 100644 --- a/extra/project-euler/002/002.factor +++ b/extra/project-euler/002/002.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2007, 2008 Aaron Schaefer, Alexander Solovyov, Vishal Talwar. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math sequences shuffle ; +USING: kernel math sequences ; IN: project-euler.002 ! http://projecteuler.net/index.php?section=problems&id=2 @@ -41,7 +41,7 @@ PRIVATE> ! ------------------- : fib-upto* ( n -- seq ) - 0 1 [ pick over >= ] [ tuck + dup ] [ ] produce 3nip + 0 1 [ pick over >= ] [ tuck + dup ] [ ] produce [ 3drop ] dip but-last-slice { 0 1 } prepend ; : euler002a ( -- answer ) diff --git a/extra/project-euler/134/134.factor b/extra/project-euler/134/134.factor index e00e86865d..0f009919d9 100644 --- a/extra/project-euler/134/134.factor +++ b/extra/project-euler/134/134.factor @@ -39,7 +39,7 @@ IN: project-euler.134 PRIVATE> : euler134 ( -- answer ) - 0 5 lprimes-from uncons swap [ 1000000 > ] luntil + 0 5 lprimes-from uncons [ 1000000 > ] luntil [ [ s + ] keep ] leach drop ; ! [ euler134 ] 10 ave-time diff --git a/extra/reports/noise/noise.factor b/extra/reports/noise/noise.factor index 3e47adac0b..89e00f88c5 100755 --- a/extra/reports/noise/noise.factor +++ b/extra/reports/noise/noise.factor @@ -25,7 +25,6 @@ IN: reports.noise { 3drop 1 } { 3dup 2 } { 3keep 3 } - { 3nip 4 } { 3slip 3 } { 4drop 2 } { 4dup 3 } @@ -50,7 +49,6 @@ IN: reports.noise { ndrop 2 } { ndup 3 } { nip 2 } - { nipd 3 } { nkeep 5 } { npick 6 } { nrot 5 } @@ -66,7 +64,6 @@ IN: reports.noise { swap 1 } { swapd 3 } { tuck 2 } - { tuckd 4 } { with 1/2 } { bi 1/2 } diff --git a/extra/system-info/linux/linux.factor b/extra/system-info/linux/linux.factor index 00a49fb2a2..b77e1fe649 100644 --- a/extra/system-info/linux/linux.factor +++ b/extra/system-info/linux/linux.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: unix alien alien.c-types kernel math sequences strings -io.backend.unix splitting ; +io.backend.unix splitting io.encodings.utf8 io.encodings.string ; IN: system-info.linux : (uname) ( buf -- int ) @@ -9,7 +9,7 @@ IN: system-info.linux : uname ( -- seq ) 65536 "char" [ (uname) io-error ] keep - "\0" split harvest [ >string ] map + "\0" split harvest [ utf8 decode ] map 6 "" pad-tail ; : sysname ( -- string ) uname first ; diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor index a4413c07b3..37c022fe43 100755 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -5,8 +5,8 @@ system tools.hexdump io.encodings.binary summary accessors io.backend byte-arrays ; IN: tar -: zero-checksum 256 ; inline -: block-size 512 ; inline +CONSTANT: zero-checksum 256 +CONSTANT: block-size 512 TUPLE: tar-header name mode uid gid size mtime checksum typeflag linkname magic version uname gname devmajor devminor prefix ; @@ -89,8 +89,7 @@ M: unknown-typeflag summary ( obj -- str ) ! Symlink : typeflag-2 ( header -- ) - [ name>> ] [ linkname>> ] bi - [ make-link ] 2curry ignore-errors ; + [ name>> ] [ linkname>> ] bi make-link ; ! character special : typeflag-3 ( header -- ) unknown-typeflag ; diff --git a/extra/taxes/usa/futa/futa.factor b/extra/taxes/usa/futa/futa.factor index 7368aef825..9b862a8960 100644 --- a/extra/taxes/usa/futa/futa.factor +++ b/extra/taxes/usa/futa/futa.factor @@ -11,5 +11,4 @@ IN: taxes.usa.futa : futa-tax ( salary w4 -- x ) drop futa-base-rate min - futa-tax-rate futa-tax-offset-credit - - * ; + futa-tax-rate futa-tax-offset-credit - * ; diff --git a/extra/taxes/usa/usa.factor b/extra/taxes/usa/usa.factor index 27ff4aef98..bbfc332868 100644 --- a/extra/taxes/usa/usa.factor +++ b/extra/taxes/usa/usa.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs kernel math math.intervals -namespaces sequences money math.order taxes.usa.w4 ; +namespaces sequences money math.order taxes.usa.w4 +taxes.usa.futa math.finance ; IN: taxes.usa ! Withhold: FICA, Medicare, Federal (FICA is social security) diff --git a/extra/twitter/twitter.factor b/extra/twitter/twitter.factor new file mode 100644 index 0000000000..48388de382 --- /dev/null +++ b/extra/twitter/twitter.factor @@ -0,0 +1,132 @@ +! Copyright (C) 2009 Joe Groff. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs combinators hashtables http +http.client json.reader kernel macros namespaces sequences +urls.secure fry ; +IN: twitter + +! Configuration +SYMBOLS: twitter-username twitter-password twitter-source ; + +twitter-source [ "factor" ] initialize + +: set-twitter-credentials ( username password -- ) + [ twitter-username set ] [ twitter-password set ] bi* ; + + + +! Data types + +TUPLE: twitter-status + created-at + id + text + source + truncated? + in-reply-to-status-id + in-reply-to-user-id + favorited? + user ; +TUPLE: twitter-user + id + name + screen-name + description + location + profile-image-url + url + protected? + followers-count ; + + ( assoc -- user ) + { + "id" + "name" + "screen_name" + "description" + "location" + "profile_image_url" + "url" + "protected" + "followers_count" + } twitter-user keys-boa ; + +: ( assoc -- tweet ) + clone "user" over [ ] change-at + { + "created_at" + "id" + "text" + "source" + "truncated" + "in_reply_to_status_id" + "in_reply_to_user_id" + "favorited" + "user" + } twitter-status keys-boa ; + +: json>twitter-statuses ( json-array -- tweets ) + json> [ ] map ; + +: json>twitter-status ( json-object -- tweet ) + json> ; + +PRIVATE> + +! Updates + twitter-request ; + +PRIVATE> + +: tweet* ( string -- tweet ) + (tweet) json>twitter-status ; + +: tweet ( string -- ) (tweet) drop ; + +! Timelines + + twitter-request json>twitter-statuses ; + +PRIVATE> + +: public-timeline ( -- tweets ) + "public_timeline" timeline ; + +: friends-timeline ( -- tweets ) + "friends_timeline" timeline ; + +: user-timeline ( username -- tweets ) + "user_timeline/" prepend timeline ; diff --git a/extra/ui/offscreen/offscreen-docs.factor b/extra/ui/offscreen/offscreen-docs.factor index 5d800981bf..4123a83675 100644 --- a/extra/ui/offscreen/offscreen-docs.factor +++ b/extra/ui/offscreen/offscreen-docs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Joe Groff. ! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax kernel quotations ui.gadgets -graphics.bitmap strings ui.gadgets.worlds ; +images.bitmap strings ui.gadgets.worlds ; IN: ui.offscreen HELP: diff --git a/extra/ui/offscreen/offscreen.factor b/extra/ui/offscreen/offscreen.factor index 89c1c7f860..cf9370ed7f 100755 --- a/extra/ui/offscreen/offscreen.factor +++ b/extra/ui/offscreen/offscreen.factor @@ -1,5 +1,5 @@ ! (c) 2008 Joe Groff, see license for details -USING: accessors continuations graphics.bitmap kernel math +USING: accessors continuations images.bitmap kernel math sequences ui.gadgets ui.gadgets.worlds ui ui.backend destructors ; IN: ui.offscreen diff --git a/extra/ui/render/test/test.factor b/extra/ui/render/test/test.factor index 2267c22a20..bd3c082652 100755 --- a/extra/ui/render/test/test.factor +++ b/extra/ui/render/test/test.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors colors arrays kernel sequences math byte-arrays -namespaces grouping fry cap graphics.bitmap +namespaces grouping fry cap images.bitmap ui.gadgets ui.gadgets.packs ui.gadgets.borders ui.gadgets.grids ui.gadgets.grid-lines ui.gadgets.labels ui.gadgets.buttons -ui.render ui opengl opengl.gl ; +ui.render ui opengl opengl.gl images images.loader ; IN: ui.render.test SINGLETON: line-test @@ -30,7 +30,7 @@ SYMBOL: render-output : bitmap= ( bitmap1 bitmap2 -- ? ) [ - [ [ array>> ] [ stride 4 align ] bi group ] [ stride ] bi + [ [ buffer>> ] [ stride 4 align ] bi group ] [ stride ] bi '[ _ head twiddle ] map ] bi@ = ; @@ -38,7 +38,7 @@ SYMBOL: render-output screenshot [ render-output set-global ] [ - "resource:extra/ui/render/test/reference.bmp" load-bitmap + "resource:extra/ui/render/test/reference.bmp" load-image bitmap= "is perfect" "needs work" ? "Your UI rendering " prepend message-window diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor index e1f6c8735a..6ef60c198f 100755 --- a/extra/webapps/todo/todo.factor +++ b/extra/webapps/todo/todo.factor @@ -106,7 +106,8 @@ todo "TODO" : ( -- responder ) todo-list new-dispatcher - "" add-responder + "list" add-responder + URL" /list" "" add-responder "view" add-responder "new" add-responder "edit" add-responder @@ -115,3 +116,52 @@ todo "TODO" { todo-list "todo" } >>template "view your todo list" >>description ; + +USING: furnace.auth.features.registration +furnace.auth.features.edit-profile +furnace.auth.features.deactivate-user +db.sqlite +furnace.alloy +io.servers.connection +io.sockets.secure ; + +: ( responder -- responder' ) + "Todo list" + "Todo list" >>name + allow-registration + allow-edit-profile + allow-deactivation ; + +: todo-db ( -- db ) "resource:todo.db" ; + +: init-todo-db ( -- ) + todo-db [ + init-furnace-tables + todo ensure-table + ] with-db ; + +: ( -- config ) + ! This is only suitable for testing! + + "resource:basis/openssl/test/dh1024.pem" >>dh-file + "resource:basis/openssl/test/server.pem" >>key-file + "password" >>password ; + +: ( -- responder ) + init-todo-db + + + todo-db ; + +: ( -- threaded-server ) + + >>secure-config + 8080 >>insecure + 8431 >>secure ; + +: run-todo ( -- ) + main-responder set-global + todo-db start-expiring + start-server ; + +MAIN: run-todo diff --git a/extra/webapps/todo/todo.xml b/extra/webapps/todo/todo.xml index f7500cdad2..00ed63560c 100644 --- a/extra/webapps/todo/todo.xml +++ b/extra/webapps/todo/todo.xml @@ -2,7 +2,14 @@ + + + + + + +
List Items @@ -19,4 +26,8 @@ + + + + diff --git a/vm/os-unix.c b/vm/os-unix.c index b49f7637af..97c29d8c6e 100755 --- a/vm/os-unix.c +++ b/vm/os-unix.c @@ -36,7 +36,7 @@ void init_ffi(void) void ffi_dlopen(F_DLL *dll) { - dll->dll = dlopen(alien_offset(dll->path), RTLD_LAZY|RTLD_GLOBAL); + dll->dll = dlopen(alien_offset(dll->path), RTLD_LAZY); } void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol)