steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Daniel Ehrenberg 2009-02-10 21:57:07 -06:00
parent 72c898e2b5 610c43a3c3
commit e138355abe
43 changed files with 627 additions and 408 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
basis/alien/fortran/fortran-docs.factor
View File

@ -1,9 +1,19 @@
! Copyright (C) 2009 Joe Groff ! Copyright (C) 2009 Joe Groff
! See http://factorcode.org/license.txt for BSD license. ! 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 QUALIFIED-WITH: alien.syntax c
IN: alien.fortran 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" ARTICLE: "alien.fortran-types" "Fortran types"
"The Fortran FFI recognizes the following Fortran types:" "The Fortran FFI recognizes the following Fortran types:"
{ $list { $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 "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." } { { $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 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." ; "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: HELP: LIBRARY:
{ $syntax "LIBRARY: name" } { $syntax "LIBRARY: name" }
{ $values { "name" "a logical 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: HELP: RECORD:
{ $syntax "RECORD: NAME { \"TYPE\" \"SLOT\" } ... ;" } { $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 HELP: fortran-invoke
{ $values { $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 "\"!\"" } "." } { $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" ARTICLE: "alien.fortran" "Fortran FFI"
"The " { $vocab-link "alien.fortran" } " vocabulary provides an interface to code in shared libraries written in Fortran." "The " { $vocab-link "alien.fortran" } " vocabulary provides an interface to code in shared libraries written in Fortran."
{ $subsection "alien.fortran-types" } { $subsection "alien.fortran-types" }
{ $subsection "alien.fortran-abis" }
{ $subsection add-fortran-library }
{ $subsection POSTPONE: LIBRARY: } { $subsection POSTPONE: LIBRARY: }
{ $subsection POSTPONE: FUNCTION: } { $subsection POSTPONE: FUNCTION: }
{ $subsection POSTPONE: SUBROUTINE: } { $subsection POSTPONE: SUBROUTINE: }

546
basis/alien/fortran/fortran-tests.factor
View File

@ -1,295 +1,381 @@
! (c) 2009 Joe Groff, see BSD license ! (c) 2009 Joe Groff, see BSD license
USING: accessors alien alien.c-types alien.complex USING: accessors alien alien.c-types alien.complex
alien.fortran alien.strings alien.structs alien.syntax arrays alien.fortran alien.fortran.private alien.strings alien.structs
assocs byte-arrays combinators fry generalizations arrays assocs byte-arrays combinators fry
io.encodings.ascii kernel macros macros.expander namespaces generalizations io.encodings.ascii kernel macros
sequences shuffle tools.test ; macros.expander namespaces sequences shuffle tools.test ;
IN: alien.fortran.tests IN: alien.fortran.tests
<< intel-unix-abi "(alien.fortran-tests)" (add-fortran-library) >>
LIBRARY: (alien.fortran-tests)
RECORD: FORTRAN_TEST_RECORD RECORD: FORTRAN_TEST_RECORD
{ "INTEGER" "FOO" } { "INTEGER" "FOO" }
{ "REAL(2)" "BAR" } { "REAL(2)" "BAR" }
{ "CHARACTER*4" "BAS" } ; { "CHARACTER*4" "BAS" } ;
! fortran-name>symbol-name intel-unix-abi fortran-abi [
[ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test ! fortran-name>symbol-name
[ "fun_times__" ] [ "Fun_Times" fortran-name>symbol-name ] unit-test
[ "funtimes___" ] [ "FunTimes_" fortran-name>symbol-name ] unit-test
! 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" ] ! fortran-type>c-type
[ "integer*2" fortran-type>c-type ] unit-test
[ "int" ] [ "short" ]
[ "integer*4" fortran-type>c-type ] unit-test [ "integer*2" fortran-type>c-type ] unit-test
[ "int" ] [ "int" ]
[ "INTEGER" fortran-type>c-type ] unit-test [ "integer*4" fortran-type>c-type ] unit-test
[ "longlong" ] [ "int" ]
[ "iNteger*8" fortran-type>c-type ] unit-test [ "INTEGER" fortran-type>c-type ] unit-test
[ "int[0]" ] [ "longlong" ]
[ "integer(*)" fortran-type>c-type ] unit-test [ "iNteger*8" fortran-type>c-type ] unit-test
[ "int[0]" ] [ "int[0]" ]
[ "integer(3,*)" fortran-type>c-type ] unit-test [ "integer(*)" fortran-type>c-type ] unit-test
[ "int[3]" ] [ "int[0]" ]
[ "integer(3)" fortran-type>c-type ] unit-test [ "integer(3,*)" fortran-type>c-type ] unit-test
[ "int[6]" ] [ "int[3]" ]
[ "integer(3,2)" fortran-type>c-type ] unit-test [ "integer(3)" fortran-type>c-type ] unit-test
[ "int[24]" ] [ "int[6]" ]
[ "integer(4,3,2)" fortran-type>c-type ] unit-test [ "integer(3,2)" fortran-type>c-type ] unit-test
[ "char[1]" ] [ "int[24]" ]
[ "character" fortran-type>c-type ] unit-test [ "integer(4,3,2)" fortran-type>c-type ] unit-test
[ "char[17]" ] [ "char" ]
[ "character*17" fortran-type>c-type ] unit-test [ "character" fortran-type>c-type ] unit-test
[ "char[17]" ] [ "char" ]
[ "character(17)" fortran-type>c-type ] unit-test [ "character*1" fortran-type>c-type ] unit-test
[ "int" ] [ "char[17]" ]
[ "logical" fortran-type>c-type ] unit-test [ "character*17" fortran-type>c-type ] unit-test
[ "float" ] [ "char[17]" ]
[ "real" fortran-type>c-type ] unit-test [ "character(17)" fortran-type>c-type ] unit-test
[ "double" ] [ "int" ]
[ "double-precision" fortran-type>c-type ] unit-test [ "logical" fortran-type>c-type ] unit-test
[ "float" ] [ "float" ]
[ "real*4" fortran-type>c-type ] unit-test [ "real" fortran-type>c-type ] unit-test
[ "double" ] [ "double" ]
[ "real*8" fortran-type>c-type ] unit-test [ "double-precision" fortran-type>c-type ] unit-test
[ "complex-float" ] [ "float" ]
[ "complex" fortran-type>c-type ] unit-test [ "real*4" fortran-type>c-type ] unit-test
[ "complex-double" ] [ "double" ]
[ "double-complex" fortran-type>c-type ] unit-test [ "real*8" fortran-type>c-type ] unit-test
[ "complex-float" ] [ "complex-float" ]
[ "complex*8" fortran-type>c-type ] unit-test [ "complex" fortran-type>c-type ] unit-test
[ "complex-double" ] [ "complex-double" ]
[ "complex*16" fortran-type>c-type ] unit-test [ "double-complex" fortran-type>c-type ] unit-test
[ "fortran_test_record" ] [ "complex-float" ]
[ "fortran_test_record" fortran-type>c-type ] unit-test [ "complex*8" fortran-type>c-type ] unit-test
! fortran-arg-type>c-type [ "complex-double" ]
[ "complex*16" fortran-type>c-type ] unit-test
[ "int*" { } ] [ "fortran_test_record" ]
[ "integer" fortran-arg-type>c-type ] unit-test [ "fortran_test_record" fortran-type>c-type ] unit-test
[ "int*" { } ] ! fortran-arg-type>c-type
[ "integer(3)" fortran-arg-type>c-type ] unit-test
[ "int*" { } ] [ "int*" { } ]
[ "integer(*)" fortran-arg-type>c-type ] unit-test [ "integer" fortran-arg-type>c-type ] unit-test
[ "fortran_test_record*" { } ] [ "int*" { } ]
[ "fortran_test_record" fortran-arg-type>c-type ] unit-test [ "integer(3)" fortran-arg-type>c-type ] unit-test
[ "char*" { "long" } ] [ "int*" { } ]
[ "character" fortran-arg-type>c-type ] unit-test [ "integer(*)" fortran-arg-type>c-type ] unit-test
[ "char*" { "long" } ] [ "fortran_test_record*" { } ]
[ "character(17)" fortran-arg-type>c-type ] unit-test [ "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" } ] [ "char*" { } ]
[ "character(17)" fortran-ret-type>c-type ] unit-test [ "character(1)" fortran-arg-type>c-type ] unit-test
[ "int" { } ] [ "char*" { "long" } ]
[ "integer" fortran-ret-type>c-type ] unit-test [ "character(17)" fortran-arg-type>c-type ] unit-test
[ "int" { } ] ! fortran-ret-type>c-type
[ "logical" fortran-ret-type>c-type ] unit-test
[ "float" { } ] [ "char" { } ]
[ "real" fortran-ret-type>c-type ] unit-test [ "character(1)" fortran-ret-type>c-type ] unit-test
[ "double" { } ] [ "void" { "char*" "long" } ]
[ "double-precision" fortran-ret-type>c-type ] unit-test [ "character(17)" fortran-ret-type>c-type ] unit-test
[ "void" { "complex-float*" } ] [ "int" { } ]
[ "complex" fortran-ret-type>c-type ] unit-test [ "integer" fortran-ret-type>c-type ] unit-test
[ "void" { "complex-double*" } ] [ "int" { } ]
[ "double-complex" fortran-ret-type>c-type ] unit-test [ "logical" fortran-ret-type>c-type ] unit-test
[ "void" { "int*" } ] [ "float" { } ]
[ "integer(*)" fortran-ret-type>c-type ] unit-test [ "real" fortran-ret-type>c-type ] unit-test
[ "void" { "fortran_test_record*" } ] [ "void" { "float*" } ]
[ "fortran_test_record" fortran-ret-type>c-type ] unit-test [ "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" } ] [ "void" { "complex-float*" } ]
[ "real" { "integer" "character*17" "real" "real*8" } fortran-sig>c-sig ] [ "complex" fortran-ret-type>c-type ] unit-test
unit-test
[ "void" { "char*" "long" "char*" "char*" "int*" "long" "long" } ] [ "void" { "complex-double*" } ]
[ "character*18" { "character*17" "character" "integer" } fortran-sig>c-sig ] [ "double-complex" fortran-ret-type>c-type ] unit-test
unit-test
[ "void" { "complex-float*" "char*" "char*" "int*" "long" "long" } ] [ "void" { "int*" } ]
[ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ] [ "integer(*)" fortran-ret-type>c-type ] unit-test
unit-test
! fortran-record>c-struct [ "void" { "fortran_test_record*" } ]
[ "fortran_test_record" fortran-ret-type>c-type ] unit-test
[ { ! fortran-sig>c-sig
{ "double" "ex" }
{ "float" "wye" }
{ "int" "zee" }
{ "char[20]" "woo" }
} ] [
{
{ "DOUBLE-PRECISION" "EX" }
{ "REAL" "WYE" }
{ "INTEGER" "ZEE" }
{ "CHARACTER(20)" "WOO" }
} fortran-record>c-struct
] unit-test
! RECORD: [ "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 [ "char" { "char*" "char*" "int*" "long" } ]
[ 0 ] [ "foo" "fortran_test_record" offset-of ] unit-test [ "character(1)" { "character*17" "character" "integer" } fortran-sig>c-sig ]
[ 4 ] [ "bar" "fortran_test_record" offset-of ] unit-test unit-test
[ 12 ] [ "bas" "fortran_test_record" offset-of ] unit-test
! (fortran-invoke) [ "void" { "char*" "long" "char*" "char*" "int*" "long" } ]
[ "character*18" { "character*17" "character" "integer" } fortran-sig>c-sig ]
unit-test
[ [ [ "void" { "complex-float*" "char*" "char*" "int*" "long" } ]
! [fortran-args>c-args] [ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ]
{ unit-test
[ {
[ 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-record>c-struct
! [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>] { "double" "ex" }
[ "complex-float" <c-object> ] 1 ndip { "float" "wye" }
! [fortran-args>c-args] { "int" "zee" }
{ [ { [ ] } spread ] [ { [ drop ] } spread ] } 1 ncleave { "char[20]" "woo" }
! [fortran-invoke] } ] [
[ {
"void" "funpack" "fun_times__" { "DOUBLE-PRECISION" "EX" }
{ "complex-float*" "float*" } { "REAL" "WYE" }
alien-invoke { "INTEGER" "ZEE" }
] 2 nkeep { "CHARACTER(20)" "WOO" }
! [fortran-results>] } fortran-record>c-struct
shuffle( reta aa -- reta aa ) ] unit-test
{ [ *complex-float ] [ drop ] } spread
] ] [
"COMPLEX" "funpack" "FUN_TIMES" { "REAL(*)" }
(fortran-invoke)
] unit-test
[ [ ! RECORD:
! [<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
[ [ [ 16 ] [ "fortran_test_record" heap-size ] unit-test
! [<fortran-result>] [ 0 ] [ "foo" "fortran_test_record" offset-of ] unit-test
[ 10 <byte-array> 10 ] 3 ndip [ 4 ] [ "bar" "fortran_test_record" offset-of ] unit-test
! [fortran-args>c-args] [ 12 ] [ "bas" "fortran_test_record" offset-of ] unit-test
{
[ {
[ 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
! (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

96
basis/alien/fortran/fortran.factor
View File

@ -5,11 +5,10 @@ byte-arrays combinators combinators.short-circuit fry generalizations
kernel lexer macros math math.parser namespaces parser sequences kernel lexer macros math math.parser namespaces parser sequences
splitting stack-checker vectors vocabs.parser words locals splitting stack-checker vectors vocabs.parser words locals
io.encodings.ascii io.encodings.string shuffle effects math.ranges io.encodings.ascii io.encodings.string shuffle effects math.ranges
math.order sorting system ; math.order sorting strings system ;
IN: alien.fortran IN: alien.fortran
! XXX this currently only supports the gfortran/f2c abi. SINGLETONS: f2c-abi gfortran-abi intel-unix-abi intel-windows-abi ;
! XXX we should also support ifort at some point for commercial BLASes
<< <<
: add-f2c-libraries ( -- ) : add-f2c-libraries ( -- )
@ -22,18 +21,55 @@ os netbsd? [ add-f2c-libraries ] when
: alien>nstring ( alien len encoding -- string ) : alien>nstring ( alien len encoding -- string )
[ memory>byte-array ] dip decode ; [ 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 ; ERROR: invalid-fortran-type type ;
DEFER: fortran-sig>c-sig DEFER: fortran-sig>c-sig
DEFER: fortran-ret-type>c-type DEFER: fortran-ret-type>c-type
DEFER: fortran-arg-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 <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: fortran-type dims size out? ;
TUPLE: number-type < fortran-type ; TUPLE: number-type < fortran-type ;
@ -107,10 +143,14 @@ M: double-complex-type (fortran-type>c-type)
M: misc-type (fortran-type>c-type) M: misc-type (fortran-type>c-type)
dup name>> simple-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' ) : fix-character-type ( character-type -- character-type' )
clone dup size>> clone dup size>>
[ dup dims>> [ invalid-fortran-type ] [ dup size>> 1array >>dims f >>size ] if ] [ 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) M: character-type (fortran-type>c-type)
fix-character-type "char" simple-type ; fix-character-type "char" simple-type ;
@ -142,22 +182,23 @@ M: character-type (fortran-type>c-type)
GENERIC: added-c-args ( type -- args ) GENERIC: added-c-args ( type -- args )
M: fortran-type added-c-args drop { } ; 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 -- ? ) GENERIC: returns-by-value? ( type -- ? )
M: f returns-by-value? drop t ; M: f returns-by-value? drop t ;
M: fortran-type returns-by-value? drop f ; M: fortran-type returns-by-value? drop f ;
M: number-type returns-by-value? dims>> not ; 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 ) GENERIC: (fortran-ret-type>c-type) ( type -- c-type )
M: f (fortran-ret-type>c-type) drop "void" ; M: f (fortran-ret-type>c-type) drop "void" ;
M: fortran-type (fortran-ret-type>c-type) (fortran-type>c-type) ; M: fortran-type (fortran-ret-type>c-type) (fortran-type>c-type) ;
! XXX F2C claims to return double for REAL typed functions M: real-type (fortran-ret-type>c-type)
! XXX OSX Accelerate.framework uses float drop real-functions-return-double? [ "double" ] [ "float" ] if ;
! M: real-type (fortran-ret-type>c-type) drop "double" ;
: suffix! ( seq elt -- seq ) over push ; inline : suffix! ( seq elt -- seq ) over push ; inline
: append! ( seq-a seq-b -- seq-a ) over push-all ; 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 ; [ drop [ <complex-double> ] [ drop ] ] args?dims ;
M: character-type (fortran-arg>c-args) 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) M: misc-type (fortran-arg>c-args)
drop [ ] [ drop ] ; drop [ ] [ drop ] ;
@ -255,7 +298,9 @@ M: double-complex-type (fortran-result>)
[ drop { [ *complex-double ] } ] result?dims ; [ drop { [ *complex-double ] } ] result?dims ;
M: character-type (fortran-result>) 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>) M: misc-type (fortran-result>)
drop { [ ] } ; drop { [ ] } ;
@ -331,8 +376,18 @@ M: character-type (<fortran-result>)
append append
\ spread [ ] 2sequence append ; \ spread [ ] 2sequence append ;
: (add-fortran-library) ( fortran-abi name -- )
library-fortran-abis get-global set-at ;
PRIVATE> 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 ) : fortran-type>c-type ( fortran-type -- c-type )
parse-fortran-type (fortran-type>c-type) ; parse-fortran-type (fortran-type>c-type) ;
@ -344,7 +399,7 @@ PRIVATE>
parse-fortran-type dup returns-by-value? parse-fortran-type dup returns-by-value?
[ (fortran-ret-type>c-type) { } ] [ [ (fortran-ret-type>c-type) { } ] [
"void" swap "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 ; ] if ;
: fortran-arg-types>c-types ( fortran-types -- c-types ) : fortran-arg-types>c-types ( fortran-types -- c-types )
@ -363,8 +418,12 @@ PRIVATE>
: RECORD: scan in get parse-definition define-fortran-record ; parsing : 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 ) : (fortran-invoke) ( return library function parameters -- quot )
{ {
[ 2drop nip set-fortran-abi ]
[ 2nip [<fortran-result>] ] [ 2nip [<fortran-result>] ]
[ nip nip nip [fortran-args>c-args] ] [ nip nip nip [fortran-args>c-args] ]
[ [fortran-invoke] ] [ [fortran-invoke] ]
@ -388,4 +447,7 @@ MACRO: fortran-invoke ( return library function parameters -- )
[ "()" subseq? not ] filter define-fortran-function ; parsing [ "()" subseq? not ] filter define-fortran-function ; parsing
: LIBRARY: : LIBRARY:
scan "c-library" set ; parsing scan
[ "c-library" set ]
[ set-fortran-abi ] bi ; parsing

1
basis/alien/fortran/tags.txt
View File

@ -1,3 +1,2 @@
fortran fortran
ffi ffi
unportable

21
basis/bit-arrays/bit-arrays.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Slava Pestov. ! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types accessors math alien.accessors kernel 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 ; parser prettyprint.custom fry ;
IN: bit-arrays IN: bit-arrays
@ -70,16 +70,15 @@ M: bit-array byte-length length 7 + -3 shift ;
: ?{ \ } [ >bit-array ] parse-literal ; parsing : ?{ \ } [ >bit-array ] parse-literal ; parsing
:: integer>bit-array ( n -- bit-array ) : integer>bit-array ( n -- bit-array )
n zero? [ 0 <bit-array> ] [ dup 0 = [
[let | out [ n log2 1+ <bit-array> ] i! [ 0 ] n'! [ n ] | <bit-array>
[ n' zero? ] [ ] [
n' out underlying>> i set-alien-unsigned-1 [ log2 1+ <bit-array> 0 ] keep
n' -8 shift n'! [ dup 0 = ] [
i 1+ i! [ pick underlying>> pick set-alien-unsigned-1 ] keep
] [ ] until [ 1+ ] [ -8 shift ] bi*
out ] [ ] until 2drop
]
] if ; ] if ;
: bit-array>integer ( bit-array -- n ) : bit-array>integer ( bit-array -- n )

2
basis/cocoa/cocoa.factor
View File

@ -29,7 +29,7 @@ SYMBOL: super-sent-messages
SYMBOL: frameworks SYMBOL: frameworks
frameworks global [ V{ } clone or ] change-at frameworks [ V{ } clone ] initialize
[ frameworks get [ load-framework ] each ] "cocoa.messages" add-init-hook [ frameworks get [ load-framework ] each ] "cocoa.messages" add-init-hook

8
basis/cocoa/messages/messages.factor
View File

@ -19,8 +19,8 @@ IN: cocoa.messages
SYMBOL: message-senders SYMBOL: message-senders
SYMBOL: super-message-senders SYMBOL: super-message-senders
message-senders global [ H{ } assoc-like ] change-at message-senders [ H{ } clone ] initialize
super-message-senders global [ H{ } assoc-like ] change-at super-message-senders [ H{ } clone ] initialize
: cache-stub ( method function hash -- ) : cache-stub ( method function hash -- )
[ [
@ -53,7 +53,7 @@ MEMO: <selector> ( name -- sel ) f \ selector boa ;
SYMBOL: objc-methods SYMBOL: objc-methods
objc-methods global [ H{ } assoc-like ] change-at objc-methods [ H{ } clone ] initialize
: lookup-method ( selector -- method ) : lookup-method ( selector -- method )
dup objc-methods get at dup objc-methods get at
@ -79,7 +79,7 @@ MACRO: (send) ( selector super? -- quot )
! Runtime introspection ! Runtime introspection
SYMBOL: class-init-hooks SYMBOL: class-init-hooks
class-init-hooks global [ H{ } clone or ] change-at class-init-hooks [ H{ } clone ] initialize
: (objc-class) ( name word -- class ) : (objc-class) ( name word -- class )
2dup execute dup [ 2nip ] [ 2dup execute dup [ 2nip ] [

2
basis/compiler/utilities/utilities.factor
View File

@ -24,4 +24,4 @@ IN: compiler.utilities
SYMBOL: yield-hook SYMBOL: yield-hook
yield-hook global [ [ ] or ] change-at yield-hook [ [ ] ] initialize

2
basis/concurrency/messaging/messaging.factor
View File

@ -85,4 +85,4 @@ PRIVATE>
: get-process ( name -- process ) : get-process ( name -- process )
dup registered-processes at [ ] [ thread ] ?if ; dup registered-processes at [ ] [ thread ] ?if ;
\ registered-processes global [ H{ } assoc-like ] change-at \ registered-processes [ H{ } clone ] initialize

2
basis/help/help.factor
View File

@ -118,7 +118,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
SYMBOL: help-hook SYMBOL: help-hook
help-hook global [ [ print-topic ] or ] change-at help-hook [ [ print-topic ] ] initialize
: help ( topic -- ) : help ( topic -- )
help-hook get call ; help-hook get call ;

4
basis/help/topics/topics.factor
View File

@ -27,11 +27,11 @@ M: link summary
! Help articles ! Help articles
SYMBOL: articles SYMBOL: articles
articles global [ H{ } assoc-like ] change-at articles [ H{ } clone ] initialize
SYMBOL: article-xref SYMBOL: article-xref
article-xref global [ H{ } assoc-like ] change-at article-xref [ H{ } clone ] initialize
GENERIC: article-name ( topic -- string ) GENERIC: article-name ( topic -- string )
GENERIC: article-title ( topic -- string ) GENERIC: article-title ( topic -- string )

2
basis/html/templates/chloe/syntax/syntax.factor
View File

@ -11,7 +11,7 @@ html.templates ;
SYMBOL: tags SYMBOL: tags
tags global [ H{ } clone or ] change-at tags [ H{ } clone ] initialize
: define-chloe-tag ( name quot -- ) swap tags get set-at ; : define-chloe-tag ( name quot -- ) swap tags get set-at ;

2
basis/http/server/server.factor
View File

@ -161,7 +161,7 @@ C: <trivial-responder> trivial-responder
M: trivial-responder call-responder* nip response>> clone ; 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' ) : invert-slice ( slice -- slice' )
dup slice? [ [ seq>> ] [ from>> ] bi head-slice ] [ drop { } ] if ; dup slice? [ [ seq>> ] [ from>> ] bi head-slice ] [ drop { } ] if ;

4
basis/io/encodings/iana/iana.factor
View File

@ -47,8 +47,8 @@ PRIVATE>
"resource:basis/io/encodings/iana/character-sets" "resource:basis/io/encodings/iana/character-sets"
utf8 <file-reader> make-aliases aliases set-global utf8 <file-reader> make-aliases aliases set-global
n>e-table global [ initial-n>e or ] change-at n>e-table [ initial-n>e ] initialize
e>n-table global [ initial-e>n or ] change-at e>n-table [ initial-e>n ] initialize
: register-encoding ( descriptor name -- ) : register-encoding ( descriptor name -- )
[ [

8
basis/math/blas/ffi/ffi.factor
View File

@ -3,9 +3,11 @@ IN: math.blas.ffi
<< <<
"blas" { "blas" {
{ [ os macosx? ] [ "libblas.dylib" "cdecl" add-library ] } { [ os macosx? ] [ "libblas.dylib" intel-unix-abi add-fortran-library ] }
{ [ os windows? ] [ "blas.dll" "cdecl" add-library ] } { [ os windows? cpu x86.32? and ] [ "blas.dll" f2c-abi add-fortran-library ] }
[ "libblas.so" "cdecl" add-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 } cond
>> >>

1
basis/math/blas/ffi/tags.txt
View File

@ -1,4 +1,3 @@
math math
bindings bindings
fortran fortran
unportable

1
basis/math/blas/matrices/tags.txt
View File

@ -1,3 +1,2 @@
math math
bindings bindings
unportable

1
basis/math/blas/vectors/tags.txt
View File

@ -1,3 +1,2 @@
math math
bindings bindings
unportable

2
basis/tools/annotations/annotations.factor
View File

@ -87,7 +87,7 @@ M: word annotate-methods
SYMBOL: word-timing SYMBOL: word-timing
word-timing global [ H{ } clone or ] change-at word-timing [ H{ } clone ] initialize
: reset-word-timing ( -- ) : reset-word-timing ( -- )
word-timing get clear-assoc ; word-timing get clear-assoc ;

6
basis/ui/cocoa/cocoa.factor
View File

@ -141,9 +141,9 @@ CLASS: {
SYMBOL: cocoa-init-hook SYMBOL: cocoa-init-hook
cocoa-init-hook global [ cocoa-init-hook [
[ "MiniFactor.nib" load-nib install-app-delegate ] or [ "MiniFactor.nib" load-nib install-app-delegate ]
] change-at ] initialize
M: cocoa-ui-backend ui M: cocoa-ui-backend ui
"UI" assert.app [ "UI" assert.app [

2
basis/ui/gadgets/worlds/worlds.factor
View File

@ -81,7 +81,7 @@ SYMBOL: ui-error-hook
: ui-error ( error -- ) : ui-error ( error -- )
ui-error-hook get [ call ] [ die ] if* ; ui-error-hook get [ call ] [ die ] if* ;
ui-error-hook global [ [ rethrow ] or ] change-at ui-error-hook [ [ rethrow ] ] initialize
: draw-world ( world -- ) : draw-world ( world -- )
dup draw-world? [ dup draw-world? [

2
core/alien/alien.factor
View File

@ -51,7 +51,7 @@ M: alien equal?
SYMBOL: libraries SYMBOL: libraries
libraries global [ H{ } assoc-like ] change-at libraries [ H{ } clone ] initialize
TUPLE: library path abi dll ; TUPLE: library path abi dll ;

14
core/combinators/combinators-tests.factor
View File

@ -324,3 +324,17 @@ DEFER: corner-case-1
[ 4 ] [ 2 corner-case-1 ] 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

4
core/combinators/combinators.factor
View File

@ -49,7 +49,7 @@ ERROR: no-cond ;
reverse [ no-cond ] swap alist>quot ; reverse [ no-cond ] swap alist>quot ;
! case ! case
ERROR: no-case ; ERROR: no-case object ;
: case-find ( obj assoc -- obj' ) : case-find ( obj assoc -- obj' )
[ [
@ -66,7 +66,7 @@ ERROR: no-case ;
case-find { case-find {
{ [ dup array? ] [ nip second call ] } { [ dup array? ] [ nip second call ] }
{ [ dup callable? ] [ call ] } { [ dup callable? ] [ call ] }
{ [ dup not ] [ no-case ] } { [ dup not ] [ drop no-case ] }
} cond ; } cond ;
: linear-case-quot ( default assoc -- quot ) : linear-case-quot ( default assoc -- quot )

4
core/compiler/units/units.factor
View File

@ -178,6 +178,4 @@ SYMBOL: remake-generics-hook
: default-recompile-hook ( words -- alist ) : default-recompile-hook ( words -- alist )
[ f ] { } map>assoc ; [ f ] { } map>assoc ;
recompile-hook global recompile-hook [ [ default-recompile-hook ] ] initialize
[ [ default-recompile-hook ] or ]
change-at

2
core/io/backend/backend.factor
View File

@ -8,7 +8,7 @@ SYMBOL: io-backend
SINGLETON: c-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 ( -- ) HOOK: init-io io-backend ( -- )

9
core/namespaces/namespaces-docs.factor
View File

@ -1,6 +1,6 @@
USING: help.markup help.syntax kernel kernel.private USING: help.markup help.syntax kernel kernel.private
sequences words namespaces.private quotations vectors sequences words namespaces.private quotations vectors
math.parser math ; math.parser math words.symbol ;
IN: namespaces IN: namespaces
ARTICLE: "namespaces-combinators" "Namespace combinators" ARTICLE: "namespaces-combinators" "Namespace combinators"
@ -20,7 +20,8 @@ ARTICLE: "namespaces-global" "Global variables"
{ $subsection namespace } { $subsection namespace }
{ $subsection global } { $subsection global }
{ $subsection get-global } { $subsection get-global }
{ $subsection set-global } ; { $subsection set-global }
{ $subsection initialize } ;
ARTICLE: "namespaces.private" "Namespace implementation details" ARTICLE: "namespaces.private" "Namespace implementation details"
"The namestack holds namespaces." "The namestack holds namespaces."
@ -159,3 +160,7 @@ HELP: ndrop
HELP: init-namespaces HELP: init-namespaces
{ $description "Resets the name stack to its initial state, holding a single copy of the global namespace." } { $description "Resets the name stack to its initial state, holding a single copy of the global namespace." }
$low-level-note ; $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." } ;

11
core/namespaces/namespaces-tests.factor
View File

@ -12,3 +12,14 @@ H{ } clone "test-namespace" set
[ f ] [ f ]
[ H{ } clone [ f "some-global" set "some-global" get ] bind ] [ H{ } clone [ f "some-global" set "some-global" get ] bind ]
unit-test 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

3
core/namespaces/namespaces.factor
View File

@ -38,3 +38,6 @@ PRIVATE>
: with-variable ( value key quot -- ) : 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 ;

2
core/parser/parser.factor
View File

@ -200,7 +200,7 @@ SYMBOL: interactive-vocabs
SYMBOL: print-use-hook SYMBOL: print-use-hook
print-use-hook global [ [ ] or ] change-at print-use-hook [ [ ] ] initialize
: parse-fresh ( lines -- quot ) : parse-fresh ( lines -- quot )
[ [

6
core/strings/parser/parser.factor
View File

@ -22,9 +22,9 @@ ERROR: bad-escape ;
SYMBOL: name>char-hook SYMBOL: name>char-hook
name>char-hook global [ name>char-hook [
[ "Unicode support not available" throw ] or [ "Unicode support not available" throw ]
] change-at ] initialize
: unicode-escape ( str -- ch str' ) : unicode-escape ( str -- ch str' )
"{" ?head-slice [ "{" ?head-slice [

4
core/words/words.factor
View File

@ -96,11 +96,11 @@ M: word uses ( word -- seq )
SYMBOL: compiled-crossref SYMBOL: compiled-crossref
compiled-crossref global [ H{ } assoc-like ] change-at compiled-crossref [ H{ } clone ] initialize
SYMBOL: compiled-generic-crossref 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 -- ) : (compiled-xref) ( word dependencies word-prop variable -- )
[ [ set-word-prop ] curry ] [ [ set-word-prop ] curry ]

12
extra/id3/id3-docs.factor
View File

@ -3,15 +3,15 @@
USING: help.markup help.syntax sequences kernel ; USING: help.markup help.syntax sequences kernel ;
IN: id3 IN: id3
HELP: id3-parse-mp3-file HELP: file-id3-tags
{ $values { $values
{ "path" "a path string" } { "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." } } { "object/f" "a tuple storing ID3 metadata or f" } }
{ $description "Return a tuple containing the ID3 information parsed out of the MP3 file" } ; { $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" ARTICLE: "id3" "ID3 tags"
{ $emphasis "ID3" } " tags are textual data that is used to describe the information (title, artist, etc.) in an .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 an MP3 file: " "Parsing ID3 tags from an MP3 file:"
{ $subsection id3-parse-mp3-file } ; { $subsection file-id3-tags } ;
ABOUT: "id3" ABOUT: "id3"

6
extra/id3/id3-tests.factor
View File

@ -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 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 T{ mp3v1-file
@ -178,5 +178,5 @@ IN: id3.tests
} }
{ genre 89 } { 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

2
extra/id3/id3.factor
View File

@ -142,7 +142,7 @@ PRIVATE>
! main stuff ! main stuff
: id3-parse-mp3-file ( path -- object ) : file-id3-tags ( path -- object/f )
[ [
{ {
{ [ dup id3v2? ] [ read-v2-tag-data ] } ! ( ? -- mp3v2-file ) { [ dup id3v2? ] [ read-v2-tag-data ] } ! ( ? -- mp3v2-file )

51
extra/images/backend/backend.factor
View File

@ -1,18 +1,51 @@
! Copyright (C) 2009 Doug Coleman. ! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel ; USING: accessors kernel grouping fry sequences combinators
math ;
IN: images.backend 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 ) GENERIC: load-image* ( path tuple -- image )
: load-image ( path class -- image ) GENERIC: >image ( object -- image )
new load-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 new
swap >>buffer swap >>bitmap
swap >>depth swap >>component-order
swap >>height swap >>dim ; inline
swap >>width ; inline

3
extra/images/bitmap/bitmap-tests.factor
View File

@ -5,9 +5,6 @@ IN: images.bitmap.tests
: test-bitmap24 ( -- path ) : test-bitmap24 ( -- path )
"resource:extra/images/test-images/thiswayup24.bmp" ; "resource:extra/images/test-images/thiswayup24.bmp" ;
: test-bitmap16 ( -- path )
"resource:extra/images/test-images/rgb16bit.bmp" ;
: test-bitmap8 ( -- path ) : test-bitmap8 ( -- path )
"resource:extra/images/test-images/rgb8bit.bmp" ; "resource:extra/images/test-images/rgb8bit.bmp" ;

36
extra/images/bitmap/bitmap.factor
View File

@ -15,7 +15,6 @@ TUPLE: bitmap-image < image ;
TUPLE: bitmap magic size reserved offset header-length width TUPLE: bitmap magic size reserved offset header-length width
height planes bit-count compression size-image height planes bit-count compression size-image
x-pels y-pels color-used color-important rgb-quads color-index x-pels y-pels color-used color-important rgb-quads color-index
alpha-channel-zero?
buffer ; buffer ;
: array-copy ( bitmap array -- bitmap array' ) : array-copy ( bitmap array -- bitmap array' )
@ -87,23 +86,36 @@ M: bitmap-magic summary
parse-file-header parse-bitmap-header parse-bitmap parse-file-header parse-bitmap-header parse-bitmap
] with-file-reader ; ] with-file-reader ;
: alpha-channel-zero? ( bitmap -- ? )
buffer>> 4 <sliced-groups> 3 <column> [ 0 = ] all? ;
: process-bitmap-data ( bitmap -- bitmap ) : process-bitmap-data ( bitmap -- bitmap )
dup raw-bitmap>buffer >>buffer dup raw-bitmap>buffer >>buffer ;
dup alpha-channel-zero? >>alpha-channel-zero? ;
: load-bitmap ( path -- bitmap ) : load-bitmap ( path -- bitmap )
load-bitmap-data process-bitmap-data ; load-bitmap-data process-bitmap-data ;
: bitmap>image ( bitmap -- bitmap-image ) ERROR: unknown-component-order bitmap ;
{ [ width>> ] [ height>> ] [ bit-count>> ] [ buffer>> ] } cleave
bitmap-image new-image ; : 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 ) M: bitmap-image load-image* ( path bitmap -- bitmap-image )
drop load-bitmap drop load-bitmap >image ;
bitmap>image ;
M: bitmap-image normalize-scan-line-order
dup dim>> '[
_ first 4 * <sliced-groups> reverse concat
] change-bitmap ;
MACRO: (nbits>bitmap) ( bits -- ) MACRO: (nbits>bitmap) ( bits -- )
[ -3 shift ] keep '[ [ -3 shift ] keep '[
@ -112,7 +124,7 @@ MACRO: (nbits>bitmap) ( bits -- )
swap >>height swap >>height
swap >>width swap >>width
swap array-copy [ >>buffer ] [ >>color-index ] bi swap array-copy [ >>buffer ] [ >>color-index ] bi
_ >>bit-count bitmap>image _ >>bit-count >image
] ; ] ;
: bgr>bitmap ( array height width -- bitmap ) : bgr>bitmap ( array height width -- bitmap )

18
extra/images/images.factor
View File

@ -5,9 +5,17 @@ accessors images.bitmap images.tiff images.backend io.backend
io.pathnames ; io.pathnames ;
IN: images IN: images
: <image> ( path -- image ) ERROR: unknown-image-extension extension ;
normalize-path dup "." split1-last nip >lower
{ : image-class ( path -- class )
{ "bmp" [ bitmap-image load-image ] } file-extension >lower {
{ "tiff" [ tiff-image load-image ] } { "bmp" [ bitmap-image ] }
{ "tiff" [ tiff-image ] }
[ unknown-image-extension ]
} case ; } case ;
: load-image ( path -- image )
dup image-class new load-image* ;
: <image> ( path -- image )
load-image normalize-image ;

34
extra/images/tiff/tiff.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2009 Doug Coleman. ! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators io io.encodings.binary io.files 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 sorting.slots math.order math.parser prettyprint classes
io.binary assocs math math.bitwise byte-arrays grouping io.binary assocs math math.bitwise byte-arrays grouping
images.backend ; images.backend ;
@ -13,7 +13,7 @@ TUPLE: parsed-tiff endianness the-answer ifd-offset ifds ;
CONSTRUCTOR: parsed-tiff ( -- tiff ) V{ } clone >>ifds ; CONSTRUCTOR: parsed-tiff ( -- tiff ) V{ } clone >>ifds ;
TUPLE: ifd count ifd-entries next TUPLE: ifd count ifd-entries next
processed-tags strips buffer ; processed-tags strips bitmap ;
CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ; CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ;
TUPLE: ifd-entry tag type count offset/value ; TUPLE: ifd-entry tag type count offset/value ;
@ -257,29 +257,37 @@ ERROR: bad-small-ifd-type n ;
dup ifd-entries>> dup ifd-entries>>
[ process-ifd-entry swap ] H{ } map>assoc >>processed-tags ; [ process-ifd-entry swap ] H{ } map>assoc >>processed-tags ;
: strips>buffer ( ifd -- ifd ) : strips>bitmap ( ifd -- ifd )
dup strips>> concat >>buffer ; 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-width find-tag ] [ image-length find-tag ] bi 2array ]
[ image-length find-tag ] [ ifd-component-order ]
[ bits-per-sample find-tag sum ] [ bitmap>> ]
[ buffer>> ]
} cleave tiff-image new-image ; } cleave tiff-image new-image ;
: parsed-tiff>images ( tiff -- sequence ) M: parsed-tiff >image ( image -- image )
ifds>> [ ifd>image ] map ; ifds>> [ >image ] map first ;
: load-tiff ( path -- parsed-tiff ) : load-tiff ( path -- parsed-tiff )
binary [ binary [
<parsed-tiff> <parsed-tiff>
read-header dup endianness>> [ read-header dup endianness>> [
read-ifds 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-endianness
] with-file-reader ; ] with-file-reader ;
! tiff files can store several images -- we just take the first for now ! tiff files can store several images -- we just take the first for now
M: tiff-image load-image* ( path tiff-image -- image ) M: tiff-image load-image* ( path tiff-image -- image )
drop load-tiff parsed-tiff>images first ; drop load-tiff >image ;

62
extra/images/viewer/viewer.factor
View File

@ -1,19 +1,19 @@
! Copyright (C) 2007 Doug Coleman. ! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators images.bitmap kernel math USING: accessors images images.backend io.pathnames kernel
math.functions namespaces opengl opengl.gl ui ui.gadgets namespaces opengl opengl.gl sequences strings ui ui.gadgets
ui.gadgets.panes ui.render images.tiff sequences multiline ui.gadgets.panes ui.render ;
images.backend images io.pathnames strings ;
IN: images.viewer IN: images.viewer
TUPLE: image-gadget < gadget { image image } ; TUPLE: image-gadget < gadget { image image } ;
GENERIC: draw-image ( image -- )
M: image-gadget pref-dim* M: image-gadget pref-dim*
image>> image>> dim>> ;
[ width>> ] [ height>> ] bi
[ abs ] bi@ 2array ; : 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 -- ) M: image-gadget draw-gadget* ( gadget -- )
origin get [ image>> draw-image ] with-translation ; origin get [ image>> draw-image ] with-translation ;
@ -22,48 +22,16 @@ M: image-gadget draw-gadget* ( gadget -- )
\ image-gadget new-gadget \ image-gadget new-gadget
swap >>image ; 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-window ( path -- gadget )
[ <image> <image-gadget> dup ] [ open-window ] bi ; [ <image> <image-gadget> dup ] [ open-window ] bi ;
M: tiff-image draw-image ( tiff -- ) GENERIC: image. ( object -- )
0 0 glRasterPos2i 1.0 -1.0 glPixelZoom
{
[ height>> ]
[ width>> ]
[ depth>> bits>gl-params ]
[ buffer>> ]
} cleave glDrawPixels ;
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. ;

4
extra/mason/config/config.factor
View File

@ -81,7 +81,7 @@ SYMBOL: upload-directory
! Optional: override ssh and scp command names ! Optional: override ssh and scp command names
SYMBOL: scp-command SYMBOL: scp-command
scp-command global [ "scp" or ] change-at scp-command [ "scp" ] initialize
SYMBOL: ssh-command SYMBOL: ssh-command
ssh-command global [ "ssh" or ] change-at ssh-command [ "ssh" ] initialize

2
vm/os-unix.c
View File

@ -36,7 +36,7 @@ void init_ffi(void)
void ffi_dlopen(F_DLL *dll) 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) void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol)