Merge branch 'master' of git://factorcode.org/git/factor
commit
e138355abe
|
@ -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: }
|
||||
|
|
|
@ -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 ]
|
||||
[ <longlong> ]
|
||||
[ <float> ]
|
||||
[ <complex-float> ]
|
||||
[ 1 0 ? <short> ]
|
||||
} 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
|
||||
|
||||
[ [
|
||||
! [<fortran-result>]
|
||||
[ "complex-float" <c-object> ] 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
|
||||
|
||||
[ [
|
||||
! [<fortran-result>]
|
||||
[ 20 <byte-array> 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:
|
||||
|
||||
[ [
|
||||
! [<fortran-result>]
|
||||
[ 10 <byte-array> 10 ] 3 ndip
|
||||
! [fortran-args>c-args]
|
||||
{
|
||||
[ {
|
||||
[ ascii string>alien ]
|
||||
[ <float> ]
|
||||
[ 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 ]
|
||||
[ <longlong> ]
|
||||
[ <float> ]
|
||||
[ <complex-float> ]
|
||||
[ 1 0 ? <short> ]
|
||||
} 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
|
||||
|
||||
[ [
|
||||
! [<fortran-result>]
|
||||
[ "complex-float" <c-object> ] 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
|
||||
|
||||
[ [
|
||||
! [<fortran-result>]
|
||||
[ 20 <byte-array> 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
|
||||
|
||||
[ [
|
||||
! [<fortran-result>]
|
||||
[ 10 <byte-array> 10 ] 3 ndip
|
||||
! [fortran-args>c-args]
|
||||
{
|
||||
[ {
|
||||
[ ascii string>alien ]
|
||||
[ <float> ]
|
||||
[ 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
|
||||
|
|
|
@ -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
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: lowercase-name-with-underscore ( name -- name' )
|
||||
>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 [ <complex-double> ] [ drop ] ] args?dims ;
|
||||
|
||||
M: character-type (fortran-arg>c-args)
|
||||
drop [ ascii string>alien ] [ length ] ;
|
||||
fix-character-type single-char?
|
||||
[ [ first <char> ] [ 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 (<fortran-result>)
|
|||
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 )
|
||||
|
@ -363,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 [<fortran-result>] ]
|
||||
[ nip nip nip [fortran-args>c-args] ]
|
||||
[ [fortran-invoke] ]
|
||||
|
@ -388,4 +447,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 ]
|
||||
[ set-fortran-abi ] bi ; parsing
|
||||
|
||||
|
|
|
@ -1,3 +1,2 @@
|
|||
fortran
|
||||
ffi
|
||||
unportable
|
||||
|
|
|
@ -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 <bit-array> ] [
|
||||
[let | out [ n log2 1+ <bit-array> ] 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 = [
|
||||
<bit-array>
|
||||
] [
|
||||
[ log2 1+ <bit-array> 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 )
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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: <selector> ( 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 ] [
|
||||
|
|
|
@ -24,4 +24,4 @@ IN: compiler.utilities
|
|||
|
||||
SYMBOL: yield-hook
|
||||
|
||||
yield-hook global [ [ ] or ] change-at
|
||||
yield-hook [ [ ] ] initialize
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -161,7 +161,7 @@ C: <trivial-responder> trivial-responder
|
|||
|
||||
M: trivial-responder call-responder* nip response>> clone ;
|
||||
|
||||
main-responder global [ <404> <trivial-responder> or ] change-at
|
||||
main-responder [ <404> <trivial-responder> ] initialize
|
||||
|
||||
: invert-slice ( slice -- slice' )
|
||||
dup slice? [ [ seq>> ] [ from>> ] bi head-slice ] [ drop { } ] if ;
|
||||
|
|
|
@ -47,8 +47,8 @@ PRIVATE>
|
|||
"resource:basis/io/encodings/iana/character-sets"
|
||||
utf8 <file-reader> 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 -- )
|
||||
[
|
||||
|
|
|
@ -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
|
||||
>>
|
||||
|
||||
|
|
|
@ -1,4 +1,3 @@
|
|||
math
|
||||
bindings
|
||||
fortran
|
||||
unportable
|
||||
|
|
|
@ -1,3 +1,2 @@
|
|||
math
|
||||
bindings
|
||||
unportable
|
||||
|
|
|
@ -1,3 +1,2 @@
|
|||
math
|
||||
bindings
|
||||
unportable
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 [
|
||||
|
|
|
@ -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? [
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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
|
||||
[ 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
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ( -- )
|
||||
|
||||
|
|
|
@ -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." } ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 )
|
||||
[
|
||||
|
|
|
@ -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 [
|
||||
|
|
|
@ -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 ]
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -1,18 +1,51 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel ;
|
||||
USING: accessors kernel grouping fry sequences combinators
|
||||
math ;
|
||||
IN: images.backend
|
||||
|
||||
TUPLE: image width height depth pitch buffer ;
|
||||
SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ;
|
||||
|
||||
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 buffer class -- image )
|
||||
: no-op ( -- ) ;
|
||||
|
||||
: normalize-component-order ( image -- image )
|
||||
dup component-order>>
|
||||
{
|
||||
{ RGBA [ no-op ] }
|
||||
{ BGRA [
|
||||
[
|
||||
[ 4 <sliced-groups> [ [ 0 3 ] dip <slice> reverse-here ] each ]
|
||||
[ RGBA >>component-order ] bi
|
||||
] change-bitmap
|
||||
] }
|
||||
{ RGB [
|
||||
[ 3 <sliced-groups> [ 255 suffix ] map concat ] change-bitmap
|
||||
] }
|
||||
{ BGR [
|
||||
[
|
||||
3 <sliced-groups> dup [ [ 0 3 ] dip <slice> reverse-here ] each
|
||||
[ 255 suffix ] map concat
|
||||
] change-bitmap
|
||||
] }
|
||||
} case RGBA >>component-order ;
|
||||
|
||||
GENERIC: normalize-scan-line-order ( image -- image )
|
||||
|
||||
M: image normalize-scan-line-order ;
|
||||
: normalize-image ( image -- image )
|
||||
normalize-component-order
|
||||
normalize-scan-line-order ;
|
||||
|
||||
: new-image ( dim component-order bitmap class -- image )
|
||||
new
|
||||
swap >>buffer
|
||||
swap >>depth
|
||||
swap >>height
|
||||
swap >>width ; inline
|
||||
swap >>bitmap
|
||||
swap >>component-order
|
||||
swap >>dim ; inline
|
||||
|
|
|
@ -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" ;
|
||||
|
||||
|
|
|
@ -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,23 +86,36 @@ M: bitmap-magic summary
|
|||
parse-file-header parse-bitmap-header parse-bitmap
|
||||
] with-file-reader ;
|
||||
|
||||
: alpha-channel-zero? ( bitmap -- ? )
|
||||
buffer>> 4 <sliced-groups> 3 <column> [ 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 ;
|
||||
|
||||
: bitmap>image ( bitmap -- bitmap-image )
|
||||
{ [ width>> ] [ height>> ] [ bit-count>> ] [ buffer>> ] } cleave
|
||||
bitmap-image new-image ;
|
||||
ERROR: unknown-component-order bitmap ;
|
||||
|
||||
: bitmap>component-order ( bitmap -- object )
|
||||
bit-count>> {
|
||||
{ 32 [ BGRA ] }
|
||||
{ 24 [ BGR ] }
|
||||
{ 8 [ BGR ] }
|
||||
[ unknown-component-order ]
|
||||
} case ;
|
||||
|
||||
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 ;
|
||||
|
||||
M: bitmap-image normalize-scan-line-order
|
||||
dup dim>> '[
|
||||
_ first 4 * <sliced-groups> reverse concat
|
||||
] change-bitmap ;
|
||||
|
||||
MACRO: (nbits>bitmap) ( bits -- )
|
||||
[ -3 shift ] keep '[
|
||||
|
@ -112,7 +124,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 )
|
||||
|
|
|
@ -5,9 +5,17 @@ accessors images.bitmap images.tiff images.backend io.backend
|
|||
io.pathnames ;
|
||||
IN: images
|
||||
|
||||
: <image> ( path -- image )
|
||||
normalize-path dup "." split1-last nip >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* ;
|
||||
|
||||
: <image> ( path -- image )
|
||||
load-image normalize-image ;
|
||||
|
|
|
@ -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 ;
|
||||
|
@ -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,29 +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 ;
|
||||
|
||||
: ifd>image ( ifd -- image )
|
||||
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 ;
|
||||
|
||||
M: ifd >image ( ifd -- image )
|
||||
{
|
||||
[ image-width find-tag ]
|
||||
[ image-length find-tag ]
|
||||
[ bits-per-sample find-tag sum ]
|
||||
[ buffer>> ]
|
||||
[ [ image-width find-tag ] [ image-length find-tag ] bi 2array ]
|
||||
[ ifd-component-order ]
|
||||
[ 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 [
|
||||
<parsed-tiff>
|
||||
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 ;
|
||||
|
|
|
@ -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,48 +22,16 @@ M: image-gadget draw-gadget* ( gadget -- )
|
|||
\ image-gadget new-gadget
|
||||
swap >>image ;
|
||||
|
||||
: bits>gl-params ( n -- gl-bgr gl-format )
|
||||
{
|
||||
{ 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 ;
|
||||
|
||||
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 ]
|
||||
[ depth>> bits>gl-params ]
|
||||
[ buffer>> ]
|
||||
} cleave glDrawPixels ;
|
||||
|
||||
: image-window ( path -- gadget )
|
||||
[ <image> <image-gadget> dup ] [ open-window ] bi ;
|
||||
|
||||
M: tiff-image draw-image ( tiff -- )
|
||||
0 0 glRasterPos2i 1.0 -1.0 glPixelZoom
|
||||
{
|
||||
[ height>> ]
|
||||
[ width>> ]
|
||||
[ depth>> bits>gl-params ]
|
||||
[ buffer>> ]
|
||||
} cleave glDrawPixels ;
|
||||
GENERIC: image. ( object -- )
|
||||
|
||||
GENERIC: image. ( image -- )
|
||||
: default-image. ( path -- )
|
||||
<image-gadget> gadget. ;
|
||||
|
||||
M: string image. ( image -- ) <image> <image-gadget> gadget. ;
|
||||
M: string image. ( image -- ) <image> default-image. ;
|
||||
|
||||
M: pathname image. ( image -- ) <image> <image-gadget> gadget. ;
|
||||
M: pathname image. ( image -- ) <image> default-image. ;
|
||||
|
||||
M: image image. ( image -- ) <image-gadget> gadget. ;
|
||||
M: image image. ( image -- ) default-image. ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
Loading…
Reference in New Issue