From 1cd285bcaa8112272ddb46fe641204599c08cbc6 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Wed, 28 Jan 2009 01:57:14 -0600 Subject: [PATCH 01/38] Slots with declared type of callable or quotation now have an initial value [ ] --- core/slots/slots.factor | 1 + 1 file changed, 1 insertion(+) mode change 100644 => 100755 core/slots/slots.factor diff --git a/core/slots/slots.factor b/core/slots/slots.factor old mode 100644 new mode 100755 index f166378d9d..24ff1b0f8b --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -151,6 +151,7 @@ M: class initial-value* no-initial-value ; { [ array bootstrap-word over class<= ] [ { } ] } { [ byte-array bootstrap-word over class<= ] [ B{ } ] } { [ simple-alien bootstrap-word over class<= ] [ ] } + { [ quotation bootstrap-word over class<= ] [ [ ] ] } [ dup initial-value* ] } cond nip ; From 49875b9cc7db5c1c514d0a85f8d3ed0917fc67d9 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Wed, 28 Jan 2009 01:57:46 -0600 Subject: [PATCH 02/38] Use factor.exe or factor.com when deploying on Windows, depending on whether or not the UI is enabled --- basis/tools/deploy/backend/backend.factor | 2 +- basis/tools/deploy/macosx/macosx.factor | 2 +- basis/tools/deploy/unix/unix.factor | 2 +- basis/tools/deploy/windows/windows.factor | 23 ++++++++++++++--------- 4 files changed, 17 insertions(+), 12 deletions(-) mode change 100644 => 100755 basis/tools/deploy/backend/backend.factor mode change 100644 => 100755 basis/tools/deploy/macosx/macosx.factor mode change 100644 => 100755 basis/tools/deploy/unix/unix.factor diff --git a/basis/tools/deploy/backend/backend.factor b/basis/tools/deploy/backend/backend.factor old mode 100644 new mode 100755 index 636e44062e..22d6eb2ffa --- a/basis/tools/deploy/backend/backend.factor +++ b/basis/tools/deploy/backend/backend.factor @@ -11,7 +11,7 @@ tools.deploy.config.editor bootstrap.image io.encodings.utf8 destructors accessors ; IN: tools.deploy.backend -: copy-vm ( executable bundle-name extension -- vm ) +: copy-vm ( executable bundle-name -- vm ) [ prepend-path ] dip append vm over copy-file ; : copy-fonts ( name dir -- ) diff --git a/basis/tools/deploy/macosx/macosx.factor b/basis/tools/deploy/macosx/macosx.factor old mode 100644 new mode 100755 index 91b4d603af..8fe31ac6cc --- a/basis/tools/deploy/macosx/macosx.factor +++ b/basis/tools/deploy/macosx/macosx.factor @@ -54,7 +54,7 @@ IN: tools.deploy.macosx } cleave ] [ create-app-plist ] - [ "Contents/MacOS/" append-path "" copy-vm ] 2tri + [ "Contents/MacOS/" append-path copy-vm ] 2tri dup OCT: 755 set-file-permissions ; : deploy.app-image ( vocab bundle-name -- str ) diff --git a/basis/tools/deploy/unix/unix.factor b/basis/tools/deploy/unix/unix.factor old mode 100644 new mode 100755 index 9e0bb8ac68..c9bf308357 --- a/basis/tools/deploy/unix/unix.factor +++ b/basis/tools/deploy/unix/unix.factor @@ -8,7 +8,7 @@ IN: tools.deploy.unix : create-app-dir ( vocab bundle-name -- vm ) dup "" copy-fonts - "" copy-vm + copy-vm dup OCT: 755 set-file-permissions ; : bundle-name ( -- str ) diff --git a/basis/tools/deploy/windows/windows.factor b/basis/tools/deploy/windows/windows.factor index 7ce635b1ba..0e9146b26e 100755 --- a/basis/tools/deploy/windows/windows.factor +++ b/basis/tools/deploy/windows/windows.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2007, 2008 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io io.files io.directories kernel namespaces sequences system -tools.deploy.backend tools.deploy.config -tools.deploy.config.editor assocs hashtables prettyprint -combinators windows.shell32 windows.user32 ; +USING: io io.files io.pathnames io.directories kernel namespaces +sequences locals system splitting tools.deploy.backend +tools.deploy.config tools.deploy.config.editor assocs hashtables +prettyprint combinators windows.shell32 windows.user32 ; IN: tools.deploy.windows : copy-dll ( bundle-name -- ) @@ -15,13 +15,18 @@ IN: tools.deploy.windows "resource:zlib1.dll" } swap copy-files-into ; +:: copy-vm ( executable bundle-name extension -- vm ) + vm "." split1-last drop extension append + bundle-name executable ".exe" append append-path + [ copy-file ] keep ; + : create-exe-dir ( vocab bundle-name -- vm ) dup copy-dll deploy-ui? get [ - dup copy-freetype - dup "" copy-fonts - ] when - ".exe" copy-vm ; + [ copy-freetype ] + [ "" copy-fonts ] + [ ".exe" copy-vm ] tri + ] [ ".com" copy-vm ] if ; M: winnt deploy* "resource:" [ From 5af6c10eedfd8eb348b04ce5b614495da6dc4469 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Wed, 28 Jan 2009 01:58:03 -0600 Subject: [PATCH 03/38] Fix io.launcher.windows.nt test when run from factor.exe --- basis/io/launcher/windows/nt/nt-tests.factor | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) mode change 100644 => 100755 basis/io/launcher/windows/nt/nt-tests.factor diff --git a/basis/io/launcher/windows/nt/nt-tests.factor b/basis/io/launcher/windows/nt/nt-tests.factor old mode 100644 new mode 100755 index 4dd0eebed3..04202365fd --- a/basis/io/launcher/windows/nt/nt-tests.factor +++ b/basis/io/launcher/windows/nt/nt-tests.factor @@ -37,11 +37,12 @@ IN: io.launcher.windows.nt.tests "out.txt" temp-file ascii file-lines first ] unit-test -[ ] [ +[ "( scratchpad ) " ] [ console-vm "-run=listener" 2array >>command +closed+ >>stdin - try-process + +stdout+ >>stderr + ascii [ input-stream get contents ] with-process-reader ] unit-test : launcher-test-path ( -- str ) @@ -162,3 +163,5 @@ IN: io.launcher.windows.nt.tests "append-test" temp-file ascii file-contents ] unit-test + + From a4a6885189bb7a432d4c78638975f7b6a1c9564d Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Wed, 28 Jan 2009 01:58:57 -0600 Subject: [PATCH 04/38] Fix setters for value struct slots and add unit test for this case; this fixes an io.mmap regression on Windows --- basis/alien/arrays/arrays.factor | 2 +- basis/alien/c-types/c-types.factor | 26 +++++++++++++----------- basis/alien/structs/structs-tests.factor | 15 ++++++++++++++ basis/alien/structs/structs.factor | 12 +++++++++-- 4 files changed, 40 insertions(+), 15 deletions(-) mode change 100644 => 100755 basis/alien/arrays/arrays.factor mode change 100644 => 100755 basis/alien/c-types/c-types.factor mode change 100644 => 100755 basis/alien/structs/structs-tests.factor mode change 100644 => 100755 basis/alien/structs/structs.factor diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor old mode 100644 new mode 100755 index 8253d9458c..6a182f8dbf --- a/basis/alien/arrays/arrays.factor +++ b/basis/alien/arrays/arrays.factor @@ -26,7 +26,7 @@ M: array box-return drop "void*" box-return ; M: array stack-size drop "void*" stack-size ; -M: array c-type-boxer-quot drop f ; +M: array c-type-boxer-quot drop [ ] ; M: array c-type-unboxer-quot drop [ >c-ptr ] ; diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor old mode 100644 new mode 100755 index a4bc3d3f52..a44b5cf2b6 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -4,7 +4,7 @@ USING: byte-arrays arrays assocs kernel kernel.private libc math namespaces make parser sequences strings words assocs splitting math.parser cpu.architecture alien alien.accessors quotations layouts system compiler.units io.files io.encodings.binary -accessors combinators effects continuations fry call ; +accessors combinators effects continuations fry call classes ; IN: alien.c-types DEFER: @@ -13,18 +13,20 @@ DEFER: *char : little-endian? ( -- ? ) 1 *char 1 = ; foldable TUPLE: c-type -class -boxer boxer-quot unboxer unboxer-quot -getter setter -reg-class size align stack-align? ; - -: new-c-type ( class -- type ) - new - int-regs >>reg-class - object >>class ; inline +{ class class initial: object } +boxer +{ boxer-quot callable } +unboxer +{ unboxer-quot callable } +{ getter callable } +{ setter callable } +{ reg-class initial: int-regs } +size +align +stack-align? ; : ( -- type ) - \ c-type new-c-type ; + \ c-type new ; SYMBOL: c-types @@ -224,7 +226,7 @@ M: f byte-length drop 0 ; TUPLE: long-long-type < c-type ; : ( -- type ) - long-long-type new-c-type ; + long-long-type new ; M: long-long-type unbox-parameter ( n type -- ) c-type-unboxer %unbox-long-long ; diff --git a/basis/alien/structs/structs-tests.factor b/basis/alien/structs/structs-tests.factor old mode 100644 new mode 100755 index ec0c01c2e7..8bc570c448 --- a/basis/alien/structs/structs-tests.factor +++ b/basis/alien/structs/structs-tests.factor @@ -42,3 +42,18 @@ C-UNION: barx [ ] [ \ foox-x "help" get execute ] unit-test [ ] [ \ set-foox-x "help" get execute ] unit-test ] when + +C-STRUCT: nested + { "int" "x" } ; + +C-STRUCT: nested-2 + { "nested" "y" } ; + +[ 4 ] [ + "nested-2" + "nested" + 4 over set-nested-x + over set-nested-2-y + nested-2-y + nested-x +] unit-test diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor old mode 100644 new mode 100755 index 698518b4e5..8ec694198d --- a/basis/alien/structs/structs.factor +++ b/basis/alien/structs/structs.factor @@ -2,10 +2,18 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs generic hashtables kernel kernel.private math namespaces parser sequences strings words libc fry -alien.c-types alien.structs.fields cpu.architecture math.order ; +alien.c-types alien.structs.fields cpu.architecture math.order +quotations ; IN: alien.structs -TUPLE: struct-type size align fields boxer-quot unboxer-quot getter setter ; +TUPLE: struct-type +size +align +fields +{ boxer-quot callable } +{ unboxer-quot callable } +{ getter callable } +{ setter callable } ; M: struct-type heap-size size>> ; From c24bc639d11f792f4eadd14e8fbe7e6da4584574 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 5 Feb 2009 15:29:59 -0600 Subject: [PATCH 05/38] unit tests for alien.fortran --- basis/alien/fortran/fortran-tests.factor | 141 +++++++++++++++++++++++ 1 file changed, 141 insertions(+) create mode 100644 basis/alien/fortran/fortran-tests.factor diff --git a/basis/alien/fortran/fortran-tests.factor b/basis/alien/fortran/fortran-tests.factor new file mode 100644 index 0000000000..29bd024930 --- /dev/null +++ b/basis/alien/fortran/fortran-tests.factor @@ -0,0 +1,141 @@ +USING: alien.fortran alien.syntax tools.test ; +IN: alien.fortran.tests + +C-STRUCT: fortran_test_struct + { "int" "foo" } + { "float" "bar" } + { "char[4]" "bas" } ; + +! F-RECORD: fortran_test_record +! { "integer" "foo" } +! { "real" "bar" } +! { "character*4" "bar" } + +! fortran-name>symbol-name + +[ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test +[ "fun_times__" ] [ "Fun_Times" fortran-name>symbol-name ] unit-test + +! fortran-type>c-type + +[ "short" ] +[ "integer*2" fortran-type>c-type ] unit-test + +[ "int" ] +[ "integer*4" fortran-type>c-type ] unit-test + +[ "int" ] +[ "integer" fortran-type>c-type ] unit-test + +[ "longlong" ] +[ "iNteger*8" fortran-type>c-type ] unit-test + +[ "int[0]" ] +[ "integer(*)" fortran-type>c-type ] unit-test + +[ "int[0]" ] +[ "integer(3,*)" fortran-type>c-type ] unit-test + +[ "int[3]" ] +[ "integer(3)" fortran-type>c-type ] unit-test + +[ "int[6]" ] +[ "integer(3,2)" fortran-type>c-type ] unit-test + +[ "int[24]" ] +[ "integer(4,3,2)" fortran-type>c-type ] unit-test + +[ "char[1]" ] +[ "character" fortran-type>c-type ] unit-test + +[ "char[17]" ] +[ "character*17" fortran-type>c-type ] unit-test + +[ "char[17]" ] +[ "character(17)" fortran-type>c-type ] unit-test + +[ "int" ] +[ "logical" fortran-type>c-type ] unit-test + +[ "float" ] +[ "real" fortran-type>c-type ] unit-test + +[ "double" ] +[ "double precision" fortran-type>c-type ] unit-test + +[ "float" ] +[ "real*4" fortran-type>c-type ] unit-test + +[ "double" ] +[ "real*8" fortran-type>c-type ] unit-test + +[ "(fortran-complex)" ] +[ "complex" fortran-type>c-type ] unit-test + +[ "(fortran-double-complex)" ] +[ "double complex" fortran-type>c-type ] unit-test + +[ "(fortran-complex)" ] +[ "complex*8" fortran-type>c-type ] unit-test + +[ "(fortran-double-complex)" ] +[ "complex*16" fortran-type>c-type ] unit-test + +[ "(fortran-double-complex)" ] +[ "complex*16" fortran-type>c-type ] unit-test + +[ "fortran_test_struct" ] +[ "fortran_test_struct" fortran-type>c-type ] unit-test + +[ "fortran_test_record" ] +[ "fortran_test_record" fortran-type>c-type ] unit-test + +! fortran-arg-type>c-type + +[ "int*" { } ] +[ "integer" fortran-arg-type>c-type ] unit-test + +[ "int*" { } ] +[ "integer(3)" fortran-arg-type>c-type ] unit-test + +[ "int*" { } ] +[ "integer(*)" fortran-arg-type>c-type ] unit-test + +[ "fortran_test_struct*" { } ] +[ "fortran_test_struct" fortran-arg-type>c-type ] unit-test + +[ "char*" { "long" } ] +[ "character" fortran-arg-type>c-type ] unit-test + +[ "char*" { "long" } ] +[ "character(17)" fortran-arg-type>c-type ] unit-test + +! fortran-ret-type>c-type + +[ "void" { "char*" "long" } ] +[ "character(17)" fortran-ret-type>c-type ] unit-test + +[ "int" { } ] +[ "integer" fortran-ret-type>c-type ] unit-test + +[ "int" { } ] +[ "logical" fortran-ret-type>c-type ] unit-test + +[ "double" { } ] +[ "real" fortran-ret-type>c-type ] unit-test + +[ "double" { } ] +[ "double precision" fortran-ret-type>c-type ] unit-test + +[ "void" { "(fortran-complex)*" } ] +[ "complex" fortran-ret-type>c-type ] unit-test + +[ "void" { "(fortran-double-complex)*" } ] +[ "double complex" fortran-ret-type>c-type ] unit-test + +[ "void" { "int*" } ] +[ "integer(*)" fortran-ret-type>c-type ] unit-test + +[ "void" { "fortran_test_record*" } ] +[ "fortran_test_record" fortran-ret-type>c-type ] unit-test + From 4f1dc5cd0c46693d31ab51f7deaf6b2af41f8089 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 5 Feb 2009 15:31:58 -0600 Subject: [PATCH 06/38] implement fortran-name>symbol-name and fortran-type>c-type --- basis/alien/fortran/fortran.factor | 140 +++++++++++++++++++++++++++++ 1 file changed, 140 insertions(+) create mode 100644 basis/alien/fortran/fortran.factor diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor new file mode 100644 index 0000000000..d83df9bd45 --- /dev/null +++ b/basis/alien/fortran/fortran.factor @@ -0,0 +1,140 @@ +USING: accessors alien alien.c-types alien.syntax arrays ascii +assocs combinators fry kernel macros math.parser sequences splitting ; +IN: alien.fortran + +! XXX this currently only supports the gfortran/f2c abi. +! XXX we should also support ifort at some point for commercial BLASes + +C-STRUCT: (fortran-complex) + { "float" "r" } + { "float" "i" } ; +C-STRUCT: (fortran-double-complex) + { "double" "r" } + { "double" "i" } ; + +: fortran-c-abi ( -- abi ) "cdecl" ; + +: fortran-name>symbol-name ( fortran-name -- c-name ) + >lower CHAR: _ over member? + [ "__" append ] [ "_" append ] if ; + +ERROR: invalid-fortran-type type ; + +c-types H{ + { "character" character-type } + { "integer" integer-type } + { "logical" logical-type } + { "real" real-type } + { "double precision" double-precision-type } + { "complex" real-complex-type } + { "double complex" double-complex-type } +} + +: append-dimensions ( base-c-type type -- c-type ) + dims>> + [ product number>string "[" "]" surround append ] when* ; + +MACRO: size-case-type ( cases -- ) + [ invalid-fortran-type ] suffix + '[ [ size>> _ case ] [ append-dimensions ] bi ] ; + +: simple-type ( type base-c-type -- c-type ) + swap + [ dup size>> [ invalid-fortran-type ] [ drop ] if ] + [ append-dimensions ] bi ; + +: new-fortran-type ( dims size class -- type ) + new [ (>>size) ] [ (>>dims) ] [ ] tri ; + +GENERIC: (fortran-type>c-type) ( type -- c-type ) + +M: integer-type (fortran-type>c-type) + { + { f [ "int" ] } + { 2 [ "short" ] } + { 4 [ "int" ] } + { 8 [ "longlong" ] } + } size-case-type ; +M: real-type (fortran-type>c-type) + { + { f [ "float" ] } + { 4 [ "float" ] } + { 8 [ "double" ] } + } size-case-type ; +M: complex-type (fortran-type>c-type) + { + { f [ "(fortran-complex)" ] } + { 8 [ "(fortran-complex)" ] } + { 16 [ "(fortran-double-complex)" ] } + } size-case-type ; + +M: double-precision-type (fortran-type>c-type) + "double" simple-type ; +M: double-complex-type (fortran-type>c-type) + "(fortran-double-complex)" simple-type ; +M: misc-type (fortran-type>c-type) + dup name>> simple-type ; + +: 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 ; + +M: character-type (fortran-type>c-type) + fix-character-type "char" simple-type ; + +: dimension>number ( string -- number ) + dup "*" = [ drop 0 ] [ string>number ] if ; + +: parse-dims ( string -- string' dim ) + "(" split1 dup + [ ")" ?tail drop "," split [ [ blank? ] trim dimension>number ] map ] when ; + +: parse-size ( string -- string' size ) + "*" split1 dup [ string>number ] when ; + +: parse-fortran-type ( fortran-type-string -- type ) + parse-dims swap parse-size swap + dup >lower fortran>c-types at* + [ nip new-fortran-type ] [ drop misc-type boa ] if ; + +: c-type>pointer ( c-type -- c-type* ) + "[" split1 drop "*" append ; + +GENERIC: added-c-args ( type -- args ) + +M: fortran-type added-c-args drop { } ; +M: character-type added-c-args drop { "long" } ; + +PRIVATE> + +: fortran-type>c-type ( fortran-type -- c-type ) + parse-fortran-type (fortran-type>c-type) ; + +: fortran-arg-type>c-type ( fortran-type -- c-type added-args ) { } ; +: fortran-ret-type>c-type ( fortran-type -- c-type added-args ) { } ; + +: fortran-sig>c-sig ( fortran-return fortran-args -- c-return c-args ) ; + +! : F-RECORD: ... ; parsing +! : F-ABI: ... ; parsing +! : F-SUBROUTINE: ... ; parsing +! : F-FUNCTION: ... ; parsing + From 4429c17f63840647ce2467dbb385126fd9a081ef Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 5 Feb 2009 16:39:23 -0600 Subject: [PATCH 07/38] implement fortran-arg-type>c-type and fortran-ret-type>c-type --- basis/alien/fortran/fortran.factor | 29 +++++++++++++++++++++++++++-- 1 file changed, 27 insertions(+), 2 deletions(-) diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index d83df9bd45..0c30258895 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -123,13 +123,38 @@ GENERIC: added-c-args ( type -- args ) M: fortran-type added-c-args drop { } ; M: character-type added-c-args drop { "long" } ; +GENERIC: added-c-arg-values ( type -- arg-values ) + +M: fortran-type added-c-arg-values drop { } ; +M: character-type added-c-arg-values + fix-character-type dims>> first 1array ; + +GENERIC: returns-by-value? ( type -- ? ) + +M: fortran-type returns-by-value? drop f ; +M: number-type returns-by-value? dims>> not ; +M: complex-type returns-by-value? drop f ; + +GENERIC: (fortran-ret-type>c-type) ( type -- c-type ) + +M: fortran-type (fortran-ret-type>c-type) (fortran-type>c-type) ; +M: real-type (fortran-ret-type>c-type) drop "double" ; + PRIVATE> : fortran-type>c-type ( fortran-type -- c-type ) parse-fortran-type (fortran-type>c-type) ; -: fortran-arg-type>c-type ( fortran-type -- c-type added-args ) { } ; -: fortran-ret-type>c-type ( fortran-type -- c-type added-args ) { } ; +: fortran-arg-type>c-type ( fortran-type -- c-type added-args ) + parse-fortran-type + [ (fortran-type>c-type) c-type>pointer ] + [ added-c-args ] bi ; +: fortran-ret-type>c-type ( fortran-type -- c-type added-args ) + parse-fortran-type dup returns-by-value? + [ (fortran-ret-type>c-type) { } ] [ + "void" swap + [ added-c-args ] [ (fortran-ret-type>c-type) c-type>pointer ] bi prefix + ] if ; : fortran-sig>c-sig ( fortran-return fortran-args -- c-return c-args ) ; From 7b1f16ae5ed2ee0b788456db20a84eb7922f14d2 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 5 Feb 2009 18:51:50 -0600 Subject: [PATCH 08/38] fortran records --- basis/alien/fortran/fortran-tests.factor | 62 ++++++++++++++++++------ basis/alien/fortran/fortran.factor | 28 +++++++++-- basis/alien/structs/structs.factor | 7 ++- 3 files changed, 75 insertions(+), 22 deletions(-) diff --git a/basis/alien/fortran/fortran-tests.factor b/basis/alien/fortran/fortran-tests.factor index 29bd024930..11f0a2efc7 100644 --- a/basis/alien/fortran/fortran-tests.factor +++ b/basis/alien/fortran/fortran-tests.factor @@ -1,15 +1,11 @@ -USING: alien.fortran alien.syntax tools.test ; +USING: accessors alien alien.c-types alien.fortran alien.structs +alien.syntax arrays assocs kernel namespaces sequences tools.test ; IN: alien.fortran.tests -C-STRUCT: fortran_test_struct - { "int" "foo" } - { "float" "bar" } - { "char[4]" "bas" } ; - -! F-RECORD: fortran_test_record -! { "integer" "foo" } -! { "real" "bar" } -! { "character*4" "bar" } +F-RECORD: fortran_test_record + { "integer" "foo" } + { "real" "bar" } + { "character*4" "bas" } ; ! fortran-name>symbol-name @@ -25,7 +21,7 @@ C-STRUCT: fortran_test_struct [ "integer*4" fortran-type>c-type ] unit-test [ "int" ] -[ "integer" fortran-type>c-type ] unit-test +[ "INTEGER" fortran-type>c-type ] unit-test [ "longlong" ] [ "iNteger*8" fortran-type>c-type ] unit-test @@ -84,9 +80,6 @@ C-STRUCT: fortran_test_struct [ "(fortran-double-complex)" ] [ "complex*16" fortran-type>c-type ] unit-test -[ "fortran_test_struct" ] -[ "fortran_test_struct" fortran-type>c-type ] unit-test - [ "fortran_test_record" ] [ "fortran_test_record" fortran-type>c-type ] unit-test @@ -101,8 +94,8 @@ C-STRUCT: fortran_test_struct [ "int*" { } ] [ "integer(*)" fortran-arg-type>c-type ] unit-test -[ "fortran_test_struct*" { } ] -[ "fortran_test_struct" fortran-arg-type>c-type ] unit-test +[ "fortran_test_record*" { } ] +[ "fortran_test_record" fortran-arg-type>c-type ] unit-test [ "char*" { "long" } ] [ "character" fortran-arg-type>c-type ] unit-test @@ -139,3 +132,40 @@ C-STRUCT: fortran_test_struct [ "void" { "fortran_test_record*" } ] [ "fortran_test_record" fortran-ret-type>c-type ] unit-test +! fortran-sig>c-sig + +[ "double" { "int*" "char*" "float*" "double*" "long" } ] +[ "real" { "integer" "character*17" "real" "real*8" } fortran-sig>c-sig ] +unit-test + +[ "void" { "char*" "long" "char*" "char*" "int*" "long" "long" } ] +[ "character*18" { "character*17" "character" "integer" } fortran-sig>c-sig ] +unit-test + +[ "void" { "(fortran-complex)*" "char*" "char*" "int*" "long" "long" } ] +[ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ] +unit-test + +! fortran-record>c-struct + +[ { + { "double" "ex" } + { "float" "wye" } + { "int" "zee" } + { "char[20]" "woo" } +} ] [ + { + { "DOUBLE PRECISION" "EX" } + { "REAL" "WYE" } + { "INTEGER" "ZEE" } + { "CHARACTER(20)" "WOO" } + } fortran-record>c-struct +] unit-test + +! F-RECORD: + +[ 12 ] [ "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 +[ 8 ] [ "bas" "fortran_test_record" offset-of ] unit-test + diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index 0c30258895..327db12909 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -1,5 +1,6 @@ -USING: accessors alien alien.c-types alien.syntax arrays ascii -assocs combinators fry kernel macros math.parser sequences splitting ; +USING: accessors alien alien.c-types alien.structs alien.syntax +arrays ascii assocs combinators fry kernel lexer macros math.parser +namespaces parser sequences splitting vectors vocabs.parser ; IN: alien.fortran ! XXX this currently only supports the gfortran/f2c abi. @@ -65,9 +66,12 @@ MACRO: size-case-type ( cases -- ) GENERIC: (fortran-type>c-type) ( type -- c-type ) +M: f (fortran-type>c-type) ; + M: integer-type (fortran-type>c-type) { { f [ "int" ] } + { 1 [ "char" ] } { 2 [ "short" ] } { 4 [ "int" ] } { 8 [ "longlong" ] } @@ -140,6 +144,9 @@ GENERIC: (fortran-ret-type>c-type) ( type -- c-type ) M: fortran-type (fortran-ret-type>c-type) (fortran-type>c-type) ; M: real-type (fortran-ret-type>c-type) drop "double" ; +: suffix! ( seq elt -- seq ) over push ; inline +: append! ( seq-a seq-b -- seq-a ) over push-all ; inline + PRIVATE> : fortran-type>c-type ( fortran-type -- c-type ) @@ -156,10 +163,21 @@ PRIVATE> [ added-c-args ] [ (fortran-ret-type>c-type) c-type>pointer ] bi prefix ] if ; -: fortran-sig>c-sig ( fortran-return fortran-args -- c-return c-args ) ; +: fortran-arg-types>c-types ( fortran-types -- c-types ) + [ length 1 ] keep + [ fortran-arg-type>c-type swapd [ suffix! ] [ append! ] 2bi* ] each + append >array ; -! : F-RECORD: ... ; parsing -! : F-ABI: ... ; parsing +: fortran-sig>c-sig ( fortran-return fortran-args -- c-return c-args ) + [ fortran-ret-type>c-type ] [ fortran-arg-types>c-types ] bi* append ; + +: fortran-record>c-struct ( record -- struct ) + [ first2 [ fortran-type>c-type ] [ >lower ] bi* 2array ] map ; + +: define-record ( name vocab fields -- ) + [ >lower ] [ ] [ fortran-record>c-struct ] tri* define-struct ; + +: F-RECORD: scan in get parse-definition define-record ; parsing ! : F-SUBROUTINE: ... ; parsing ! : F-FUNCTION: ... ; parsing diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor index 42923fb28b..cb3f90d358 100644 --- a/basis/alien/structs/structs.factor +++ b/basis/alien/structs/structs.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays generic hashtables kernel kernel.private +USING: accessors arrays assocs generic hashtables kernel kernel.private math namespaces parser sequences strings words libc fry alien.c-types alien.structs.fields cpu.architecture math.order ; IN: alien.structs @@ -61,3 +61,8 @@ M: struct-type stack-size [ expand-constants ] map [ [ heap-size ] [ max ] map-reduce ] keep compute-struct-align f (define-struct) ; + +: offset-of ( field struct -- offset ) + c-types get at fields>> + [ name>> = ] with find nip offset>> ; + From 7e2ac604e718b29bf3e6e8052ac75e22390d92e1 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 6 Feb 2009 10:06:22 -0600 Subject: [PATCH 09/38] some initial work on invoking fortran functions --- basis/alien/fortran/fortran-tests.factor | 46 +++++++++++++-- basis/alien/fortran/fortran.factor | 72 ++++++++++++++++++++---- 2 files changed, 103 insertions(+), 15 deletions(-) diff --git a/basis/alien/fortran/fortran-tests.factor b/basis/alien/fortran/fortran-tests.factor index 11f0a2efc7..a1f2443b30 100644 --- a/basis/alien/fortran/fortran-tests.factor +++ b/basis/alien/fortran/fortran-tests.factor @@ -1,3 +1,4 @@ +! (c) 2009 Joe Groff, see BSD license USING: accessors alien alien.c-types alien.fortran alien.structs alien.syntax arrays assocs kernel namespaces sequences tools.test ; IN: alien.fortran.tests @@ -11,6 +12,7 @@ F-RECORD: fortran_test_record [ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test [ "fun_times__" ] [ "Fun_Times" fortran-name>symbol-name ] unit-test +[ "funtimes___" ] [ "FunTimes_" fortran-name>symbol-name ] unit-test ! fortran-type>c-type @@ -57,7 +59,7 @@ F-RECORD: fortran_test_record [ "real" fortran-type>c-type ] unit-test [ "double" ] -[ "double precision" fortran-type>c-type ] unit-test +[ "double-precision" fortran-type>c-type ] unit-test [ "float" ] [ "real*4" fortran-type>c-type ] unit-test @@ -69,7 +71,7 @@ F-RECORD: fortran_test_record [ "complex" fortran-type>c-type ] unit-test [ "(fortran-double-complex)" ] -[ "double complex" fortran-type>c-type ] unit-test +[ "double-complex" fortran-type>c-type ] unit-test [ "(fortran-complex)" ] [ "complex*8" fortran-type>c-type ] unit-test @@ -118,13 +120,13 @@ F-RECORD: fortran_test_record [ "real" fortran-ret-type>c-type ] unit-test [ "double" { } ] -[ "double precision" fortran-ret-type>c-type ] unit-test +[ "double-precision" fortran-ret-type>c-type ] unit-test [ "void" { "(fortran-complex)*" } ] [ "complex" fortran-ret-type>c-type ] unit-test [ "void" { "(fortran-double-complex)*" } ] -[ "double complex" fortran-ret-type>c-type ] unit-test +[ "double-complex" fortran-ret-type>c-type ] unit-test [ "void" { "int*" } ] [ "integer(*)" fortran-ret-type>c-type ] unit-test @@ -155,7 +157,7 @@ unit-test { "char[20]" "woo" } } ] [ { - { "DOUBLE PRECISION" "EX" } + { "DOUBLE-PRECISION" "EX" } { "REAL" "WYE" } { "INTEGER" "ZEE" } { "CHARACTER(20)" "WOO" } @@ -169,3 +171,37 @@ unit-test [ 4 ] [ "bar" "fortran_test_record" offset-of ] unit-test [ 8 ] [ "bas" "fortran_test_record" offset-of ] unit-test +! fortran-arg>c-args + +[ B{ 128 } { } ] +[ 128 "integer*1" fortran-arg>c-args ] unit-test + +little-endian? [ B{ 128 0 } { } ] [ B{ 0 128 } { } ] ? +[ 128 "integer*2" fortran-arg>c-args ] unit-test + +little-endian? [ B{ 128 0 0 0 } { } ] [ B{ 0 0 0 128 } { } ] ? +[ 128 "integer*4" fortran-arg>c-args ] unit-test + +little-endian? [ B{ 128 0 0 0 0 0 0 0 } { } ] [ B{ 0 0 0 0 0 0 0 128 } { } ] ? +[ 128 "integer*8" fortran-arg>c-args ] unit-test + +[ B{ CHAR: h CHAR: e CHAR: l CHAR: l CHAR: o } { 5 } ] +[ "hello" "character*5" fortran-arg>c-args ] unit-test + +little-endian? [ B{ 0 0 128 63 } { } ] [ B{ 63 128 0 0 } { } ] ? +[ 1.0 "real" fortran-arg>c-args ] unit-test + +little-endian? [ B{ 0 0 128 63 0 0 0 64 } { } ] [ B{ 63 128 0 0 64 0 0 0 } { } ] ? +[ C{ 1.0 2.0 } "complex" fortran-arg>c-args ] unit-test + +little-endian? [ B{ 0 0 0 0 0 0 240 63 } { } ] [ B{ 63 240 0 0 0 0 0 0 } { } ] ? +[ 1.0 "double-precision" fortran-arg>c-args ] unit-test + +little-endian? +[ B{ 0 0 0 0 0 0 240 63 0 0 0 0 0 0 0 64 } { } ] +[ B{ 63 240 0 0 0 0 0 0 64 0 0 0 0 0 0 0 } { } ] ? +[ C{ 1.0 2.0 } "double-complex" fortran-arg>c-args ] unit-test + +[ B{ 1 0 0 0 2 0 0 0 } { } ] +[ B{ 1 0 0 0 2 0 0 0 } "integer(2)" fortran-arg>c-args ] unit-test + diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index 327db12909..faec9b5b86 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -1,6 +1,7 @@ +! (c) 2009 Joe Groff, see BSD license USING: accessors alien alien.c-types alien.structs alien.syntax arrays ascii assocs combinators fry kernel lexer macros math.parser -namespaces parser sequences splitting vectors vocabs.parser ; +namespaces parser sequences splitting vectors vocabs.parser locals ; IN: alien.fortran ! XXX this currently only supports the gfortran/f2c abi. @@ -43,9 +44,9 @@ CONSTANT: fortran>c-types H{ { "integer" integer-type } { "logical" logical-type } { "real" real-type } - { "double precision" double-precision-type } + { "double-precision" double-precision-type } { "complex" real-complex-type } - { "double complex" double-complex-type } + { "double-complex" double-complex-type } } : append-dimensions ( base-c-type type -- c-type ) @@ -82,7 +83,7 @@ M: real-type (fortran-type>c-type) { 4 [ "float" ] } { 8 [ "double" ] } } size-case-type ; -M: complex-type (fortran-type>c-type) +M: real-complex-type (fortran-type>c-type) { { f [ "(fortran-complex)" ] } { 8 [ "(fortran-complex)" ] } @@ -127,12 +128,6 @@ GENERIC: added-c-args ( type -- args ) M: fortran-type added-c-args drop { } ; M: character-type added-c-args drop { "long" } ; -GENERIC: added-c-arg-values ( type -- arg-values ) - -M: fortran-type added-c-arg-values drop { } ; -M: character-type added-c-arg-values - fix-character-type dims>> first 1array ; - GENERIC: returns-by-value? ( type -- ? ) M: fortran-type returns-by-value? drop f ; @@ -147,6 +142,56 @@ M: real-type (fortran-ret-type>c-type) drop "double" ; : suffix! ( seq elt -- seq ) over push ; inline : append! ( seq-a seq-b -- seq-a ) over push-all ; inline +: ( complex -- byte-array ) + "(fortran-complex)" c-object + [ [ real-part ] dip set-(fortran-complex)-r ] + [ [ imaginary-part ] dip set-(fortran-complex)-i ] + [ ] tri ; + +: ( complex -- byte-array ) + "(fortran-double-complex)" c-object + [ [ real-part ] dip set-(fortran-complex)-r ] + [ [ imaginary-part ] dip set-(fortran-complex)-i ] + [ ] tri ; + +GENERIC: [fortran-arg>c-args] ( type -- main-quot added-quot ) + +M: integer-type [fortran-arg>c-args] + size>> { + { f [ [ ] [ drop ] ] } + { 1 [ [ ] [ drop ] ] } + { 2 [ [ ] [ drop ] ] } + { 4 [ [ ] [ drop ] ] } + { 8 [ [ ] [ drop ] ] } + [ invalid-fortran-type ] + } case ; + +M: real-type [fortran-arg>c-args] + size>> { + { f [ [ ] [ drop ] ] } + { 4 [ [ ] [ drop ] ] } + { 8 [ [ ] [ drop ] ] } + [ invalid-fortran-type ] + } case ; + +M: real-complex-type [fortran-arg>c-args] + size>> { + { f [ [ ] [ drop ] ] } + { 8 [ [ ] [ drop ] ] } + { 16 [ [ ] [ drop ] ] } + [ invalid-fortran-type ] + } case ; + +M: real-complex-type [fortran-arg>c-args] + size>> { + { f [ [ ] [ drop ] ] } + { 8 [ [ ] [ drop ] ] } + { 16 [ [ ] [ drop ] ] } + [ invalid-fortran-type ] + } case ; + +M: + PRIVATE> : fortran-type>c-type ( fortran-type -- c-type ) @@ -178,6 +223,13 @@ PRIVATE> [ >lower ] [ ] [ fortran-record>c-struct ] tri* define-struct ; : F-RECORD: scan in get parse-definition define-record ; parsing + +:: define-fortran-function ( return library function parameters -- ) + ; + +: F-SUBROUTINE: + + ! : F-SUBROUTINE: ... ; parsing ! : F-FUNCTION: ... ; parsing From 118f2de4667d47a79563b7a3d9c07308781c14b5 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 6 Feb 2009 19:05:56 -0600 Subject: [PATCH 10/38] fortran-invoke sketch --- basis/alien/complex/complex-tests.factor | 2 +- basis/alien/complex/functor/functor.factor | 14 +- basis/alien/fortran/fortran-tests.factor | 170 ++++++++++++++------ basis/alien/fortran/fortran.factor | 178 +++++++++++++++------ 4 files changed, 260 insertions(+), 104 deletions(-) diff --git a/basis/alien/complex/complex-tests.factor b/basis/alien/complex/complex-tests.factor index bfb2c1137c..0bff73b898 100644 --- a/basis/alien/complex/complex-tests.factor +++ b/basis/alien/complex/complex-tests.factor @@ -15,4 +15,4 @@ C-STRUCT: complex-holder C{ 1.0 2.0 } "h" set ] unit-test -[ C{ 1.0 2.0 } ] [ "h" get complex-holder-z ] unit-test \ No newline at end of file +[ C{ 1.0 2.0 } ] [ "h" get complex-holder-z ] unit-test diff --git a/basis/alien/complex/functor/functor.factor b/basis/alien/complex/functor/functor.factor index 1d12bb0ff4..c6644eba1d 100644 --- a/basis/alien/complex/functor/functor.factor +++ b/basis/alien/complex/functor/functor.factor @@ -12,15 +12,15 @@ T-imaginary DEFINES ${T}-imaginary set-T-real DEFINES set-${T}-real set-T-imaginary DEFINES set-${T}-imaginary ->T DEFINES >${T} -T> DEFINES ${T}> + DEFINES <${T}> +*T DEFINES *${T} WHERE -: >T ( z -- alien ) +: ( z -- alien ) >rect T [ set-T-imaginary ] [ set-T-real ] [ ] tri ; inline -: T> ( alien -- z ) +: *T ( alien -- z ) [ T-real ] [ T-imaginary ] bi rect> ; inline T in get @@ -28,8 +28,8 @@ T in get define-struct T c-type -T> 1quotation >>boxer-quot ->T 1quotation >>unboxer-quot + 1quotation >>boxer-quot +*T 1quotation >>unboxer-quot drop -;FUNCTOR \ No newline at end of file +;FUNCTOR diff --git a/basis/alien/fortran/fortran-tests.factor b/basis/alien/fortran/fortran-tests.factor index a1f2443b30..0a86cba7e3 100644 --- a/basis/alien/fortran/fortran-tests.factor +++ b/basis/alien/fortran/fortran-tests.factor @@ -1,12 +1,13 @@ ! (c) 2009 Joe Groff, see BSD license USING: accessors alien alien.c-types alien.fortran alien.structs -alien.syntax arrays assocs kernel namespaces sequences tools.test ; +alien.syntax arrays assocs kernel macros namespaces sequences +tools.test fry ; IN: alien.fortran.tests -F-RECORD: fortran_test_record - { "integer" "foo" } - { "real" "bar" } - { "character*4" "bas" } ; +RECORD: FORTRAN_TEST_RECORD + { "INTEGER" "FOO" } + { "REAL(2)" "BAR" } + { "CHARACTER*4" "BAS" } ; ! fortran-name>symbol-name @@ -67,19 +68,16 @@ F-RECORD: fortran_test_record [ "double" ] [ "real*8" fortran-type>c-type ] unit-test -[ "(fortran-complex)" ] +[ "complex-float" ] [ "complex" fortran-type>c-type ] unit-test -[ "(fortran-double-complex)" ] +[ "complex-double" ] [ "double-complex" fortran-type>c-type ] unit-test -[ "(fortran-complex)" ] +[ "complex-float" ] [ "complex*8" fortran-type>c-type ] unit-test -[ "(fortran-double-complex)" ] -[ "complex*16" fortran-type>c-type ] unit-test - -[ "(fortran-double-complex)" ] +[ "complex-double" ] [ "complex*16" fortran-type>c-type ] unit-test [ "fortran_test_record" ] @@ -122,10 +120,10 @@ F-RECORD: fortran_test_record [ "double" { } ] [ "double-precision" fortran-ret-type>c-type ] unit-test -[ "void" { "(fortran-complex)*" } ] +[ "void" { "complex-float*" } ] [ "complex" fortran-ret-type>c-type ] unit-test -[ "void" { "(fortran-double-complex)*" } ] +[ "void" { "complex-double*" } ] [ "double-complex" fortran-ret-type>c-type ] unit-test [ "void" { "int*" } ] @@ -144,7 +142,7 @@ unit-test [ "character*18" { "character*17" "character" "integer" } fortran-sig>c-sig ] unit-test -[ "void" { "(fortran-complex)*" "char*" "char*" "int*" "long" "long" } ] +[ "void" { "complex-float*" "char*" "char*" "int*" "long" "long" } ] [ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ] unit-test @@ -164,44 +162,126 @@ unit-test } fortran-record>c-struct ] unit-test -! F-RECORD: +! RECORD: -[ 12 ] [ "fortran_test_record" heap-size ] 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 -[ 8 ] [ "bas" "fortran_test_record" offset-of ] unit-test +[ 12 ] [ "bas" "fortran_test_record" offset-of ] unit-test -! fortran-arg>c-args +! fortran-invoke -[ B{ 128 } { } ] -[ 128 "integer*1" fortran-arg>c-args ] unit-test +: fortran-invoke-expansion ( return library function parameters -- quot ) + '[ _ _ _ _ fortran-invoke ] expand-macros ; inline -little-endian? [ B{ 128 0 } { } ] [ B{ 0 128 } { } ] ? -[ 128 "integer*2" fortran-arg>c-args ] unit-test +[ [ + ! [fortran-args>c-args] + { + [ { + [ ascii string>alien ] + [ ] + [ ] + [ ] + [ 1 0 ? ] + } spread ] + [ { [ length ] [ drop ] [ drop ] [ drop ] [ drop ] } spread ] + } 5 ncleave + ! [fortran-invoke] + [ + "void" "foopack" "funtimes_" + { "char*" "int*" "float*" "complex-float*" "short*" "long" } + alien-invoke + ] 6 nkeep + ! [fortran-results>] + { + [ drop ] + [ drop ] + [ *float ] + [ drop ] + [ drop ] + [ drop ] + } spread +] ] [ + f "foopack" "FUNTIMES" { "CHARACTER*12" "INTEGER*8" "!REAL" "COMPLEX" "LOGICAL*2" } + fortran-invoke-expansion +] unit-test -little-endian? [ B{ 128 0 0 0 } { } ] [ B{ 0 0 0 128 } { } ] ? -[ 128 "integer*4" fortran-arg>c-args ] unit-test +[ [ + ! [fortran-invoke] + "double" "foopack" "fun_times__" + { "float*" } + alien-invoke +] ] [ + "REAL" "foopack" "FUN_TIMES" { "REAL(*)" } + fortran-invoke-expansion +] unit-test -little-endian? [ B{ 128 0 0 0 0 0 0 0 } { } ] [ B{ 0 0 0 0 0 0 0 128 } { } ] ? -[ 128 "integer*8" fortran-arg>c-args ] unit-test +[ [ + ! [] + [ "complex-float" ] 1 ndip + ! [fortran-invoke] + [ + "void" "foopack" "fun_times__" + { "complex-float*" "float*" } + alien-invoke + ] 2 nkeep + ! [fortran-results>] + { + [ *complex-float ] + [ drop ] + } spread +] ] [ + "COMPLEX" "foopack" "FUN_TIMES" { "REAL(*)" } + fortran-invoke-expansion +] unit-test -[ B{ CHAR: h CHAR: e CHAR: l CHAR: l CHAR: o } { 5 } ] -[ "hello" "character*5" fortran-arg>c-args ] unit-test +[ [ + ! [] + [ 20 20 ] 1 ndip + ! [fortran-invoke] + [ + "void" "foopack" "fun_times__" + { "char*" "long" "float*" } + alien-invoke + ] 3 nkeep + ! [fortran-results>] + { + [ ] + [ ascii alien>nstring ] + [ drop ] + } spread +] ] [ + "CHARACTER*20" "foopack" "FUN_TIMES" { } + fortran-invoke-expansion +] unit-test -little-endian? [ B{ 0 0 128 63 } { } ] [ B{ 63 128 0 0 } { } ] ? -[ 1.0 "real" fortran-arg>c-args ] unit-test - -little-endian? [ B{ 0 0 128 63 0 0 0 64 } { } ] [ B{ 63 128 0 0 64 0 0 0 } { } ] ? -[ C{ 1.0 2.0 } "complex" fortran-arg>c-args ] unit-test - -little-endian? [ B{ 0 0 0 0 0 0 240 63 } { } ] [ B{ 63 240 0 0 0 0 0 0 } { } ] ? -[ 1.0 "double-precision" fortran-arg>c-args ] unit-test - -little-endian? -[ B{ 0 0 0 0 0 0 240 63 0 0 0 0 0 0 0 64 } { } ] -[ B{ 63 240 0 0 0 0 0 0 64 0 0 0 0 0 0 0 } { } ] ? -[ C{ 1.0 2.0 } "double-complex" fortran-arg>c-args ] unit-test - -[ B{ 1 0 0 0 2 0 0 0 } { } ] -[ B{ 1 0 0 0 2 0 0 0 } "integer(2)" fortran-arg>c-args ] unit-test +[ [ + ! [] + [ 10 10 ] 2 ndip + ! [fortran-args>c-args] + { + [ { + [ ascii string>alien ] + [ ] + } spread ] + [ { [ length ] [ drop ] } spread ] + } 2 ncleave + ! [fortran-invoke] + [ + "void" "foopack" "fun_times__" + { "char*" "long" "char*" "float*" "long" } + alien-invoke + ] 5 nkeep + ! [fortran-results>] + { + [ ] + [ ascii alien>nstring ] + [ ] + [ *float swap ] + [ ascii alien>nstring ] + } spread +] ] [ + "CHARACTER*10" "foopack" "FUN_TIMES" { "!CHARACTER*20" "!REAL" } + fortran-invoke-expansion +] unit-test diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index faec9b5b86..b0bbedd716 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -1,20 +1,15 @@ ! (c) 2009 Joe Groff, see BSD license USING: accessors alien alien.c-types alien.structs alien.syntax arrays ascii assocs combinators fry kernel lexer macros math.parser -namespaces parser sequences splitting vectors vocabs.parser locals ; +namespaces parser sequences splitting vectors vocabs.parser locals +io.encodings.ascii io.encodings.string ; IN: alien.fortran ! XXX this currently only supports the gfortran/f2c abi. ! XXX we should also support ifort at some point for commercial BLASes -C-STRUCT: (fortran-complex) - { "float" "r" } - { "float" "i" } ; -C-STRUCT: (fortran-double-complex) - { "double" "r" } - { "double" "i" } ; - -: fortran-c-abi ( -- abi ) "cdecl" ; +: alien>nstring ( alien len encoding -- string ) + [ memory>byte-array ] dip decode ; : fortran-name>symbol-name ( fortran-name -- c-name ) >lower CHAR: _ over member? @@ -22,9 +17,11 @@ C-STRUCT: (fortran-double-complex) ERROR: invalid-fortran-type type ; +DEFER: fortran-sig>c-sig + > [ invalid-fortran-type ] [ drop ] if ] [ append-dimensions ] bi ; -: new-fortran-type ( dims size class -- type ) - new [ (>>size) ] [ (>>dims) ] [ ] tri ; +: new-fortran-type ( out? dims size class -- type ) + new [ [ (>>size) ] [ (>>dims) ] [ (>>out?) ] tri ] keep ; GENERIC: (fortran-type>c-type) ( type -- c-type ) -M: f (fortran-type>c-type) ; +M: f (fortran-type>c-type) drop "void" ; M: integer-type (fortran-type>c-type) { @@ -85,9 +82,9 @@ M: real-type (fortran-type>c-type) } size-case-type ; M: real-complex-type (fortran-type>c-type) { - { f [ "(fortran-complex)" ] } - { 8 [ "(fortran-complex)" ] } - { 16 [ "(fortran-double-complex)" ] } + { f [ "complex-float" ] } + { 8 [ "complex-float" ] } + { 16 [ "complex-double" ] } } size-case-type ; M: double-precision-type (fortran-type>c-type) @@ -108,6 +105,9 @@ M: character-type (fortran-type>c-type) : dimension>number ( string -- number ) dup "*" = [ drop 0 ] [ string>number ] if ; +: parse-out ( string -- string' out? ) + "!" ?head ; + : parse-dims ( string -- string' dim ) "(" split1 dup [ ")" ?tail drop "," split [ [ blank? ] trim dimension>number ] map ] when ; @@ -115,10 +115,13 @@ M: character-type (fortran-type>c-type) : parse-size ( string -- string' size ) "*" split1 dup [ string>number ] when ; -: parse-fortran-type ( fortran-type-string -- type ) - parse-dims swap parse-size swap +: (parse-fortran-type) ( fortran-type-string -- type ) + parse-out swap parse-dims swap parse-size swap dup >lower fortran>c-types at* - [ nip new-fortran-type ] [ drop misc-type boa ] if ; + [ nip new-fortran-type ] [ drop f misc-type boa ] if ; + +: parse-fortran-type ( fortran-type-string/f -- type/f ) + dup [ (parse-fortran-type) ] when ; : c-type>pointer ( c-type -- c-type* ) "[" split1 drop "*" append ; @@ -130,33 +133,23 @@ M: character-type added-c-args drop { "long" } ; 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 ; GENERIC: (fortran-ret-type>c-type) ( type -- c-type ) +M: f (fortran-ret-type>c-type) drop "void" ; M: fortran-type (fortran-ret-type>c-type) (fortran-type>c-type) ; M: real-type (fortran-ret-type>c-type) drop "double" ; : suffix! ( seq elt -- seq ) over push ; inline : append! ( seq-a seq-b -- seq-a ) over push-all ; inline -: ( complex -- byte-array ) - "(fortran-complex)" c-object - [ [ real-part ] dip set-(fortran-complex)-r ] - [ [ imaginary-part ] dip set-(fortran-complex)-i ] - [ ] tri ; +GENERIC: (fortran-arg>c-args) ( type -- main-quot added-quot ) -: ( complex -- byte-array ) - "(fortran-double-complex)" c-object - [ [ real-part ] dip set-(fortran-complex)-r ] - [ [ imaginary-part ] dip set-(fortran-complex)-i ] - [ ] tri ; - -GENERIC: [fortran-arg>c-args] ( type -- main-quot added-quot ) - -M: integer-type [fortran-arg>c-args] +M: integer-type (fortran-arg>c-args) size>> { { f [ [ ] [ drop ] ] } { 1 [ [ ] [ drop ] ] } @@ -166,7 +159,10 @@ M: integer-type [fortran-arg>c-args] [ invalid-fortran-type ] } case ; -M: real-type [fortran-arg>c-args] +M: logical-type (fortran-arg>c-args) + call-next-method [ [ 1 0 ? ] prepend ] dip ; + +M: real-type (fortran-arg>c-args) size>> { { f [ [ ] [ drop ] ] } { 4 [ [ ] [ drop ] ] } @@ -174,23 +170,92 @@ M: real-type [fortran-arg>c-args] [ invalid-fortran-type ] } case ; -M: real-complex-type [fortran-arg>c-args] +M: real-complex-type (fortran-arg>c-args) size>> { - { f [ [ ] [ drop ] ] } - { 8 [ [ ] [ drop ] ] } - { 16 [ [ ] [ drop ] ] } + { f [ [ ] [ drop ] ] } + { 8 [ [ ] [ drop ] ] } + { 16 [ [ ] [ drop ] ] } [ invalid-fortran-type ] } case ; -M: real-complex-type [fortran-arg>c-args] +M: double-precision-type (fortran-arg>c-args) + drop [ ] [ drop ] ; + +M: double-complex-type (fortran-arg>c-args) + drop [ ] [ drop ] ; + +M: character-type (fortran-arg>c-args) + drop [ ascii string>alien ] [ length ] ; + +M: misc-type (fortran-arg>c-args) + drop [ ] [ drop ] ; + +GENERIC: (fortran-result>) ( type -- quot ) + +M: integer-type (fortran-result>) size>> { - { f [ [ ] [ drop ] ] } - { 8 [ [ ] [ drop ] ] } - { 16 [ [ ] [ drop ] ] } + { f [ [ *int ] ] } + { 1 [ [ *char ] ] } + { 2 [ [ *short ] ] } + { 4 [ [ *int ] ] } + { 8 [ [ *longlong ] ] } [ invalid-fortran-type ] } case ; -M: +M: logical-type (fortran-result>) + call-next-method [ zero? not ] append ; + +M: real-type (fortran-result>) + size>> { + { f [ [ *float ] ] } + { 4 [ [ *float ] ] } + { 8 [ [ *double ] ] } + [ invalid-fortran-type ] + } case ; + +M: real-complex-type (fortran-result>) + size>> { + { f [ [ *complex-float ] ] } + { 8 [ [ *complex-float ] ] } + { 16 [ [ *complex-double ] ] } + [ invalid-fortran-type ] + } case ; + +M: double-precision-type (fortran-result>) + drop [ *double ] ; + +M: double-complex-type (fortran-result>) + drop [ *complex-double ] ; + +M: character-type (fortran-result>) + drop [ ascii alien>nstring ] ; + +M: misc-type (fortran-result>) + drop [ ] ; + +GENERIC: () ( type -- quot ) + +M: fortran-type () + (fortran-type>c-type) '[ _ ] ; + +: [] ( return parameters -- quot ) + [ parse-fortran-type ] dip + over returns-by-value? + [ 2drop [ ] ] + [ [ () ] [ '[ _ _ ndip ] ] bi* ] if ; + +: [fortran-args>c-args] ( parameters -- quot ) + [ parse-fortran-type (fortran-arg>c-args) 2array ] map flip first2 + [ [ '[ _ spread ] ] bi@ 2array ] [ length ] bi + '[ _ _ ncleave ] ; + +:: [fortran-invoke] ( return library function parameters -- quot ) + return parameters fortran-sig>c-sig :> c-parameters :> c-return + function fortran-name>symbol-name :> c-function + [ c-return library c-function c-parameters alien-invoke ] ; + +: [fortran-results>] ( return parameters -- quot ) + 2drop [ ] ; PRIVATE> @@ -219,17 +284,28 @@ PRIVATE> : fortran-record>c-struct ( record -- struct ) [ first2 [ fortran-type>c-type ] [ >lower ] bi* 2array ] map ; -: define-record ( name vocab fields -- ) +: define-fortran-record ( name vocab fields -- ) [ >lower ] [ ] [ fortran-record>c-struct ] tri* define-struct ; -: F-RECORD: scan in get parse-definition define-record ; parsing +: RECORD: scan in get parse-definition define-fortran-record ; parsing + +MACRO: fortran-invoke ( return library function parameters -- ) + { + [ 2nip [] ] + [ nip nip nip [fortran-args>c-args] ] + [ [fortran-invoke] ] + [ 2nip [fortran-results>] ] + } 4 ncleave 3append ; :: define-fortran-function ( return library function parameters -- ) - ; + function create-in dup reset-generic + return library function parameters return parse-arglist + [ '[ _ _ _ _ fortran-invoke ] ] dip define-declared ; -: F-SUBROUTINE: - - -! : F-SUBROUTINE: ... ; parsing -! : F-FUNCTION: ... ; parsing +: SUBROUTINE: + f "c-library" get scan ";" parse-tokens + [ "()" subseq? not ] filter define-fortran-function ; parsing +: FUNCTION: + scan "c-library" get scan ";" parse-tokens + [ "()" subseq? not ] filter define-fortran-function ; parsing From 3bc557467e7b01b472bc4372927634a84489847a Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 11:40:05 -0600 Subject: [PATCH 11/38] shuffle( -- ) arbitrary stack shuffling word --- basis/shuffle/shuffle-tests.factor | 2 ++ basis/shuffle/shuffle.factor | 23 +++++++++++++++++++++-- 2 files changed, 23 insertions(+), 2 deletions(-) diff --git a/basis/shuffle/shuffle-tests.factor b/basis/shuffle/shuffle-tests.factor index f190544e19..8202146b3d 100644 --- a/basis/shuffle/shuffle-tests.factor +++ b/basis/shuffle/shuffle-tests.factor @@ -3,3 +3,5 @@ USING: shuffle tools.test ; [ 8 ] [ 5 6 7 8 3nip ] unit-test [ 3 1 2 3 ] [ 1 2 3 tuckd ] unit-test [ 1 2 3 4 ] [ 3 4 1 2 2swap ] unit-test + +[ 4 2 3 ] [ 1 2 3 4 shuffle( a b c d -- d b c ) ] unit-test diff --git a/basis/shuffle/shuffle.factor b/basis/shuffle/shuffle.factor index b195e4abf9..632c09e338 100644 --- a/basis/shuffle/shuffle.factor +++ b/basis/shuffle/shuffle.factor @@ -1,9 +1,28 @@ ! Copyright (C) 2007 Chris Double, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel generalizations ; - +USING: accessors assocs effects.parser generalizations +hashtables kernel locals locals.backend macros make math +parser sequences ; IN: shuffle +locals-assoc ( sequence -- assoc ) + dup length dup 1- [ - ] curry map zip >hashtable ; + +PRIVATE> + +MACRO: shuffle-effect ( effect -- ) + [ out>> ] [ in>> >locals-assoc ] bi + [ + [ nip assoc-size , \ load-locals , ] + [ [ at , \ get-local , ] curry each ] + [ nip assoc-size , \ drop-locals , ] 2tri + ] [ ] make ; + +: shuffle( + ")" parse-effect parsed \ shuffle-effect parsed ; parsing + : 2swap ( x y z t -- z t x y ) 2 2 mnswap ; inline : nipd ( a b c -- b c ) rot drop ; inline From 4dd500b5b1ab7d96fb1608f176782a5f57a1abc5 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 13:29:50 -0600 Subject: [PATCH 12/38] fortran-invoke works(?) --- basis/alien/fortran/fortran-tests.factor | 98 ++++++------ basis/alien/fortran/fortran.factor | 194 +++++++++++++++-------- 2 files changed, 184 insertions(+), 108 deletions(-) diff --git a/basis/alien/fortran/fortran-tests.factor b/basis/alien/fortran/fortran-tests.factor index 0a86cba7e3..9b618ef513 100644 --- a/basis/alien/fortran/fortran-tests.factor +++ b/basis/alien/fortran/fortran-tests.factor @@ -1,7 +1,9 @@ ! (c) 2009 Joe Groff, see BSD license -USING: accessors alien alien.c-types alien.fortran alien.structs -alien.syntax arrays assocs kernel macros namespaces sequences -tools.test fry ; +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 ; IN: alien.fortran.tests RECORD: FORTRAN_TEST_RECORD @@ -169,17 +171,14 @@ unit-test [ 4 ] [ "bar" "fortran_test_record" offset-of ] unit-test [ 12 ] [ "bas" "fortran_test_record" offset-of ] unit-test -! fortran-invoke - -: fortran-invoke-expansion ( return library function parameters -- quot ) - '[ _ _ _ _ fortran-invoke ] expand-macros ; inline +! (fortran-invoke) [ [ ! [fortran-args>c-args] { [ { [ ascii string>alien ] - [ ] + [ ] [ ] [ ] [ 1 0 ? ] @@ -188,100 +187,109 @@ unit-test } 5 ncleave ! [fortran-invoke] [ - "void" "foopack" "funtimes_" - { "char*" "int*" "float*" "complex-float*" "short*" "long" } + "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 ] - [ drop ] } spread ] ] [ - f "foopack" "FUNTIMES" { "CHARACTER*12" "INTEGER*8" "!REAL" "COMPLEX" "LOGICAL*2" } - fortran-invoke-expansion + 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] - "double" "foopack" "fun_times__" - { "float*" } - alien-invoke + [ "double" "funpack" "fun_times__" { "float*" } alien-invoke ] + 1 nkeep + ! [fortran-results>] + shuffle( reta aa -- reta aa ) + { [ ] [ drop ] } spread ] ] [ - "REAL" "foopack" "FUN_TIMES" { "REAL(*)" } - fortran-invoke-expansion + "REAL" "funpack" "FUN_TIMES" { "REAL(*)" } + (fortran-invoke) ] unit-test [ [ ! [] [ "complex-float" ] 1 ndip + ! [fortran-args>c-args] + { [ { [ ] } spread ] [ { [ drop ] } spread ] } 1 ncleave ! [fortran-invoke] [ - "void" "foopack" "fun_times__" + "void" "funpack" "fun_times__" { "complex-float*" "float*" } alien-invoke ] 2 nkeep ! [fortran-results>] - { - [ *complex-float ] - [ drop ] - } spread + shuffle( reta aa -- reta aa ) + { [ *complex-float ] [ drop ] } spread ] ] [ - "COMPLEX" "foopack" "FUN_TIMES" { "REAL(*)" } - fortran-invoke-expansion + "COMPLEX" "funpack" "FUN_TIMES" { "REAL(*)" } + (fortran-invoke) ] unit-test [ [ ! [] - [ 20 20 ] 1 ndip + [ 20 20 ] 0 ndip ! [fortran-invoke] [ - "void" "foopack" "fun_times__" - { "char*" "long" "float*" } + "void" "funpack" "fun_times__" + { "char*" "long" } alien-invoke - ] 3 nkeep + ] 2 nkeep ! [fortran-results>] - { - [ ] - [ ascii alien>nstring ] - [ drop ] - } spread + shuffle( reta retb -- reta retb ) + { [ ] [ ascii alien>nstring ] } spread ] ] [ - "CHARACTER*20" "foopack" "FUN_TIMES" { } - fortran-invoke-expansion + "CHARACTER*20" "funpack" "FUN_TIMES" { } + (fortran-invoke) ] unit-test [ [ ! [] - [ 10 10 ] 2 ndip + [ 10 10 ] 3 ndip ! [fortran-args>c-args] { [ { [ ascii string>alien ] [ ] + [ ascii string>alien ] } spread ] - [ { [ length ] [ drop ] } spread ] - } 2 ncleave + [ { [ length ] [ drop ] [ length ] } spread ] + } 3 ncleave ! [fortran-invoke] [ - "void" "foopack" "fun_times__" - { "char*" "long" "char*" "float*" "long" } + "void" "funpack" "fun_times__" + { "char*" "long" "char*" "float*" "char*" "long" "long" } alien-invoke - ] 5 nkeep + ] 7 nkeep ! [fortran-results>] + shuffle( reta retb aa ba ca ab cb -- reta retb aa ab ba ca cb ) { [ ] [ ascii alien>nstring ] [ ] - [ *float swap ] + [ ascii alien>nstring ] + [ *float ] + [ ] [ ascii alien>nstring ] } spread ] ] [ - "CHARACTER*10" "foopack" "FUN_TIMES" { "!CHARACTER*20" "!REAL" } - fortran-invoke-expansion + "CHARACTER*10" "funpack" "FUN_TIMES" { "!CHARACTER*20" "!REAL" "!CHARACTER*30" } + (fortran-invoke) ] unit-test diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index b0bbedd716..85fa0e536e 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -1,8 +1,11 @@ ! (c) 2009 Joe Groff, see BSD license -USING: accessors alien alien.c-types alien.structs alien.syntax -arrays ascii assocs combinators fry kernel lexer macros math.parser -namespaces parser sequences splitting vectors vocabs.parser locals -io.encodings.ascii io.encodings.string ; +USING: accessors alien alien.c-types alien.complex alien.parser +alien.strings alien.structs alien.syntax arrays ascii assocs +byte-arrays combinators combinators.short-circuit fry generalizations +kernel lexer macros math math.parser namespaces parser sequences +splitting stack-checker vectors vocabs.parser words locals +io.encodings.ascii io.encodings.string shuffle effects math.ranges +math.order sorting ; IN: alien.fortran ! XXX this currently only supports the gfortran/f2c abi. @@ -18,6 +21,8 @@ IN: alien.fortran ERROR: invalid-fortran-type type ; DEFER: fortran-sig>c-sig +DEFER: fortran-ret-type>c-type +DEFER: fortran-arg-type>c-type c-type) M: double-precision-type (fortran-type>c-type) "double" simple-type ; M: double-complex-type (fortran-type>c-type) - "(fortran-double-complex)" simple-type ; + "complex-double" simple-type ; M: misc-type (fortran-type>c-type) dup name>> simple-type ; @@ -118,7 +123,7 @@ M: character-type (fortran-type>c-type) : (parse-fortran-type) ( fortran-type-string -- type ) parse-out swap parse-dims swap parse-size swap dup >lower fortran>c-types at* - [ nip new-fortran-type ] [ drop f misc-type boa ] if ; + [ nip new-fortran-type ] [ drop misc-type boa ] if ; : parse-fortran-type ( fortran-type-string/f -- type/f ) dup [ (parse-fortran-type) ] when ; @@ -149,40 +154,49 @@ M: real-type (fortran-ret-type>c-type) drop "double" ; GENERIC: (fortran-arg>c-args) ( type -- main-quot added-quot ) +: args?dims ( type quot -- main-quot added-quot ) + [ dup dims>> [ drop [ ] [ drop ] ] ] dip if ; inline + M: integer-type (fortran-arg>c-args) - size>> { - { f [ [ ] [ drop ] ] } - { 1 [ [ ] [ drop ] ] } - { 2 [ [ ] [ drop ] ] } - { 4 [ [ ] [ drop ] ] } - { 8 [ [ ] [ drop ] ] } - [ invalid-fortran-type ] - } case ; + [ + size>> { + { f [ [ ] [ drop ] ] } + { 1 [ [ ] [ drop ] ] } + { 2 [ [ ] [ drop ] ] } + { 4 [ [ ] [ drop ] ] } + { 8 [ [ ] [ drop ] ] } + [ invalid-fortran-type ] + } case + ] args?dims ; M: logical-type (fortran-arg>c-args) - call-next-method [ [ 1 0 ? ] prepend ] dip ; + [ call-next-method [ [ 1 0 ? ] prepend ] dip ] args?dims ; M: real-type (fortran-arg>c-args) - size>> { - { f [ [ ] [ drop ] ] } - { 4 [ [ ] [ drop ] ] } - { 8 [ [ ] [ drop ] ] } - [ invalid-fortran-type ] - } case ; + [ + size>> { + { f [ [ ] [ drop ] ] } + { 4 [ [ ] [ drop ] ] } + { 8 [ [ ] [ drop ] ] } + [ invalid-fortran-type ] + } case + ] args?dims ; M: real-complex-type (fortran-arg>c-args) - size>> { - { f [ [ ] [ drop ] ] } - { 8 [ [ ] [ drop ] ] } - { 16 [ [ ] [ drop ] ] } - [ invalid-fortran-type ] - } case ; + [ + size>> { + { f [ [ ] [ drop ] ] } + { 8 [ [ ] [ drop ] ] } + { 16 [ [ ] [ drop ] ] } + [ invalid-fortran-type ] + } case + ] args?dims ; M: double-precision-type (fortran-arg>c-args) - drop [ ] [ drop ] ; + [ drop [ ] [ drop ] ] args?dims ; M: double-complex-type (fortran-arg>c-args) - drop [ ] [ drop ] ; + [ drop [ ] [ drop ] ] args?dims ; M: character-type (fortran-arg>c-args) drop [ ascii string>alien ] [ length ] ; @@ -190,72 +204,122 @@ M: character-type (fortran-arg>c-args) M: misc-type (fortran-arg>c-args) drop [ ] [ drop ] ; -GENERIC: (fortran-result>) ( type -- quot ) +GENERIC: (fortran-result>) ( type -- quots ) + +: result?dims ( type quot -- quot ) + [ dup dims>> [ drop { [ ] } ] ] dip if ; inline M: integer-type (fortran-result>) - size>> { - { f [ [ *int ] ] } - { 1 [ [ *char ] ] } - { 2 [ [ *short ] ] } - { 4 [ [ *int ] ] } - { 8 [ [ *longlong ] ] } + [ size>> { + { f [ { [ *int ] } ] } + { 1 [ { [ *char ] } ] } + { 2 [ { [ *short ] } ] } + { 4 [ { [ *int ] } ] } + { 8 [ { [ *longlong ] } ] } [ invalid-fortran-type ] - } case ; + } case ] result?dims ; M: logical-type (fortran-result>) - call-next-method [ zero? not ] append ; + [ call-next-method first [ zero? not ] append 1array ] result?dims ; M: real-type (fortran-result>) - size>> { - { f [ [ *float ] ] } - { 4 [ [ *float ] ] } - { 8 [ [ *double ] ] } + [ size>> { + { f [ { [ *float ] } ] } + { 4 [ { [ *float ] } ] } + { 8 [ { [ *double ] } ] } [ invalid-fortran-type ] - } case ; + } case ] result?dims ; M: real-complex-type (fortran-result>) - size>> { - { f [ [ *complex-float ] ] } - { 8 [ [ *complex-float ] ] } - { 16 [ [ *complex-double ] ] } + [ size>> { + { f [ { [ *complex-float ] } ] } + { 8 [ { [ *complex-float ] } ] } + { 16 [ { [ *complex-double ] } ] } [ invalid-fortran-type ] - } case ; + } case ] result?dims ; M: double-precision-type (fortran-result>) - drop [ *double ] ; + [ drop { [ *double ] } ] result?dims ; M: double-complex-type (fortran-result>) - drop [ *complex-double ] ; + [ drop { [ *complex-double ] } ] result?dims ; M: character-type (fortran-result>) - drop [ ascii alien>nstring ] ; + drop { [ ] [ ascii alien>nstring ] } ; M: misc-type (fortran-result>) - drop [ ] ; + drop { [ ] } ; GENERIC: () ( type -- quot ) M: fortran-type () - (fortran-type>c-type) '[ _ ] ; + (fortran-type>c-type) \ [ ] 2sequence ; + +M: character-type () + fix-character-type dims>> product dup + [ \ ] dip [ ] 3sequence ; : [] ( return parameters -- quot ) [ parse-fortran-type ] dip over returns-by-value? [ 2drop [ ] ] - [ [ () ] [ '[ _ _ ndip ] ] bi* ] if ; + [ [ () ] [ length \ ndip [ ] 3sequence ] bi* ] if ; : [fortran-args>c-args] ( parameters -- quot ) - [ parse-fortran-type (fortran-arg>c-args) 2array ] map flip first2 - [ [ '[ _ spread ] ] bi@ 2array ] [ length ] bi - '[ _ _ ncleave ] ; + [ [ ] ] [ + [ parse-fortran-type (fortran-arg>c-args) 2array ] map flip first2 + [ [ \ spread [ ] 2sequence ] bi@ 2array ] [ length ] bi + \ ncleave [ ] 3sequence + ] if-empty ; -:: [fortran-invoke] ( return library function parameters -- quot ) +:: [fortran-invoke] ( [args>args] return library function parameters -- [args>args] quot ) return parameters fortran-sig>c-sig :> c-parameters :> c-return function fortran-name>symbol-name :> c-function - [ c-return library c-function c-parameters alien-invoke ] ; + [args>args] + c-return library c-function c-parameters \ alien-invoke + 5 [ ] nsequence + c-parameters length \ nkeep + [ ] 3sequence ; + +: [fortran-out-param>] ( parameter -- quot ) + parse-fortran-type + [ (fortran-result>) ] [ out?>> ] bi + [ ] [ [ drop [ drop ] ] map ] if ; + +: [fortran-return>] ( return -- quot ) + parse-fortran-type { + { [ dup not ] [ drop { } ] } + { [ dup returns-by-value? ] [ drop { [ ] } ] } + [ (fortran-result>) ] + } cond ; + +: letters ( -- seq ) CHAR: a CHAR: z [a,b] ; + +: (shuffle-map) ( return parameters -- ret par ) + [ + fortran-ret-type>c-type length swap "void" = [ 1+ ] unless + letters swap head [ "ret" swap suffix ] map + ] [ + [ fortran-arg-type>c-type nip length 1+ ] map letters swap zip + [ first2 letters swap head [ "" 2sequence ] with map ] map concat + ] bi* ; + +: (fortran-in-shuffle) ( ret par -- seq ) + [ [ second ] bi@ <=> ] sort append ; + +: (fortran-out-shuffle) ( ret par -- seq ) + append ; + +: [fortran-result-shuffle] ( return parameters -- quot ) + (shuffle-map) [ (fortran-in-shuffle) ] [ (fortran-out-shuffle) ] 2bi + \ shuffle-effect [ ] 2sequence ; : [fortran-results>] ( return parameters -- quot ) - 2drop [ ] ; + [ [fortran-result-shuffle] ] + [ drop [fortran-return>] ] + [ nip [ [fortran-out-param>] ] map concat ] 2tri + append + \ spread [ ] 2sequence append ; PRIVATE> @@ -289,22 +353,26 @@ PRIVATE> : RECORD: scan in get parse-definition define-fortran-record ; parsing -MACRO: fortran-invoke ( return library function parameters -- ) +: (fortran-invoke) ( return library function parameters -- quot ) { [ 2nip [] ] [ nip nip nip [fortran-args>c-args] ] [ [fortran-invoke] ] [ 2nip [fortran-results>] ] - } 4 ncleave 3append ; + } 4 ncleave 4 nappend ; + +MACRO: fortran-invoke ( return library function parameters -- ) + (fortran-invoke) ; :: define-fortran-function ( return library function parameters -- ) function create-in dup reset-generic return library function parameters return parse-arglist - [ '[ _ _ _ _ fortran-invoke ] ] dip define-declared ; + [ \ fortran-invoke 5 [ ] nsequence ] dip define-declared ; : SUBROUTINE: f "c-library" get scan ";" parse-tokens [ "()" subseq? not ] filter define-fortran-function ; parsing + : FUNCTION: scan "c-library" get scan ";" parse-tokens [ "()" subseq? not ] filter define-fortran-function ; parsing From 0522f63e5fe9154bbfada242e65f14f262650c9e Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 14:20:29 -0600 Subject: [PATCH 13/38] alien.fortran metadata --- basis/alien/fortran/authors.txt | 1 + basis/alien/fortran/summary.txt | 1 + basis/alien/fortran/tags.txt | 2 ++ 3 files changed, 4 insertions(+) create mode 100644 basis/alien/fortran/authors.txt create mode 100644 basis/alien/fortran/summary.txt create mode 100644 basis/alien/fortran/tags.txt diff --git a/basis/alien/fortran/authors.txt b/basis/alien/fortran/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/basis/alien/fortran/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/basis/alien/fortran/summary.txt b/basis/alien/fortran/summary.txt new file mode 100644 index 0000000000..8ed8b0ca00 --- /dev/null +++ b/basis/alien/fortran/summary.txt @@ -0,0 +1 @@ +GNU Fortran/G77/F2C alien interface diff --git a/basis/alien/fortran/tags.txt b/basis/alien/fortran/tags.txt new file mode 100644 index 0000000000..2a9b5def7a --- /dev/null +++ b/basis/alien/fortran/tags.txt @@ -0,0 +1,2 @@ +fortran +ffi From 3b83d9f760304b55617f7664db5d795fdcce34dc Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 14:20:52 -0600 Subject: [PATCH 14/38] fortran ffi for blas --- basis/math/blas/ffi/authors.txt | 1 + basis/math/blas/ffi/ffi.factor | 528 ++++++++++++++++++++++++++++++++ basis/math/blas/ffi/summary.txt | 1 + basis/math/blas/ffi/tags.txt | 3 + 4 files changed, 533 insertions(+) create mode 100644 basis/math/blas/ffi/authors.txt create mode 100644 basis/math/blas/ffi/ffi.factor create mode 100644 basis/math/blas/ffi/summary.txt create mode 100644 basis/math/blas/ffi/tags.txt diff --git a/basis/math/blas/ffi/authors.txt b/basis/math/blas/ffi/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/basis/math/blas/ffi/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/basis/math/blas/ffi/ffi.factor b/basis/math/blas/ffi/ffi.factor new file mode 100644 index 0000000000..7b0138357a --- /dev/null +++ b/basis/math/blas/ffi/ffi.factor @@ -0,0 +1,528 @@ +USING: alien alien.fortran kernel system combinators ; +IN: math.blas.ffi + +<< +"blas" { + { [ os macosx? ] [ "libblas.dylib" "cdecl" add-library ] } + { [ os windows? ] [ "blas.dll" "cdecl" add-library ] } + [ "libblas.so" "cdecl" add-library ] +} cond +>> + +LIBRARY: blas + +! Level 1 BLAS (scalar-vector and vector-vector) + +FUNCTION: REAL SDSDOT + ( INTEGER N, REAL ALPHA, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ; +FUNCTION: DOUBLE-PRECISION DSDOT + ( INTEGER N, DOUBLE-PRECISION-PRECISION(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ; +FUNCTION: REAL SDOT + ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ; +FUNCTION: DOUBLE-PRECISION DDOT + ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ; + +FUNCTION: COMPLEX CDOTU + ( INTEGER N, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ; +FUNCTION: COMPLEX CDOTC + ( INTEGER N, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ; + +SUBROUTINE: DOUBLE-COMPLEX ZDOTU + ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: DOUBLE-COMPLEX ZDOTC + ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; + +FUNCTION: REAL SNRM2 + ( INTEGER N, REAL(*) X, INTEGER INCX ) ; +FUNCTION: REAL SASUM + ( INTEGER N, REAL(*) X, INTEGER INCX ) ; + +FUNCTION: DOUBLE-PRECISION DNRM2 + ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX ) ; +FUNCTION: DOUBLE-PRECISION DASUM + ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX ) ; + +FUNCTION: REAL SCNRM2 + ( INTEGER N, COMPLEX(*) X, INTEGER INCX ) ; +FUNCTION: REAL SCASUM + ( INTEGER N, COMPLEX(*) X, INTEGER INCX ) ; + +FUNCTION: DOUBLE-PRECISION DZNRM2 + ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ; +FUNCTION: DOUBLE-PRECISION DZASUM + ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ; + +FUNCTION: INTEGER ISAMAX + ( INTEGER N, REAL(*) X, INTEGER INCX ) ; +FUNCTION: INTEGER IDAMAX + ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX ) ; +FUNCTION: INTEGER ICAMAX + ( INTEGER N, COMPLEX(*) X, INTEGER INCX ) ; +FUNCTION: INTEGER IZAMAX + ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ; + +SUBROUTINE: SSWAP + ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ; +SUBROUTINE: SCOPY + ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ; +SUBROUTINE: SAXPY + ( INTEGER N, REAL ALPHA, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ; + +SUBROUTINE: DSWAP + ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ; +SUBROUTINE: DCOPY + ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ; +SUBROUTINE: DAXPY + ( INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ; + +SUBROUTINE: CSWAP + ( INTEGER N, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: CCOPY + ( INTEGER N, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: CAXPY + ( INTEGER N, COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ; + +SUBROUTINE: ZSWAP + ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: ZCOPY + ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: ZAXPY + ( INTEGER N, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; + +SUBROUTINE: SSCAL + ( INTEGER N, REAL ALPHA, REAL(*) X, INTEGER INCX ) ; +SUBROUTINE: DSCAL + ( INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X, INTEGER INCX ) ; +SUBROUTINE: CSCAL + ( INTEGER N, COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: ZSCAL + ( INTEGER N, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: CSSCAL + ( INTEGER N, REAL ALPHA, COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: ZDSCAL + ( INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ; + +SUBROUTINE: SROTG + ( REAL(*) A, REAL(*) B, REAL(*) C, REAL(*) S ) ; +SUBROUTINE: SROTMG + ( REAL(*) D1, REAL(*) D2, REAL(*) B1, REAL B2, REAL(*) P ) ; +SUBROUTINE: SROT + ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY, REAL C, REAL S ) ; +SUBROUTINE: SROTM + ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY, REAL(*) P ) ; + +SUBROUTINE: DROTG + ( DOUBLE-PRECISION(*) A, DOUBLE-PRECISION(*) B, DOUBLE-PRECISION(*) C, DOUBLE-PRECISION(*) S ) ; +SUBROUTINE: DROTMG + ( DOUBLE-PRECISION(*) D1, DOUBLE-PRECISION(*) D2, DOUBLE-PRECISION(*) B1, DOUBLE-PRECISION B2, DOUBLE-PRECISION(*) P ) ; +SUBROUTINE: DROT + ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION C, DOUBLE-PRECISION S ) ; +SUBROUTINE: DROTM + ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION(*) P ) ; + +! LEVEL 2 BLAS (MATRIX-VECTOR) + +SUBROUTINE: SGEMV ( CHARACTER*1 ORDER, + CHARACTER*1 TRANSA, INTEGER M, INTEGER N, + REAL ALPHA, REAL(*) A, INTEGER LDA, + REAL(*) X, INTEGER INCX, REAL BETA, + REAL(*) Y, INTEGER INCY ) ; +SUBROUTINE: SGBMV ( CHARACTER*1 ORDER, + CHARACTER*1 TRANSA, INTEGER M, INTEGER N, + INTEGER KL, INTEGER KU, REAL ALPHA, + REAL(*) A, INTEGER LDA, REAL(*) X, + INTEGER INCX, REAL BETA, REAL(*) Y, INTEGER INCY ) ; +SUBROUTINE: STRMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, REAL(*) A, INTEGER LDA, + REAL(*) X, INTEGER INCX ) ; +SUBROUTINE: STBMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, INTEGER K, REAL(*) A, INTEGER LDA, + REAL(*) X, INTEGER INCX ) ; +SUBROUTINE: STPMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, REAL(*) AP, REAL(*) X, INTEGER INCX ) ; +SUBROUTINE: STRSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, REAL(*) A, INTEGER LDA, REAL(*) X, + INTEGER INCX ) ; +SUBROUTINE: STBSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, INTEGER K, REAL(*) A, INTEGER LDA, + REAL(*) X, INTEGER INCX ) ; +SUBROUTINE: STPSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, REAL(*) AP, REAL(*) X, INTEGER INCX ) ; + +SUBROUTINE: DGEMV ( CHARACTER*1 ORDER, + CHARACTER*1 TRANSA, INTEGER M, INTEGER N, + DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA, + DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION BETA, + DOUBLE-PRECISION(*) Y, INTEGER INCY ) ; +SUBROUTINE: DGBMV ( CHARACTER*1 ORDER, + CHARACTER*1 TRANSA, INTEGER M, INTEGER N, + INTEGER KL, INTEGER KU, DOUBLE-PRECISION ALPHA, + DOUBLE-PRECISION(*) A, INTEGER LDA, DOUBLE-PRECISION(*) X, + INTEGER INCX, DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ; +SUBROUTINE: DTRMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, DOUBLE-PRECISION(*) A, INTEGER LDA, + DOUBLE-PRECISION(*) X, INTEGER INCX ) ; +SUBROUTINE: DTBMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, INTEGER K, DOUBLE-PRECISION(*) A, INTEGER LDA, + DOUBLE-PRECISION(*) X, INTEGER INCX ) ; +SUBROUTINE: DTPMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, DOUBLE-PRECISION(*) AP, DOUBLE-PRECISION(*) X, INTEGER INCX ) ; +SUBROUTINE: DTRSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, DOUBLE-PRECISION(*) A, INTEGER LDA, DOUBLE-PRECISION(*) X, + INTEGER INCX ) ; +SUBROUTINE: DTBSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, INTEGER K, DOUBLE-PRECISION(*) A, INTEGER LDA, + DOUBLE-PRECISION(*) X, INTEGER INCX ) ; +SUBROUTINE: DTPSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, DOUBLE-PRECISION(*) AP, DOUBLE-PRECISION(*) X, INTEGER INCX ) ; + +SUBROUTINE: CGEMV ( CHARACTER*1 ORDER, + CHARACTER*1 TRANSA, INTEGER M, INTEGER N, + COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA, + COMPLEX(*) X, INTEGER INCX, COMPLEX BETA, + COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: CGBMV ( CHARACTER*1 ORDER, + CHARACTER*1 TRANSA, INTEGER M, INTEGER N, + INTEGER KL, INTEGER KU, COMPLEX ALPHA, + COMPLEX(*) A, INTEGER LDA, COMPLEX(*) X, + INTEGER INCX, COMPLEX BETA, COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: CTRMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, COMPLEX(*) A, INTEGER LDA, + COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: CTBMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, INTEGER K, COMPLEX(*) A, INTEGER LDA, + COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: CTPMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, COMPLEX(*) AP, COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: CTRSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, COMPLEX(*) A, INTEGER LDA, COMPLEX(*) X, + INTEGER INCX ) ; +SUBROUTINE: CTBSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, INTEGER K, COMPLEX(*) A, INTEGER LDA, + COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: CTPSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, COMPLEX(*) AP, COMPLEX(*) X, INTEGER INCX ) ; + +SUBROUTINE: ZGEMV ( CHARACTER*1 ORDER, + CHARACTER*1 TRANSA, INTEGER M, INTEGER N, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX BETA, + DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: ZGBMV ( CHARACTER*1 ORDER, + CHARACTER*1 TRANSA, INTEGER M, INTEGER N, + INTEGER KL, INTEGER KU, DOUBLE-COMPLEX ALPHA, + DOUBLE-COMPLEX(*) A, INTEGER LDA, DOUBLE-COMPLEX(*) X, + INTEGER INCX, DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: ZTRMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: ZTBMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, INTEGER K, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: ZTPMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, DOUBLE-COMPLEX(*) AP, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: ZTRSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, DOUBLE-COMPLEX(*) A, INTEGER LDA, DOUBLE-COMPLEX(*) X, + INTEGER INCX ) ; +SUBROUTINE: ZTBSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, INTEGER K, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: ZTPSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, DOUBLE-COMPLEX(*) AP, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ; + + +SUBROUTINE: SSYMV ( CHARACTER*1 UPLO, + INTEGER N, REAL ALPHA, REAL(*) A, + INTEGER LDA, REAL(*) X, INTEGER INCX, + REAL BETA, REAL(*) Y, INTEGER INCY ) ; +SUBROUTINE: SSBMV ( CHARACTER*1 UPLO, + INTEGER N, INTEGER K, REAL ALPHA, REAL(*) A, + INTEGER LDA, REAL(*) X, INTEGER INCX, + REAL BETA, REAL(*) Y, INTEGER INCY ) ; +SUBROUTINE: SSPMV ( CHARACTER*1 UPLO, + INTEGER N, REAL ALPHA, REAL(*) AP, + REAL(*) X, INTEGER INCX, + REAL BETA, REAL(*) Y, INTEGER INCY ) ; +SUBROUTINE: SGER ( INTEGER M, INTEGER N, + REAL ALPHA, REAL(*) X, INTEGER INCX, + REAL(*) Y, INTEGER INCY, REAL(*) A, INTEGER LDA ) ; +SUBROUTINE: SSYR ( CHARACTER*1 UPLO, + INTEGER N, REAL ALPHA, REAL(*) X, + INTEGER INCX, REAL(*) A, INTEGER LDA ) ; +SUBROUTINE: SSPR ( CHARACTER*1 UPLO, + INTEGER N, REAL ALPHA, REAL(*) X, + INTEGER INCX, REAL(*) AP ) ; +SUBROUTINE: SSYR2 ( CHARACTER*1 UPLO, + INTEGER N, REAL ALPHA, REAL(*) X, + INTEGER INCX, REAL(*) Y, INTEGER INCY, REAL(*) A, + INTEGER LDA ) ; +SUBROUTINE: SSPR2 ( CHARACTER*1 UPLO, + INTEGER N, REAL ALPHA, REAL(*) X, + INTEGER INCX, REAL(*) Y, INTEGER INCY, REAL(*) A ) ; + +SUBROUTINE: DSYMV ( CHARACTER*1 UPLO, + INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, + INTEGER LDA, DOUBLE-PRECISION(*) X, INTEGER INCX, + DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ; +SUBROUTINE: DSBMV ( CHARACTER*1 UPLO, + INTEGER N, INTEGER K, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, + INTEGER LDA, DOUBLE-PRECISION(*) X, INTEGER INCX, + DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ; +SUBROUTINE: DSPMV ( CHARACTER*1 UPLO, + INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) AP, + DOUBLE-PRECISION(*) X, INTEGER INCX, + DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ; +SUBROUTINE: DGER ( INTEGER M, INTEGER N, + DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X, INTEGER INCX, + DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION(*) A, INTEGER LDA ) ; +SUBROUTINE: DSYR ( CHARACTER*1 UPLO, + INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X, + INTEGER INCX, DOUBLE-PRECISION(*) A, INTEGER LDA ) ; +SUBROUTINE: DSPR ( CHARACTER*1 UPLO, + INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X, + INTEGER INCX, DOUBLE-PRECISION(*) AP ) ; +SUBROUTINE: DSYR2 ( CHARACTER*1 UPLO, + INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X, + INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION(*) A, + INTEGER LDA ) ; +SUBROUTINE: DSPR2 ( CHARACTER*1 UPLO, + INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X, + INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION(*) A ) ; + + +SUBROUTINE: CHEMV ( CHARACTER*1 UPLO, + INTEGER N, COMPLEX ALPHA, COMPLEX(*) A, + INTEGER LDA, COMPLEX(*) X, INTEGER INCX, + COMPLEX BETA, COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: CHBMV ( CHARACTER*1 UPLO, + INTEGER N, INTEGER K, COMPLEX ALPHA, COMPLEX(*) A, + INTEGER LDA, COMPLEX(*) X, INTEGER INCX, + COMPLEX BETA, COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: CHPMV ( CHARACTER*1 UPLO, + INTEGER N, COMPLEX ALPHA, COMPLEX(*) AP, + COMPLEX(*) X, INTEGER INCX, + COMPLEX BETA, COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: CGERU ( INTEGER M, INTEGER N, + COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX, + COMPLEX(*) Y, INTEGER INCY, COMPLEX(*) A, INTEGER LDA ) ; +SUBROUTINE: CGERC ( INTEGER M, INTEGER N, + COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX, + COMPLEX(*) Y, INTEGER INCY, COMPLEX(*) A, INTEGER LDA ) ; +SUBROUTINE: CHER ( CHARACTER*1 UPLO, + INTEGER N, REAL ALPHA, COMPLEX(*) X, INTEGER INCX, + COMPLEX(*) A, INTEGER LDA ) ; +SUBROUTINE: CHPR ( CHARACTER*1 UPLO, + INTEGER N, REAL ALPHA, COMPLEX(*) X, + INTEGER INCX, COMPLEX(*) A ) ; +SUBROUTINE: CHER2 ( CHARACTER*1 UPLO, INTEGER N, + COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX, + COMPLEX(*) Y, INTEGER INCY, COMPLEX(*) A, INTEGER LDA ) ; +SUBROUTINE: CHPR2 ( CHARACTER*1 UPLO, INTEGER N, + COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX, + COMPLEX(*) Y, INTEGER INCY, COMPLEX(*) AP ) ; + +SUBROUTINE: ZHEMV ( CHARACTER*1 UPLO, + INTEGER N, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, + INTEGER LDA, DOUBLE-COMPLEX(*) X, INTEGER INCX, + DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: ZHBMV ( CHARACTER*1 UPLO, + INTEGER N, INTEGER K, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, + INTEGER LDA, DOUBLE-COMPLEX(*) X, INTEGER INCX, + DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: ZHPMV ( CHARACTER*1 UPLO, + INTEGER N, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) AP, + DOUBLE-COMPLEX(*) X, INTEGER INCX, + DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: ZGERU ( INTEGER M, INTEGER N, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX, + DOUBLE-COMPLEX(*) Y, INTEGER INCY, DOUBLE-COMPLEX(*) A, INTEGER LDA ) ; +SUBROUTINE: ZGERC ( INTEGER M, INTEGER N, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX, + DOUBLE-COMPLEX(*) Y, INTEGER INCY, DOUBLE-COMPLEX(*) A, INTEGER LDA ) ; +SUBROUTINE: ZHER ( CHARACTER*1 UPLO, + INTEGER N, REAL ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX, + DOUBLE-COMPLEX(*) A, INTEGER LDA ) ; +SUBROUTINE: ZHPR ( CHARACTER*1 UPLO, + INTEGER N, REAL ALPHA, DOUBLE-COMPLEX(*) X, + INTEGER INCX, DOUBLE-COMPLEX(*) A ) ; +SUBROUTINE: ZHER2 ( CHARACTER*1 UPLO, INTEGER N, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX, + DOUBLE-COMPLEX(*) Y, INTEGER INCY, DOUBLE-COMPLEX(*) A, INTEGER LDA ) ; +SUBROUTINE: ZHPR2 ( CHARACTER*1 UPLO, INTEGER N, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX, + DOUBLE-COMPLEX(*) Y, INTEGER INCY, DOUBLE-COMPLEX(*) AP ) ; + +! LEVEL 3 BLAS (MATRIX-MATRIX) + +SUBROUTINE: SGEMM ( CHARACTER*1 TRANSA, + CHARACTER*1 TRANSB, INTEGER M, INTEGER N, + INTEGER K, REAL ALPHA, REAL(*) A, + INTEGER LDA, REAL(*) B, INTEGER LDB, + REAL BETA, REAL(*) C, INTEGER LDC ) ; +SUBROUTINE: SSYMM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, INTEGER M, INTEGER N, + REAL ALPHA, REAL(*) A, INTEGER LDA, + REAL(*) B, INTEGER LDB, REAL BETA, + REAL(*) C, INTEGER LDC ) ; +SUBROUTINE: SSYRK ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + REAL ALPHA, REAL(*) A, INTEGER LDA, + REAL BETA, REAL(*) C, INTEGER LDC ) ; +SUBROUTINE: SSYR2K ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + REAL ALPHA, REAL(*) A, INTEGER LDA, + REAL(*) B, INTEGER LDB, REAL BETA, + REAL(*) C, INTEGER LDC ) ; +SUBROUTINE: STRMM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, CHARACTER*1 TRANSA, + CHARACTER*1 DIAG, INTEGER M, INTEGER N, + REAL ALPHA, REAL(*) A, INTEGER LDA, + REAL(*) B, INTEGER LDB ) ; +SUBROUTINE: STRSM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, CHARACTER*1 TRANSA, + CHARACTER*1 DIAG, INTEGER M, INTEGER N, + REAL ALPHA, REAL(*) A, INTEGER LDA, + REAL(*) B, INTEGER LDB ) ; + +SUBROUTINE: DGEMM ( CHARACTER*1 TRANSA, + CHARACTER*1 TRANSB, INTEGER M, INTEGER N, + INTEGER K, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, + INTEGER LDA, DOUBLE-PRECISION(*) B, INTEGER LDB, + DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) C, INTEGER LDC ) ; +SUBROUTINE: DSYMM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, INTEGER M, INTEGER N, + DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA, + DOUBLE-PRECISION(*) B, INTEGER LDB, DOUBLE-PRECISION BETA, + DOUBLE-PRECISION(*) C, INTEGER LDC ) ; +SUBROUTINE: DSYRK ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA, + DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) C, INTEGER LDC ) ; +SUBROUTINE: DSYR2K ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA, + DOUBLE-PRECISION(*) B, INTEGER LDB, DOUBLE-PRECISION BETA, + DOUBLE-PRECISION(*) C, INTEGER LDC ) ; +SUBROUTINE: DTRMM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, CHARACTER*1 TRANSA, + CHARACTER*1 DIAG, INTEGER M, INTEGER N, + DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA, + DOUBLE-PRECISION(*) B, INTEGER LDB ) ; +SUBROUTINE: DTRSM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, CHARACTER*1 TRANSA, + CHARACTER*1 DIAG, INTEGER M, INTEGER N, + DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA, + DOUBLE-PRECISION(*) B, INTEGER LDB ) ; + +SUBROUTINE: CGEMM ( CHARACTER*1 TRANSA, + CHARACTER*1 TRANSB, INTEGER M, INTEGER N, + INTEGER K, COMPLEX ALPHA, COMPLEX(*) A, + INTEGER LDA, COMPLEX(*) B, INTEGER LDB, + COMPLEX BETA, COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: CSYMM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, INTEGER M, INTEGER N, + COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA, + COMPLEX(*) B, INTEGER LDB, COMPLEX BETA, + COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: CSYRK ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA, + COMPLEX BETA, COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: CSYR2K ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA, + COMPLEX(*) B, INTEGER LDB, COMPLEX BETA, + COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: CTRMM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, CHARACTER*1 TRANSA, + CHARACTER*1 DIAG, INTEGER M, INTEGER N, + COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA, + COMPLEX(*) B, INTEGER LDB ) ; +SUBROUTINE: CTRSM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, CHARACTER*1 TRANSA, + CHARACTER*1 DIAG, INTEGER M, INTEGER N, + COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA, + COMPLEX(*) B, INTEGER LDB ) ; + +SUBROUTINE: ZGEMM ( CHARACTER*1 TRANSA, + CHARACTER*1 TRANSB, INTEGER M, INTEGER N, + INTEGER K, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, + INTEGER LDA, DOUBLE-COMPLEX(*) B, INTEGER LDB, + DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: ZSYMM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, INTEGER M, INTEGER N, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX(*) B, INTEGER LDB, DOUBLE-COMPLEX BETA, + DOUBLE-COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: ZSYRK ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: ZSYR2K ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX(*) B, INTEGER LDB, DOUBLE-COMPLEX BETA, + DOUBLE-COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: ZTRMM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, CHARACTER*1 TRANSA, + CHARACTER*1 DIAG, INTEGER M, INTEGER N, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX(*) B, INTEGER LDB ) ; +SUBROUTINE: ZTRSM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, CHARACTER*1 TRANSA, + CHARACTER*1 DIAG, INTEGER M, INTEGER N, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX(*) B, INTEGER LDB ) ; + +SUBROUTINE: CHEMM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, INTEGER M, INTEGER N, + COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA, + COMPLEX(*) B, INTEGER LDB, COMPLEX BETA, + COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: CHERK ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + REAL ALPHA, COMPLEX(*) A, INTEGER LDA, + REAL BETA, COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: CHER2K ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA, + COMPLEX(*) B, INTEGER LDB, REAL BETA, + COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: ZHEMM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, INTEGER M, INTEGER N, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX(*) B, INTEGER LDB, DOUBLE-COMPLEX BETA, + DOUBLE-COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: ZHERK ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + REAL ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA, + REAL BETA, DOUBLE-COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: ZHER2K ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX(*) B, INTEGER LDB, REAL BETA, + DOUBLE-COMPLEX(*) C, INTEGER LDC ) ; diff --git a/basis/math/blas/ffi/summary.txt b/basis/math/blas/ffi/summary.txt new file mode 100644 index 0000000000..8c0106b173 --- /dev/null +++ b/basis/math/blas/ffi/summary.txt @@ -0,0 +1 @@ +Low-level bindings to the Basic Linear Algebra Subroutines (BLAS) library diff --git a/basis/math/blas/ffi/tags.txt b/basis/math/blas/ffi/tags.txt new file mode 100644 index 0000000000..f468a9989d --- /dev/null +++ b/basis/math/blas/ffi/tags.txt @@ -0,0 +1,3 @@ +math +bindings +fortran From 42265cbc62fbb50ee8b8a201603fb78624678160 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 14:35:44 -0600 Subject: [PATCH 15/38] start hacking on math.blas.vectors to switch to fortran --- basis/alien/fortran/fortran.factor | 10 ++++++++++ basis/math/blas/vectors/vectors.factor | 25 +++++++++++++------------ 2 files changed, 23 insertions(+), 12 deletions(-) diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index 85fa0e536e..00dd8583fc 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -11,6 +11,14 @@ IN: alien.fortran ! XXX this currently only supports the gfortran/f2c abi. ! XXX we should also support ifort at some point for commercial BLASes +<< +: add-f2c-libraries ( -- ) + "I77" "libI77.so" "cdecl" add-library + "F77" "libF77.so" "cdecl" add-library ; + +os netbsd? [ add-f2c-libraries ] when +>> + : alien>nstring ( alien len encoding -- string ) [ memory>byte-array ] dip decode ; @@ -377,3 +385,5 @@ MACRO: fortran-invoke ( return library function parameters -- ) scan "c-library" get scan ";" parse-tokens [ "()" subseq? not ] filter define-fortran-function ; parsing +: LIBRARY: + scan "c-library" set ; parsing diff --git a/basis/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor index 4e61f4478e..d111023456 100755 --- a/basis/math/blas/vectors/vectors.factor +++ b/basis/math/blas/vectors/vectors.factor @@ -1,10 +1,13 @@ USING: accessors alien alien.c-types arrays byte-arrays combinators -combinators.short-circuit fry kernel math math.blas.cblas +combinators.short-circuit fry kernel math math.blas.ffi math.complex math.functions math.order sequences.complex sequences.complex-components sequences sequences.private functors words locals parser prettyprint.backend prettyprint.custom specialized-arrays.float specialized-arrays.double -specialized-arrays.direct.float specialized-arrays.direct.double ; +specialized-arrays.direct.float specialized-arrays.direct.double +specialized-arrays.complex-float specialized-arrays.complex-double +specialized-arrays.direct.complex-float +specialized-arrays.direct.complex-double ; IN: math.blas.vectors TUPLE: blas-vector-base underlying length inc ; @@ -130,9 +133,9 @@ FUNCTOR: (define-blas-vector) ( TYPE T -- ) IS >ARRAY IS >${TYPE}-array -XCOPY IS cblas_${T}copy -XSWAP IS cblas_${T}swap -IXAMAX IS cblas_i${T}amax +XCOPY IS ${T}COPY +XSWAP IS ${T}SWAP +IXAMAX IS I${T}AMAX VECTOR DEFINES-CLASS ${TYPE}-blas-vector DEFINES <${TYPE}-blas-vector> @@ -264,16 +267,14 @@ M: VECTOR n*V! : define-real-blas-vector ( TYPE T -- ) [ (define-blas-vector) ] [ (define-real-blas-vector) ] 2bi ; -:: define-complex-blas-vector ( TYPE C S -- ) - TYPE (define-complex-helpers) - TYPE "-complex" append - [ C (define-blas-vector) ] - [ C S (define-complex-blas-vector) ] bi ; +: define-complex-blas-vector ( TYPE C S -- ) + [ drop (define-blas-vector) ] + [ (define-complex-blas-vector) ] 3bi ; "float" "s" define-real-blas-vector "double" "d" define-real-blas-vector -"float" "c" "s" define-complex-blas-vector -"double" "z" "d" define-complex-blas-vector +"complex-float" "c" "s" define-complex-blas-vector +"complex-double" "z" "d" define-complex-blas-vector >> From 32481f8e2f2909a50788532c58f8d9deff479ed9 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 15:01:41 -0600 Subject: [PATCH 16/38] my stuped, let me show u it --- basis/alien/complex/functor/functor.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/alien/complex/functor/functor.factor b/basis/alien/complex/functor/functor.factor index c6644eba1d..31af0291b4 100644 --- a/basis/alien/complex/functor/functor.factor +++ b/basis/alien/complex/functor/functor.factor @@ -28,8 +28,8 @@ T in get define-struct T c-type - 1quotation >>boxer-quot -*T 1quotation >>unboxer-quot + 1quotation >>unboxer-quot +*T 1quotation >>boxer-quot drop ;FUNCTOR From d24b03098a58526dc43c2cb11142498ef512ed84 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 15:11:27 -0600 Subject: [PATCH 17/38] specialized arrays for complex types --- basis/specialized-arrays/complex-double/complex-double.factor | 4 ++++ basis/specialized-arrays/complex-float/complex-float.factor | 4 ++++ .../direct/complex-double/complex-double.factor | 4 ++++ .../direct/complex-float/complex-float.factor | 4 ++++ 4 files changed, 16 insertions(+) create mode 100644 basis/specialized-arrays/complex-double/complex-double.factor create mode 100644 basis/specialized-arrays/complex-float/complex-float.factor create mode 100644 basis/specialized-arrays/direct/complex-double/complex-double.factor create mode 100644 basis/specialized-arrays/direct/complex-float/complex-float.factor diff --git a/basis/specialized-arrays/complex-double/complex-double.factor b/basis/specialized-arrays/complex-double/complex-double.factor new file mode 100644 index 0000000000..00b07fb9b3 --- /dev/null +++ b/basis/specialized-arrays/complex-double/complex-double.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-arrays.complex-double + +<< "complex-double" define-array >> diff --git a/basis/specialized-arrays/complex-float/complex-float.factor b/basis/specialized-arrays/complex-float/complex-float.factor new file mode 100644 index 0000000000..5348343bae --- /dev/null +++ b/basis/specialized-arrays/complex-float/complex-float.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-arrays.complex-float + +<< "complex-float" define-array >> diff --git a/basis/specialized-arrays/direct/complex-double/complex-double.factor b/basis/specialized-arrays/direct/complex-double/complex-double.factor new file mode 100644 index 0000000000..58af77b0c0 --- /dev/null +++ b/basis/specialized-arrays/direct/complex-double/complex-double.factor @@ -0,0 +1,4 @@ +USING: specialized-arrays.float specialized-arrays.direct.functor ; +IN: specialized-arrays.direct.complex-double + +<< "complex-double" define-direct-array >> diff --git a/basis/specialized-arrays/direct/complex-float/complex-float.factor b/basis/specialized-arrays/direct/complex-float/complex-float.factor new file mode 100644 index 0000000000..d881c1e0d4 --- /dev/null +++ b/basis/specialized-arrays/direct/complex-float/complex-float.factor @@ -0,0 +1,4 @@ +USING: specialized-arrays.float specialized-arrays.direct.functor ; +IN: specialized-arrays.direct.complex-float + +<< "complex-float" define-direct-array >> From db6706434d711e5313ca1618302a8f83c9c3d817 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 15:38:07 -0600 Subject: [PATCH 18/38] tweak specialized-arrays to box values returned by nth --- basis/alien/c-types/c-types.factor | 3 +++ basis/alien/structs/fields/fields.factor | 5 +---- basis/specialized-arrays/direct/functor/functor.factor | 2 +- basis/specialized-arrays/functor/functor.factor | 2 +- 4 files changed, 6 insertions(+), 6 deletions(-) diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 89b3572daf..a4bc3d3f52 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -185,6 +185,9 @@ M: f byte-length drop 0 ; [ "Cannot read struct fields with this type" throw ] ] unless* ; +: c-type-getter-boxer ( name -- quot ) + [ c-getter ] [ c-type-boxer-quot ] bi append ; + : c-setter ( name -- quot ) c-type-setter [ [ "Cannot write struct fields with this type" throw ] diff --git a/basis/alien/structs/fields/fields.factor b/basis/alien/structs/fields/fields.factor index f5537fa239..0477683442 100644 --- a/basis/alien/structs/fields/fields.factor +++ b/basis/alien/structs/fields/fields.factor @@ -58,10 +58,7 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ; : define-getter ( type spec -- ) [ set-reader-props ] keep [ reader>> ] - [ - type>> - [ c-getter ] [ c-type-boxer-quot ] bi append - ] + [ type>> c-type-getter-boxer ] [ ] tri (( c-ptr -- value )) define-struct-slot-word ; diff --git a/basis/specialized-arrays/direct/functor/functor.factor b/basis/specialized-arrays/direct/functor/functor.factor index 0c3999db44..e7e891fede 100755 --- a/basis/specialized-arrays/direct/functor/functor.factor +++ b/basis/specialized-arrays/direct/functor/functor.factor @@ -14,7 +14,7 @@ A' IS ${T}-array A DEFINES-CLASS direct-${T}-array DEFINES <${A}> -NTH [ T dup c-getter array-accessor ] +NTH [ T dup c-type-getter-boxer array-accessor ] SET-NTH [ T dup c-setter array-accessor ] WHERE diff --git a/basis/specialized-arrays/functor/functor.factor b/basis/specialized-arrays/functor/functor.factor index 3c2c53db31..09433a3b51 100644 --- a/basis/specialized-arrays/functor/functor.factor +++ b/basis/specialized-arrays/functor/functor.factor @@ -22,7 +22,7 @@ A DEFINES-CLASS ${T}-array byte-array>A DEFINES byte-array>${A} A{ DEFINES ${A}{ -NTH [ T dup c-getter array-accessor ] +NTH [ T dup c-type-getter-boxer array-accessor ] SET-NTH [ T dup c-setter array-accessor ] WHERE From 85620fc74118037dd35e908bd210e74ec03ea173 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 15:51:47 -0600 Subject: [PATCH 19/38] C CONVERT VECTORS TO USE FORTRAN BLAS BINDINGS C INSTEAD OF CBLAS --- basis/math/blas/vectors/vectors.factor | 83 ++++++++------------------ 1 file changed, 25 insertions(+), 58 deletions(-) diff --git a/basis/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor index d111023456..9a2f9a4350 100755 --- a/basis/math/blas/vectors/vectors.factor +++ b/basis/math/blas/vectors/vectors.factor @@ -1,4 +1,4 @@ -USING: accessors alien alien.c-types arrays byte-arrays combinators +USING: accessors alien alien.c-types arrays ascii byte-arrays combinators combinators.short-circuit fry kernel math math.blas.ffi math.complex math.functions math.order sequences.complex sequences.complex-components sequences sequences.private @@ -141,7 +141,12 @@ VECTOR DEFINES-CLASS ${TYPE}-blas-vector DEFINES <${TYPE}-blas-vector> >VECTOR DEFINES >${TYPE}-blas-vector -XVECTOR{ DEFINES ${T}vector{ +t [ T >lower ] + +XVECTOR{ DEFINES ${t}vector{ + +XAXPY IS ${T}AXPY +XSCAL IS ${T}SCAL WHERE @@ -170,6 +175,11 @@ M: VECTOR (blas-direct-array) [ [ length>> ] [ inc>> ] bi * ] bi ; +M: VECTOR n*V+V! + (prepare-axpy) [ XAXPY ] dip ; +M: VECTOR n*V! + (prepare-scal) [ XSCAL ] dip ; + : XVECTOR{ \ } [ >VECTOR ] parse-literal ; parsing M: VECTOR pprint-delims @@ -181,11 +191,9 @@ M: VECTOR pprint-delims FUNCTOR: (define-real-blas-vector) ( TYPE T -- ) VECTOR IS ${TYPE}-blas-vector -XDOT IS cblas_${T}dot -XNRM2 IS cblas_${T}nrm2 -XASUM IS cblas_${T}asum -XAXPY IS cblas_${T}axpy -XSCAL IS cblas_${T}scal +XDOT IS ${T}DOT +XNRM2 IS ${T}NRM2 +XASUM IS ${T}ASUM WHERE @@ -197,33 +205,6 @@ M: VECTOR Vnorm (prepare-nrm2) XNRM2 ; M: VECTOR Vasum (prepare-nrm2) XASUM ; -M: VECTOR n*V+V! - (prepare-axpy) [ XAXPY ] dip ; -M: VECTOR n*V! - (prepare-scal) [ XSCAL ] dip ; - -;FUNCTOR - - -FUNCTOR: (define-complex-helpers) ( TYPE -- ) - - DEFINES ->COMPLEX-ARRAY DEFINES >${TYPE}-complex-array -ARG>COMPLEX DEFINES arg>${TYPE}-complex -COMPLEX>ARG DEFINES ${TYPE}-complex>arg - IS ->ARRAY IS >${TYPE}-array - -WHERE - -: ( alien len -- sequence ) - 1 shift ; -: >COMPLEX-ARRAY ( sequence -- sequence ) - >ARRAY ; -: COMPLEX>ARG ( complex -- alien ) - >rect 2array >ARRAY underlying>> ; -: ARG>COMPLEX ( alien -- complex ) - 2 first2 rect> ; ;FUNCTOR @@ -231,35 +212,21 @@ WHERE FUNCTOR: (define-complex-blas-vector) ( TYPE C S -- ) VECTOR IS ${TYPE}-blas-vector -XDOTU_SUB IS cblas_${C}dotu_sub -XDOTC_SUB IS cblas_${C}dotc_sub -XXNRM2 IS cblas_${S}${C}nrm2 -XXASUM IS cblas_${S}${C}asum -XAXPY IS cblas_${C}axpy -XSCAL IS cblas_${C}scal -TYPE>ARG IS ${TYPE}>arg -ARG>TYPE IS arg>${TYPE} +XDOTU IS ${C}DOTU +XDOTC IS ${C}DOTC +XXNRM2 IS ${S}${C}NRM2 +XXASUM IS ${S}${C}ASUM WHERE M: VECTOR V. - (prepare-dot) TYPE - [ XDOTU_SUB ] keep - ARG>TYPE ; + (prepare-dot) XDOTU ; M: VECTOR V.conj - (prepare-dot) TYPE - [ XDOTC_SUB ] keep - ARG>TYPE ; + (prepare-dot) XDOTC ; M: VECTOR Vnorm (prepare-nrm2) XXNRM2 ; M: VECTOR Vasum (prepare-nrm2) XXASUM ; -M: VECTOR n*V+V! - [ TYPE>ARG ] 2dip - (prepare-axpy) [ XAXPY ] dip ; -M: VECTOR n*V! - [ TYPE>ARG ] dip - (prepare-scal) [ XSCAL ] dip ; ;FUNCTOR @@ -271,10 +238,10 @@ M: VECTOR n*V! [ drop (define-blas-vector) ] [ (define-complex-blas-vector) ] 3bi ; -"float" "s" define-real-blas-vector -"double" "d" define-real-blas-vector -"complex-float" "c" "s" define-complex-blas-vector -"complex-double" "z" "d" define-complex-blas-vector +"float" "S" define-real-blas-vector +"double" "D" define-real-blas-vector +"complex-float" "C" "S" define-complex-blas-vector +"complex-double" "Z" "D" define-complex-blas-vector >> From 08b02fadc9ea836e6fb65da5da841ac1ce236fb6 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 15:51:59 -0600 Subject: [PATCH 20/38] typos --- basis/alien/fortran/fortran.factor | 2 +- basis/math/blas/ffi/ffi.factor | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index 00dd8583fc..c7688fbe3a 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -5,7 +5,7 @@ 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 ; +math.order sorting system ; IN: alien.fortran ! XXX this currently only supports the gfortran/f2c abi. diff --git a/basis/math/blas/ffi/ffi.factor b/basis/math/blas/ffi/ffi.factor index 7b0138357a..03043e54ed 100644 --- a/basis/math/blas/ffi/ffi.factor +++ b/basis/math/blas/ffi/ffi.factor @@ -27,9 +27,9 @@ FUNCTION: COMPLEX CDOTU FUNCTION: COMPLEX CDOTC ( INTEGER N, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ; -SUBROUTINE: DOUBLE-COMPLEX ZDOTU +FUNCTION: DOUBLE-COMPLEX ZDOTU ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; -SUBROUTINE: DOUBLE-COMPLEX ZDOTC +FUNCTION: DOUBLE-COMPLEX ZDOTC ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; FUNCTION: REAL SNRM2 From d45f0c83eb94675ac655a15ebb93c7fa5335f2f7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 16:19:09 -0600 Subject: [PATCH 21/38] more work on tiff files. --- extra/graphics/tiff/tiff-tests.factor | 4 +- extra/graphics/tiff/tiff.factor | 174 ++++++++++++++++++++++---- 2 files changed, 151 insertions(+), 27 deletions(-) diff --git a/extra/graphics/tiff/tiff-tests.factor b/extra/graphics/tiff/tiff-tests.factor index daee9a5d9e..f800b4d213 100755 --- a/extra/graphics/tiff/tiff-tests.factor +++ b/extra/graphics/tiff/tiff-tests.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2009 Your name. +! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: tools.test graphics.tiff ; IN: graphics.tiff.tests @@ -6,4 +6,6 @@ IN: graphics.tiff.tests : tiff-test-path ( -- path ) "resource:extra/graphics/tiff/rgb.tiff" ; +: tiff-test-path2 ( -- path ) + "resource:extra/graphics/tiff/octagon.tiff" ; diff --git a/extra/graphics/tiff/tiff.factor b/extra/graphics/tiff/tiff.factor index f0b3f9337e..9461403805 100755 --- a/extra/graphics/tiff/tiff.factor +++ b/extra/graphics/tiff/tiff.factor @@ -2,7 +2,10 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators io io.encodings.binary io.files kernel pack endian tools.hexdump constructors sequences arrays -sorting.slots math.order math.parser prettyprint classes ; +sorting.slots math.order math.parser prettyprint classes +io.binary assocs math math.bitwise byte-arrays grouping ; +USE: multiline + IN: graphics.tiff TUPLE: tiff @@ -14,13 +17,14 @@ ifds ; CONSTRUCTOR: tiff ( -- tiff ) V{ } clone >>ifds ; -TUPLE: ifd count ifd-entries next processed-tags strips ; +TUPLE: ifd count ifd-entries next +processed-tags strips buffer ; CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ; -TUPLE: ifd-entry tag type count offset ; +TUPLE: ifd-entry tag type count offset/value ; -CONSTRUCTOR: ifd-entry ( tag type count offset -- ifd-entry ) ; +CONSTRUCTOR: ifd-entry ( tag type count offset/value -- ifd-entry ) ; TUPLE: photometric-interpretation color ; @@ -132,6 +136,44 @@ ERROR: bad-planar-configuration n ; [ bad-predictor ] } case ; +TUPLE: sample-format n ; +CONSTRUCTOR: sample-format ( n -- object ) ; +ERROR: bad-sample-format n ; + +SINGLETONS: sample-unsigned-integer sample-signed-integer +sample-ieee-float sample-undefined-data ; + +: lookup-sample-format ( seq -- object ) + [ + { + { 1 [ sample-unsigned-integer ] } + { 2 [ sample-signed-integer ] } + { 3 [ sample-ieee-float ] } + { 4 [ sample-undefined-data ] } + [ bad-sample-format ] + } case + ] map ; + + +TUPLE: extra-samples n ; +CONSTRUCTOR: extra-samples ( n -- object ) ; +ERROR: bad-extra-samples n ; + +SINGLETONS: unspecified-alpha-data associated-alpha-data +unassociated-alpha-data ; + +: lookup-extra-samples ( seq -- object ) + { + { 0 [ unspecified-alpha-data ] } + { 1 [ associated-alpha-data ] } + { 2 [ unassociated-alpha-data ] } + [ bad-extra-samples ] + } case ; + + +TUPLE: orientation n ; +CONSTRUCTOR: orientation ( n -- object ) ; + TUPLE: new-subfile-type n ; CONSTRUCTOR: new-subfile-type ( n -- object ) ; @@ -157,6 +199,7 @@ ERROR: bad-tiff-magic bytes ; : push-ifd ( tiff ifd -- tiff ) over ifds>> push ; + ! over [ dup class ] [ ifds>> ] bi* set-at ; : read-ifd ( -- ifd ) 2 read endian> @@ -165,29 +208,96 @@ ERROR: bad-tiff-magic bytes ; 4 read endian> ; : read-ifds ( tiff -- tiff ) - [ - dup ifd-offset>> seek-absolute seek-input - 2 read endian> - dup [ read-ifd ] replicate - 4 read endian> - [ push-ifd ] [ 0 = [ read-ifds ] unless ] bi - ] with-tiff-endianness ; + dup ifd-offset>> seek-absolute seek-input + 2 read endian> + dup [ read-ifd ] replicate + 4 read endian> + [ push-ifd ] [ 0 = [ read-ifds ] unless ] bi ; + +ERROR: no-tag class ; + +: ?at ( key assoc -- value/key ? ) + dupd at* [ nip t ] [ drop f ] if ; inline + +: find-tag ( idf class -- tag ) + swap processed-tags>> + ?at [ no-tag ] unless ; : read-strips ( ifd -- ifd ) - dup processed-tags>> - [ [ strip-byte-counts instance? ] find nip n>> ] - [ [ strip-offsets instance? ] find nip n>> ] bi - [ seek-absolute seek-input read ] { } 2map-as >>strips ; + dup + [ strip-byte-counts find-tag n>> ] + [ strip-offsets find-tag n>> ] bi + 2dup [ integer? ] both? [ + seek-absolute seek-input read 1array + ] [ + [ seek-absolute seek-input read ] { } 2map-as + ] if >>strips ; ! ERROR: unhandled-ifd-entry data n ; : unhandled-ifd-entry ; +ERROR: unknown-ifd-type n ; + +: bytes>bits ( n/byte-array -- n ) + dup byte-array? [ byte-array>bignum ] when ; + +: value-length ( ifd-entry -- n ) + [ count>> ] [ type>> ] bi { + { 1 [ ] } + { 2 [ ] } + { 3 [ 2 * ] } + { 4 [ 4 * ] } + { 5 [ 8 * ] } + { 6 [ ] } + { 7 [ ] } + { 8 [ 2 * ] } + { 9 [ 4 * ] } + { 10 [ 8 * ] } + { 11 [ 4 * ] } + { 12 [ 8 * ] } + [ unknown-ifd-type ] + } case ; + +ERROR: bad-small-ifd-type n ; + +: adjust-offset/value ( ifd-entry -- obj ) + [ offset/value>> 4 >endian ] [ type>> ] bi + { + { 1 [ 1 head endian> ] } + { 3 [ 2 head endian> ] } + { 4 [ endian> ] } + { 6 [ 1 head endian> 8 >signed ] } + { 8 [ 2 head endian> 16 >signed ] } + { 9 [ endian> 32 >signed ] } + { 11 [ endian> bits>float ] } + [ bad-small-ifd-type ] + } case ; + +: offset-bytes>obj ( bytes type -- obj ) + { + { 1 [ ] } ! blank + { 2 [ ] } ! read c strings here + { 3 [ 2 [ endian> ] map ] } + { 4 [ 4 [ endian> ] map ] } + { 5 [ 8 [ "II" unpack first2 / ] map ] } + { 6 [ [ 8 >signed ] map ] } + { 7 [ ] } ! blank + { 8 [ 2 [ endian> 16 >signed ] map ] } + { 9 [ 4 [ endian> 32 >signed ] map ] } + { 10 [ 8 group [ "ii" unpack first2 / ] map ] } + { 11 [ 4 group [ "f" unpack ] map ] } + { 12 [ 8 group [ "d" unpack ] map ] } + [ unknown-ifd-type ] + } case ; + : ifd-entry-value ( ifd-entry -- n ) - dup count>> 1 = [ - offset>> + dup value-length 4 <= [ + adjust-offset/value ] [ - [ offset>> seek-absolute seek-input ] [ count>> read ] bi + [ offset/value>> seek-absolute seek-input ] + [ value-length read ] + [ type>> ] tri offset-bytes>obj ] if ; : process-ifd-entry ( ifd-entry -- object ) @@ -199,6 +309,7 @@ ERROR: bad-tiff-magic bytes ; { 259 [ lookup-compression ] } { 262 [ lookup-photometric-interpretation ] } { 273 [ ] } + { 274 [ ] } { 277 [ ] } { 278 [ ] } { 279 [ ] } @@ -207,21 +318,32 @@ ERROR: bad-tiff-magic bytes ; { 284 [ ] } { 296 [ lookup-resolution-unit ] } { 317 [ lookup-predictor ] } + { 338 [ lookup-extra-samples ] } + { 339 [ lookup-sample-format ] } [ unhandled-ifd-entry swap 2array ] } case ; : process-ifd ( ifd -- ifd ) - dup ifd-entries>> [ process-ifd-entry ] map >>processed-tags ; + dup ifd-entries>> + [ process-ifd-entry [ class ] keep ] H{ } map>assoc >>processed-tags ; + +/* +: ifd-strips>buffer ( ifd -- ifd ) + [ + [ rows-per-strip find-tag n>> ] + [ image-length find-tag n>> ] bi + ] [ + strips>> [ length ] keep + ] bi assemble-image ; +*/ : (load-tiff) ( path -- tiff ) binary [ - read-header - read-ifds - dup ifds>> [ process-ifd read-strips drop ] each + read-header [ + read-ifds + dup ifds>> [ process-ifd read-strips drop ] each + ] with-tiff-endianness ] with-file-reader ; -: load-tiff ( path -- tiff ) - (load-tiff) ; - -! TODO: duplicate ifds = error, seeking out of bounds = error +: load-tiff ( path -- tiff ) (load-tiff) ; From 41e0db098caff53221560f50bb46855123b2c43a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 16:19:43 -0600 Subject: [PATCH 22/38] make pack/unpack public --- basis/pack/pack.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/pack/pack.factor b/basis/pack/pack.factor index 9078817206..27cba6d6e7 100755 --- a/basis/pack/pack.factor +++ b/basis/pack/pack.factor @@ -87,12 +87,12 @@ CONSTANT: packed-length-table { CHAR: D 8 } } +PRIVATE> + MACRO: pack ( str -- quot ) [ pack-table at '[ _ execute ] ] { } map-as '[ [ [ _ spread ] input - : ch>packed-length ( ch -- n ) packed-length-table at ; inline @@ -113,14 +113,14 @@ PRIVATE> : start/end ( seq -- seq1 seq2 ) [ 0 [ + ] accumulate nip dup ] keep v+ ; inline +PRIVATE> + MACRO: unpack ( str -- quot ) [ [ ch>packed-length ] { } map-as start/end ] [ [ unpack-table at '[ @ ] ] { } map-as ] bi [ '[ [ _ _ ] dip @ ] ] 3map '[ [ _ cleave ] output>array ] ; -PRIVATE> - : unpack-native ( seq str -- seq ) '[ _ _ unpack ] with-native-endian ; inline From ebdd135d6281e0758d2641e005fbff4253de5749 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 16:36:46 -0600 Subject: [PATCH 23/38] gfortran returns float for REAL functions, not double like f2c --- basis/alien/fortran/fortran-tests.factor | 6 +++--- basis/alien/fortran/fortran.factor | 6 ++++-- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/basis/alien/fortran/fortran-tests.factor b/basis/alien/fortran/fortran-tests.factor index 9b618ef513..1b2ffda4a9 100644 --- a/basis/alien/fortran/fortran-tests.factor +++ b/basis/alien/fortran/fortran-tests.factor @@ -116,7 +116,7 @@ RECORD: FORTRAN_TEST_RECORD [ "int" { } ] [ "logical" fortran-ret-type>c-type ] unit-test -[ "double" { } ] +[ "float" { } ] [ "real" fortran-ret-type>c-type ] unit-test [ "double" { } ] @@ -136,7 +136,7 @@ RECORD: FORTRAN_TEST_RECORD ! fortran-sig>c-sig -[ "double" { "int*" "char*" "float*" "double*" "long" } ] +[ "float" { "int*" "char*" "float*" "double*" "long" } ] [ "real" { "integer" "character*17" "real" "real*8" } fortran-sig>c-sig ] unit-test @@ -213,7 +213,7 @@ unit-test [ { [ drop ] } spread ] } 1 ncleave ! [fortran-invoke] - [ "double" "funpack" "fun_times__" { "float*" } alien-invoke ] + [ "float" "funpack" "fun_times__" { "float*" } alien-invoke ] 1 nkeep ! [fortran-results>] shuffle( reta aa -- reta aa ) diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index c7688fbe3a..9327c7b02c 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -155,7 +155,9 @@ GENERIC: (fortran-ret-type>c-type) ( type -- c-type ) M: f (fortran-ret-type>c-type) drop "void" ; M: fortran-type (fortran-ret-type>c-type) (fortran-type>c-type) ; -M: real-type (fortran-ret-type>c-type) drop "double" ; +! 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" ; : suffix! ( seq elt -- seq ) over push ; inline : append! ( seq-a seq-b -- seq-a ) over push-all ; inline @@ -374,7 +376,7 @@ MACRO: fortran-invoke ( return library function parameters -- ) :: define-fortran-function ( return library function parameters -- ) function create-in dup reset-generic - return library function parameters return parse-arglist + return library function parameters return [ "void" ] unless* parse-arglist [ \ fortran-invoke 5 [ ] nsequence ] dip define-declared ; : SUBROUTINE: From 4623e9bd683df29dd7fc405e0679db4d8fd47967 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 16:37:01 -0600 Subject: [PATCH 24/38] another typo --- basis/math/blas/ffi/ffi.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/math/blas/ffi/ffi.factor b/basis/math/blas/ffi/ffi.factor index 03043e54ed..7e0694ae4f 100644 --- a/basis/math/blas/ffi/ffi.factor +++ b/basis/math/blas/ffi/ffi.factor @@ -16,7 +16,7 @@ LIBRARY: blas FUNCTION: REAL SDSDOT ( INTEGER N, REAL ALPHA, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ; FUNCTION: DOUBLE-PRECISION DSDOT - ( INTEGER N, DOUBLE-PRECISION-PRECISION(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ; + ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ; FUNCTION: REAL SDOT ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ; FUNCTION: DOUBLE-PRECISION DDOT From ddf8afbb7ee49c8b3b894928168ab6c113417190 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 16:37:12 -0600 Subject: [PATCH 25/38] more typos --- .../direct/complex-double/complex-double.factor | 2 +- .../direct/complex-float/complex-float.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/specialized-arrays/direct/complex-double/complex-double.factor b/basis/specialized-arrays/direct/complex-double/complex-double.factor index 58af77b0c0..ae8d2b5fb3 100644 --- a/basis/specialized-arrays/direct/complex-double/complex-double.factor +++ b/basis/specialized-arrays/direct/complex-double/complex-double.factor @@ -1,4 +1,4 @@ -USING: specialized-arrays.float specialized-arrays.direct.functor ; +USING: specialized-arrays.complex-double specialized-arrays.direct.functor ; IN: specialized-arrays.direct.complex-double << "complex-double" define-direct-array >> diff --git a/basis/specialized-arrays/direct/complex-float/complex-float.factor b/basis/specialized-arrays/direct/complex-float/complex-float.factor index d881c1e0d4..8971196297 100644 --- a/basis/specialized-arrays/direct/complex-float/complex-float.factor +++ b/basis/specialized-arrays/direct/complex-float/complex-float.factor @@ -1,4 +1,4 @@ -USING: specialized-arrays.float specialized-arrays.direct.functor ; +USING: specialized-arrays.complex-float specialized-arrays.direct.functor ; IN: specialized-arrays.direct.complex-float << "complex-float" define-direct-array >> From ad843a1bcf53f3a21f3ec13dbf24b5507dff0bc7 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 16:37:45 -0600 Subject: [PATCH 26/38] iXamax returns a 1-based array index. decrement that shit --- basis/math/blas/vectors/vectors-docs.factor | 16 ++++++++-------- basis/math/blas/vectors/vectors.factor | 5 ++--- 2 files changed, 10 insertions(+), 11 deletions(-) diff --git a/basis/math/blas/vectors/vectors-docs.factor b/basis/math/blas/vectors/vectors-docs.factor index b37a4b966e..296437c32b 100644 --- a/basis/math/blas/vectors/vectors-docs.factor +++ b/basis/math/blas/vectors/vectors-docs.factor @@ -37,8 +37,8 @@ HELP: blas-vector-base { $list { { $link float-blas-vector } } { { $link double-blas-vector } } - { { $link float-complex-blas-vector } } - { { $link double-complex-blas-vector } } + { { $link complex-float-blas-vector } } + { { $link complex-double-blas-vector } } } "All of these subclasses share the same tuple layout:" { $list @@ -51,10 +51,10 @@ HELP: float-blas-vector { $class-description "A vector of single-precision floating-point values. For details on the tuple layout, see " { $link blas-vector-base } "." } ; HELP: double-blas-vector { $class-description "A vector of double-precision floating-point values. For details on the tuple layout, see " { $link blas-vector-base } "." } ; -HELP: float-complex-blas-vector -{ $class-description "A vector of single-precision floating-point complex values. Complex values are stored in memory as two consecutive float values, real part then imaginary part. For details on the tuple layout, see " { $link blas-vector-base } "." } ; -HELP: double-complex-blas-vector -{ $class-description "A vector of single-precision floating-point complex values. Complex values are stored in memory as two consecutive float values, real part then imaginary part. For details on the tuple layout, see " { $link blas-vector-base } "." } ; +HELP: complex-float-blas-vector +{ $class-description "A vector of single-precision floating-point complex values. For details on the tuple layout, see " { $link blas-vector-base } "." } ; +HELP: complex-double-blas-vector +{ $class-description "A vector of double-precision floating-point complex values. For details on the tuple layout, see " { $link blas-vector-base } "." } ; HELP: n*V+V! { $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "y=alpha*x+y" blas-vector-base } } @@ -145,11 +145,11 @@ HELP: dvector{ HELP: cvector{ { $syntax "cvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" } -{ $description "Construct a literal " { $link float-complex-blas-vector } "." } ; +{ $description "Construct a literal " { $link complex-float-blas-vector } "." } ; HELP: zvector{ { $syntax "dvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" } -{ $description "Construct a literal " { $link double-complex-blas-vector } "." } ; +{ $description "Construct a literal " { $link complex-double-blas-vector } "." } ; { POSTPONE: svector{ POSTPONE: dvector{ diff --git a/basis/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor index 9a2f9a4350..a373ec7c5a 100755 --- a/basis/math/blas/vectors/vectors.factor +++ b/basis/math/blas/vectors/vectors.factor @@ -1,7 +1,6 @@ USING: accessors alien alien.c-types arrays ascii byte-arrays combinators combinators.short-circuit fry kernel math math.blas.ffi -math.complex math.functions math.order sequences.complex -sequences.complex-components sequences sequences.private +math.complex math.functions math.order sequences sequences.private functors words locals parser prettyprint.backend prettyprint.custom specialized-arrays.float specialized-arrays.double specialized-arrays.direct.float specialized-arrays.direct.double @@ -165,7 +164,7 @@ M: VECTOR element-type M: VECTOR Vswap (prepare-swap) [ XSWAP ] 2dip ; M: VECTOR Viamax - (prepare-nrm2) IXAMAX ; + (prepare-nrm2) IXAMAX 1- ; M: VECTOR (blas-vector-like) drop ; From 35c54a91ac5d937795b2ff9912f8d0aa719fb6bf Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 16:59:00 -0600 Subject: [PATCH 27/38] oops, leftover ORDER arguments from converting from CBLAS --- basis/math/blas/ffi/ffi.factor | 24 ++++++++---------------- 1 file changed, 8 insertions(+), 16 deletions(-) diff --git a/basis/math/blas/ffi/ffi.factor b/basis/math/blas/ffi/ffi.factor index 7e0694ae4f..77cee1aa82 100644 --- a/basis/math/blas/ffi/ffi.factor +++ b/basis/math/blas/ffi/ffi.factor @@ -122,13 +122,11 @@ SUBROUTINE: DROTM ! LEVEL 2 BLAS (MATRIX-VECTOR) -SUBROUTINE: SGEMV ( CHARACTER*1 ORDER, - CHARACTER*1 TRANSA, INTEGER M, INTEGER N, +SUBROUTINE: SGEMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N, REAL ALPHA, REAL(*) A, INTEGER LDA, REAL(*) X, INTEGER INCX, REAL BETA, REAL(*) Y, INTEGER INCY ) ; -SUBROUTINE: SGBMV ( CHARACTER*1 ORDER, - CHARACTER*1 TRANSA, INTEGER M, INTEGER N, +SUBROUTINE: SGBMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N, INTEGER KL, INTEGER KU, REAL ALPHA, REAL(*) A, INTEGER LDA, REAL(*) X, INTEGER INCX, REAL BETA, REAL(*) Y, INTEGER INCY ) ; @@ -155,13 +153,11 @@ SUBROUTINE: STPSV ( CHARACTER*1 UPLO, CHARACTER*1 TRANSA, CHARACTER*1 DIAG, INTEGER N, REAL(*) AP, REAL(*) X, INTEGER INCX ) ; -SUBROUTINE: DGEMV ( CHARACTER*1 ORDER, - CHARACTER*1 TRANSA, INTEGER M, INTEGER N, +SUBROUTINE: DGEMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ; -SUBROUTINE: DGBMV ( CHARACTER*1 ORDER, - CHARACTER*1 TRANSA, INTEGER M, INTEGER N, +SUBROUTINE: DGBMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N, INTEGER KL, INTEGER KU, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ; @@ -188,13 +184,11 @@ SUBROUTINE: DTPSV ( CHARACTER*1 UPLO, CHARACTER*1 TRANSA, CHARACTER*1 DIAG, INTEGER N, DOUBLE-PRECISION(*) AP, DOUBLE-PRECISION(*) X, INTEGER INCX ) ; -SUBROUTINE: CGEMV ( CHARACTER*1 ORDER, - CHARACTER*1 TRANSA, INTEGER M, INTEGER N, +SUBROUTINE: CGEMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N, COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA, COMPLEX(*) X, INTEGER INCX, COMPLEX BETA, COMPLEX(*) Y, INTEGER INCY ) ; -SUBROUTINE: CGBMV ( CHARACTER*1 ORDER, - CHARACTER*1 TRANSA, INTEGER M, INTEGER N, +SUBROUTINE: CGBMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N, INTEGER KL, INTEGER KU, COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA, COMPLEX(*) X, INTEGER INCX, COMPLEX BETA, COMPLEX(*) Y, INTEGER INCY ) ; @@ -221,13 +215,11 @@ SUBROUTINE: CTPSV ( CHARACTER*1 UPLO, CHARACTER*1 TRANSA, CHARACTER*1 DIAG, INTEGER N, COMPLEX(*) AP, COMPLEX(*) X, INTEGER INCX ) ; -SUBROUTINE: ZGEMV ( CHARACTER*1 ORDER, - CHARACTER*1 TRANSA, INTEGER M, INTEGER N, +SUBROUTINE: ZGEMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; -SUBROUTINE: ZGBMV ( CHARACTER*1 ORDER, - CHARACTER*1 TRANSA, INTEGER M, INTEGER N, +SUBROUTINE: ZGBMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N, INTEGER KL, INTEGER KU, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; From d160b80dacbcf7e598613930fb83781df8804e7d Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 16:59:26 -0600 Subject: [PATCH 28/38] convert math.blas.matrices to use fortran calls --- basis/math/blas/matrices/matrices-docs.factor | 40 +++++------ basis/math/blas/matrices/matrices.factor | 72 +++++++++---------- 2 files changed, 54 insertions(+), 58 deletions(-) diff --git a/basis/math/blas/matrices/matrices-docs.factor b/basis/math/blas/matrices/matrices-docs.factor index f20a565e1f..b6e118836e 100644 --- a/basis/math/blas/matrices/matrices-docs.factor +++ b/basis/math/blas/matrices/matrices-docs.factor @@ -14,34 +14,34 @@ ARTICLE: "math.blas-types" "BLAS interface types" "BLAS vectors come in single- and double-precision, real and complex flavors:" { $subsection float-blas-vector } { $subsection double-blas-vector } -{ $subsection float-complex-blas-vector } -{ $subsection double-complex-blas-vector } +{ $subsection complex-float-blas-vector } +{ $subsection complex-double-blas-vector } "These vector types all follow the " { $link sequence } " protocol. In addition, there are corresponding types for matrix data:" { $subsection float-blas-matrix } { $subsection double-blas-matrix } -{ $subsection float-complex-blas-matrix } -{ $subsection double-complex-blas-matrix } +{ $subsection complex-float-blas-matrix } +{ $subsection complex-double-blas-matrix } "There are BOA constructors for all vector and matrix types, which provide the most flexibility in specifying memory layout:" { $subsection } { $subsection } -{ $subsection } -{ $subsection } +{ $subsection } +{ $subsection } { $subsection } { $subsection } -{ $subsection } -{ $subsection } +{ $subsection } +{ $subsection } "For the simple case of creating a dense, zero-filled vector or matrix, simple empty object constructors are provided:" { $subsection } { $subsection } "BLAS vectors and matrices can also be constructed from other Factor sequences:" { $subsection >float-blas-vector } { $subsection >double-blas-vector } -{ $subsection >float-complex-blas-vector } -{ $subsection >double-complex-blas-vector } +{ $subsection >complex-float-blas-vector } +{ $subsection >complex-double-blas-vector } { $subsection >float-blas-matrix } { $subsection >double-blas-matrix } -{ $subsection >float-complex-blas-matrix } -{ $subsection >double-complex-blas-matrix } ; +{ $subsection >complex-float-blas-matrix } +{ $subsection >complex-double-blas-matrix } ; ARTICLE: "math.blas.matrices" "BLAS interface matrix operations" "Transposing and slicing matrices:" @@ -87,8 +87,8 @@ HELP: blas-matrix-base { $list { { $link float-blas-matrix } } { { $link double-blas-matrix } } - { { $link float-complex-blas-matrix } } - { { $link double-complex-blas-matrix } } + { { $link complex-float-blas-matrix } } + { { $link complex-double-blas-matrix } } } "All of these subclasses share the same tuple layout:" { $list @@ -104,14 +104,14 @@ HELP: float-blas-matrix { $class-description "A matrix of single-precision floating-point values. For details on the tuple layout, see " { $link blas-matrix-base } "." } ; HELP: double-blas-matrix { $class-description "A matrix of double-precision floating-point values. For details on the tuple layout, see " { $link blas-matrix-base } "." } ; -HELP: float-complex-blas-matrix +HELP: complex-float-blas-matrix { $class-description "A matrix of single-precision floating-point complex values. Complex values are stored in memory as two consecutive float values, real part then imaginary part. For details on the tuple layout, see " { $link blas-matrix-base } "." } ; -HELP: double-complex-blas-matrix +HELP: complex-double-blas-matrix { $class-description "A matrix of double-precision floating-point complex values. Complex values are stored in memory as two consecutive float values, real part then imaginary part. For details on the tuple layout, see " { $link blas-matrix-base } "." } ; { - float-blas-matrix double-blas-matrix float-complex-blas-matrix double-complex-blas-matrix - float-blas-vector double-blas-vector float-complex-blas-vector double-complex-blas-vector + float-blas-matrix double-blas-matrix complex-float-blas-matrix complex-double-blas-matrix + float-blas-vector double-blas-vector complex-float-blas-vector complex-double-blas-vector } related-words HELP: Mwidth @@ -272,7 +272,7 @@ HELP: cmatrix{ { 0.0 0.0 -1.0 3.0 } { 0.0 0.0 0.0 C{ 0.0 -1.0 } } } "> } -{ $description "Construct a literal " { $link float-complex-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ; +{ $description "Construct a literal " { $link complex-float-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ; HELP: zmatrix{ { $syntax <" zmatrix{ @@ -281,7 +281,7 @@ HELP: zmatrix{ { 0.0 0.0 -1.0 3.0 } { 0.0 0.0 0.0 C{ 0.0 -1.0 } } } "> } -{ $description "Construct a literal " { $link double-complex-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ; +{ $description "Construct a literal " { $link complex-double-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ; { POSTPONE: smatrix{ POSTPONE: dmatrix{ diff --git a/basis/math/blas/matrices/matrices.factor b/basis/math/blas/matrices/matrices.factor index d9653fca6f..6a948b6fe1 100755 --- a/basis/math/blas/matrices/matrices.factor +++ b/basis/math/blas/matrices/matrices.factor @@ -1,11 +1,13 @@ USING: accessors alien alien.c-types arrays byte-arrays combinators combinators.short-circuit fry kernel locals macros -math math.blas.cblas math.blas.vectors math.blas.vectors.private +math math.blas.ffi math.blas.vectors math.blas.vectors.private math.complex math.functions math.order functors words sequences sequences.merged sequences.private shuffle specialized-arrays.direct.float specialized-arrays.direct.double specialized-arrays.float specialized-arrays.double -parser prettyprint.backend prettyprint.custom ; +specialized-arrays.direct.complex-float specialized-arrays.direct.complex-double +specialized-arrays.complex-float specialized-arrays.complex-double +parser prettyprint.backend prettyprint.custom ascii ; IN: math.blas.matrices TUPLE: blas-matrix-base underlying ld rows cols transpose ; @@ -25,7 +27,7 @@ GENERIC: n*M.M+n*M! ( alpha A B beta C -- C=alpha*A.B+beta*C ) > [ CblasTrans ] [ CblasNoTrans ] if ; + transpose>> [ "T" ] [ "N" ] if ; GENERIC: (blas-matrix-like) ( data ld rows cols transpose exemplar -- matrix ) @@ -38,19 +40,18 @@ GENERIC: (blas-matrix-like) ( data ld rows cols transpose exemplar -- matrix ) unless ; :: (prepare-gemv) - ( alpha A x beta y >c-arg -- order A-trans m n alpha A-data A-ld x-data x-inc beta y-data y-inc - y ) + ( alpha A x beta y -- A-trans m n alpha A-data A-ld x-data x-inc beta y-data y-inc + y ) A x y (validate-gemv) - CblasColMajor A (blas-transpose) A rows>> A cols>> - alpha >c-arg call + alpha A underlying>> A ld>> x underlying>> x inc>> - beta >c-arg call + beta y underlying>> y inc>> y ; inline @@ -64,13 +65,12 @@ GENERIC: (blas-matrix-like) ( data ld rows cols transpose exemplar -- matrix ) unless ; :: (prepare-ger) - ( alpha x y A >c-arg -- order m n alpha x-data x-inc y-data y-inc A-data A-ld - A ) + ( alpha x y A -- m n alpha x-data x-inc y-data y-inc A-data A-ld + A ) x y A (validate-ger) - CblasColMajor A rows>> A cols>> - alpha >c-arg call + alpha x underlying>> x inc>> y underlying>> @@ -89,21 +89,20 @@ GENERIC: (blas-matrix-like) ( data ld rows cols transpose exemplar -- matrix ) unless ; :: (prepare-gemm) - ( alpha A B beta C >c-arg -- order A-trans B-trans m n k alpha A-data A-ld B-data B-ld beta C-data C-ld - C ) + ( alpha A B beta C -- A-trans B-trans m n k alpha A-data A-ld B-data B-ld beta C-data C-ld + C ) A B C (validate-gemm) - CblasColMajor A (blas-transpose) B (blas-transpose) C rows>> C cols>> A Mwidth - alpha >c-arg call + alpha A underlying>> A ld>> B underlying>> B ld>> - beta >c-arg call + beta C underlying>> C ld>> C f >>transpose ; inline @@ -250,16 +249,18 @@ FUNCTOR: (define-blas-matrix) ( TYPE T U C -- ) VECTOR IS ${TYPE}-blas-vector IS <${TYPE}-blas-vector> >ARRAY IS >${TYPE}-array -TYPE>ARG IS ${TYPE}>arg -XGEMV IS cblas_${T}gemv -XGEMM IS cblas_${T}gemm -XGERU IS cblas_${T}ger${U} -XGERC IS cblas_${T}ger${C} +XGEMV IS ${T}GEMV +XGEMM IS ${T}GEMM +XGERU IS ${T}GER${U} +XGERC IS ${T}GER${C} MATRIX DEFINES-CLASS ${TYPE}-blas-matrix DEFINES <${TYPE}-blas-matrix> >MATRIX DEFINES >${TYPE}-blas-matrix -XMATRIX{ DEFINES ${T}matrix{ + +t [ T >lower ] + +XMATRIX{ DEFINES ${t}matrix{ WHERE @@ -277,21 +278,16 @@ M: MATRIX (blas-vector-like) drop ; : >MATRIX ( arrays -- matrix ) - [ >ARRAY underlying>> ] (>matrix) - ; + [ >ARRAY underlying>> ] (>matrix) ; M: VECTOR n*M.V+n*V! - [ TYPE>ARG ] (prepare-gemv) - [ XGEMV ] dip ; + (prepare-gemv) [ XGEMV ] dip ; M: MATRIX n*M.M+n*M! - [ TYPE>ARG ] (prepare-gemm) - [ XGEMM ] dip ; + (prepare-gemm) [ XGEMM ] dip ; M: MATRIX n*V(*)V+M! - [ TYPE>ARG ] (prepare-ger) - [ XGERU ] dip ; + (prepare-ger) [ XGERU ] dip ; M: MATRIX n*V(*)Vconj+M! - [ TYPE>ARG ] (prepare-ger) - [ XGERC ] dip ; + (prepare-ger) [ XGERC ] dip ; : XMATRIX{ \ } [ >MATRIX ] parse-literal ; parsing @@ -304,12 +300,12 @@ M: MATRIX pprint-delims : define-real-blas-matrix ( TYPE T -- ) "" "" (define-blas-matrix) ; : define-complex-blas-matrix ( TYPE T -- ) - "u" "c" (define-blas-matrix) ; + "U" "C" (define-blas-matrix) ; -"float" "s" define-real-blas-matrix -"double" "d" define-real-blas-matrix -"float-complex" "c" define-complex-blas-matrix -"double-complex" "z" define-complex-blas-matrix +"float" "S" define-real-blas-matrix +"double" "D" define-real-blas-matrix +"complex-float" "C" define-complex-blas-matrix +"complex-double" "Z" define-complex-blas-matrix >> From 4325f5a7a9a08c6c9b67eccd2141acf6b353138f Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 17:04:37 -0600 Subject: [PATCH 29/38] kill math.blas.cblas --- basis/math/blas/cblas/authors.txt | 1 - basis/math/blas/cblas/cblas.factor | 574 ------------------ basis/math/blas/cblas/summary.txt | 1 - basis/math/blas/cblas/tags.txt | 2 - basis/math/blas/matrices/matrices-docs.factor | 2 +- 5 files changed, 1 insertion(+), 579 deletions(-) delete mode 100644 basis/math/blas/cblas/authors.txt delete mode 100644 basis/math/blas/cblas/cblas.factor delete mode 100644 basis/math/blas/cblas/summary.txt delete mode 100644 basis/math/blas/cblas/tags.txt diff --git a/basis/math/blas/cblas/authors.txt b/basis/math/blas/cblas/authors.txt deleted file mode 100644 index f13c9c1e77..0000000000 --- a/basis/math/blas/cblas/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Joe Groff diff --git a/basis/math/blas/cblas/cblas.factor b/basis/math/blas/cblas/cblas.factor deleted file mode 100644 index 2a2e9e3a72..0000000000 --- a/basis/math/blas/cblas/cblas.factor +++ /dev/null @@ -1,574 +0,0 @@ -USING: alien alien.c-types alien.syntax kernel system -combinators ; -IN: math.blas.cblas - -<< -: load-atlas ( -- ) - "atlas" "libatlas.so" "cdecl" add-library ; -: load-fortran ( -- ) - "I77" "libI77.so" "cdecl" add-library - "F77" "libF77.so" "cdecl" add-library ; -: load-blas ( -- ) - "blas" "libblas.so" "cdecl" add-library ; - -"cblas" { - { [ os macosx? ] [ "libblas.dylib" "cdecl" add-library ] } - { [ os windows? ] [ "blas.dll" "cdecl" add-library ] } - { [ os openbsd? ] [ "libcblas.so" "cdecl" add-library load-blas ] } - { [ os netbsd? ] [ - load-fortran load-blas - "/usr/local/lib/libcblas.so" "cdecl" add-library - ] } - { [ os freebsd? ] [ "libcblas.so" "cdecl" add-library load-atlas ] } - [ "libblas.so" "cdecl" add-library ] -} cond ->> - -LIBRARY: cblas - -TYPEDEF: int CBLAS_ORDER -CONSTANT: CblasRowMajor 101 -CONSTANT: CblasColMajor 102 - -TYPEDEF: int CBLAS_TRANSPOSE -CONSTANT: CblasNoTrans 111 -CONSTANT: CblasTrans 112 -CONSTANT: CblasConjTrans 113 - -TYPEDEF: int CBLAS_UPLO -CONSTANT: CblasUpper 121 -CONSTANT: CblasLower 122 - -TYPEDEF: int CBLAS_DIAG -CONSTANT: CblasNonUnit 131 -CONSTANT: CblasUnit 132 - -TYPEDEF: int CBLAS_SIDE -CONSTANT: CblasLeft 141 -CONSTANT: CblasRight 142 - -TYPEDEF: int CBLAS_INDEX - -C-STRUCT: float-complex - { "float" "real" } - { "float" "imag" } ; -C-STRUCT: double-complex - { "double" "real" } - { "double" "imag" } ; - -! Level 1 BLAS (scalar-vector and vector-vector) - -FUNCTION: float cblas_sdsdot - ( int N, float alpha, float* X, int incX, float* Y, int incY ) ; -FUNCTION: double cblas_dsdot - ( int N, float* X, int incX, float* Y, int incY ) ; -FUNCTION: float cblas_sdot - ( int N, float* X, int incX, float* Y, int incY ) ; -FUNCTION: double cblas_ddot - ( int N, double* X, int incX, double* Y, int incY ) ; - -FUNCTION: void cblas_cdotu_sub - ( int N, void* X, int incX, void* Y, int incY, void* dotu ) ; -FUNCTION: void cblas_cdotc_sub - ( int N, void* X, int incX, void* Y, int incY, void* dotc ) ; - -FUNCTION: void cblas_zdotu_sub - ( int N, void* X, int incX, void* Y, int incY, void* dotu ) ; -FUNCTION: void cblas_zdotc_sub - ( int N, void* X, int incX, void* Y, int incY, void* dotc ) ; - -FUNCTION: float cblas_snrm2 - ( int N, float* X, int incX ) ; -FUNCTION: float cblas_sasum - ( int N, float* X, int incX ) ; - -FUNCTION: double cblas_dnrm2 - ( int N, double* X, int incX ) ; -FUNCTION: double cblas_dasum - ( int N, double* X, int incX ) ; - -FUNCTION: float cblas_scnrm2 - ( int N, void* X, int incX ) ; -FUNCTION: float cblas_scasum - ( int N, void* X, int incX ) ; - -FUNCTION: double cblas_dznrm2 - ( int N, void* X, int incX ) ; -FUNCTION: double cblas_dzasum - ( int N, void* X, int incX ) ; - -FUNCTION: CBLAS_INDEX cblas_isamax - ( int N, float* X, int incX ) ; -FUNCTION: CBLAS_INDEX cblas_idamax - ( int N, double* X, int incX ) ; -FUNCTION: CBLAS_INDEX cblas_icamax - ( int N, void* X, int incX ) ; -FUNCTION: CBLAS_INDEX cblas_izamax - ( int N, void* X, int incX ) ; - -FUNCTION: void cblas_sswap - ( int N, float* X, int incX, float* Y, int incY ) ; -FUNCTION: void cblas_scopy - ( int N, float* X, int incX, float* Y, int incY ) ; -FUNCTION: void cblas_saxpy - ( int N, float alpha, float* X, int incX, float* Y, int incY ) ; - -FUNCTION: void cblas_dswap - ( int N, double* X, int incX, double* Y, int incY ) ; -FUNCTION: void cblas_dcopy - ( int N, double* X, int incX, double* Y, int incY ) ; -FUNCTION: void cblas_daxpy - ( int N, double alpha, double* X, int incX, double* Y, int incY ) ; - -FUNCTION: void cblas_cswap - ( int N, void* X, int incX, void* Y, int incY ) ; -FUNCTION: void cblas_ccopy - ( int N, void* X, int incX, void* Y, int incY ) ; -FUNCTION: void cblas_caxpy - ( int N, void* alpha, void* X, int incX, void* Y, int incY ) ; - -FUNCTION: void cblas_zswap - ( int N, void* X, int incX, void* Y, int incY ) ; -FUNCTION: void cblas_zcopy - ( int N, void* X, int incX, void* Y, int incY ) ; -FUNCTION: void cblas_zaxpy - ( int N, void* alpha, void* X, int incX, void* Y, int incY ) ; - -FUNCTION: void cblas_sscal - ( int N, float alpha, float* X, int incX ) ; -FUNCTION: void cblas_dscal - ( int N, double alpha, double* X, int incX ) ; -FUNCTION: void cblas_cscal - ( int N, void* alpha, void* X, int incX ) ; -FUNCTION: void cblas_zscal - ( int N, void* alpha, void* X, int incX ) ; -FUNCTION: void cblas_csscal - ( int N, float alpha, void* X, int incX ) ; -FUNCTION: void cblas_zdscal - ( int N, double alpha, void* X, int incX ) ; - -FUNCTION: void cblas_srotg - ( float* a, float* b, float* c, float* s ) ; -FUNCTION: void cblas_srotmg - ( float* d1, float* d2, float* b1, float b2, float* P ) ; -FUNCTION: void cblas_srot - ( int N, float* X, int incX, float* Y, int incY, float c, float s ) ; -FUNCTION: void cblas_srotm - ( int N, float* X, int incX, float* Y, int incY, float* P ) ; - -FUNCTION: void cblas_drotg - ( double* a, double* b, double* c, double* s ) ; -FUNCTION: void cblas_drotmg - ( double* d1, double* d2, double* b1, double b2, double* P ) ; -FUNCTION: void cblas_drot - ( int N, double* X, int incX, double* Y, int incY, double c, double s ) ; -FUNCTION: void cblas_drotm - ( int N, double* X, int incX, double* Y, int incY, double* P ) ; - -! Level 2 BLAS (matrix-vector) - -FUNCTION: void cblas_sgemv ( CBLAS_ORDER Order, - CBLAS_TRANSPOSE TransA, int M, int N, - float alpha, float* A, int lda, - float* X, int incX, float beta, - float* Y, int incY ) ; -FUNCTION: void cblas_sgbmv ( CBLAS_ORDER Order, - CBLAS_TRANSPOSE TransA, int M, int N, - int KL, int KU, float alpha, - float* A, int lda, float* X, - int incX, float beta, float* Y, int incY ) ; -FUNCTION: void cblas_strmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, float* A, int lda, - float* X, int incX ) ; -FUNCTION: void cblas_stbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, int K, float* A, int lda, - float* X, int incX ) ; -FUNCTION: void cblas_stpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, float* Ap, float* X, int incX ) ; -FUNCTION: void cblas_strsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, float* A, int lda, float* X, - int incX ) ; -FUNCTION: void cblas_stbsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, int K, float* A, int lda, - float* X, int incX ) ; -FUNCTION: void cblas_stpsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, float* Ap, float* X, int incX ) ; - -FUNCTION: void cblas_dgemv ( CBLAS_ORDER Order, - CBLAS_TRANSPOSE TransA, int M, int N, - double alpha, double* A, int lda, - double* X, int incX, double beta, - double* Y, int incY ) ; -FUNCTION: void cblas_dgbmv ( CBLAS_ORDER Order, - CBLAS_TRANSPOSE TransA, int M, int N, - int KL, int KU, double alpha, - double* A, int lda, double* X, - int incX, double beta, double* Y, int incY ) ; -FUNCTION: void cblas_dtrmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, double* A, int lda, - double* X, int incX ) ; -FUNCTION: void cblas_dtbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, int K, double* A, int lda, - double* X, int incX ) ; -FUNCTION: void cblas_dtpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, double* Ap, double* X, int incX ) ; -FUNCTION: void cblas_dtrsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, double* A, int lda, double* X, - int incX ) ; -FUNCTION: void cblas_dtbsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, int K, double* A, int lda, - double* X, int incX ) ; -FUNCTION: void cblas_dtpsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, double* Ap, double* X, int incX ) ; - -FUNCTION: void cblas_cgemv ( CBLAS_ORDER Order, - CBLAS_TRANSPOSE TransA, int M, int N, - void* alpha, void* A, int lda, - void* X, int incX, void* beta, - void* Y, int incY ) ; -FUNCTION: void cblas_cgbmv ( CBLAS_ORDER Order, - CBLAS_TRANSPOSE TransA, int M, int N, - int KL, int KU, void* alpha, - void* A, int lda, void* X, - int incX, void* beta, void* Y, int incY ) ; -FUNCTION: void cblas_ctrmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, void* A, int lda, - void* X, int incX ) ; -FUNCTION: void cblas_ctbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, int K, void* A, int lda, - void* X, int incX ) ; -FUNCTION: void cblas_ctpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, void* Ap, void* X, int incX ) ; -FUNCTION: void cblas_ctrsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, void* A, int lda, void* X, - int incX ) ; -FUNCTION: void cblas_ctbsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, int K, void* A, int lda, - void* X, int incX ) ; -FUNCTION: void cblas_ctpsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, void* Ap, void* X, int incX ) ; - -FUNCTION: void cblas_zgemv ( CBLAS_ORDER Order, - CBLAS_TRANSPOSE TransA, int M, int N, - void* alpha, void* A, int lda, - void* X, int incX, void* beta, - void* Y, int incY ) ; -FUNCTION: void cblas_zgbmv ( CBLAS_ORDER Order, - CBLAS_TRANSPOSE TransA, int M, int N, - int KL, int KU, void* alpha, - void* A, int lda, void* X, - int incX, void* beta, void* Y, int incY ) ; -FUNCTION: void cblas_ztrmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, void* A, int lda, - void* X, int incX ) ; -FUNCTION: void cblas_ztbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, int K, void* A, int lda, - void* X, int incX ) ; -FUNCTION: void cblas_ztpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, void* Ap, void* X, int incX ) ; -FUNCTION: void cblas_ztrsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, void* A, int lda, void* X, - int incX ) ; -FUNCTION: void cblas_ztbsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, int K, void* A, int lda, - void* X, int incX ) ; -FUNCTION: void cblas_ztpsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, void* Ap, void* X, int incX ) ; - - -FUNCTION: void cblas_ssymv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, float alpha, float* A, - int lda, float* X, int incX, - float beta, float* Y, int incY ) ; -FUNCTION: void cblas_ssbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, int K, float alpha, float* A, - int lda, float* X, int incX, - float beta, float* Y, int incY ) ; -FUNCTION: void cblas_sspmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, float alpha, float* Ap, - float* X, int incX, - float beta, float* Y, int incY ) ; -FUNCTION: void cblas_sger ( CBLAS_ORDER Order, int M, int N, - float alpha, float* X, int incX, - float* Y, int incY, float* A, int lda ) ; -FUNCTION: void cblas_ssyr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, float alpha, float* X, - int incX, float* A, int lda ) ; -FUNCTION: void cblas_sspr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, float alpha, float* X, - int incX, float* Ap ) ; -FUNCTION: void cblas_ssyr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, float alpha, float* X, - int incX, float* Y, int incY, float* A, - int lda ) ; -FUNCTION: void cblas_sspr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, float alpha, float* X, - int incX, float* Y, int incY, float* A ) ; - -FUNCTION: void cblas_dsymv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, double alpha, double* A, - int lda, double* X, int incX, - double beta, double* Y, int incY ) ; -FUNCTION: void cblas_dsbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, int K, double alpha, double* A, - int lda, double* X, int incX, - double beta, double* Y, int incY ) ; -FUNCTION: void cblas_dspmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, double alpha, double* Ap, - double* X, int incX, - double beta, double* Y, int incY ) ; -FUNCTION: void cblas_dger ( CBLAS_ORDER Order, int M, int N, - double alpha, double* X, int incX, - double* Y, int incY, double* A, int lda ) ; -FUNCTION: void cblas_dsyr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, double alpha, double* X, - int incX, double* A, int lda ) ; -FUNCTION: void cblas_dspr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, double alpha, double* X, - int incX, double* Ap ) ; -FUNCTION: void cblas_dsyr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, double alpha, double* X, - int incX, double* Y, int incY, double* A, - int lda ) ; -FUNCTION: void cblas_dspr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, double alpha, double* X, - int incX, double* Y, int incY, double* A ) ; - - -FUNCTION: void cblas_chemv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, void* alpha, void* A, - int lda, void* X, int incX, - void* beta, void* Y, int incY ) ; -FUNCTION: void cblas_chbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, int K, void* alpha, void* A, - int lda, void* X, int incX, - void* beta, void* Y, int incY ) ; -FUNCTION: void cblas_chpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, void* alpha, void* Ap, - void* X, int incX, - void* beta, void* Y, int incY ) ; -FUNCTION: void cblas_cgeru ( CBLAS_ORDER Order, int M, int N, - void* alpha, void* X, int incX, - void* Y, int incY, void* A, int lda ) ; -FUNCTION: void cblas_cgerc ( CBLAS_ORDER Order, int M, int N, - void* alpha, void* X, int incX, - void* Y, int incY, void* A, int lda ) ; -FUNCTION: void cblas_cher ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, float alpha, void* X, int incX, - void* A, int lda ) ; -FUNCTION: void cblas_chpr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, float alpha, void* X, - int incX, void* A ) ; -FUNCTION: void cblas_cher2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, int N, - void* alpha, void* X, int incX, - void* Y, int incY, void* A, int lda ) ; -FUNCTION: void cblas_chpr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, int N, - void* alpha, void* X, int incX, - void* Y, int incY, void* Ap ) ; - -FUNCTION: void cblas_zhemv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, void* alpha, void* A, - int lda, void* X, int incX, - void* beta, void* Y, int incY ) ; -FUNCTION: void cblas_zhbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, int K, void* alpha, void* A, - int lda, void* X, int incX, - void* beta, void* Y, int incY ) ; -FUNCTION: void cblas_zhpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, void* alpha, void* Ap, - void* X, int incX, - void* beta, void* Y, int incY ) ; -FUNCTION: void cblas_zgeru ( CBLAS_ORDER Order, int M, int N, - void* alpha, void* X, int incX, - void* Y, int incY, void* A, int lda ) ; -FUNCTION: void cblas_zgerc ( CBLAS_ORDER Order, int M, int N, - void* alpha, void* X, int incX, - void* Y, int incY, void* A, int lda ) ; -FUNCTION: void cblas_zher ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, double alpha, void* X, int incX, - void* A, int lda ) ; -FUNCTION: void cblas_zhpr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, double alpha, void* X, - int incX, void* A ) ; -FUNCTION: void cblas_zher2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, int N, - void* alpha, void* X, int incX, - void* Y, int incY, void* A, int lda ) ; -FUNCTION: void cblas_zhpr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, int N, - void* alpha, void* X, int incX, - void* Y, int incY, void* Ap ) ; - -! Level 3 BLAS (matrix-matrix) - -FUNCTION: void cblas_sgemm ( CBLAS_ORDER Order, CBLAS_TRANSPOSE TransA, - CBLAS_TRANSPOSE TransB, int M, int N, - int K, float alpha, float* A, - int lda, float* B, int ldb, - float beta, float* C, int ldc ) ; -FUNCTION: void cblas_ssymm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, int M, int N, - float alpha, float* A, int lda, - float* B, int ldb, float beta, - float* C, int ldc ) ; -FUNCTION: void cblas_ssyrk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - float alpha, float* A, int lda, - float beta, float* C, int ldc ) ; -FUNCTION: void cblas_ssyr2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - float alpha, float* A, int lda, - float* B, int ldb, float beta, - float* C, int ldc ) ; -FUNCTION: void cblas_strmm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, - CBLAS_DIAG Diag, int M, int N, - float alpha, float* A, int lda, - float* B, int ldb ) ; -FUNCTION: void cblas_strsm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, - CBLAS_DIAG Diag, int M, int N, - float alpha, float* A, int lda, - float* B, int ldb ) ; - -FUNCTION: void cblas_dgemm ( CBLAS_ORDER Order, CBLAS_TRANSPOSE TransA, - CBLAS_TRANSPOSE TransB, int M, int N, - int K, double alpha, double* A, - int lda, double* B, int ldb, - double beta, double* C, int ldc ) ; -FUNCTION: void cblas_dsymm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, int M, int N, - double alpha, double* A, int lda, - double* B, int ldb, double beta, - double* C, int ldc ) ; -FUNCTION: void cblas_dsyrk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - double alpha, double* A, int lda, - double beta, double* C, int ldc ) ; -FUNCTION: void cblas_dsyr2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - double alpha, double* A, int lda, - double* B, int ldb, double beta, - double* C, int ldc ) ; -FUNCTION: void cblas_dtrmm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, - CBLAS_DIAG Diag, int M, int N, - double alpha, double* A, int lda, - double* B, int ldb ) ; -FUNCTION: void cblas_dtrsm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, - CBLAS_DIAG Diag, int M, int N, - double alpha, double* A, int lda, - double* B, int ldb ) ; - -FUNCTION: void cblas_cgemm ( CBLAS_ORDER Order, CBLAS_TRANSPOSE TransA, - CBLAS_TRANSPOSE TransB, int M, int N, - int K, void* alpha, void* A, - int lda, void* B, int ldb, - void* beta, void* C, int ldc ) ; -FUNCTION: void cblas_csymm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, int M, int N, - void* alpha, void* A, int lda, - void* B, int ldb, void* beta, - void* C, int ldc ) ; -FUNCTION: void cblas_csyrk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - void* alpha, void* A, int lda, - void* beta, void* C, int ldc ) ; -FUNCTION: void cblas_csyr2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - void* alpha, void* A, int lda, - void* B, int ldb, void* beta, - void* C, int ldc ) ; -FUNCTION: void cblas_ctrmm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, - CBLAS_DIAG Diag, int M, int N, - void* alpha, void* A, int lda, - void* B, int ldb ) ; -FUNCTION: void cblas_ctrsm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, - CBLAS_DIAG Diag, int M, int N, - void* alpha, void* A, int lda, - void* B, int ldb ) ; - -FUNCTION: void cblas_zgemm ( CBLAS_ORDER Order, CBLAS_TRANSPOSE TransA, - CBLAS_TRANSPOSE TransB, int M, int N, - int K, void* alpha, void* A, - int lda, void* B, int ldb, - void* beta, void* C, int ldc ) ; -FUNCTION: void cblas_zsymm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, int M, int N, - void* alpha, void* A, int lda, - void* B, int ldb, void* beta, - void* C, int ldc ) ; -FUNCTION: void cblas_zsyrk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - void* alpha, void* A, int lda, - void* beta, void* C, int ldc ) ; -FUNCTION: void cblas_zsyr2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - void* alpha, void* A, int lda, - void* B, int ldb, void* beta, - void* C, int ldc ) ; -FUNCTION: void cblas_ztrmm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, - CBLAS_DIAG Diag, int M, int N, - void* alpha, void* A, int lda, - void* B, int ldb ) ; -FUNCTION: void cblas_ztrsm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, - CBLAS_DIAG Diag, int M, int N, - void* alpha, void* A, int lda, - void* B, int ldb ) ; - -FUNCTION: void cblas_chemm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, int M, int N, - void* alpha, void* A, int lda, - void* B, int ldb, void* beta, - void* C, int ldc ) ; -FUNCTION: void cblas_cherk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - float alpha, void* A, int lda, - float beta, void* C, int ldc ) ; -FUNCTION: void cblas_cher2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - void* alpha, void* A, int lda, - void* B, int ldb, float beta, - void* C, int ldc ) ; -FUNCTION: void cblas_zhemm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, int M, int N, - void* alpha, void* A, int lda, - void* B, int ldb, void* beta, - void* C, int ldc ) ; -FUNCTION: void cblas_zherk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - double alpha, void* A, int lda, - double beta, void* C, int ldc ) ; -FUNCTION: void cblas_zher2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - void* alpha, void* A, int lda, - void* B, int ldb, double beta, - void* C, int ldc ) ; - diff --git a/basis/math/blas/cblas/summary.txt b/basis/math/blas/cblas/summary.txt deleted file mode 100644 index c72e78eb0d..0000000000 --- a/basis/math/blas/cblas/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Low-level bindings to the C Basic Linear Algebra Subroutines (BLAS) library diff --git a/basis/math/blas/cblas/tags.txt b/basis/math/blas/cblas/tags.txt deleted file mode 100644 index 241ec1ecda..0000000000 --- a/basis/math/blas/cblas/tags.txt +++ /dev/null @@ -1,2 +0,0 @@ -math -bindings diff --git a/basis/math/blas/matrices/matrices-docs.factor b/basis/math/blas/matrices/matrices-docs.factor index b6e118836e..17d2f9ccd1 100644 --- a/basis/math/blas/matrices/matrices-docs.factor +++ b/basis/math/blas/matrices/matrices-docs.factor @@ -8,7 +8,7 @@ ARTICLE: "math.blas-summary" "Basic Linear Algebra Subroutines (BLAS) interface" { $subsection "math.blas.vectors" } "Vector-matrix and matrix-matrix operations are available in the " { $vocab-link "math.blas.matrices" } " vocabulary:" { $subsection "math.blas.matrices" } -"The low-level BLAS C interface can be accessed directly through the " { $vocab-link "math.blas.cblas" } " vocabulary." ; +"The low-level BLAS Fortran interface can be accessed directly through the " { $vocab-link "math.blas.ffi" } " vocabulary." ; ARTICLE: "math.blas-types" "BLAS interface types" "BLAS vectors come in single- and double-precision, real and complex flavors:" From bfc2af7ea13679158f5a88df190f4730b5dde946 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 17:22:43 -0600 Subject: [PATCH 30/38] remove unnecessary calls to underlying>> from math.blas --- basis/math/blas/vectors/vectors.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor index a373ec7c5a..84b5fd9e6f 100755 --- a/basis/math/blas/vectors/vectors.factor +++ b/basis/math/blas/vectors/vectors.factor @@ -33,7 +33,7 @@ GENERIC: (blas-direct-array) ( blas-vector -- direct-array ) : shorter-length ( v1 v2 -- length ) [ length>> ] bi@ min ; inline : data-and-inc ( v -- data inc ) - [ underlying>> ] [ inc>> ] bi ; inline + [ ] [ inc>> ] bi ; inline : datas-and-incs ( v1 v2 -- v1-data v1-inc v2-data v2-inc ) [ data-and-inc ] bi@ ; inline From fecc9890985d2d75f04de117356e4f85f616ebfd Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 17:23:56 -0600 Subject: [PATCH 31/38] get rid of underlying>>s, again --- basis/math/blas/matrices/matrices.factor | 28 ++++++++++++------------ 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/basis/math/blas/matrices/matrices.factor b/basis/math/blas/matrices/matrices.factor index 6a948b6fe1..6fad545501 100755 --- a/basis/math/blas/matrices/matrices.factor +++ b/basis/math/blas/matrices/matrices.factor @@ -47,19 +47,19 @@ GENERIC: (blas-matrix-like) ( data ld rows cols transpose exemplar -- matrix ) A rows>> A cols>> alpha - A underlying>> + A A ld>> - x underlying>> + x x inc>> beta - y underlying>> + y y inc>> y ; inline : (validate-ger) ( x y A -- ) { - [ nip [ length>> ] [ Mheight ] bi* = ] - [ nipd [ length>> ] [ Mwidth ] bi* = ] + [ [ length>> ] [ drop ] [ Mheight ] tri* = ] + [ [ drop ] [ length>> ] [ Mwidth ] tri* = ] } 3&& [ "Mismatched vertices and matrix in vector outer product" throw ] unless ; @@ -71,19 +71,19 @@ GENERIC: (blas-matrix-like) ( data ld rows cols transpose exemplar -- matrix ) A rows>> A cols>> alpha - x underlying>> + x x inc>> - y underlying>> + y y inc>> - A underlying>> + A A ld>> A f >>transpose ; inline : (validate-gemm) ( A B C -- ) { - [ drop [ Mwidth ] [ Mheight ] bi* = ] - [ nip [ Mheight ] bi@ = ] - [ nipd [ Mwidth ] bi@ = ] + [ [ Mwidth ] [ Mheight ] [ drop ] tri* = ] + [ [ Mheight ] [ drop ] [ Mheight ] tri* = ] + [ [ drop ] [ Mwidth ] [ Mwidth ] tri* = ] } 3&& [ "Mismatched matrices in matrix multiplication" throw ] unless ; @@ -98,12 +98,12 @@ GENERIC: (blas-matrix-like) ( data ld rows cols transpose exemplar -- matrix ) C cols>> A Mwidth alpha - A underlying>> + A A ld>> - B underlying>> + B B ld>> beta - C underlying>> + C C ld>> C f >>transpose ; inline From 296a1ce0a93e9c66dd0220e436df76c7b31c9ddc Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 17:26:12 -0600 Subject: [PATCH 32/38] unit tests for complex specialized-arrays --- .../complex-double/complex-double-tests.factor | 13 +++++++++++++ 1 file changed, 13 insertions(+) create mode 100644 basis/specialized-arrays/complex-double/complex-double-tests.factor diff --git a/basis/specialized-arrays/complex-double/complex-double-tests.factor b/basis/specialized-arrays/complex-double/complex-double-tests.factor new file mode 100644 index 0000000000..9f2bcc99b7 --- /dev/null +++ b/basis/specialized-arrays/complex-double/complex-double-tests.factor @@ -0,0 +1,13 @@ +USING: kernel sequences specialized-arrays.complex-double tools.test ; +IN: specialized-arrays.complex-double.tests + +[ C{ 3.0 2.0 } ] +[ complex-double-array{ 1.0 C{ 3.0 2.0 } 5.0 } second ] unit-test + +[ C{ 1.0 0.0 } ] +[ complex-double-array{ 1.0 C{ 3.0 2.0 } 5.0 } first ] unit-test + +[ complex-double-array{ 1.0 C{ 6.0 -7.0 } 5.0 } ] [ + complex-double-array{ 1.0 C{ 3.0 2.0 } 5.0 } + dup [ C{ 6.0 -7.0 } 1 ] dip set-nth +] unit-test From 4ee82b19f66a4b6ac27a946466cc3d68442c2bbf Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 17:47:55 -0600 Subject: [PATCH 33/38] rewrite shuffle( -- ) to avoid locals primitives --- basis/shuffle/shuffle.factor | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/basis/shuffle/shuffle.factor b/basis/shuffle/shuffle.factor index 632c09e338..d375ec9c20 100644 --- a/basis/shuffle/shuffle.factor +++ b/basis/shuffle/shuffle.factor @@ -1,23 +1,22 @@ ! Copyright (C) 2007 Chris Double, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs effects.parser generalizations +USING: accessors assocs combinators effects.parser generalizations hashtables kernel locals locals.backend macros make math parser sequences ; IN: shuffle locals-assoc ( sequence -- assoc ) - dup length dup 1- [ - ] curry map zip >hashtable ; +: >index-assoc ( sequence -- assoc ) + dup length zip >hashtable ; PRIVATE> MACRO: shuffle-effect ( effect -- ) - [ out>> ] [ in>> >locals-assoc ] bi + [ out>> ] [ in>> >index-assoc ] bi [ - [ nip assoc-size , \ load-locals , ] - [ [ at , \ get-local , ] curry each ] - [ nip assoc-size , \ drop-locals , ] 2tri + [ nip assoc-size , \ narray , ] + [ [ at \ swap \ nth [ ] 3sequence ] curry map , \ cleave , ] 2bi ] [ ] make ; : shuffle( From b5a96dccdf7f44ce9f3df5eac2d2f5767dc3c6ef Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 9 Feb 2009 18:36:36 -0600 Subject: [PATCH 34/38] Slight cleanup in xml-rpc --- basis/xml-rpc/xml-rpc.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/xml-rpc/xml-rpc.factor b/basis/xml-rpc/xml-rpc.factor index 9632cbb1ac..690ebe94f8 100644 --- a/basis/xml-rpc/xml-rpc.factor +++ b/basis/xml-rpc/xml-rpc.factor @@ -126,11 +126,11 @@ TAG: int xml>item children>number ; TAG: double xml>item children>number ; TAG: boolean xml>item - dup children>string { - { [ dup "1" = ] [ 2drop t ] } - { [ "0" = ] [ drop f ] } + children>string { + { "1" [ t ] } + { "0" [ f ] } [ "Bad boolean" server-error ] - } cond ; + } case ; : unstruct-member ( tag -- ) children-tags first2 From 3672bcb08f12e4d4059d988152c9fc3956adab08 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 18:39:46 -0600 Subject: [PATCH 35/38] loading some tiff files works! --- extra/graphics/tiff/tiff.factor | 6 ++++-- extra/graphics/viewer/viewer.factor | 30 ++++++++++++++++++++++------- 2 files changed, 27 insertions(+), 9 deletions(-) diff --git a/extra/graphics/tiff/tiff.factor b/extra/graphics/tiff/tiff.factor index 9461403805..b4e57d4ed6 100755 --- a/extra/graphics/tiff/tiff.factor +++ b/extra/graphics/tiff/tiff.factor @@ -14,6 +14,7 @@ the-answer ifd-offset ifds ; + CONSTRUCTOR: tiff ( -- tiff ) V{ } clone >>ifds ; @@ -327,8 +328,9 @@ ERROR: bad-small-ifd-type n ; dup ifd-entries>> [ process-ifd-entry [ class ] keep ] H{ } map>assoc >>processed-tags ; +: strips>buffer ( ifd -- ifd ) + dup strips>> concat >>buffer ; /* -: ifd-strips>buffer ( ifd -- ifd ) [ [ rows-per-strip find-tag n>> ] [ image-length find-tag n>> ] bi @@ -342,7 +344,7 @@ ERROR: bad-small-ifd-type n ; read-header [ read-ifds - dup ifds>> [ process-ifd read-strips drop ] each + dup ifds>> [ process-ifd read-strips strips>buffer drop ] each ] with-tiff-endianness ] with-file-reader ; diff --git a/extra/graphics/viewer/viewer.factor b/extra/graphics/viewer/viewer.factor index 8e0b1ec43c..90425722da 100644 --- a/extra/graphics/viewer/viewer.factor +++ b/extra/graphics/viewer/viewer.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays combinators graphics.bitmap kernel math math.functions namespaces opengl opengl.gl ui ui.gadgets -ui.gadgets.panes ui.render ; +ui.gadgets.panes ui.render graphics.tiff sequences ; IN: graphics.viewer TUPLE: graphics-gadget < gadget image ; @@ -21,6 +21,14 @@ M: graphics-gadget draw-gadget* ( gadget -- ) \ graphics-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 draw-image ( bitmap -- ) dup height>> 0 < [ 0 0 glRasterPos2i @@ -32,12 +40,7 @@ M: bitmap draw-image ( bitmap -- ) [ width>> ] keep [ [ height>> abs ] keep - bit-count>> { - { 32 [ GL_BGRA GL_UNSIGNED_BYTE ] } - { 24 [ GL_BGR GL_UNSIGNED_BYTE ] } - { 8 [ GL_BGR GL_UNSIGNED_BYTE ] } - { 4 [ GL_BGR GL_UNSIGNED_BYTE ] } - } case + bit-count>> bits>gl-params ] keep array>> glDrawPixels ; M: bitmap width ( bitmap -- ) width>> ; @@ -48,3 +51,16 @@ M: bitmap height ( bitmap -- ) height>> ; : bitmap-window ( path -- gadget ) load-bitmap [ "bitmap" open-window ] keep ; + +M: tiff width ( tiff -- ) ifds>> first image-width find-tag n>> ; +M: tiff height ( tiff -- ) ifds>> first image-length find-tag n>> ; + +M: tiff draw-image ( tiff -- ) + [ 0 0 glRasterPos2i 1.0 -1.0 glPixelZoom ] dip + ifds>> first + { + [ image-width find-tag n>> ] + [ image-length find-tag n>> ] + [ bits-per-sample find-tag n>> sum bits>gl-params ] + [ buffer>> ] + } cleave glDrawPixels ; From 03f7a72d41fb448943f771b3a5f535f6560bbfb8 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 18:44:36 -0600 Subject: [PATCH 36/38] alien.fortran docs --- basis/alien/fortran/fortran-docs.factor | 56 +++++++++++++++++++++++++ 1 file changed, 56 insertions(+) create mode 100644 basis/alien/fortran/fortran-docs.factor diff --git a/basis/alien/fortran/fortran-docs.factor b/basis/alien/fortran/fortran-docs.factor new file mode 100644 index 0000000000..1b942d30c5 --- /dev/null +++ b/basis/alien/fortran/fortran-docs.factor @@ -0,0 +1,56 @@ +! Copyright (C) 2009 Joe Groff +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax kernel quotations sequences strings ; +QUALIFIED-WITH: alien.syntax c +IN: alien.fortran + +ARTICLE: "alien.fortran-types" "Fortran types" +"The Fortran FFI recognizes the following Fortran types:" +{ $list + { { $snippet "INTEGER" } " specifies a four-byte integer value. Sized integers can be specified with " { $snippet "INTEGER*1" } ", " { $snippet "INTEGER*2" } ", " { $snippet "INTEGER*4" } ", and " { $snippet "INTEGER*8" } "." } + { { $snippet "LOGICAL" } " specifies a four-byte boolean value. Sized booleans can be specified with " { $snippet "LOGICAL*1" } ", " { $snippet "LOGICAL*2" } ", " { $snippet "LOGICAL*4" } ", and " { $snippet "LOGICAL*8" } "." } + { { $snippet "REAL" } " specifies a single-precision floating-point real value." } + { { $snippet "DOUBLE-PRECISION" } " specifies a double-precision floating-point real value. The alias " { $snippet "REAL*8" } " is also recognized." } + { { $snippet "COMPLEX" } " specifies a single-precision floating-point complex value." } + { { $snippet "DOUBLE-COMPLEX" } " specifies a double-precision floating-point complex value. The alias " { $snippet "COMPLEX*16" } " is also recognized." } + { { $snippet "CHARACTER(n)" } " specifies a character string of length " { $snippet "n" } ". The Fortran 77 syntax " { $snippet "CHARACTER*n" } " is also recognized." } + { "Fortran arrays can be specified by suffixing a comma-separated set of dimensions in parentheses, e.g. " { $snippet "REAL(2,3,4)" } ". Arrays of unspecified length can be specified using " { $snippet "*" } " as a dimension. Arrays are passed in as flat " { $link "specialized-arrays" } "." } + { "Fortran records defined by " { $link POSTPONE: RECORD: } " and C structs defined by " { $link POSTPONE: c:C-STRUCT: } " are also supported as parameters." } +} +"When declaring the parameters of Fortran functions, an output argument can be specified by prefixing an exclamation point to the type name. This will cause the function word to leave the final value of the parameter on the stack." ; + +HELP: FUNCTION: +{ $syntax "FUNCTION: RETURN-TYPE NAME ( [!]ARGUMENT-TYPE NAME, ... ) ;" } +{ $description "Declares a Fortran function binding with the given return type and arguments. See " { $link "alien.fortran-types" } " for a list of supported types." } ; + +HELP: SUBROUTINE: +{ $syntax "SUBROUTINE: NAME ( [!]ARGUMENT-TYPE NAME, ... ) ;" } +{ $description "Declares a Fortran subroutine binding with the given arguments. See " { $link "alien.fortran-types" } " for a list of supported types." } ; + +HELP: LIBRARY: +{ $syntax "LIBRARY: name" } +{ $values { "name" "a logical library name" } } +{ $description "Sets the logical library for subsequent " { $link POSTPONE: FUNCTION: } " and " { $link POSTPONE: SUBROUTINE: } " definitions." } ; + +HELP: RECORD: +{ $syntax "RECORD: NAME { \"TYPE\" \"SLOT\" } ... ;" } +{ $description "Defines a Fortran record type with the given slots." } ; + +HELP: fortran-invoke +{ $values + { "return" string } { "library" string } { "procedure" string } { "parameters" sequence } +} +{ $description "Invokes the Fortran subroutine or function " { $snippet "procedure" } " in " { $snippet "library" } " with parameters specified by the " { $link "alien.fortran-types" } " specified in the " { $snippet "parameters" } " sequence. If the " { $snippet "return" } " value is " { $link f } ", no return value is expected, otherwise a return value of the specified Fortran type is expected. Input values are taken off the top of the datastack, and output values are left for the return value (if any) and any parameters specified as out parameters by prepending " { $snippet "\"!\"" } "." } +; + +ARTICLE: "alien.fortran" "Fortran FFI" +"The " { $vocab-link "alien.fortran" } " vocabulary provides an interface to code shared libraries written in Fortran." +{ $subsection "alien.fortran-types" } +{ $subsection POSTPONE: LIBRARY: } +{ $subsection POSTPONE: FUNCTION: } +{ $subsection POSTPONE: SUBROUTINE: } +{ $subsection POSTPONE: RECORD: } +{ $subsection fortran-invoke } +; + +ABOUT: "alien.fortran" From fbba25e968c0513605092fa1500fbcb8761a8540 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 19:16:46 -0600 Subject: [PATCH 37/38] clean up tiff --- extra/graphics/tiff/tiff.factor | 262 ++++++++++------------------ extra/graphics/viewer/viewer.factor | 10 +- 2 files changed, 96 insertions(+), 176 deletions(-) diff --git a/extra/graphics/tiff/tiff.factor b/extra/graphics/tiff/tiff.factor index b4e57d4ed6..0481af8747 100755 --- a/extra/graphics/tiff/tiff.factor +++ b/extra/graphics/tiff/tiff.factor @@ -4,183 +4,121 @@ USING: accessors combinators io io.encodings.binary io.files kernel pack endian tools.hexdump constructors sequences arrays sorting.slots math.order math.parser prettyprint classes io.binary assocs math math.bitwise byte-arrays grouping ; -USE: multiline - IN: graphics.tiff -TUPLE: tiff -endianness -the-answer -ifd-offset -ifds ; - +TUPLE: tiff endianness the-answer ifd-offset ifds ; CONSTRUCTOR: tiff ( -- tiff ) V{ } clone >>ifds ; TUPLE: ifd count ifd-entries next processed-tags strips buffer ; - CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ; TUPLE: ifd-entry tag type count offset/value ; - CONSTRUCTOR: ifd-entry ( tag type count offset/value -- ifd-entry ) ; - -TUPLE: photometric-interpretation color ; - -CONSTRUCTOR: photometric-interpretation ( color -- object ) ; - -SINGLETONS: white-is-zero black-is-zero rgb palette-color ; - +SINGLETONS: photometric-interpretation +photometric-interpretation-white-is-zero +photometric-interpretation-black-is-zero +photometric-interpretation-rgb +photometric-interpretation-palette-color ; ERROR: bad-photometric-interpretation n ; - : lookup-photometric-interpretation ( n -- singleton ) { - { 0 [ white-is-zero ] } - { 1 [ black-is-zero ] } - { 2 [ rgb ] } - { 3 [ palette-color ] } + { 0 [ photometric-interpretation-white-is-zero ] } + { 1 [ photometric-interpretation-black-is-zero ] } + { 2 [ photometric-interpretation-rgb ] } + { 3 [ photometric-interpretation-palette-color ] } [ bad-photometric-interpretation ] - } case ; - - -TUPLE: compression method ; - -CONSTRUCTOR: compression ( method -- object ) ; - -SINGLETONS: no-compression CCITT-2 pack-bits lzw ; + } case ; +SINGLETONS: compression +compression-none +compression-CCITT-2 +compression-lzw +compression-pack-bits ; ERROR: bad-compression n ; - : lookup-compression ( n -- compression ) { - { 1 [ no-compression ] } - { 2 [ CCITT-2 ] } - { 5 [ lzw ] } - { 32773 [ pack-bits ] } + { 1 [ compression-none ] } + { 2 [ compression-CCITT-2 ] } + { 5 [ compression-lzw ] } + { 32773 [ compression-pack-bits ] } [ bad-compression ] - } case ; - -TUPLE: image-length n ; -CONSTRUCTOR: image-length ( n -- object ) ; - -TUPLE: image-width n ; -CONSTRUCTOR: image-width ( n -- object ) ; - -TUPLE: x-resolution n ; -CONSTRUCTOR: x-resolution ( n -- object ) ; - -TUPLE: y-resolution n ; -CONSTRUCTOR: y-resolution ( n -- object ) ; - -TUPLE: rows-per-strip n ; -CONSTRUCTOR: rows-per-strip ( n -- object ) ; - -TUPLE: strip-offsets n ; -CONSTRUCTOR: strip-offsets ( n -- object ) ; - -TUPLE: strip-byte-counts n ; -CONSTRUCTOR: strip-byte-counts ( n -- object ) ; - -TUPLE: bits-per-sample n ; -CONSTRUCTOR: bits-per-sample ( n -- object ) ; - -TUPLE: samples-per-pixel n ; -CONSTRUCTOR: samples-per-pixel ( n -- object ) ; - -SINGLETONS: no-resolution-unit -inch-resolution-unit -centimeter-resolution-unit ; - -TUPLE: resolution-unit type ; -CONSTRUCTOR: resolution-unit ( type -- object ) ; + } case ; +SINGLETONS: resolution-unit +resolution-unit-none +resolution-unit-inch +resolution-unit-centimeter ; ERROR: bad-resolution-unit n ; - : lookup-resolution-unit ( n -- object ) { - { 1 [ no-resolution-unit ] } - { 2 [ inch-resolution-unit ] } - { 3 [ centimeter-resolution-unit ] } + { 1 [ resolution-unit-none ] } + { 2 [ resolution-unit-inch ] } + { 3 [ resolution-unit-centimeter ] } [ bad-resolution-unit ] - } case ; - - -TUPLE: predictor type ; -CONSTRUCTOR: predictor ( type -- object ) ; - -SINGLETONS: no-predictor horizontal-differencing-predictor ; + } case ; +SINGLETONS: predictor +predictor-none +predictor-horizontal-differencing ; ERROR: bad-predictor n ; - : lookup-predictor ( n -- object ) { - { 1 [ no-predictor ] } - { 2 [ horizontal-differencing-predictor ] } + { 1 [ predictor-none ] } + { 2 [ predictor-horizontal-differencing ] } [ bad-predictor ] - } case ; - - -TUPLE: planar-configuration type ; -CONSTRUCTOR: planar-configuration ( type -- object ) ; - -SINGLETONS: chunky planar ; + } case ; +SINGLETONS: planar-configuration +planar-configuration-chunky +planar-configuration-planar ; ERROR: bad-planar-configuration n ; - : lookup-planar-configuration ( n -- object ) { - { 1 [ no-predictor ] } - { 2 [ horizontal-differencing-predictor ] } - [ bad-predictor ] - } case ; + { 1 [ planar-configuration-chunky ] } + { 2 [ planar-configuration-planar ] } + [ bad-planar-configuration ] + } case ; -TUPLE: sample-format n ; -CONSTRUCTOR: sample-format ( n -- object ) ; ERROR: bad-sample-format n ; - -SINGLETONS: sample-unsigned-integer sample-signed-integer -sample-ieee-float sample-undefined-data ; - +SINGLETONS: sample-format +sample-format-unsigned-integer +sample-format-signed-integer +sample-format-ieee-float +sample-format-undefined-data ; : lookup-sample-format ( seq -- object ) [ { - { 1 [ sample-unsigned-integer ] } - { 2 [ sample-signed-integer ] } - { 3 [ sample-ieee-float ] } - { 4 [ sample-undefined-data ] } + { 1 [ sample-format-unsigned-integer ] } + { 2 [ sample-format-signed-integer ] } + { 3 [ sample-format-ieee-float ] } + { 4 [ sample-format-undefined-data ] } [ bad-sample-format ] } case - ] map ; + ] map ; - -TUPLE: extra-samples n ; -CONSTRUCTOR: extra-samples ( n -- object ) ; ERROR: bad-extra-samples n ; - -SINGLETONS: unspecified-alpha-data associated-alpha-data -unassociated-alpha-data ; - +SINGLETONS: extra-samples +extra-samples-unspecified-alpha-data +extra-samples-associated-alpha-data +extra-samples-unassociated-alpha-data ; : lookup-extra-samples ( seq -- object ) { - { 0 [ unspecified-alpha-data ] } - { 1 [ associated-alpha-data ] } - { 2 [ unassociated-alpha-data ] } + { 0 [ extra-samples-unspecified-alpha-data ] } + { 1 [ extra-samples-associated-alpha-data ] } + { 2 [ extra-samples-unassociated-alpha-data ] } [ bad-extra-samples ] - } case ; + } case ; - -TUPLE: orientation n ; -CONSTRUCTOR: orientation ( n -- object ) ; - - -TUPLE: new-subfile-type n ; -CONSTRUCTOR: new-subfile-type ( n -- object ) ; +SINGLETONS: image-length image-width x-resolution y-resolution +rows-per-strip strip-offsets strip-byte-counts bits-per-sample +samples-per-pixel new-subfile-type orientation +unhandled-ifd-entry ; ERROR: bad-tiff-magic bytes ; - : tiff-endianness ( byte-array -- ? ) { { B{ CHAR: M CHAR: M } [ big-endian ] } @@ -188,9 +126,6 @@ ERROR: bad-tiff-magic bytes ; [ bad-tiff-magic ] } case ; -: with-tiff-endianness ( tiff quot -- tiff ) - [ dup endianness>> ] dip with-endianness ; inline - : read-header ( tiff -- tiff ) 2 read tiff-endianness [ >>endianness ] keep [ @@ -198,9 +133,7 @@ ERROR: bad-tiff-magic bytes ; 4 read endian> >>ifd-offset ] with-endianness ; -: push-ifd ( tiff ifd -- tiff ) - over ifds>> push ; - ! over [ dup class ] [ ifds>> ] bi* set-at ; +: push-ifd ( tiff ifd -- tiff ) over ifds>> push ; : read-ifd ( -- ifd ) 2 read endian> @@ -221,23 +154,18 @@ ERROR: no-tag class ; dupd at* [ nip t ] [ drop f ] if ; inline : find-tag ( idf class -- tag ) - swap processed-tags>> - ?at [ no-tag ] unless ; + swap processed-tags>> ?at [ no-tag ] unless ; : read-strips ( ifd -- ifd ) dup - [ strip-byte-counts find-tag n>> ] - [ strip-offsets find-tag n>> ] bi + [ strip-byte-counts find-tag ] + [ strip-offsets find-tag ] bi 2dup [ integer? ] both? [ seek-absolute seek-input read 1array ] [ [ seek-absolute seek-input read ] { } 2map-as ] if >>strips ; -! ERROR: unhandled-ifd-entry data n ; - -: unhandled-ifd-entry ; - ERROR: unknown-ifd-type n ; : bytes>bits ( n/byte-array -- n ) @@ -301,51 +229,43 @@ ERROR: bad-small-ifd-type n ; [ type>> ] tri offset-bytes>obj ] if ; -: process-ifd-entry ( ifd-entry -- object ) +: process-ifd-entry ( ifd-entry -- value class ) [ ifd-entry-value ] [ tag>> ] bi { - { 254 [ ] } - { 256 [ ] } - { 257 [ ] } - { 258 [ ] } - { 259 [ lookup-compression ] } - { 262 [ lookup-photometric-interpretation ] } - { 273 [ ] } - { 274 [ ] } - { 277 [ ] } - { 278 [ ] } - { 279 [ ] } - { 282 [ ] } - { 283 [ ] } - { 284 [ ] } - { 296 [ lookup-resolution-unit ] } - { 317 [ lookup-predictor ] } - { 338 [ lookup-extra-samples ] } - { 339 [ lookup-sample-format ] } - [ unhandled-ifd-entry swap 2array ] + { 254 [ new-subfile-type ] } + { 256 [ image-width ] } + { 257 [ image-length ] } + { 258 [ bits-per-sample ] } + { 259 [ lookup-compression compression ] } + { 262 [ lookup-photometric-interpretation photometric-interpretation ] } + { 273 [ strip-offsets ] } + { 274 [ orientation ] } + { 277 [ samples-per-pixel ] } + { 278 [ rows-per-strip ] } + { 279 [ strip-byte-counts ] } + { 282 [ x-resolution ] } + { 283 [ y-resolution ] } + { 284 [ planar-configuration ] } + { 296 [ lookup-resolution-unit resolution-unit ] } + { 317 [ lookup-predictor predictor ] } + { 338 [ lookup-extra-samples extra-samples ] } + { 339 [ lookup-sample-format sample-format ] } + [ nip unhandled-ifd-entry ] } case ; : process-ifd ( ifd -- ifd ) dup ifd-entries>> - [ process-ifd-entry [ class ] keep ] H{ } map>assoc >>processed-tags ; + [ process-ifd-entry swap ] H{ } map>assoc >>processed-tags ; : strips>buffer ( ifd -- ifd ) dup strips>> concat >>buffer ; -/* - [ - [ rows-per-strip find-tag n>> ] - [ image-length find-tag n>> ] bi - ] [ - strips>> [ length ] keep - ] bi assemble-image ; -*/ : (load-tiff) ( path -- tiff ) binary [ - read-header [ + read-header dup endianness>> [ read-ifds dup ifds>> [ process-ifd read-strips strips>buffer drop ] each - ] with-tiff-endianness + ] with-endianness ] with-file-reader ; : load-tiff ( path -- tiff ) (load-tiff) ; diff --git a/extra/graphics/viewer/viewer.factor b/extra/graphics/viewer/viewer.factor index 90425722da..517ab4e010 100644 --- a/extra/graphics/viewer/viewer.factor +++ b/extra/graphics/viewer/viewer.factor @@ -52,15 +52,15 @@ M: bitmap height ( bitmap -- ) height>> ; : bitmap-window ( path -- gadget ) load-bitmap [ "bitmap" open-window ] keep ; -M: tiff width ( tiff -- ) ifds>> first image-width find-tag n>> ; -M: tiff height ( tiff -- ) ifds>> first image-length find-tag n>> ; +M: tiff width ( tiff -- ) ifds>> first image-width find-tag ; +M: tiff height ( tiff -- ) ifds>> first image-length find-tag ; M: tiff draw-image ( tiff -- ) [ 0 0 glRasterPos2i 1.0 -1.0 glPixelZoom ] dip ifds>> first { - [ image-width find-tag n>> ] - [ image-length find-tag n>> ] - [ bits-per-sample find-tag n>> sum bits>gl-params ] + [ image-width find-tag ] + [ image-length find-tag ] + [ bits-per-sample find-tag sum bits>gl-params ] [ buffer>> ] } cleave glDrawPixels ; From 045cd614c669a892a5c45ec3526c95f1f96f7d5c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 19:18:18 -0600 Subject: [PATCH 38/38] make more taxes vocabs load by default --- extra/taxes/usa/futa/futa.factor | 3 +-- extra/taxes/usa/usa.factor | 4 +++- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/extra/taxes/usa/futa/futa.factor b/extra/taxes/usa/futa/futa.factor index 7368aef825..9b862a8960 100644 --- a/extra/taxes/usa/futa/futa.factor +++ b/extra/taxes/usa/futa/futa.factor @@ -11,5 +11,4 @@ IN: taxes.usa.futa : futa-tax ( salary w4 -- x ) drop futa-base-rate min - futa-tax-rate futa-tax-offset-credit - - * ; + futa-tax-rate futa-tax-offset-credit - * ; diff --git a/extra/taxes/usa/usa.factor b/extra/taxes/usa/usa.factor index 27ff4aef98..efdb969c01 100644 --- a/extra/taxes/usa/usa.factor +++ b/extra/taxes/usa/usa.factor @@ -1,7 +1,9 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs kernel math math.intervals -namespaces sequences money math.order taxes.usa.w4 ; +namespaces sequences money math.order taxes.usa.w4 +taxes.usa.futa math.finance taxes.usa.fica +taxes.usa.federal ; IN: taxes.usa ! Withhold: FICA, Medicare, Federal (FICA is social security)