From bac9705da1e9bbd13953461c0d6bcc67ff2551e0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 10 Feb 2009 10:37:46 -0600 Subject: [PATCH 01/18] spiff up id3 docs a bit, and fix help-lint --- extra/id3/id3-docs.factor | 12 ++++++------ extra/id3/id3-tests.factor | 6 +++--- extra/id3/id3.factor | 2 +- 3 files changed, 10 insertions(+), 10 deletions(-) diff --git a/extra/id3/id3-docs.factor b/extra/id3/id3-docs.factor index 94128dc3b2..da69c2ced3 100644 --- a/extra/id3/id3-docs.factor +++ b/extra/id3/id3-docs.factor @@ -3,15 +3,15 @@ USING: help.markup help.syntax sequences kernel ; IN: id3 -HELP: id3-parse-mp3-file +HELP: file-id3-tags { $values { "path" "a path string" } - { "object/f" "either a tuple consisting of the data from an MP3 file, or an f indicating this file has no (supported) ID3 information." } } -{ $description "Return a tuple containing the ID3 information parsed out of the MP3 file" } ; + { "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" -{ $emphasis "ID3" } " tags are textual data that is used to describe the information (title, artist, etc.) in an .MP3 file" -"Parsing an MP3 file: " -{ $subsection id3-parse-mp3-file } ; +"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 index d84f2c8726..b9d45b1b04 100644 --- a/extra/id3/id3-tests.factor +++ b/extra/id3/id3-tests.factor @@ -58,7 +58,7 @@ IN: id3.tests } } } -] [ "resource:extra/id3/tests/blah3.mp3" id3-parse-mp3-file ] unit-test +] [ "resource:extra/id3/tests/blah3.mp3" file-id3-tags ] unit-test [ T{ mp3v2-file @@ -159,7 +159,7 @@ IN: id3.tests } } } -] [ "resource:extra/id3/tests/blah2.mp3" id3-parse-mp3-file ] unit-test +] [ "resource:extra/id3/tests/blah2.mp3" file-id3-tags ] unit-test [ T{ mp3v1-file @@ -178,5 +178,5 @@ IN: id3.tests } { genre 89 } } -] [ "resource:extra/id3/tests/blah.mp3" id3-parse-mp3-file ] unit-test +] [ "resource:extra/id3/tests/blah.mp3" file-id3-tags ] unit-test diff --git a/extra/id3/id3.factor b/extra/id3/id3.factor index b2c2ec0621..64e1ff1d10 100644 --- a/extra/id3/id3.factor +++ b/extra/id3/id3.factor @@ -142,7 +142,7 @@ PRIVATE> ! main stuff -: id3-parse-mp3-file ( path -- object ) +: file-id3-tags ( path -- object/f ) [ { { [ dup id3v2? ] [ read-v2-tag-data ] } ! ( ? -- mp3v2-file ) From 1708d10c9a94e0af4ac1da04c0494aafc0fa33cc Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 10 Feb 2009 13:02:33 -0600 Subject: [PATCH 02/18] add initialize word to namespaces. foo global [ [ bar ] unless* ] curry => foo [ bar ] initialize --- core/namespaces/namespaces-docs.factor | 9 +++++++-- core/namespaces/namespaces-tests.factor | 11 +++++++++++ core/namespaces/namespaces.factor | 5 ++++- 3 files changed, 22 insertions(+), 3 deletions(-) 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 ; From 8a144b7b948d72239b484dabeefc016bf9c1ea58 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 10 Feb 2009 13:11:06 -0600 Subject: [PATCH 03/18] support different fortran ABIs --- basis/alien/fortran/fortran-docs.factor | 27 +- basis/alien/fortran/fortran-tests.factor | 546 +++++++++++++---------- basis/alien/fortran/fortran.factor | 92 +++- basis/math/blas/ffi/ffi.factor | 8 +- 4 files changed, 418 insertions(+), 255 deletions(-) diff --git a/basis/alien/fortran/fortran-docs.factor b/basis/alien/fortran/fortran-docs.factor index 4accbf5965..c5d124e198 100644 --- a/basis/alien/fortran/fortran-docs.factor +++ b/basis/alien/fortran/fortran-docs.factor @@ -1,9 +1,19 @@ ! Copyright (C) 2009 Joe Groff ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax kernel quotations sequences strings ; +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 @@ -15,7 +25,7 @@ ARTICLE: "alien.fortran-types" "Fortran types" { { $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 parameters." } + { "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." ; @@ -30,15 +40,20 @@ HELP: SUBROUTINE: 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." } ; +{ $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." } ; +{ $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 } + { "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 "\"!\"" } "." } ; @@ -46,6 +61,8 @@ HELP: fortran-invoke 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: } diff --git a/basis/alien/fortran/fortran-tests.factor b/basis/alien/fortran/fortran-tests.factor index 1b2ffda4a9..177d1077c2 100644 --- a/basis/alien/fortran/fortran-tests.factor +++ b/basis/alien/fortran/fortran-tests.factor @@ -1,295 +1,381 @@ ! (c) 2009 Joe Groff, see BSD license USING: accessors alien alien.c-types alien.complex -alien.fortran alien.strings alien.structs alien.syntax arrays -assocs byte-arrays combinators fry generalizations -io.encodings.ascii kernel macros macros.expander namespaces -sequences shuffle tools.test ; +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" } ; -! fortran-name>symbol-name +intel-unix-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 + ! fortran-name>symbol-name -! fortran-type>c-type + [ "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 -[ "short" ] -[ "integer*2" fortran-type>c-type ] unit-test + ! fortran-type>c-type -[ "int" ] -[ "integer*4" fortran-type>c-type ] unit-test + [ "short" ] + [ "integer*2" fortran-type>c-type ] unit-test -[ "int" ] -[ "INTEGER" fortran-type>c-type ] unit-test + [ "int" ] + [ "integer*4" fortran-type>c-type ] unit-test -[ "longlong" ] -[ "iNteger*8" fortran-type>c-type ] unit-test + [ "int" ] + [ "INTEGER" fortran-type>c-type ] unit-test -[ "int[0]" ] -[ "integer(*)" fortran-type>c-type ] unit-test + [ "longlong" ] + [ "iNteger*8" fortran-type>c-type ] unit-test -[ "int[0]" ] -[ "integer(3,*)" fortran-type>c-type ] unit-test + [ "int[0]" ] + [ "integer(*)" fortran-type>c-type ] unit-test -[ "int[3]" ] -[ "integer(3)" fortran-type>c-type ] unit-test + [ "int[0]" ] + [ "integer(3,*)" fortran-type>c-type ] unit-test -[ "int[6]" ] -[ "integer(3,2)" fortran-type>c-type ] unit-test + [ "int[3]" ] + [ "integer(3)" fortran-type>c-type ] unit-test -[ "int[24]" ] -[ "integer(4,3,2)" fortran-type>c-type ] unit-test + [ "int[6]" ] + [ "integer(3,2)" fortran-type>c-type ] unit-test -[ "char[1]" ] -[ "character" fortran-type>c-type ] unit-test + [ "int[24]" ] + [ "integer(4,3,2)" fortran-type>c-type ] unit-test -[ "char[17]" ] -[ "character*17" fortran-type>c-type ] unit-test + [ "char" ] + [ "character" fortran-type>c-type ] unit-test -[ "char[17]" ] -[ "character(17)" fortran-type>c-type ] unit-test + [ "char" ] + [ "character*1" fortran-type>c-type ] unit-test -[ "int" ] -[ "logical" fortran-type>c-type ] unit-test + [ "char[17]" ] + [ "character*17" fortran-type>c-type ] unit-test -[ "float" ] -[ "real" fortran-type>c-type ] unit-test + [ "char[17]" ] + [ "character(17)" fortran-type>c-type ] unit-test -[ "double" ] -[ "double-precision" fortran-type>c-type ] unit-test + [ "int" ] + [ "logical" fortran-type>c-type ] unit-test -[ "float" ] -[ "real*4" fortran-type>c-type ] unit-test + [ "float" ] + [ "real" fortran-type>c-type ] unit-test -[ "double" ] -[ "real*8" fortran-type>c-type ] unit-test + [ "double" ] + [ "double-precision" fortran-type>c-type ] unit-test -[ "complex-float" ] -[ "complex" fortran-type>c-type ] unit-test + [ "float" ] + [ "real*4" fortran-type>c-type ] unit-test -[ "complex-double" ] -[ "double-complex" fortran-type>c-type ] unit-test + [ "double" ] + [ "real*8" fortran-type>c-type ] unit-test -[ "complex-float" ] -[ "complex*8" fortran-type>c-type ] unit-test + [ "complex-float" ] + [ "complex" fortran-type>c-type ] unit-test -[ "complex-double" ] -[ "complex*16" fortran-type>c-type ] unit-test + [ "complex-double" ] + [ "double-complex" fortran-type>c-type ] unit-test -[ "fortran_test_record" ] -[ "fortran_test_record" fortran-type>c-type ] unit-test + [ "complex-float" ] + [ "complex*8" fortran-type>c-type ] unit-test -! fortran-arg-type>c-type + [ "complex-double" ] + [ "complex*16" fortran-type>c-type ] unit-test -[ "int*" { } ] -[ "integer" fortran-arg-type>c-type ] unit-test + [ "fortran_test_record" ] + [ "fortran_test_record" fortran-type>c-type ] unit-test -[ "int*" { } ] -[ "integer(3)" fortran-arg-type>c-type ] unit-test + ! fortran-arg-type>c-type -[ "int*" { } ] -[ "integer(*)" 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 + [ "int*" { } ] + [ "integer(3)" fortran-arg-type>c-type ] unit-test -[ "char*" { "long" } ] -[ "character" fortran-arg-type>c-type ] unit-test + [ "int*" { } ] + [ "integer(*)" fortran-arg-type>c-type ] unit-test -[ "char*" { "long" } ] -[ "character(17)" fortran-arg-type>c-type ] unit-test + [ "fortran_test_record*" { } ] + [ "fortran_test_record" fortran-arg-type>c-type ] unit-test -! fortran-ret-type>c-type + [ "char*" { } ] + [ "character" fortran-arg-type>c-type ] unit-test -[ "void" { "char*" "long" } ] -[ "character(17)" fortran-ret-type>c-type ] unit-test + [ "char*" { } ] + [ "character(1)" fortran-arg-type>c-type ] unit-test -[ "int" { } ] -[ "integer" fortran-ret-type>c-type ] unit-test + [ "char*" { "long" } ] + [ "character(17)" fortran-arg-type>c-type ] unit-test -[ "int" { } ] -[ "logical" fortran-ret-type>c-type ] unit-test + ! fortran-ret-type>c-type -[ "float" { } ] -[ "real" fortran-ret-type>c-type ] unit-test + [ "char" { } ] + [ "character(1)" fortran-ret-type>c-type ] unit-test -[ "double" { } ] -[ "double-precision" fortran-ret-type>c-type ] unit-test + [ "void" { "char*" "long" } ] + [ "character(17)" fortran-ret-type>c-type ] unit-test -[ "void" { "complex-float*" } ] -[ "complex" fortran-ret-type>c-type ] unit-test + [ "int" { } ] + [ "integer" fortran-ret-type>c-type ] unit-test -[ "void" { "complex-double*" } ] -[ "double-complex" fortran-ret-type>c-type ] unit-test + [ "int" { } ] + [ "logical" fortran-ret-type>c-type ] unit-test -[ "void" { "int*" } ] -[ "integer(*)" fortran-ret-type>c-type ] unit-test + [ "float" { } ] + [ "real" fortran-ret-type>c-type ] unit-test -[ "void" { "fortran_test_record*" } ] -[ "fortran_test_record" fortran-ret-type>c-type ] unit-test + [ "void" { "float*" } ] + [ "real(*)" fortran-ret-type>c-type ] unit-test -! fortran-sig>c-sig + [ "double" { } ] + [ "double-precision" fortran-ret-type>c-type ] unit-test -[ "float" { "int*" "char*" "float*" "double*" "long" } ] -[ "real" { "integer" "character*17" "real" "real*8" } fortran-sig>c-sig ] -unit-test + [ "void" { "complex-float*" } ] + [ "complex" fortran-ret-type>c-type ] unit-test -[ "void" { "char*" "long" "char*" "char*" "int*" "long" "long" } ] -[ "character*18" { "character*17" "character" "integer" } fortran-sig>c-sig ] -unit-test + [ "void" { "complex-double*" } ] + [ "double-complex" fortran-ret-type>c-type ] unit-test -[ "void" { "complex-float*" "char*" "char*" "int*" "long" "long" } ] -[ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ] -unit-test + [ "void" { "int*" } ] + [ "integer(*)" fortran-ret-type>c-type ] unit-test -! fortran-record>c-struct + [ "void" { "fortran_test_record*" } ] + [ "fortran_test_record" fortran-ret-type>c-type ] unit-test -[ { - { "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 + ! fortran-sig>c-sig -! RECORD: + [ "float" { "int*" "char*" "float*" "double*" "long" } ] + [ "real" { "integer" "character*17" "real" "real*8" } fortran-sig>c-sig ] + unit-test -[ 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 + [ "char" { "char*" "char*" "int*" "long" } ] + [ "character(1)" { "character*17" "character" "integer" } fortran-sig>c-sig ] + unit-test -! (fortran-invoke) + [ "void" { "char*" "long" "char*" "char*" "int*" "long" } ] + [ "character*18" { "character*17" "character" "integer" } fortran-sig>c-sig ] + unit-test -[ [ - ! [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 + [ "void" { "complex-float*" "char*" "char*" "int*" "long" } ] + [ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ] + 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 + ! fortran-record>c-struct -[ [ - ! [] - [ "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 + [ { + { "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 -[ [ - ! [] - [ 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 + ! RECORD: -[ [ - ! [] - [ 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 + [ 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 index 9327c7b02c..cdf64ecb10 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -5,11 +5,10 @@ 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 system ; +math.order sorting strings system ; IN: alien.fortran -! XXX this currently only supports the gfortran/f2c abi. -! XXX we should also support ifort at some point for commercial BLASes +SINGLETONS: f2c-abi gfortran-abi intel-unix-abi intel-windows-abi ; << : add-f2c-libraries ( -- ) @@ -22,18 +21,55 @@ os netbsd? [ add-f2c-libraries ] when : alien>nstring ( alien len encoding -- string ) [ memory>byte-array ] dip decode ; -: fortran-name>symbol-name ( fortran-name -- c-name ) - >lower CHAR: _ over member? - [ "__" append ] [ "_" append ] if ; - 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 ; @@ -107,10 +143,14 @@ M: double-complex-type (fortran-type>c-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>> [ ] [ { 1 } >>dims ] if ] 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 ; @@ -142,22 +182,23 @@ M: character-type (fortran-type>c-type) GENERIC: added-c-args ( type -- args ) M: fortran-type added-c-args drop { } ; -M: character-type added-c-args drop { "long" } ; +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: complex-type returns-by-value? drop f ; +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) ; -! XXX F2C claims to return double for REAL typed functions -! XXX OSX Accelerate.framework uses float -! M: real-type (fortran-ret-type>c-type) drop "double" ; +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 @@ -209,7 +250,9 @@ M: double-complex-type (fortran-arg>c-args) [ drop [ ] [ drop ] ] args?dims ; M: character-type (fortran-arg>c-args) - drop [ ascii string>alien ] [ length ] ; + fix-character-type single-char? + [ [ first ] [ drop ] ] + [ [ ascii string>alien ] [ length ] ] if ; M: misc-type (fortran-arg>c-args) drop [ ] [ drop ] ; @@ -255,7 +298,9 @@ M: double-complex-type (fortran-result>) [ drop { [ *complex-double ] } ] result?dims ; M: character-type (fortran-result>) - drop { [ ] [ ascii alien>nstring ] } ; + fix-character-type single-char? + [ { [ *char 1string ] } ] + [ { [ ] [ ascii alien>nstring ] } ] if ; M: misc-type (fortran-result>) drop { [ ] } ; @@ -331,8 +376,18 @@ M: character-type () 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) ; @@ -344,7 +399,7 @@ PRIVATE> parse-fortran-type dup returns-by-value? [ (fortran-ret-type>c-type) { } ] [ "void" swap - [ added-c-args ] [ (fortran-ret-type>c-type) c-type>pointer ] bi prefix + [ added-c-args ] [ (fortran-type>c-type) c-type>pointer ] bi prefix ] if ; : fortran-arg-types>c-types ( fortran-types -- c-types ) @@ -388,4 +443,7 @@ MACRO: fortran-invoke ( return library function parameters -- ) [ "()" subseq? not ] filter define-fortran-function ; parsing : LIBRARY: - scan "c-library" set ; parsing + scan + [ "c-library" set ] + [ library-fortran-abis get-global at fortran-abi set ] bi ; parsing + diff --git a/basis/math/blas/ffi/ffi.factor b/basis/math/blas/ffi/ffi.factor index 77cee1aa82..1749103ce4 100644 --- a/basis/math/blas/ffi/ffi.factor +++ b/basis/math/blas/ffi/ffi.factor @@ -3,9 +3,11 @@ IN: math.blas.ffi << "blas" { - { [ os macosx? ] [ "libblas.dylib" "cdecl" add-library ] } - { [ os windows? ] [ "blas.dll" "cdecl" add-library ] } - [ "libblas.so" "cdecl" add-library ] + { [ 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 >> From 0279270dda37a45323bdb3170970ec62abab3005 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 10 Feb 2009 15:11:39 -0600 Subject: [PATCH 04/18] un-unportable the blas stuff --- basis/alien/fortran/tags.txt | 1 - basis/math/blas/ffi/tags.txt | 1 - basis/math/blas/matrices/tags.txt | 1 - basis/math/blas/vectors/tags.txt | 1 - 4 files changed, 4 deletions(-) diff --git a/basis/alien/fortran/tags.txt b/basis/alien/fortran/tags.txt index 58465edeb5..2a9b5def7a 100644 --- a/basis/alien/fortran/tags.txt +++ b/basis/alien/fortran/tags.txt @@ -1,3 +1,2 @@ fortran ffi -unportable diff --git a/basis/math/blas/ffi/tags.txt b/basis/math/blas/ffi/tags.txt index a4a4ea88ab..f468a9989d 100644 --- a/basis/math/blas/ffi/tags.txt +++ b/basis/math/blas/ffi/tags.txt @@ -1,4 +1,3 @@ math bindings fortran -unportable diff --git a/basis/math/blas/matrices/tags.txt b/basis/math/blas/matrices/tags.txt index 5118958180..241ec1ecda 100644 --- a/basis/math/blas/matrices/tags.txt +++ b/basis/math/blas/matrices/tags.txt @@ -1,3 +1,2 @@ math bindings -unportable diff --git a/basis/math/blas/vectors/tags.txt b/basis/math/blas/vectors/tags.txt index 5118958180..241ec1ecda 100644 --- a/basis/math/blas/vectors/tags.txt +++ b/basis/math/blas/vectors/tags.txt @@ -1,3 +1,2 @@ math bindings -unportable From 07caee3405a9ae8c2f9aa2125b74aac279d41131 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 10 Feb 2009 16:16:12 -0600 Subject: [PATCH 05/18] Update some existing code to use initialize --- basis/cocoa/cocoa.factor | 2 +- basis/cocoa/messages/messages.factor | 8 ++++---- basis/compiler/utilities/utilities.factor | 2 +- basis/concurrency/messaging/messaging.factor | 2 +- basis/help/help.factor | 2 +- basis/help/topics/topics.factor | 4 ++-- basis/html/templates/chloe/syntax/syntax.factor | 2 +- basis/http/server/server.factor | 2 +- basis/io/encodings/iana/iana.factor | 4 ++-- basis/tools/annotations/annotations.factor | 2 +- basis/ui/cocoa/cocoa.factor | 6 +++--- basis/ui/gadgets/worlds/worlds.factor | 2 +- core/alien/alien.factor | 2 +- core/compiler/units/units.factor | 4 +--- core/io/backend/backend.factor | 2 +- core/parser/parser.factor | 2 +- core/strings/parser/parser.factor | 6 +++--- core/words/words.factor | 4 ++-- extra/mason/config/config.factor | 4 ++-- 19 files changed, 30 insertions(+), 32 deletions(-) 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..529efeb564 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 or ] initialize : (objc-class) ( name word -- class ) 2dup execute dup [ 2nip ] [ 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/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/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/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/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/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/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/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/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/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/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/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/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 From a0421edf97056f14a1dceb9f0e90a553cbf28ca4 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 10 Feb 2009 16:39:24 -0600 Subject: [PATCH 06/18] set fortran abi in fortran-invoke macro --- basis/alien/fortran/fortran.factor | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index cdf64ecb10..a2ffc55c02 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -418,8 +418,12 @@ PRIVATE> : 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 ) { + [ 2drop nip set-fortran-abi ] [ 2nip [] ] [ nip nip nip [fortran-args>c-args] ] [ [fortran-invoke] ] @@ -445,5 +449,5 @@ MACRO: fortran-invoke ( return library function parameters -- ) : LIBRARY: scan [ "c-library" set ] - [ library-fortran-abis get-global at fortran-abi set ] bi ; parsing + [ set-fortran-abi ] bi ; parsing From 9060905983c9d11c7a26cce5a027278da2f08b58 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 10 Feb 2009 16:52:27 -0600 Subject: [PATCH 07/18] Fix bootstrap --- basis/cocoa/messages/messages.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index 529efeb564..ce66467203 100644 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -79,7 +79,7 @@ MACRO: (send) ( selector super? -- quot ) ! Runtime introspection SYMBOL: class-init-hooks -class-init-hooks [ H{ } clone or ] initialize +class-init-hooks [ H{ } clone ] initialize : (objc-class) ( name word -- class ) 2dup execute dup [ 2nip ] [ From 8bad9f014ac500647a3c10b06956a3956f86e187 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 10 Feb 2009 16:59:55 -0600 Subject: [PATCH 08/18] case now throws the value it can't find --- core/combinators/combinators-tests.factor | 16 +++++++++++++++- core/combinators/combinators.factor | 4 ++-- 2 files changed, 17 insertions(+), 3 deletions(-) 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 ) From 970953be1f3dcd874f35c131c6b00adafa43e4cf Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 10 Feb 2009 17:17:36 -0600 Subject: [PATCH 09/18] fix tiff/bitmaps color order --- extra/images/backend/backend.factor | 7 +++++-- extra/images/bitmap/bitmap.factor | 12 +++++++++++- extra/images/tiff/tiff.factor | 12 +++++++++++- extra/images/viewer/viewer.factor | 20 +++++++++++++------- 4 files changed, 40 insertions(+), 11 deletions(-) diff --git a/extra/images/backend/backend.factor b/extra/images/backend/backend.factor index ef2a9a4248..5e05db0f4d 100644 --- a/extra/images/backend/backend.factor +++ b/extra/images/backend/backend.factor @@ -3,16 +3,19 @@ USING: accessors kernel ; IN: images.backend -TUPLE: image width height depth pitch buffer ; +SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ; + +TUPLE: image width height depth pitch component-order buffer ; GENERIC: load-image* ( path tuple -- image ) : load-image ( path class -- image ) new load-image* ; -: new-image ( width height depth buffer class -- image ) +: new-image ( width height depth component-order buffer class -- image ) new swap >>buffer + swap >>component-order swap >>depth swap >>height swap >>width ; inline diff --git a/extra/images/bitmap/bitmap.factor b/extra/images/bitmap/bitmap.factor index 50975b2bb3..14d52fdaf8 100755 --- a/extra/images/bitmap/bitmap.factor +++ b/extra/images/bitmap/bitmap.factor @@ -97,8 +97,18 @@ M: bitmap-magic summary : load-bitmap ( path -- bitmap ) 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 ; + : bitmap>image ( bitmap -- bitmap-image ) - { [ width>> ] [ height>> ] [ bit-count>> ] [ buffer>> ] } cleave + { [ width>> ] [ height>> ] [ bit-count>> ] [ bitmap>component-order ] [ buffer>> ] } cleave bitmap-image new-image ; M: bitmap-image load-image* ( path bitmap -- bitmap-image ) diff --git a/extra/images/tiff/tiff.factor b/extra/images/tiff/tiff.factor index 4be81af095..922e302040 100755 --- a/extra/images/tiff/tiff.factor +++ b/extra/images/tiff/tiff.factor @@ -1,7 +1,7 @@ ! 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 +kernel pack endian constructors sequences arrays sorting.slots math.order math.parser prettyprint classes io.binary assocs math math.bitwise byte-arrays grouping images.backend ; @@ -260,17 +260,27 @@ ERROR: bad-small-ifd-type n ; : strips>buffer ( ifd -- ifd ) dup strips>> concat >>buffer ; +ERROR: unknown-component-order ifd ; + +: ifd-component-order ( ifd -- byte-order ) + bits-per-sample find-tag sum { + { 32 [ RGBA ] } + [ unknown-component-order ] + } case ; + : ifd>image ( ifd -- image ) { [ image-width find-tag ] [ image-length find-tag ] [ bits-per-sample find-tag sum ] + [ ifd-component-order ] [ buffer>> ] } cleave tiff-image new-image ; : parsed-tiff>images ( tiff -- sequence ) ifds>> [ ifd>image ] map ; + : load-tiff ( path -- parsed-tiff ) binary [ diff --git a/extra/images/viewer/viewer.factor b/extra/images/viewer/viewer.factor index 4d5df4874a..0b01d75748 100644 --- a/extra/images/viewer/viewer.factor +++ b/extra/images/viewer/viewer.factor @@ -22,12 +22,18 @@ M: image-gadget draw-gadget* ( gadget -- ) \ image-gadget new-gadget swap >>image ; -: bits>gl-params ( n -- gl-bgr gl-format ) +: gl-component-order ( singletons -- n ) { - { 32 [ GL_BGRA GL_UNSIGNED_BYTE ] } - { 24 [ GL_BGR GL_UNSIGNED_BYTE ] } - { 8 [ GL_BGR GL_UNSIGNED_BYTE ] } - { 4 [ GL_BGR GL_UNSIGNED_BYTE ] } + { BGR [ GL_BGR ] } + { RGB [ GL_BGR ] } + { BGRA [ GL_BGRA ] } + { RGBA [ GL_RGBA ] } + ! { RGBX [ GL_RGBX ] } + ! { BGRX [ GL_BGRX ] } + ! { ARGB [ GL_ARGB ] } + ! { ABGR [ GL_ABGR ] } + ! { XRGB [ GL_XRGB ] } + ! { XBGR [ GL_XBGR ] } } case ; M: bitmap-image draw-image ( bitmap -- ) @@ -44,7 +50,7 @@ M: bitmap-image draw-image ( bitmap -- ) ] [ width>> abs ] [ height>> abs ] - [ depth>> bits>gl-params ] + [ component-order>> gl-component-order GL_UNSIGNED_BYTE ] [ buffer>> ] } cleave glDrawPixels ; @@ -56,7 +62,7 @@ M: tiff-image draw-image ( tiff -- ) { [ height>> ] [ width>> ] - [ depth>> bits>gl-params ] + [ component-order>> gl-component-order GL_UNSIGNED_BYTE ] [ buffer>> ] } cleave glDrawPixels ; From 46bfb5c8eab23c26fd5b2b98c62db491b4253354 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 10 Feb 2009 17:20:36 -0600 Subject: [PATCH 10/18] clean up --- extra/images/images.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/extra/images/images.factor b/extra/images/images.factor index eb4fc63fee..4b4673333f 100644 --- a/extra/images/images.factor +++ b/extra/images/images.factor @@ -6,8 +6,7 @@ io.pathnames ; IN: images : ( path -- image ) - normalize-path dup "." split1-last nip >lower - { + dup file-extension >lower { { "bmp" [ bitmap-image load-image ] } { "tiff" [ tiff-image load-image ] } } case ; From c2e6ef0366fde96c9cddc3141af42f5023cf80de Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 10 Feb 2009 17:23:21 -0600 Subject: [PATCH 11/18] remove dead pathname --- extra/images/bitmap/bitmap-tests.factor | 3 --- 1 file changed, 3 deletions(-) diff --git a/extra/images/bitmap/bitmap-tests.factor b/extra/images/bitmap/bitmap-tests.factor index a2b3188749..a7deae3178 100644 --- a/extra/images/bitmap/bitmap-tests.factor +++ b/extra/images/bitmap/bitmap-tests.factor @@ -5,9 +5,6 @@ IN: images.bitmap.tests : test-bitmap24 ( -- path ) "resource:extra/images/test-images/thiswayup24.bmp" ; -: test-bitmap16 ( -- path ) - "resource:extra/images/test-images/rgb16bit.bmp" ; - : test-bitmap8 ( -- path ) "resource:extra/images/test-images/rgb8bit.bmp" ; From cf99c7afd1bdd8e9d1d173f594b5efff6f19eac7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 10 Feb 2009 17:25:02 -0600 Subject: [PATCH 12/18] no locals in bit-arrays --- basis/bit-arrays/bit-arrays.factor | 21 ++++++++++----------- 1 file changed, 10 insertions(+), 11 deletions(-) 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 ) From a1e521b54ee51f3a2e2a9329923e3d97b04551fb Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 10 Feb 2009 18:42:21 -0600 Subject: [PATCH 13/18] working on images protocol --- extra/images/backend/backend.factor | 44 ++++++++++++++++----- extra/images/bitmap/bitmap.factor | 21 +++++----- extra/images/images.factor | 17 +++++++-- extra/images/tiff/tiff.factor | 24 ++++++------ extra/images/viewer/viewer.factor | 59 +++++------------------------ 5 files changed, 77 insertions(+), 88 deletions(-) diff --git a/extra/images/backend/backend.factor b/extra/images/backend/backend.factor index 5e05db0f4d..fb859f31a5 100644 --- a/extra/images/backend/backend.factor +++ b/extra/images/backend/backend.factor @@ -1,21 +1,47 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel ; +USING: accessors kernel grouping fry sequences combinators ; IN: images.backend SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ; +! RGBA -TUPLE: image width height depth pitch component-order buffer ; +TUPLE: image dim component-order bitmap ; + +TUPLE: normalized-image < image ; GENERIC: load-image* ( path tuple -- image ) -: load-image ( path class -- image ) - new load-image* ; +GENERIC: >image ( object -- image ) -: new-image ( width height depth component-order buffer class -- image ) +: no-op ( -- ) ; + +: normalize-component-order ( image -- image ) + dup component-order>> + { + { RGBA [ no-op ] } + { BGRA [ + [ + [ 4 [ [ 0 3 ] dip reverse-here ] each ] + [ RGBA >>component-order ] bi + ] change-bitmap + ] } + { RGB [ + [ 3 [ 255 suffix ] map concat ] change-bitmap + ] } + { BGR [ + [ + 3 dup [ [ 0 3 ] dip reverse-here ] each + [ 255 suffix ] map concat + ] change-bitmap + ] } + } case RGBA >>component-order ; + +: normalize-image ( image -- image ) + normalize-component-order ; + +: new-image ( dim component-order bitmap class -- image ) new - swap >>buffer + swap >>bitmap swap >>component-order - swap >>depth - swap >>height - swap >>width ; inline + swap >>dim ; inline diff --git a/extra/images/bitmap/bitmap.factor b/extra/images/bitmap/bitmap.factor index 14d52fdaf8..7b59827d02 100755 --- a/extra/images/bitmap/bitmap.factor +++ b/extra/images/bitmap/bitmap.factor @@ -15,7 +15,6 @@ TUPLE: bitmap-image < image ; 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? buffer ; : array-copy ( bitmap array -- bitmap array' ) @@ -87,12 +86,8 @@ M: bitmap-magic summary parse-file-header parse-bitmap-header parse-bitmap ] with-file-reader ; -: alpha-channel-zero? ( bitmap -- ? ) - buffer>> 4 3 [ 0 = ] all? ; - : process-bitmap-data ( bitmap -- bitmap ) - dup raw-bitmap>buffer >>buffer - dup alpha-channel-zero? >>alpha-channel-zero? ; + dup raw-bitmap>buffer >>buffer ; : load-bitmap ( path -- bitmap ) load-bitmap-data process-bitmap-data ; @@ -107,13 +102,15 @@ ERROR: unknown-component-order bitmap ; [ unknown-component-order ] } case ; -: bitmap>image ( bitmap -- bitmap-image ) - { [ width>> ] [ height>> ] [ bit-count>> ] [ bitmap>component-order ] [ buffer>> ] } cleave - bitmap-image new-image ; +M: bitmap >image ( bitmap -- bitmap-image ) + { + [ [ width>> ] [ height>> ] bi 2array ] + [ bitmap>component-order ] + [ buffer>> ] + } cleave bitmap-image new-image ; M: bitmap-image load-image* ( path bitmap -- bitmap-image ) - drop load-bitmap - bitmap>image ; + drop load-bitmap >image ; MACRO: (nbits>bitmap) ( bits -- ) [ -3 shift ] keep '[ @@ -122,7 +119,7 @@ MACRO: (nbits>bitmap) ( bits -- ) swap >>height swap >>width swap array-copy [ >>buffer ] [ >>color-index ] bi - _ >>bit-count bitmap>image + _ >>bit-count >image ] ; : bgr>bitmap ( array height width -- bitmap ) diff --git a/extra/images/images.factor b/extra/images/images.factor index 4b4673333f..3df7b5d2d1 100644 --- a/extra/images/images.factor +++ b/extra/images/images.factor @@ -5,8 +5,17 @@ accessors images.bitmap images.tiff images.backend io.backend io.pathnames ; IN: images -: ( path -- image ) - dup file-extension >lower { - { "bmp" [ bitmap-image load-image ] } - { "tiff" [ tiff-image load-image ] } +ERROR: unknown-image-extension extension ; + +: image-class ( path -- class ) + file-extension >lower { + { "bmp" [ bitmap-image ] } + { "tiff" [ tiff-image ] } + [ unknown-image-extension ] } case ; + +: load-image ( path -- image ) + dup image-class new load-image* ; + +: ( path -- image ) + load-image normalize-image ; diff --git a/extra/images/tiff/tiff.factor b/extra/images/tiff/tiff.factor index 922e302040..dc40f648cc 100755 --- a/extra/images/tiff/tiff.factor +++ b/extra/images/tiff/tiff.factor @@ -13,7 +13,7 @@ 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 buffer ; +processed-tags strips bitmap ; CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ; TUPLE: ifd-entry tag type count offset/value ; @@ -257,39 +257,37 @@ ERROR: bad-small-ifd-type n ; dup ifd-entries>> [ process-ifd-entry swap ] H{ } map>assoc >>processed-tags ; -: strips>buffer ( ifd -- ifd ) - dup strips>> concat >>buffer ; +: strips>bitmap ( ifd -- ifd ) + dup strips>> concat >>bitmap ; ERROR: unknown-component-order ifd ; : ifd-component-order ( ifd -- byte-order ) bits-per-sample find-tag sum { { 32 [ RGBA ] } + { 24 [ RGB ] } [ unknown-component-order ] } case ; -: ifd>image ( ifd -- image ) +M: ifd >image ( ifd -- image ) { - [ image-width find-tag ] - [ image-length find-tag ] - [ bits-per-sample find-tag sum ] + [ [ image-width find-tag ] [ image-length find-tag ] bi 2array ] [ ifd-component-order ] - [ buffer>> ] + [ bitmap>> ] } cleave tiff-image new-image ; -: parsed-tiff>images ( tiff -- sequence ) - ifds>> [ ifd>image ] map ; - +M: parsed-tiff >image ( image -- image ) + ifds>> [ >image ] map first ; : load-tiff ( path -- parsed-tiff ) binary [ read-header dup endianness>> [ read-ifds - dup ifds>> [ process-ifd read-strips strips>buffer drop ] each + dup ifds>> [ process-ifd read-strips strips>bitmap 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 parsed-tiff>images first ; + drop load-tiff >image ; diff --git a/extra/images/viewer/viewer.factor b/extra/images/viewer/viewer.factor index 0b01d75748..f99c34f509 100644 --- a/extra/images/viewer/viewer.factor +++ b/extra/images/viewer/viewer.factor @@ -1,19 +1,19 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays combinators images.bitmap kernel math -math.functions namespaces opengl opengl.gl ui ui.gadgets -ui.gadgets.panes ui.render images.tiff sequences multiline -images.backend images io.pathnames strings ; +USING: accessors images images.backend 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 } ; -GENERIC: draw-image ( image -- ) - M: image-gadget pref-dim* - image>> - [ width>> ] [ height>> ] bi - [ abs ] bi@ 2array ; + 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 ; @@ -22,50 +22,9 @@ M: image-gadget draw-gadget* ( gadget -- ) \ image-gadget new-gadget swap >>image ; -: gl-component-order ( singletons -- n ) - { - { BGR [ GL_BGR ] } - { RGB [ GL_BGR ] } - { BGRA [ GL_BGRA ] } - { RGBA [ GL_RGBA ] } - ! { RGBX [ GL_RGBX ] } - ! { BGRX [ GL_BGRX ] } - ! { ARGB [ GL_ARGB ] } - ! { ABGR [ GL_ABGR ] } - ! { XRGB [ GL_XRGB ] } - ! { XBGR [ GL_XBGR ] } - } case ; - -M: bitmap-image draw-image ( bitmap -- ) - { - [ - height>> dup 0 < [ - drop - 0 0 glRasterPos2i - 1.0 -1.0 glPixelZoom - ] [ - 0 swap abs glRasterPos2i - 1.0 1.0 glPixelZoom - ] if - ] - [ width>> abs ] - [ height>> abs ] - [ component-order>> gl-component-order GL_UNSIGNED_BYTE ] - [ buffer>> ] - } cleave glDrawPixels ; - : image-window ( path -- gadget ) [ dup ] [ open-window ] bi ; -M: tiff-image draw-image ( tiff -- ) - 0 0 glRasterPos2i 1.0 -1.0 glPixelZoom - { - [ height>> ] - [ width>> ] - [ component-order>> gl-component-order GL_UNSIGNED_BYTE ] - [ buffer>> ] - } cleave glDrawPixels ; - GENERIC: image. ( image -- ) M: string image. ( image -- ) gadget. ; From 1d5f6901c1224a8f964c148a5615739c87193297 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 10 Feb 2009 18:48:10 -0600 Subject: [PATCH 14/18] fix bitmap drawing --- extra/images/backend/backend.factor | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/extra/images/backend/backend.factor b/extra/images/backend/backend.factor index fb859f31a5..796e9a3a66 100644 --- a/extra/images/backend/backend.factor +++ b/extra/images/backend/backend.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel grouping fry sequences combinators ; +USING: accessors kernel grouping fry sequences combinators +images.bitmap math ; IN: images.backend SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ; @@ -37,8 +38,17 @@ GENERIC: >image ( object -- image ) ] } } case RGBA >>component-order ; +GENERIC: normalize-scan-line-order ( image -- image ) + +M: image normalize-scan-line-order ; +M: bitmap-image normalize-scan-line-order + dup + [ bitmap>> ] [ dim>> first 4 * ] bi reverse concat + >>bitmap ; + : normalize-image ( image -- image ) - normalize-component-order ; + normalize-component-order + normalize-scan-line-order ; : new-image ( dim component-order bitmap class -- image ) new From 7d60fcc5989134f95a57299615e94be2fbdfabd7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 10 Feb 2009 18:52:28 -0600 Subject: [PATCH 15/18] clean up some image code --- extra/images/backend/backend.factor | 7 +++---- extra/images/viewer/viewer.factor | 11 +++++++---- 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/extra/images/backend/backend.factor b/extra/images/backend/backend.factor index 796e9a3a66..2e626b73e6 100644 --- a/extra/images/backend/backend.factor +++ b/extra/images/backend/backend.factor @@ -5,7 +5,6 @@ images.bitmap math ; IN: images.backend SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ; -! RGBA TUPLE: image dim component-order bitmap ; @@ -42,9 +41,9 @@ GENERIC: normalize-scan-line-order ( image -- image ) M: image normalize-scan-line-order ; M: bitmap-image normalize-scan-line-order - dup - [ bitmap>> ] [ dim>> first 4 * ] bi reverse concat - >>bitmap ; + dup dim>> '[ + _ first 4 * reverse concat + ] change-bitmap ; : normalize-image ( image -- image ) normalize-component-order diff --git a/extra/images/viewer/viewer.factor b/extra/images/viewer/viewer.factor index f99c34f509..92277dfdef 100644 --- a/extra/images/viewer/viewer.factor +++ b/extra/images/viewer/viewer.factor @@ -25,10 +25,13 @@ M: image-gadget draw-gadget* ( gadget -- ) : image-window ( path -- gadget ) [ dup ] [ open-window ] bi ; -GENERIC: image. ( image -- ) +GENERIC: image. ( object -- ) -M: string image. ( image -- ) gadget. ; +: default-image. ( path -- ) + gadget. ; -M: pathname image. ( image -- ) gadget. ; +M: string image. ( image -- ) default-image. ; -M: image image. ( image -- ) gadget. ; +M: pathname image. ( image -- ) default-image. ; + +M: image image. ( image -- ) default-image. ; From 94f6d28f34d7a3f0a31a9c3c35ba354d54e69704 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 10 Feb 2009 19:34:02 -0600 Subject: [PATCH 16/18] fix a method --- extra/images/backend/backend.factor | 5 ----- extra/images/bitmap/bitmap.factor | 5 +++++ 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/extra/images/backend/backend.factor b/extra/images/backend/backend.factor index 2e626b73e6..6d73a253ae 100644 --- a/extra/images/backend/backend.factor +++ b/extra/images/backend/backend.factor @@ -40,11 +40,6 @@ GENERIC: >image ( object -- image ) GENERIC: normalize-scan-line-order ( image -- image ) M: image normalize-scan-line-order ; -M: bitmap-image normalize-scan-line-order - dup dim>> '[ - _ first 4 * reverse concat - ] change-bitmap ; - : normalize-image ( image -- image ) normalize-component-order normalize-scan-line-order ; diff --git a/extra/images/bitmap/bitmap.factor b/extra/images/bitmap/bitmap.factor index 7b59827d02..46f90e33f8 100755 --- a/extra/images/bitmap/bitmap.factor +++ b/extra/images/bitmap/bitmap.factor @@ -112,6 +112,11 @@ M: bitmap >image ( bitmap -- bitmap-image ) 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 From 5dd4bbcf42dab7018c3840f53feaefe923d2bd1b Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 10 Feb 2009 19:58:53 -0600 Subject: [PATCH 17/18] Defuse RTLD_GLOBAL time bomb in os-unix.c --- vm/os-unix.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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) From 610c43a3c3c6abf312ca15aa7aef30f187bf0549 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 10 Feb 2009 20:49:10 -0600 Subject: [PATCH 18/18] remove circular using --- extra/images/backend/backend.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/images/backend/backend.factor b/extra/images/backend/backend.factor index 6d73a253ae..756b98efee 100644 --- a/extra/images/backend/backend.factor +++ b/extra/images/backend/backend.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel grouping fry sequences combinators -images.bitmap math ; +math ; IN: images.backend SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ;