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

Merge branch 'master' into new_ui

db4
Slava Pestov 2009-02-09 20:30:44 -06:00
parent 0684a9b7b0 b32b666689
commit 8654bfe921
45 changed files with 1746 additions and 939 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/alien/arrays/arrays.factor Normal file → Executable file
View File

@ -26,7 +26,7 @@ M: array box-return drop "void*" box-return ;
M: array stack-size drop "void*" stack-size ; 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 ] ; M: array c-type-unboxer-quot drop [ >c-ptr ] ;

29
basis/alien/c-types/c-types.factor Normal file → Executable file
View File

@ -4,7 +4,7 @@ USING: byte-arrays arrays assocs kernel kernel.private libc math
namespaces make parser sequences strings words assocs splitting namespaces make parser sequences strings words assocs splitting
math.parser cpu.architecture alien alien.accessors quotations math.parser cpu.architecture alien alien.accessors quotations
layouts system compiler.units io.files io.encodings.binary 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 IN: alien.c-types
DEFER: <int> DEFER: <int>
@ -13,18 +13,20 @@ DEFER: *char
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable : little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
TUPLE: c-type TUPLE: c-type
class { class class initial: object }
boxer boxer-quot unboxer unboxer-quot boxer
getter setter { boxer-quot callable }
reg-class size align stack-align? ; unboxer
{ unboxer-quot callable }
: new-c-type ( class -- type ) { getter callable }
new { setter callable }
int-regs >>reg-class { reg-class initial: int-regs }
object >>class ; inline size
align
stack-align? ;
: <c-type> ( -- type ) : <c-type> ( -- type )
\ c-type new-c-type ; \ c-type new ;
SYMBOL: c-types SYMBOL: c-types
@ -185,6 +187,9 @@ M: f byte-length drop 0 ;
[ "Cannot read struct fields with this type" throw ] [ "Cannot read struct fields with this type" throw ]
] unless* ; ] unless* ;
: c-type-getter-boxer ( name -- quot )
[ c-getter ] [ c-type-boxer-quot ] bi append ;
: c-setter ( name -- quot ) : c-setter ( name -- quot )
c-type-setter [ c-type-setter [
[ "Cannot write struct fields with this type" throw ] [ "Cannot write struct fields with this type" throw ]
@ -221,7 +226,7 @@ M: f byte-length drop 0 ;
TUPLE: long-long-type < c-type ; TUPLE: long-long-type < c-type ;
: <long-long-type> ( -- type ) : <long-long-type> ( -- type )
long-long-type new-c-type ; long-long-type new ;
M: long-long-type unbox-parameter ( n type -- ) M: long-long-type unbox-parameter ( n type -- )
c-type-unboxer %unbox-long-long ; c-type-unboxer %unbox-long-long ;

2
basis/alien/complex/complex-tests.factor
View File

@ -15,4 +15,4 @@ C-STRUCT: complex-holder
C{ 1.0 2.0 } <complex-holder> "h" set C{ 1.0 2.0 } <complex-holder> "h" set
] unit-test ] unit-test
[ C{ 1.0 2.0 } ] [ "h" get complex-holder-z ] unit-test [ C{ 1.0 2.0 } ] [ "h" get complex-holder-z ] unit-test

14
basis/alien/complex/functor/functor.factor
View File

@ -12,15 +12,15 @@ T-imaginary DEFINES ${T}-imaginary
set-T-real DEFINES set-${T}-real set-T-real DEFINES set-${T}-real
set-T-imaginary DEFINES set-${T}-imaginary set-T-imaginary DEFINES set-${T}-imaginary
>T DEFINES >${T} <T> DEFINES <${T}>
T> DEFINES ${T}> *T DEFINES *${T}
WHERE WHERE
: >T ( z -- alien ) : <T> ( z -- alien )
>rect T <c-object> [ set-T-imaginary ] [ set-T-real ] [ ] tri ; inline >rect T <c-object> [ set-T-imaginary ] [ set-T-real ] [ ] tri ; inline
: T> ( alien -- z ) : *T ( alien -- z )
[ T-real ] [ T-imaginary ] bi rect> ; inline [ T-real ] [ T-imaginary ] bi rect> ; inline
T in get T in get
@ -28,8 +28,8 @@ T in get
define-struct define-struct
T c-type T c-type
T> 1quotation >>boxer-quot <T> 1quotation >>unboxer-quot
>T 1quotation >>unboxer-quot *T 1quotation >>boxer-quot
drop drop
;FUNCTOR ;FUNCTOR

0
basis/math/blas/cblas/authors.txt → basis/alien/fortran/authors.txt
View File

56
basis/alien/fortran/fortran-docs.factor Normal file
View File

@ -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"

295
basis/alien/fortran/fortran-tests.factor Normal file
View File

@ -0,0 +1,295 @@
! (c) 2009 Joe Groff, see BSD license
USING: accessors alien alien.c-types alien.complex
alien.fortran alien.strings alien.structs alien.syntax arrays
assocs byte-arrays combinators fry generalizations
io.encodings.ascii kernel macros macros.expander namespaces
sequences shuffle tools.test ;
IN: alien.fortran.tests
RECORD: FORTRAN_TEST_RECORD
{ "INTEGER" "FOO" }
{ "REAL(2)" "BAR" }
{ "CHARACTER*4" "BAS" } ;
! fortran-name>symbol-name
[ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test
[ "fun_times__" ] [ "Fun_Times" fortran-name>symbol-name ] unit-test
[ "funtimes___" ] [ "FunTimes_" fortran-name>symbol-name ] unit-test
! fortran-type>c-type
[ "short" ]
[ "integer*2" fortran-type>c-type ] unit-test
[ "int" ]
[ "integer*4" fortran-type>c-type ] unit-test
[ "int" ]
[ "INTEGER" fortran-type>c-type ] unit-test
[ "longlong" ]
[ "iNteger*8" fortran-type>c-type ] unit-test
[ "int[0]" ]
[ "integer(*)" fortran-type>c-type ] unit-test
[ "int[0]" ]
[ "integer(3,*)" fortran-type>c-type ] unit-test
[ "int[3]" ]
[ "integer(3)" fortran-type>c-type ] unit-test
[ "int[6]" ]
[ "integer(3,2)" fortran-type>c-type ] unit-test
[ "int[24]" ]
[ "integer(4,3,2)" fortran-type>c-type ] unit-test
[ "char[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
[ "complex-float" ]
[ "complex" fortran-type>c-type ] unit-test
[ "complex-double" ]
[ "double-complex" fortran-type>c-type ] unit-test
[ "complex-float" ]
[ "complex*8" fortran-type>c-type ] unit-test
[ "complex-double" ]
[ "complex*16" fortran-type>c-type ] unit-test
[ "fortran_test_record" ]
[ "fortran_test_record" fortran-type>c-type ] unit-test
! fortran-arg-type>c-type
[ "int*" { } ]
[ "integer" fortran-arg-type>c-type ] unit-test
[ "int*" { } ]
[ "integer(3)" fortran-arg-type>c-type ] unit-test
[ "int*" { } ]
[ "integer(*)" fortran-arg-type>c-type ] unit-test
[ "fortran_test_record*" { } ]
[ "fortran_test_record" fortran-arg-type>c-type ] unit-test
[ "char*" { "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
[ "float" { } ]
[ "real" fortran-ret-type>c-type ] unit-test
[ "double" { } ]
[ "double-precision" fortran-ret-type>c-type ] unit-test
[ "void" { "complex-float*" } ]
[ "complex" fortran-ret-type>c-type ] unit-test
[ "void" { "complex-double*" } ]
[ "double-complex" fortran-ret-type>c-type ] unit-test
[ "void" { "int*" } ]
[ "integer(*)" fortran-ret-type>c-type ] unit-test
[ "void" { "fortran_test_record*" } ]
[ "fortran_test_record" fortran-ret-type>c-type ] unit-test
! fortran-sig>c-sig
[ "float" { "int*" "char*" "float*" "double*" "long" } ]
[ "real" { "integer" "character*17" "real" "real*8" } fortran-sig>c-sig ]
unit-test
[ "void" { "char*" "long" "char*" "char*" "int*" "long" "long" } ]
[ "character*18" { "character*17" "character" "integer" } fortran-sig>c-sig ]
unit-test
[ "void" { "complex-float*" "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
! RECORD:
[ 16 ] [ "fortran_test_record" heap-size ] unit-test
[ 0 ] [ "foo" "fortran_test_record" offset-of ] unit-test
[ 4 ] [ "bar" "fortran_test_record" offset-of ] unit-test
[ 12 ] [ "bas" "fortran_test_record" offset-of ] unit-test
! (fortran-invoke)
[ [
! [fortran-args>c-args]
{
[ {
[ ascii string>alien ]
[ <longlong> ]
[ <float> ]
[ <complex-float> ]
[ 1 0 ? <short> ]
} spread ]
[ { [ length ] [ drop ] [ drop ] [ drop ] [ drop ] } spread ]
} 5 ncleave
! [fortran-invoke]
[
"void" "funpack" "funtimes_"
{ "char*" "longlong*" "float*" "complex-float*" "short*" "long" }
alien-invoke
] 6 nkeep
! [fortran-results>]
shuffle( aa ba ca da ea ab -- aa ab ba ca da ea )
{
[ drop ]
[ drop ]
[ drop ]
[ *float ]
[ drop ]
[ drop ]
} spread
] ] [
f "funpack" "FUNTIMES" { "CHARACTER*12" "INTEGER*8" "!REAL" "COMPLEX" "LOGICAL*2" }
(fortran-invoke)
] unit-test
[ [
! [fortran-args>c-args]
{
[ { [ ] } spread ]
[ { [ drop ] } spread ]
} 1 ncleave
! [fortran-invoke]
[ "float" "funpack" "fun_times__" { "float*" } alien-invoke ]
1 nkeep
! [fortran-results>]
shuffle( reta aa -- reta aa )
{ [ ] [ drop ] } spread
] ] [
"REAL" "funpack" "FUN_TIMES" { "REAL(*)" }
(fortran-invoke)
] unit-test
[ [
! [<fortran-result>]
[ "complex-float" <c-object> ] 1 ndip
! [fortran-args>c-args]
{ [ { [ ] } spread ] [ { [ drop ] } spread ] } 1 ncleave
! [fortran-invoke]
[
"void" "funpack" "fun_times__"
{ "complex-float*" "float*" }
alien-invoke
] 2 nkeep
! [fortran-results>]
shuffle( reta aa -- reta aa )
{ [ *complex-float ] [ drop ] } spread
] ] [
"COMPLEX" "funpack" "FUN_TIMES" { "REAL(*)" }
(fortran-invoke)
] unit-test
[ [
! [<fortran-result>]
[ 20 <byte-array> 20 ] 0 ndip
! [fortran-invoke]
[
"void" "funpack" "fun_times__"
{ "char*" "long" }
alien-invoke
] 2 nkeep
! [fortran-results>]
shuffle( reta retb -- reta retb )
{ [ ] [ ascii alien>nstring ] } spread
] ] [
"CHARACTER*20" "funpack" "FUN_TIMES" { }
(fortran-invoke)
] unit-test
[ [
! [<fortran-result>]
[ 10 <byte-array> 10 ] 3 ndip
! [fortran-args>c-args]
{
[ {
[ ascii string>alien ]
[ <float> ]
[ ascii string>alien ]
} spread ]
[ { [ length ] [ drop ] [ length ] } spread ]
} 3 ncleave
! [fortran-invoke]
[
"void" "funpack" "fun_times__"
{ "char*" "long" "char*" "float*" "char*" "long" "long" }
alien-invoke
] 7 nkeep
! [fortran-results>]
shuffle( reta retb aa ba ca ab cb -- reta retb aa ab ba ca cb )
{
[ ]
[ ascii alien>nstring ]
[ ]
[ ascii alien>nstring ]
[ *float ]
[ ]
[ ascii alien>nstring ]
} spread
] ] [
"CHARACTER*10" "funpack" "FUN_TIMES" { "!CHARACTER*20" "!REAL" "!CHARACTER*30" }
(fortran-invoke)
] unit-test

391
basis/alien/fortran/fortran.factor Normal file
View File

@ -0,0 +1,391 @@
! (c) 2009 Joe Groff, see BSD license
USING: accessors alien alien.c-types alien.complex alien.parser
alien.strings alien.structs alien.syntax arrays ascii assocs
byte-arrays combinators combinators.short-circuit fry generalizations
kernel lexer macros math math.parser namespaces parser sequences
splitting stack-checker vectors vocabs.parser words locals
io.encodings.ascii io.encodings.string shuffle effects math.ranges
math.order sorting system ;
IN: alien.fortran
! XXX this currently only supports the gfortran/f2c abi.
! XXX we should also support ifort at some point for commercial BLASes
<<
: 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 ;
: fortran-name>symbol-name ( fortran-name -- c-name )
>lower CHAR: _ over member?
[ "__" append ] [ "_" append ] if ;
ERROR: invalid-fortran-type type ;
DEFER: fortran-sig>c-sig
DEFER: fortran-ret-type>c-type
DEFER: fortran-arg-type>c-type
<PRIVATE
TUPLE: fortran-type dims size out? ;
TUPLE: number-type < fortran-type ;
TUPLE: integer-type < number-type ;
TUPLE: logical-type < integer-type ;
TUPLE: real-type < number-type ;
TUPLE: double-precision-type < number-type ;
TUPLE: character-type < fortran-type ;
TUPLE: misc-type < fortran-type name ;
TUPLE: complex-type < number-type ;
TUPLE: real-complex-type < complex-type ;
TUPLE: double-complex-type < complex-type ;
CONSTANT: fortran>c-types H{
{ "character" character-type }
{ "integer" integer-type }
{ "logical" logical-type }
{ "real" real-type }
{ "double-precision" double-precision-type }
{ "complex" real-complex-type }
{ "double-complex" double-complex-type }
}
: append-dimensions ( base-c-type type -- c-type )
dims>>
[ product number>string "[" "]" surround append ] when* ;
MACRO: size-case-type ( cases -- )
[ invalid-fortran-type ] suffix
'[ [ size>> _ case ] [ append-dimensions ] bi ] ;
: simple-type ( type base-c-type -- c-type )
swap
[ dup size>> [ invalid-fortran-type ] [ drop ] if ]
[ append-dimensions ] bi ;
: new-fortran-type ( out? dims size class -- type )
new [ [ (>>size) ] [ (>>dims) ] [ (>>out?) ] tri ] keep ;
GENERIC: (fortran-type>c-type) ( type -- c-type )
M: f (fortran-type>c-type) drop "void" ;
M: integer-type (fortran-type>c-type)
{
{ f [ "int" ] }
{ 1 [ "char" ] }
{ 2 [ "short" ] }
{ 4 [ "int" ] }
{ 8 [ "longlong" ] }
} size-case-type ;
M: real-type (fortran-type>c-type)
{
{ f [ "float" ] }
{ 4 [ "float" ] }
{ 8 [ "double" ] }
} size-case-type ;
M: real-complex-type (fortran-type>c-type)
{
{ f [ "complex-float" ] }
{ 8 [ "complex-float" ] }
{ 16 [ "complex-double" ] }
} size-case-type ;
M: double-precision-type (fortran-type>c-type)
"double" simple-type ;
M: double-complex-type (fortran-type>c-type)
"complex-double" simple-type ;
M: misc-type (fortran-type>c-type)
dup name>> simple-type ;
: 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-out ( string -- string' out? )
"!" ?head ;
: parse-dims ( string -- string' dim )
"(" split1 dup
[ ")" ?tail drop "," split [ [ blank? ] trim dimension>number ] map ] when ;
: parse-size ( string -- string' size )
"*" split1 dup [ string>number ] when ;
: (parse-fortran-type) ( fortran-type-string -- type )
parse-out swap parse-dims swap parse-size swap
dup >lower fortran>c-types at*
[ nip new-fortran-type ] [ drop misc-type boa ] if ;
: parse-fortran-type ( fortran-type-string/f -- type/f )
dup [ (parse-fortran-type) ] when ;
: c-type>pointer ( c-type -- c-type* )
"[" split1 drop "*" append ;
GENERIC: added-c-args ( type -- args )
M: fortran-type added-c-args drop { } ;
M: character-type added-c-args 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) ;
! 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
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 [ [ <int> ] [ drop ] ] }
{ 1 [ [ <char> ] [ drop ] ] }
{ 2 [ [ <short> ] [ drop ] ] }
{ 4 [ [ <int> ] [ drop ] ] }
{ 8 [ [ <longlong> ] [ drop ] ] }
[ invalid-fortran-type ]
} case
] args?dims ;
M: logical-type (fortran-arg>c-args)
[ call-next-method [ [ 1 0 ? ] prepend ] dip ] args?dims ;
M: real-type (fortran-arg>c-args)
[
size>> {
{ f [ [ <float> ] [ drop ] ] }
{ 4 [ [ <float> ] [ drop ] ] }
{ 8 [ [ <double> ] [ drop ] ] }
[ invalid-fortran-type ]
} case
] args?dims ;
M: real-complex-type (fortran-arg>c-args)
[
size>> {
{ f [ [ <complex-float> ] [ drop ] ] }
{ 8 [ [ <complex-float> ] [ drop ] ] }
{ 16 [ [ <complex-double> ] [ drop ] ] }
[ invalid-fortran-type ]
} case
] args?dims ;
M: double-precision-type (fortran-arg>c-args)
[ drop [ <double> ] [ drop ] ] args?dims ;
M: double-complex-type (fortran-arg>c-args)
[ drop [ <complex-double> ] [ drop ] ] args?dims ;
M: character-type (fortran-arg>c-args)
drop [ ascii string>alien ] [ length ] ;
M: misc-type (fortran-arg>c-args)
drop [ ] [ drop ] ;
GENERIC: (fortran-result>) ( type -- quots )
: result?dims ( type quot -- quot )
[ dup dims>> [ drop { [ ] } ] ] dip if ; inline
M: integer-type (fortran-result>)
[ size>> {
{ f [ { [ *int ] } ] }
{ 1 [ { [ *char ] } ] }
{ 2 [ { [ *short ] } ] }
{ 4 [ { [ *int ] } ] }
{ 8 [ { [ *longlong ] } ] }
[ invalid-fortran-type ]
} case ] result?dims ;
M: logical-type (fortran-result>)
[ call-next-method first [ zero? not ] append 1array ] result?dims ;
M: real-type (fortran-result>)
[ size>> {
{ f [ { [ *float ] } ] }
{ 4 [ { [ *float ] } ] }
{ 8 [ { [ *double ] } ] }
[ invalid-fortran-type ]
} case ] result?dims ;
M: real-complex-type (fortran-result>)
[ size>> {
{ f [ { [ *complex-float ] } ] }
{ 8 [ { [ *complex-float ] } ] }
{ 16 [ { [ *complex-double ] } ] }
[ invalid-fortran-type ]
} case ] result?dims ;
M: double-precision-type (fortran-result>)
[ drop { [ *double ] } ] result?dims ;
M: double-complex-type (fortran-result>)
[ drop { [ *complex-double ] } ] result?dims ;
M: character-type (fortran-result>)
drop { [ ] [ ascii alien>nstring ] } ;
M: misc-type (fortran-result>)
drop { [ ] } ;
GENERIC: (<fortran-result>) ( type -- quot )
M: fortran-type (<fortran-result>)
(fortran-type>c-type) \ <c-object> [ ] 2sequence ;
M: character-type (<fortran-result>)
fix-character-type dims>> product dup
[ \ <byte-array> ] dip [ ] 3sequence ;
: [<fortran-result>] ( return parameters -- quot )
[ parse-fortran-type ] dip
over returns-by-value?
[ 2drop [ ] ]
[ [ (<fortran-result>) ] [ length \ ndip [ ] 3sequence ] bi* ] if ;
: [fortran-args>c-args] ( parameters -- quot )
[ [ ] ] [
[ parse-fortran-type (fortran-arg>c-args) 2array ] map flip first2
[ [ \ spread [ ] 2sequence ] bi@ 2array ] [ length ] bi
\ ncleave [ ] 3sequence
] if-empty ;
:: [fortran-invoke] ( [args>args] return library function parameters -- [args>args] quot )
return parameters fortran-sig>c-sig :> c-parameters :> c-return
function fortran-name>symbol-name :> c-function
[args>args]
c-return library c-function c-parameters \ alien-invoke
5 [ ] nsequence
c-parameters length \ nkeep
[ ] 3sequence ;
: [fortran-out-param>] ( parameter -- quot )
parse-fortran-type
[ (fortran-result>) ] [ out?>> ] bi
[ ] [ [ drop [ drop ] ] map ] if ;
: [fortran-return>] ( return -- quot )
parse-fortran-type {
{ [ dup not ] [ drop { } ] }
{ [ dup returns-by-value? ] [ drop { [ ] } ] }
[ (fortran-result>) ]
} cond ;
: letters ( -- seq ) CHAR: a CHAR: z [a,b] ;
: (shuffle-map) ( return parameters -- ret par )
[
fortran-ret-type>c-type length swap "void" = [ 1+ ] unless
letters swap head [ "ret" swap suffix ] map
] [
[ fortran-arg-type>c-type nip length 1+ ] map letters swap zip
[ first2 letters swap head [ "" 2sequence ] with map ] map concat
] bi* ;
: (fortran-in-shuffle) ( ret par -- seq )
[ [ second ] bi@ <=> ] sort append ;
: (fortran-out-shuffle) ( ret par -- seq )
append ;
: [fortran-result-shuffle] ( return parameters -- quot )
(shuffle-map) [ (fortran-in-shuffle) ] [ (fortran-out-shuffle) ] 2bi <effect>
\ shuffle-effect [ ] 2sequence ;
: [fortran-results>] ( return parameters -- quot )
[ [fortran-result-shuffle] ]
[ drop [fortran-return>] ]
[ nip [ [fortran-out-param>] ] map concat ] 2tri
append
\ spread [ ] 2sequence append ;
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 )
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-arg-types>c-types ( fortran-types -- c-types )
[ length <vector> 1 <vector> ] keep
[ fortran-arg-type>c-type swapd [ suffix! ] [ append! ] 2bi* ] each
append >array ;
: fortran-sig>c-sig ( fortran-return fortran-args -- c-return c-args )
[ fortran-ret-type>c-type ] [ fortran-arg-types>c-types ] bi* append ;
: fortran-record>c-struct ( record -- struct )
[ first2 [ fortran-type>c-type ] [ >lower ] bi* 2array ] map ;
: define-fortran-record ( name vocab fields -- )
[ >lower ] [ ] [ fortran-record>c-struct ] tri* define-struct ;
: RECORD: scan in get parse-definition define-fortran-record ; parsing
: (fortran-invoke) ( return library function parameters -- quot )
{
[ 2nip [<fortran-result>] ]
[ nip nip nip [fortran-args>c-args] ]
[ [fortran-invoke] ]
[ 2nip [fortran-results>] ]
} 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 [ "void" ] unless* parse-arglist
[ \ fortran-invoke 5 [ ] nsequence ] dip define-declared ;
: SUBROUTINE:
f "c-library" get scan ";" parse-tokens
[ "()" subseq? not ] filter define-fortran-function ; parsing
: FUNCTION:
scan "c-library" get scan ";" parse-tokens
[ "()" subseq? not ] filter define-fortran-function ; parsing
: LIBRARY:
scan "c-library" set ; parsing

1
basis/alien/fortran/summary.txt Normal file
View File

@ -0,0 +1 @@
GNU Fortran/G77/F2C alien interface

2
basis/alien/fortran/tags.txt Normal file
View File

@ -0,0 +1,2 @@
fortran
ffi

5
basis/alien/structs/fields/fields.factor
View File

@ -58,10 +58,7 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ;
: define-getter ( type spec -- ) : define-getter ( type spec -- )
[ set-reader-props ] keep [ set-reader-props ] keep
[ reader>> ] [ reader>> ]
[ [ type>> c-type-getter-boxer ]
type>>
[ c-getter ] [ c-type-boxer-quot ] bi append
]
[ ] tri [ ] tri
(( c-ptr -- value )) define-struct-slot-word ; (( c-ptr -- value )) define-struct-slot-word ;

15
basis/alien/structs/structs-tests.factor Normal file → Executable file
View File

@ -42,3 +42,18 @@ C-UNION: barx
[ ] [ \ foox-x "help" get execute ] unit-test [ ] [ \ foox-x "help" get execute ] unit-test
[ ] [ \ set-foox-x "help" get execute ] unit-test [ ] [ \ set-foox-x "help" get execute ] unit-test
] when ] when
C-STRUCT: nested
{ "int" "x" } ;
C-STRUCT: nested-2
{ "nested" "y" } ;
[ 4 ] [
"nested-2" <c-object>
"nested" <c-object>
4 over set-nested-x
over set-nested-2-y
nested-2-y
nested-x
] unit-test

19
basis/alien/structs/structs.factor Normal file → Executable file
View File

@ -1,11 +1,19 @@
! Copyright (C) 2004, 2008 Slava Pestov. ! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! 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 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 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>> ; M: struct-type heap-size size>> ;
@ -68,3 +76,8 @@ M: struct-type stack-size
[ expand-constants ] map [ expand-constants ] map
[ [ heap-size ] [ max ] map-reduce ] keep [ [ heap-size ] [ max ] map-reduce ] keep
compute-struct-align f (define-struct) ; compute-struct-align f (define-struct) ;
: offset-of ( field struct -- offset )
c-types get at fields>>
[ name>> = ] with find nip offset>> ;

7
basis/io/launcher/windows/nt/nt-tests.factor Normal file → Executable file
View File

@ -37,11 +37,12 @@ IN: io.launcher.windows.nt.tests
"out.txt" temp-file ascii file-lines first "out.txt" temp-file ascii file-lines first
] unit-test ] unit-test
[ ] [ [ "( scratchpad ) " ] [
<process> <process>
console-vm "-run=listener" 2array >>command console-vm "-run=listener" 2array >>command
+closed+ >>stdin +closed+ >>stdin
try-process +stdout+ >>stderr
ascii [ input-stream get contents ] with-process-reader
] unit-test ] unit-test
: launcher-test-path ( -- str ) : launcher-test-path ( -- str )
@ -162,3 +163,5 @@ IN: io.launcher.windows.nt.tests
"append-test" temp-file ascii file-contents "append-test" temp-file ascii file-contents
] unit-test ] unit-test

574
basis/math/blas/cblas/cblas.factor
View File

@ -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 ) ;

1
basis/math/blas/cblas/summary.txt
View File

@ -1 +0,0 @@
Low-level bindings to the C Basic Linear Algebra Subroutines (BLAS) library

1
basis/math/blas/ffi/authors.txt Normal file
View File

@ -0,0 +1 @@
Joe Groff

520
basis/math/blas/ffi/ffi.factor Normal file
View File

@ -0,0 +1,520 @@
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(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ;
FUNCTION: REAL SDOT
( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ;
FUNCTION: DOUBLE-PRECISION DDOT
( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
FUNCTION: COMPLEX CDOTU
( INTEGER N, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ;
FUNCTION: COMPLEX CDOTC
( INTEGER N, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ;
FUNCTION: DOUBLE-COMPLEX ZDOTU
( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
FUNCTION: DOUBLE-COMPLEX ZDOTC
( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
FUNCTION: REAL SNRM2
( INTEGER N, REAL(*) X, INTEGER INCX ) ;
FUNCTION: REAL SASUM
( INTEGER N, REAL(*) X, INTEGER INCX ) ;
FUNCTION: DOUBLE-PRECISION DNRM2
( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
FUNCTION: DOUBLE-PRECISION DASUM
( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
FUNCTION: REAL SCNRM2
( INTEGER N, COMPLEX(*) X, INTEGER INCX ) ;
FUNCTION: REAL SCASUM
( INTEGER N, COMPLEX(*) X, INTEGER INCX ) ;
FUNCTION: DOUBLE-PRECISION DZNRM2
( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
FUNCTION: DOUBLE-PRECISION DZASUM
( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
FUNCTION: INTEGER ISAMAX
( INTEGER N, REAL(*) X, INTEGER INCX ) ;
FUNCTION: INTEGER IDAMAX
( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
FUNCTION: INTEGER ICAMAX
( INTEGER N, COMPLEX(*) X, INTEGER INCX ) ;
FUNCTION: INTEGER IZAMAX
( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
SUBROUTINE: SSWAP
( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ;
SUBROUTINE: SCOPY
( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ;
SUBROUTINE: SAXPY
( INTEGER N, REAL ALPHA, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ;
SUBROUTINE: DSWAP
( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
SUBROUTINE: DCOPY
( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
SUBROUTINE: DAXPY
( INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
SUBROUTINE: CSWAP
( INTEGER N, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ;
SUBROUTINE: CCOPY
( INTEGER N, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ;
SUBROUTINE: CAXPY
( INTEGER N, COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ;
SUBROUTINE: ZSWAP
( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
SUBROUTINE: ZCOPY
( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
SUBROUTINE: ZAXPY
( INTEGER N, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
SUBROUTINE: SSCAL
( INTEGER N, REAL ALPHA, REAL(*) X, INTEGER INCX ) ;
SUBROUTINE: DSCAL
( INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
SUBROUTINE: CSCAL
( INTEGER N, COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX ) ;
SUBROUTINE: ZSCAL
( INTEGER N, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
SUBROUTINE: CSSCAL
( INTEGER N, REAL ALPHA, COMPLEX(*) X, INTEGER INCX ) ;
SUBROUTINE: ZDSCAL
( INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
SUBROUTINE: SROTG
( REAL(*) A, REAL(*) B, REAL(*) C, REAL(*) S ) ;
SUBROUTINE: SROTMG
( REAL(*) D1, REAL(*) D2, REAL(*) B1, REAL B2, REAL(*) P ) ;
SUBROUTINE: SROT
( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY, REAL C, REAL S ) ;
SUBROUTINE: SROTM
( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY, REAL(*) P ) ;
SUBROUTINE: DROTG
( DOUBLE-PRECISION(*) A, DOUBLE-PRECISION(*) B, DOUBLE-PRECISION(*) C, DOUBLE-PRECISION(*) S ) ;
SUBROUTINE: DROTMG
( DOUBLE-PRECISION(*) D1, DOUBLE-PRECISION(*) D2, DOUBLE-PRECISION(*) B1, DOUBLE-PRECISION B2, DOUBLE-PRECISION(*) P ) ;
SUBROUTINE: DROT
( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION C, DOUBLE-PRECISION S ) ;
SUBROUTINE: DROTM
( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION(*) P ) ;
! LEVEL 2 BLAS (MATRIX-VECTOR)
SUBROUTINE: SGEMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
REAL ALPHA, REAL(*) A, INTEGER LDA,
REAL(*) X, INTEGER INCX, REAL BETA,
REAL(*) Y, INTEGER INCY ) ;
SUBROUTINE: SGBMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
INTEGER KL, INTEGER KU, REAL ALPHA,
REAL(*) A, INTEGER LDA, REAL(*) X,
INTEGER INCX, REAL BETA, REAL(*) Y, INTEGER INCY ) ;
SUBROUTINE: STRMV ( CHARACTER*1 UPLO,
CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
INTEGER N, REAL(*) A, INTEGER LDA,
REAL(*) X, INTEGER INCX ) ;
SUBROUTINE: STBMV ( CHARACTER*1 UPLO,
CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
INTEGER N, INTEGER K, REAL(*) A, INTEGER LDA,
REAL(*) X, INTEGER INCX ) ;
SUBROUTINE: STPMV ( CHARACTER*1 UPLO,
CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
INTEGER N, REAL(*) AP, REAL(*) X, INTEGER INCX ) ;
SUBROUTINE: STRSV ( CHARACTER*1 UPLO,
CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
INTEGER N, REAL(*) A, INTEGER LDA, REAL(*) X,
INTEGER INCX ) ;
SUBROUTINE: STBSV ( CHARACTER*1 UPLO,
CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
INTEGER N, INTEGER K, REAL(*) A, INTEGER LDA,
REAL(*) X, INTEGER INCX ) ;
SUBROUTINE: STPSV ( CHARACTER*1 UPLO,
CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
INTEGER N, REAL(*) AP, REAL(*) X, INTEGER INCX ) ;
SUBROUTINE: DGEMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA,
DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION BETA,
DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
SUBROUTINE: DGBMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
INTEGER KL, INTEGER KU, DOUBLE-PRECISION ALPHA,
DOUBLE-PRECISION(*) A, INTEGER LDA, DOUBLE-PRECISION(*) X,
INTEGER INCX, DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
SUBROUTINE: DTRMV ( CHARACTER*1 UPLO,
CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
INTEGER N, DOUBLE-PRECISION(*) A, INTEGER LDA,
DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
SUBROUTINE: DTBMV ( CHARACTER*1 UPLO,
CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
INTEGER N, INTEGER K, DOUBLE-PRECISION(*) A, INTEGER LDA,
DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
SUBROUTINE: DTPMV ( CHARACTER*1 UPLO,
CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
INTEGER N, DOUBLE-PRECISION(*) AP, DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
SUBROUTINE: DTRSV ( CHARACTER*1 UPLO,
CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
INTEGER N, DOUBLE-PRECISION(*) A, INTEGER LDA, DOUBLE-PRECISION(*) X,
INTEGER INCX ) ;
SUBROUTINE: DTBSV ( CHARACTER*1 UPLO,
CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
INTEGER N, INTEGER K, DOUBLE-PRECISION(*) A, INTEGER LDA,
DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
SUBROUTINE: DTPSV ( CHARACTER*1 UPLO,
CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
INTEGER N, DOUBLE-PRECISION(*) AP, DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
SUBROUTINE: CGEMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA,
COMPLEX(*) X, INTEGER INCX, COMPLEX BETA,
COMPLEX(*) Y, INTEGER INCY ) ;
SUBROUTINE: CGBMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
INTEGER KL, INTEGER KU, COMPLEX ALPHA,
COMPLEX(*) A, INTEGER LDA, COMPLEX(*) X,
INTEGER INCX, COMPLEX BETA, COMPLEX(*) Y, INTEGER INCY ) ;
SUBROUTINE: CTRMV ( CHARACTER*1 UPLO,
CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
INTEGER N, COMPLEX(*) A, INTEGER LDA,
COMPLEX(*) X, INTEGER INCX ) ;
SUBROUTINE: CTBMV ( CHARACTER*1 UPLO,
CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
INTEGER N, INTEGER K, COMPLEX(*) A, INTEGER LDA,
COMPLEX(*) X, INTEGER INCX ) ;
SUBROUTINE: CTPMV ( CHARACTER*1 UPLO,
CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
INTEGER N, COMPLEX(*) AP, COMPLEX(*) X, INTEGER INCX ) ;
SUBROUTINE: CTRSV ( CHARACTER*1 UPLO,
CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
INTEGER N, COMPLEX(*) A, INTEGER LDA, COMPLEX(*) X,
INTEGER INCX ) ;
SUBROUTINE: CTBSV ( CHARACTER*1 UPLO,
CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
INTEGER N, INTEGER K, COMPLEX(*) A, INTEGER LDA,
COMPLEX(*) X, INTEGER INCX ) ;
SUBROUTINE: CTPSV ( CHARACTER*1 UPLO,
CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
INTEGER N, COMPLEX(*) AP, COMPLEX(*) X, INTEGER INCX ) ;
SUBROUTINE: ZGEMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX BETA,
DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
SUBROUTINE: ZGBMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
INTEGER KL, INTEGER KU, DOUBLE-COMPLEX ALPHA,
DOUBLE-COMPLEX(*) A, INTEGER LDA, DOUBLE-COMPLEX(*) X,
INTEGER INCX, DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
SUBROUTINE: ZTRMV ( CHARACTER*1 UPLO,
CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
INTEGER N, DOUBLE-COMPLEX(*) A, INTEGER LDA,
DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
SUBROUTINE: ZTBMV ( CHARACTER*1 UPLO,
CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
INTEGER N, INTEGER K, DOUBLE-COMPLEX(*) A, INTEGER LDA,
DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
SUBROUTINE: ZTPMV ( CHARACTER*1 UPLO,
CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
INTEGER N, DOUBLE-COMPLEX(*) AP, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
SUBROUTINE: ZTRSV ( CHARACTER*1 UPLO,
CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
INTEGER N, DOUBLE-COMPLEX(*) A, INTEGER LDA, DOUBLE-COMPLEX(*) X,
INTEGER INCX ) ;
SUBROUTINE: ZTBSV ( CHARACTER*1 UPLO,
CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
INTEGER N, INTEGER K, DOUBLE-COMPLEX(*) A, INTEGER LDA,
DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
SUBROUTINE: ZTPSV ( CHARACTER*1 UPLO,
CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
INTEGER N, DOUBLE-COMPLEX(*) AP, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
SUBROUTINE: SSYMV ( CHARACTER*1 UPLO,
INTEGER N, REAL ALPHA, REAL(*) A,
INTEGER LDA, REAL(*) X, INTEGER INCX,
REAL BETA, REAL(*) Y, INTEGER INCY ) ;
SUBROUTINE: SSBMV ( CHARACTER*1 UPLO,
INTEGER N, INTEGER K, REAL ALPHA, REAL(*) A,
INTEGER LDA, REAL(*) X, INTEGER INCX,
REAL BETA, REAL(*) Y, INTEGER INCY ) ;
SUBROUTINE: SSPMV ( CHARACTER*1 UPLO,
INTEGER N, REAL ALPHA, REAL(*) AP,
REAL(*) X, INTEGER INCX,
REAL BETA, REAL(*) Y, INTEGER INCY ) ;
SUBROUTINE: SGER ( INTEGER M, INTEGER N,
REAL ALPHA, REAL(*) X, INTEGER INCX,
REAL(*) Y, INTEGER INCY, REAL(*) A, INTEGER LDA ) ;
SUBROUTINE: SSYR ( CHARACTER*1 UPLO,
INTEGER N, REAL ALPHA, REAL(*) X,
INTEGER INCX, REAL(*) A, INTEGER LDA ) ;
SUBROUTINE: SSPR ( CHARACTER*1 UPLO,
INTEGER N, REAL ALPHA, REAL(*) X,
INTEGER INCX, REAL(*) AP ) ;
SUBROUTINE: SSYR2 ( CHARACTER*1 UPLO,
INTEGER N, REAL ALPHA, REAL(*) X,
INTEGER INCX, REAL(*) Y, INTEGER INCY, REAL(*) A,
INTEGER LDA ) ;
SUBROUTINE: SSPR2 ( CHARACTER*1 UPLO,
INTEGER N, REAL ALPHA, REAL(*) X,
INTEGER INCX, REAL(*) Y, INTEGER INCY, REAL(*) A ) ;
SUBROUTINE: DSYMV ( CHARACTER*1 UPLO,
INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A,
INTEGER LDA, DOUBLE-PRECISION(*) X, INTEGER INCX,
DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
SUBROUTINE: DSBMV ( CHARACTER*1 UPLO,
INTEGER N, INTEGER K, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A,
INTEGER LDA, DOUBLE-PRECISION(*) X, INTEGER INCX,
DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
SUBROUTINE: DSPMV ( CHARACTER*1 UPLO,
INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) AP,
DOUBLE-PRECISION(*) X, INTEGER INCX,
DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
SUBROUTINE: DGER ( INTEGER M, INTEGER N,
DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X, INTEGER INCX,
DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION(*) A, INTEGER LDA ) ;
SUBROUTINE: DSYR ( CHARACTER*1 UPLO,
INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X,
INTEGER INCX, DOUBLE-PRECISION(*) A, INTEGER LDA ) ;
SUBROUTINE: DSPR ( CHARACTER*1 UPLO,
INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X,
INTEGER INCX, DOUBLE-PRECISION(*) AP ) ;
SUBROUTINE: DSYR2 ( CHARACTER*1 UPLO,
INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X,
INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION(*) A,
INTEGER LDA ) ;
SUBROUTINE: DSPR2 ( CHARACTER*1 UPLO,
INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X,
INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION(*) A ) ;
SUBROUTINE: CHEMV ( CHARACTER*1 UPLO,
INTEGER N, COMPLEX ALPHA, COMPLEX(*) A,
INTEGER LDA, COMPLEX(*) X, INTEGER INCX,
COMPLEX BETA, COMPLEX(*) Y, INTEGER INCY ) ;
SUBROUTINE: CHBMV ( CHARACTER*1 UPLO,
INTEGER N, INTEGER K, COMPLEX ALPHA, COMPLEX(*) A,
INTEGER LDA, COMPLEX(*) X, INTEGER INCX,
COMPLEX BETA, COMPLEX(*) Y, INTEGER INCY ) ;
SUBROUTINE: CHPMV ( CHARACTER*1 UPLO,
INTEGER N, COMPLEX ALPHA, COMPLEX(*) AP,
COMPLEX(*) X, INTEGER INCX,
COMPLEX BETA, COMPLEX(*) Y, INTEGER INCY ) ;
SUBROUTINE: CGERU ( INTEGER M, INTEGER N,
COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX,
COMPLEX(*) Y, INTEGER INCY, COMPLEX(*) A, INTEGER LDA ) ;
SUBROUTINE: CGERC ( INTEGER M, INTEGER N,
COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX,
COMPLEX(*) Y, INTEGER INCY, COMPLEX(*) A, INTEGER LDA ) ;
SUBROUTINE: CHER ( CHARACTER*1 UPLO,
INTEGER N, REAL ALPHA, COMPLEX(*) X, INTEGER INCX,
COMPLEX(*) A, INTEGER LDA ) ;
SUBROUTINE: CHPR ( CHARACTER*1 UPLO,
INTEGER N, REAL ALPHA, COMPLEX(*) X,
INTEGER INCX, COMPLEX(*) A ) ;
SUBROUTINE: CHER2 ( CHARACTER*1 UPLO, INTEGER N,
COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX,
COMPLEX(*) Y, INTEGER INCY, COMPLEX(*) A, INTEGER LDA ) ;
SUBROUTINE: CHPR2 ( CHARACTER*1 UPLO, INTEGER N,
COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX,
COMPLEX(*) Y, INTEGER INCY, COMPLEX(*) AP ) ;
SUBROUTINE: ZHEMV ( CHARACTER*1 UPLO,
INTEGER N, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A,
INTEGER LDA, DOUBLE-COMPLEX(*) X, INTEGER INCX,
DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
SUBROUTINE: ZHBMV ( CHARACTER*1 UPLO,
INTEGER N, INTEGER K, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A,
INTEGER LDA, DOUBLE-COMPLEX(*) X, INTEGER INCX,
DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
SUBROUTINE: ZHPMV ( CHARACTER*1 UPLO,
INTEGER N, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) AP,
DOUBLE-COMPLEX(*) X, INTEGER INCX,
DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
SUBROUTINE: ZGERU ( INTEGER M, INTEGER N,
DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX,
DOUBLE-COMPLEX(*) Y, INTEGER INCY, DOUBLE-COMPLEX(*) A, INTEGER LDA ) ;
SUBROUTINE: ZGERC ( INTEGER M, INTEGER N,
DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX,
DOUBLE-COMPLEX(*) Y, INTEGER INCY, DOUBLE-COMPLEX(*) A, INTEGER LDA ) ;
SUBROUTINE: ZHER ( CHARACTER*1 UPLO,
INTEGER N, REAL ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX,
DOUBLE-COMPLEX(*) A, INTEGER LDA ) ;
SUBROUTINE: ZHPR ( CHARACTER*1 UPLO,
INTEGER N, REAL ALPHA, DOUBLE-COMPLEX(*) X,
INTEGER INCX, DOUBLE-COMPLEX(*) A ) ;
SUBROUTINE: ZHER2 ( CHARACTER*1 UPLO, INTEGER N,
DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX,
DOUBLE-COMPLEX(*) Y, INTEGER INCY, DOUBLE-COMPLEX(*) A, INTEGER LDA ) ;
SUBROUTINE: ZHPR2 ( CHARACTER*1 UPLO, INTEGER N,
DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX,
DOUBLE-COMPLEX(*) Y, INTEGER INCY, DOUBLE-COMPLEX(*) AP ) ;
! LEVEL 3 BLAS (MATRIX-MATRIX)
SUBROUTINE: SGEMM ( CHARACTER*1 TRANSA,
CHARACTER*1 TRANSB, INTEGER M, INTEGER N,
INTEGER K, REAL ALPHA, REAL(*) A,
INTEGER LDA, REAL(*) B, INTEGER LDB,
REAL BETA, REAL(*) C, INTEGER LDC ) ;
SUBROUTINE: SSYMM ( CHARACTER*1 SIDE,
CHARACTER*1 UPLO, INTEGER M, INTEGER N,
REAL ALPHA, REAL(*) A, INTEGER LDA,
REAL(*) B, INTEGER LDB, REAL BETA,
REAL(*) C, INTEGER LDC ) ;
SUBROUTINE: SSYRK ( CHARACTER*1 UPLO,
CHARACTER*1 TRANS, INTEGER N, INTEGER K,
REAL ALPHA, REAL(*) A, INTEGER LDA,
REAL BETA, REAL(*) C, INTEGER LDC ) ;
SUBROUTINE: SSYR2K ( CHARACTER*1 UPLO,
CHARACTER*1 TRANS, INTEGER N, INTEGER K,
REAL ALPHA, REAL(*) A, INTEGER LDA,
REAL(*) B, INTEGER LDB, REAL BETA,
REAL(*) C, INTEGER LDC ) ;
SUBROUTINE: STRMM ( CHARACTER*1 SIDE,
CHARACTER*1 UPLO, CHARACTER*1 TRANSA,
CHARACTER*1 DIAG, INTEGER M, INTEGER N,
REAL ALPHA, REAL(*) A, INTEGER LDA,
REAL(*) B, INTEGER LDB ) ;
SUBROUTINE: STRSM ( CHARACTER*1 SIDE,
CHARACTER*1 UPLO, CHARACTER*1 TRANSA,
CHARACTER*1 DIAG, INTEGER M, INTEGER N,
REAL ALPHA, REAL(*) A, INTEGER LDA,
REAL(*) B, INTEGER LDB ) ;
SUBROUTINE: DGEMM ( CHARACTER*1 TRANSA,
CHARACTER*1 TRANSB, INTEGER M, INTEGER N,
INTEGER K, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A,
INTEGER LDA, DOUBLE-PRECISION(*) B, INTEGER LDB,
DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) C, INTEGER LDC ) ;
SUBROUTINE: DSYMM ( CHARACTER*1 SIDE,
CHARACTER*1 UPLO, INTEGER M, INTEGER N,
DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA,
DOUBLE-PRECISION(*) B, INTEGER LDB, DOUBLE-PRECISION BETA,
DOUBLE-PRECISION(*) C, INTEGER LDC ) ;
SUBROUTINE: DSYRK ( CHARACTER*1 UPLO,
CHARACTER*1 TRANS, INTEGER N, INTEGER K,
DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA,
DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) C, INTEGER LDC ) ;
SUBROUTINE: DSYR2K ( CHARACTER*1 UPLO,
CHARACTER*1 TRANS, INTEGER N, INTEGER K,
DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA,
DOUBLE-PRECISION(*) B, INTEGER LDB, DOUBLE-PRECISION BETA,
DOUBLE-PRECISION(*) C, INTEGER LDC ) ;
SUBROUTINE: DTRMM ( CHARACTER*1 SIDE,
CHARACTER*1 UPLO, CHARACTER*1 TRANSA,
CHARACTER*1 DIAG, INTEGER M, INTEGER N,
DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA,
DOUBLE-PRECISION(*) B, INTEGER LDB ) ;
SUBROUTINE: DTRSM ( CHARACTER*1 SIDE,
CHARACTER*1 UPLO, CHARACTER*1 TRANSA,
CHARACTER*1 DIAG, INTEGER M, INTEGER N,
DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA,
DOUBLE-PRECISION(*) B, INTEGER LDB ) ;
SUBROUTINE: CGEMM ( CHARACTER*1 TRANSA,
CHARACTER*1 TRANSB, INTEGER M, INTEGER N,
INTEGER K, COMPLEX ALPHA, COMPLEX(*) A,
INTEGER LDA, COMPLEX(*) B, INTEGER LDB,
COMPLEX BETA, COMPLEX(*) C, INTEGER LDC ) ;
SUBROUTINE: CSYMM ( CHARACTER*1 SIDE,
CHARACTER*1 UPLO, INTEGER M, INTEGER N,
COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA,
COMPLEX(*) B, INTEGER LDB, COMPLEX BETA,
COMPLEX(*) C, INTEGER LDC ) ;
SUBROUTINE: CSYRK ( CHARACTER*1 UPLO,
CHARACTER*1 TRANS, INTEGER N, INTEGER K,
COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA,
COMPLEX BETA, COMPLEX(*) C, INTEGER LDC ) ;
SUBROUTINE: CSYR2K ( CHARACTER*1 UPLO,
CHARACTER*1 TRANS, INTEGER N, INTEGER K,
COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA,
COMPLEX(*) B, INTEGER LDB, COMPLEX BETA,
COMPLEX(*) C, INTEGER LDC ) ;
SUBROUTINE: CTRMM ( CHARACTER*1 SIDE,
CHARACTER*1 UPLO, CHARACTER*1 TRANSA,
CHARACTER*1 DIAG, INTEGER M, INTEGER N,
COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA,
COMPLEX(*) B, INTEGER LDB ) ;
SUBROUTINE: CTRSM ( CHARACTER*1 SIDE,
CHARACTER*1 UPLO, CHARACTER*1 TRANSA,
CHARACTER*1 DIAG, INTEGER M, INTEGER N,
COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA,
COMPLEX(*) B, INTEGER LDB ) ;
SUBROUTINE: ZGEMM ( CHARACTER*1 TRANSA,
CHARACTER*1 TRANSB, INTEGER M, INTEGER N,
INTEGER K, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A,
INTEGER LDA, DOUBLE-COMPLEX(*) B, INTEGER LDB,
DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) C, INTEGER LDC ) ;
SUBROUTINE: ZSYMM ( CHARACTER*1 SIDE,
CHARACTER*1 UPLO, INTEGER M, INTEGER N,
DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
DOUBLE-COMPLEX(*) B, INTEGER LDB, DOUBLE-COMPLEX BETA,
DOUBLE-COMPLEX(*) C, INTEGER LDC ) ;
SUBROUTINE: ZSYRK ( CHARACTER*1 UPLO,
CHARACTER*1 TRANS, INTEGER N, INTEGER K,
DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) C, INTEGER LDC ) ;
SUBROUTINE: ZSYR2K ( CHARACTER*1 UPLO,
CHARACTER*1 TRANS, INTEGER N, INTEGER K,
DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
DOUBLE-COMPLEX(*) B, INTEGER LDB, DOUBLE-COMPLEX BETA,
DOUBLE-COMPLEX(*) C, INTEGER LDC ) ;
SUBROUTINE: ZTRMM ( CHARACTER*1 SIDE,
CHARACTER*1 UPLO, CHARACTER*1 TRANSA,
CHARACTER*1 DIAG, INTEGER M, INTEGER N,
DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
DOUBLE-COMPLEX(*) B, INTEGER LDB ) ;
SUBROUTINE: ZTRSM ( CHARACTER*1 SIDE,
CHARACTER*1 UPLO, CHARACTER*1 TRANSA,
CHARACTER*1 DIAG, INTEGER M, INTEGER N,
DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
DOUBLE-COMPLEX(*) B, INTEGER LDB ) ;
SUBROUTINE: CHEMM ( CHARACTER*1 SIDE,
CHARACTER*1 UPLO, INTEGER M, INTEGER N,
COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA,
COMPLEX(*) B, INTEGER LDB, COMPLEX BETA,
COMPLEX(*) C, INTEGER LDC ) ;
SUBROUTINE: CHERK ( CHARACTER*1 UPLO,
CHARACTER*1 TRANS, INTEGER N, INTEGER K,
REAL ALPHA, COMPLEX(*) A, INTEGER LDA,
REAL BETA, COMPLEX(*) C, INTEGER LDC ) ;
SUBROUTINE: CHER2K ( CHARACTER*1 UPLO,
CHARACTER*1 TRANS, INTEGER N, INTEGER K,
COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA,
COMPLEX(*) B, INTEGER LDB, REAL BETA,
COMPLEX(*) C, INTEGER LDC ) ;
SUBROUTINE: ZHEMM ( CHARACTER*1 SIDE,
CHARACTER*1 UPLO, INTEGER M, INTEGER N,
DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
DOUBLE-COMPLEX(*) B, INTEGER LDB, DOUBLE-COMPLEX BETA,
DOUBLE-COMPLEX(*) C, INTEGER LDC ) ;
SUBROUTINE: ZHERK ( CHARACTER*1 UPLO,
CHARACTER*1 TRANS, INTEGER N, INTEGER K,
REAL ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
REAL BETA, DOUBLE-COMPLEX(*) C, INTEGER LDC ) ;
SUBROUTINE: ZHER2K ( CHARACTER*1 UPLO,
CHARACTER*1 TRANS, INTEGER N, INTEGER K,
DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
DOUBLE-COMPLEX(*) B, INTEGER LDB, REAL BETA,
DOUBLE-COMPLEX(*) C, INTEGER LDC ) ;

1
basis/math/blas/ffi/summary.txt Normal file
View File

@ -0,0 +1 @@
Low-level bindings to the Basic Linear Algebra Subroutines (BLAS) library

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

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

42
basis/math/blas/matrices/matrices-docs.factor
View File

@ -8,40 +8,40 @@ ARTICLE: "math.blas-summary" "Basic Linear Algebra Subroutines (BLAS) interface"
{ $subsection "math.blas.vectors" } { $subsection "math.blas.vectors" }
"Vector-matrix and matrix-matrix operations are available in the " { $vocab-link "math.blas.matrices" } " vocabulary:" "Vector-matrix and matrix-matrix operations are available in the " { $vocab-link "math.blas.matrices" } " vocabulary:"
{ $subsection "math.blas.matrices" } { $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" ARTICLE: "math.blas-types" "BLAS interface types"
"BLAS vectors come in single- and double-precision, real and complex flavors:" "BLAS vectors come in single- and double-precision, real and complex flavors:"
{ $subsection float-blas-vector } { $subsection float-blas-vector }
{ $subsection double-blas-vector } { $subsection double-blas-vector }
{ $subsection float-complex-blas-vector } { $subsection complex-float-blas-vector }
{ $subsection double-complex-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:" "These vector types all follow the " { $link sequence } " protocol. In addition, there are corresponding types for matrix data:"
{ $subsection float-blas-matrix } { $subsection float-blas-matrix }
{ $subsection double-blas-matrix } { $subsection double-blas-matrix }
{ $subsection float-complex-blas-matrix } { $subsection complex-float-blas-matrix }
{ $subsection double-complex-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:" "There are BOA constructors for all vector and matrix types, which provide the most flexibility in specifying memory layout:"
{ $subsection <float-blas-vector> } { $subsection <float-blas-vector> }
{ $subsection <double-blas-vector> } { $subsection <double-blas-vector> }
{ $subsection <float-complex-blas-vector> } { $subsection <complex-float-blas-vector> }
{ $subsection <double-complex-blas-vector> } { $subsection <complex-double-blas-vector> }
{ $subsection <float-blas-matrix> } { $subsection <float-blas-matrix> }
{ $subsection <double-blas-matrix> } { $subsection <double-blas-matrix> }
{ $subsection <float-complex-blas-matrix> } { $subsection <complex-float-blas-matrix> }
{ $subsection <double-complex-blas-matrix> } { $subsection <complex-double-blas-matrix> }
"For the simple case of creating a dense, zero-filled vector or matrix, simple empty object constructors are provided:" "For the simple case of creating a dense, zero-filled vector or matrix, simple empty object constructors are provided:"
{ $subsection <empty-vector> } { $subsection <empty-vector> }
{ $subsection <empty-matrix> } { $subsection <empty-matrix> }
"BLAS vectors and matrices can also be constructed from other Factor sequences:" "BLAS vectors and matrices can also be constructed from other Factor sequences:"
{ $subsection >float-blas-vector } { $subsection >float-blas-vector }
{ $subsection >double-blas-vector } { $subsection >double-blas-vector }
{ $subsection >float-complex-blas-vector } { $subsection >complex-float-blas-vector }
{ $subsection >double-complex-blas-vector } { $subsection >complex-double-blas-vector }
{ $subsection >float-blas-matrix } { $subsection >float-blas-matrix }
{ $subsection >double-blas-matrix } { $subsection >double-blas-matrix }
{ $subsection >float-complex-blas-matrix } { $subsection >complex-float-blas-matrix }
{ $subsection >double-complex-blas-matrix } ; { $subsection >complex-double-blas-matrix } ;
ARTICLE: "math.blas.matrices" "BLAS interface matrix operations" ARTICLE: "math.blas.matrices" "BLAS interface matrix operations"
"Transposing and slicing matrices:" "Transposing and slicing matrices:"
@ -87,8 +87,8 @@ HELP: blas-matrix-base
{ $list { $list
{ { $link float-blas-matrix } } { { $link float-blas-matrix } }
{ { $link double-blas-matrix } } { { $link double-blas-matrix } }
{ { $link float-complex-blas-matrix } } { { $link complex-float-blas-matrix } }
{ { $link double-complex-blas-matrix } } { { $link complex-double-blas-matrix } }
} }
"All of these subclasses share the same tuple layout:" "All of these subclasses share the same tuple layout:"
{ $list { $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 } "." } ; { $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 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 } "." } ; { $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 } "." } ; { $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 } "." } ; { $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-matrix double-blas-matrix complex-float-blas-matrix complex-double-blas-matrix
float-blas-vector double-blas-vector float-complex-blas-vector double-complex-blas-vector float-blas-vector double-blas-vector complex-float-blas-vector complex-double-blas-vector
} related-words } related-words
HELP: Mwidth HELP: Mwidth
@ -272,7 +272,7 @@ HELP: cmatrix{
{ 0.0 0.0 -1.0 3.0 } { 0.0 0.0 -1.0 3.0 }
{ 0.0 0.0 0.0 C{ 0.0 -1.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{ HELP: zmatrix{
{ $syntax <" zmatrix{ { $syntax <" zmatrix{
@ -281,7 +281,7 @@ HELP: zmatrix{
{ 0.0 0.0 -1.0 3.0 } { 0.0 0.0 -1.0 3.0 }
{ 0.0 0.0 0.0 C{ 0.0 -1.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{ POSTPONE: smatrix{ POSTPONE: dmatrix{

100
basis/math/blas/matrices/matrices.factor
View File

@ -1,11 +1,13 @@
USING: accessors alien alien.c-types arrays byte-arrays combinators USING: accessors alien alien.c-types arrays byte-arrays combinators
combinators.short-circuit fry kernel locals macros 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 math.complex math.functions math.order functors words
sequences sequences.merged sequences.private shuffle sequences sequences.merged sequences.private shuffle
specialized-arrays.direct.float specialized-arrays.direct.double specialized-arrays.direct.float specialized-arrays.direct.double
specialized-arrays.float specialized-arrays.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 IN: math.blas.matrices
TUPLE: blas-matrix-base underlying ld rows cols transpose ; 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 )
<PRIVATE <PRIVATE
: (blas-transpose) ( matrix -- integer ) : (blas-transpose) ( matrix -- integer )
transpose>> [ CblasTrans ] [ CblasNoTrans ] if ; transpose>> [ "T" ] [ "N" ] if ;
GENERIC: (blas-matrix-like) ( data ld rows cols transpose exemplar -- matrix ) GENERIC: (blas-matrix-like) ( data ld rows cols transpose exemplar -- matrix )
@ -38,73 +40,70 @@ GENERIC: (blas-matrix-like) ( data ld rows cols transpose exemplar -- matrix )
unless ; unless ;
:: (prepare-gemv) :: (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 ( alpha A x beta y -- A-trans m n alpha A-data A-ld x-data x-inc beta y-data y-inc
y ) y )
A x y (validate-gemv) A x y (validate-gemv)
CblasColMajor
A (blas-transpose) A (blas-transpose)
A rows>> A rows>>
A cols>> A cols>>
alpha >c-arg call alpha
A underlying>> A
A ld>> A ld>>
x underlying>> x
x inc>> x inc>>
beta >c-arg call beta
y underlying>> y
y inc>> y inc>>
y ; inline y ; inline
: (validate-ger) ( x y A -- ) : (validate-ger) ( x y A -- )
{ {
[ nip [ length>> ] [ Mheight ] bi* = ] [ [ length>> ] [ drop ] [ Mheight ] tri* = ]
[ nipd [ length>> ] [ Mwidth ] bi* = ] [ [ drop ] [ length>> ] [ Mwidth ] tri* = ]
} 3&& } 3&&
[ "Mismatched vertices and matrix in vector outer product" throw ] [ "Mismatched vertices and matrix in vector outer product" throw ]
unless ; unless ;
:: (prepare-ger) :: (prepare-ger)
( alpha x y A >c-arg -- order m n alpha x-data x-inc y-data y-inc A-data A-ld ( alpha x y A -- m n alpha x-data x-inc y-data y-inc A-data A-ld
A ) A )
x y A (validate-ger) x y A (validate-ger)
CblasColMajor
A rows>> A rows>>
A cols>> A cols>>
alpha >c-arg call alpha
x underlying>> x
x inc>> x inc>>
y underlying>> y
y inc>> y inc>>
A underlying>> A
A ld>> A ld>>
A f >>transpose ; inline A f >>transpose ; inline
: (validate-gemm) ( A B C -- ) : (validate-gemm) ( A B C -- )
{ {
[ drop [ Mwidth ] [ Mheight ] bi* = ] [ [ Mwidth ] [ Mheight ] [ drop ] tri* = ]
[ nip [ Mheight ] bi@ = ] [ [ Mheight ] [ drop ] [ Mheight ] tri* = ]
[ nipd [ Mwidth ] bi@ = ] [ [ drop ] [ Mwidth ] [ Mwidth ] tri* = ]
} 3&& } 3&&
[ "Mismatched matrices in matrix multiplication" throw ] [ "Mismatched matrices in matrix multiplication" throw ]
unless ; unless ;
:: (prepare-gemm) :: (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 ( 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 ) C )
A B C (validate-gemm) A B C (validate-gemm)
CblasColMajor
A (blas-transpose) A (blas-transpose)
B (blas-transpose) B (blas-transpose)
C rows>> C rows>>
C cols>> C cols>>
A Mwidth A Mwidth
alpha >c-arg call alpha
A underlying>> A
A ld>> A ld>>
B underlying>> B
B ld>> B ld>>
beta >c-arg call beta
C underlying>> C
C ld>> C ld>>
C f >>transpose ; inline C f >>transpose ; inline
@ -250,16 +249,18 @@ FUNCTOR: (define-blas-matrix) ( TYPE T U C -- )
VECTOR IS ${TYPE}-blas-vector VECTOR IS ${TYPE}-blas-vector
<VECTOR> IS <${TYPE}-blas-vector> <VECTOR> IS <${TYPE}-blas-vector>
>ARRAY IS >${TYPE}-array >ARRAY IS >${TYPE}-array
TYPE>ARG IS ${TYPE}>arg XGEMV IS ${T}GEMV
XGEMV IS cblas_${T}gemv XGEMM IS ${T}GEMM
XGEMM IS cblas_${T}gemm XGERU IS ${T}GER${U}
XGERU IS cblas_${T}ger${U} XGERC IS ${T}GER${C}
XGERC IS cblas_${T}ger${C}
MATRIX DEFINES-CLASS ${TYPE}-blas-matrix MATRIX DEFINES-CLASS ${TYPE}-blas-matrix
<MATRIX> DEFINES <${TYPE}-blas-matrix> <MATRIX> DEFINES <${TYPE}-blas-matrix>
>MATRIX DEFINES >${TYPE}-blas-matrix >MATRIX DEFINES >${TYPE}-blas-matrix
XMATRIX{ DEFINES ${T}matrix{
t [ T >lower ]
XMATRIX{ DEFINES ${t}matrix{
WHERE WHERE
@ -277,21 +278,16 @@ M: MATRIX (blas-vector-like)
drop <VECTOR> ; drop <VECTOR> ;
: >MATRIX ( arrays -- matrix ) : >MATRIX ( arrays -- matrix )
[ >ARRAY underlying>> ] (>matrix) [ >ARRAY underlying>> ] (>matrix) <MATRIX> ;
<MATRIX> ;
M: VECTOR n*M.V+n*V! M: VECTOR n*M.V+n*V!
[ TYPE>ARG ] (prepare-gemv) (prepare-gemv) [ XGEMV ] dip ;
[ XGEMV ] dip ;
M: MATRIX n*M.M+n*M! M: MATRIX n*M.M+n*M!
[ TYPE>ARG ] (prepare-gemm) (prepare-gemm) [ XGEMM ] dip ;
[ XGEMM ] dip ;
M: MATRIX n*V(*)V+M! M: MATRIX n*V(*)V+M!
[ TYPE>ARG ] (prepare-ger) (prepare-ger) [ XGERU ] dip ;
[ XGERU ] dip ;
M: MATRIX n*V(*)Vconj+M! M: MATRIX n*V(*)Vconj+M!
[ TYPE>ARG ] (prepare-ger) (prepare-ger) [ XGERC ] dip ;
[ XGERC ] dip ;
: XMATRIX{ \ } [ >MATRIX ] parse-literal ; parsing : XMATRIX{ \ } [ >MATRIX ] parse-literal ; parsing
@ -304,12 +300,12 @@ M: MATRIX pprint-delims
: define-real-blas-matrix ( TYPE T -- ) : define-real-blas-matrix ( TYPE T -- )
"" "" (define-blas-matrix) ; "" "" (define-blas-matrix) ;
: define-complex-blas-matrix ( TYPE T -- ) : define-complex-blas-matrix ( TYPE T -- )
"u" "c" (define-blas-matrix) ; "U" "C" (define-blas-matrix) ;
"float" "s" define-real-blas-matrix "float" "S" define-real-blas-matrix
"double" "d" define-real-blas-matrix "double" "D" define-real-blas-matrix
"float-complex" "c" define-complex-blas-matrix "complex-float" "C" define-complex-blas-matrix
"double-complex" "z" define-complex-blas-matrix "complex-double" "Z" define-complex-blas-matrix
>> >>

16
basis/math/blas/vectors/vectors-docs.factor
View File

@ -37,8 +37,8 @@ HELP: blas-vector-base
{ $list { $list
{ { $link float-blas-vector } } { { $link float-blas-vector } }
{ { $link double-blas-vector } } { { $link double-blas-vector } }
{ { $link float-complex-blas-vector } } { { $link complex-float-blas-vector } }
{ { $link double-complex-blas-vector } } { { $link complex-double-blas-vector } }
} }
"All of these subclasses share the same tuple layout:" "All of these subclasses share the same tuple layout:"
{ $list { $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 } "." } ; { $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 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 } "." } ; { $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 HELP: complex-float-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 } "." } ; { $class-description "A vector of single-precision floating-point complex values. For details on the tuple layout, see " { $link blas-vector-base } "." } ;
HELP: double-complex-blas-vector HELP: complex-double-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 } "." } ; { $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! HELP: n*V+V!
{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "y=alpha*x+y" blas-vector-base } } { $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{ HELP: cvector{
{ $syntax "cvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" } { $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{ HELP: zvector{
{ $syntax "dvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" } { $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{ POSTPONE: svector{ POSTPONE: dvector{

111
basis/math/blas/vectors/vectors.factor
View File

@ -1,10 +1,12 @@
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.cblas combinators.short-circuit fry kernel math math.blas.ffi
math.complex math.functions math.order sequences.complex math.complex math.functions math.order sequences sequences.private
sequences.complex-components sequences sequences.private
functors words locals parser prettyprint.backend prettyprint.custom functors words locals parser prettyprint.backend prettyprint.custom
specialized-arrays.float specialized-arrays.double 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 IN: math.blas.vectors
TUPLE: blas-vector-base underlying length inc ; TUPLE: blas-vector-base underlying length inc ;
@ -31,7 +33,7 @@ GENERIC: (blas-direct-array) ( blas-vector -- direct-array )
: shorter-length ( v1 v2 -- length ) : shorter-length ( v1 v2 -- length )
[ length>> ] bi@ min ; inline [ length>> ] bi@ min ; inline
: data-and-inc ( v -- data inc ) : 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 ) : datas-and-incs ( v1 v2 -- v1-data v1-inc v2-data v2-inc )
[ data-and-inc ] bi@ ; inline [ data-and-inc ] bi@ ; inline
@ -130,15 +132,20 @@ FUNCTOR: (define-blas-vector) ( TYPE T -- )
<DIRECT-ARRAY> IS <direct-${TYPE}-array> <DIRECT-ARRAY> IS <direct-${TYPE}-array>
>ARRAY IS >${TYPE}-array >ARRAY IS >${TYPE}-array
XCOPY IS cblas_${T}copy XCOPY IS ${T}COPY
XSWAP IS cblas_${T}swap XSWAP IS ${T}SWAP
IXAMAX IS cblas_i${T}amax IXAMAX IS I${T}AMAX
VECTOR DEFINES-CLASS ${TYPE}-blas-vector VECTOR DEFINES-CLASS ${TYPE}-blas-vector
<VECTOR> DEFINES <${TYPE}-blas-vector> <VECTOR> DEFINES <${TYPE}-blas-vector>
>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 WHERE
@ -157,7 +164,7 @@ M: VECTOR element-type
M: VECTOR Vswap M: VECTOR Vswap
(prepare-swap) [ XSWAP ] 2dip ; (prepare-swap) [ XSWAP ] 2dip ;
M: VECTOR Viamax M: VECTOR Viamax
(prepare-nrm2) IXAMAX ; (prepare-nrm2) IXAMAX 1- ;
M: VECTOR (blas-vector-like) M: VECTOR (blas-vector-like)
drop <VECTOR> ; drop <VECTOR> ;
@ -167,6 +174,11 @@ M: VECTOR (blas-direct-array)
[ [ length>> ] [ inc>> ] bi * ] bi [ [ length>> ] [ inc>> ] bi * ] bi
<DIRECT-ARRAY> ; <DIRECT-ARRAY> ;
M: VECTOR n*V+V!
(prepare-axpy) [ XAXPY ] dip ;
M: VECTOR n*V!
(prepare-scal) [ XSCAL ] dip ;
: XVECTOR{ \ } [ >VECTOR ] parse-literal ; parsing : XVECTOR{ \ } [ >VECTOR ] parse-literal ; parsing
M: VECTOR pprint-delims M: VECTOR pprint-delims
@ -178,11 +190,9 @@ M: VECTOR pprint-delims
FUNCTOR: (define-real-blas-vector) ( TYPE T -- ) FUNCTOR: (define-real-blas-vector) ( TYPE T -- )
VECTOR IS ${TYPE}-blas-vector VECTOR IS ${TYPE}-blas-vector
XDOT IS cblas_${T}dot XDOT IS ${T}DOT
XNRM2 IS cblas_${T}nrm2 XNRM2 IS ${T}NRM2
XASUM IS cblas_${T}asum XASUM IS ${T}ASUM
XAXPY IS cblas_${T}axpy
XSCAL IS cblas_${T}scal
WHERE WHERE
@ -194,33 +204,6 @@ M: VECTOR Vnorm
(prepare-nrm2) XNRM2 ; (prepare-nrm2) XNRM2 ;
M: VECTOR Vasum M: VECTOR Vasum
(prepare-nrm2) XASUM ; (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 -- )
<DIRECT-COMPLEX-ARRAY> DEFINES <direct-${TYPE}-complex-array>
>COMPLEX-ARRAY DEFINES >${TYPE}-complex-array
ARG>COMPLEX DEFINES arg>${TYPE}-complex
COMPLEX>ARG DEFINES ${TYPE}-complex>arg
<DIRECT-ARRAY> IS <direct-${TYPE}-array>
>ARRAY IS >${TYPE}-array
WHERE
: <DIRECT-COMPLEX-ARRAY> ( alien len -- sequence )
1 shift <DIRECT-ARRAY> <complex-sequence> ;
: >COMPLEX-ARRAY ( sequence -- sequence )
<complex-components> >ARRAY ;
: COMPLEX>ARG ( complex -- alien )
>rect 2array >ARRAY underlying>> ;
: ARG>COMPLEX ( alien -- complex )
2 <DIRECT-ARRAY> first2 rect> ;
;FUNCTOR ;FUNCTOR
@ -228,35 +211,21 @@ WHERE
FUNCTOR: (define-complex-blas-vector) ( TYPE C S -- ) FUNCTOR: (define-complex-blas-vector) ( TYPE C S -- )
VECTOR IS ${TYPE}-blas-vector VECTOR IS ${TYPE}-blas-vector
XDOTU_SUB IS cblas_${C}dotu_sub XDOTU IS ${C}DOTU
XDOTC_SUB IS cblas_${C}dotc_sub XDOTC IS ${C}DOTC
XXNRM2 IS cblas_${S}${C}nrm2 XXNRM2 IS ${S}${C}NRM2
XXASUM IS cblas_${S}${C}asum XXASUM IS ${S}${C}ASUM
XAXPY IS cblas_${C}axpy
XSCAL IS cblas_${C}scal
TYPE>ARG IS ${TYPE}>arg
ARG>TYPE IS arg>${TYPE}
WHERE WHERE
M: VECTOR V. M: VECTOR V.
(prepare-dot) TYPE <c-object> (prepare-dot) XDOTU ;
[ XDOTU_SUB ] keep
ARG>TYPE ;
M: VECTOR V.conj M: VECTOR V.conj
(prepare-dot) TYPE <c-object> (prepare-dot) XDOTC ;
[ XDOTC_SUB ] keep
ARG>TYPE ;
M: VECTOR Vnorm M: VECTOR Vnorm
(prepare-nrm2) XXNRM2 ; (prepare-nrm2) XXNRM2 ;
M: VECTOR Vasum M: VECTOR Vasum
(prepare-nrm2) XXASUM ; (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 ;FUNCTOR
@ -264,16 +233,14 @@ M: VECTOR n*V!
: define-real-blas-vector ( TYPE T -- ) : define-real-blas-vector ( TYPE T -- )
[ (define-blas-vector) ] [ (define-blas-vector) ]
[ (define-real-blas-vector) ] 2bi ; [ (define-real-blas-vector) ] 2bi ;
:: define-complex-blas-vector ( TYPE C S -- ) : define-complex-blas-vector ( TYPE C S -- )
TYPE (define-complex-helpers) [ drop (define-blas-vector) ]
TYPE "-complex" append [ (define-complex-blas-vector) ] 3bi ;
[ C (define-blas-vector) ]
[ C S (define-complex-blas-vector) ] bi ;
"float" "s" define-real-blas-vector "float" "S" define-real-blas-vector
"double" "d" define-real-blas-vector "double" "D" define-real-blas-vector
"float" "c" "s" define-complex-blas-vector "complex-float" "C" "S" define-complex-blas-vector
"double" "z" "d" define-complex-blas-vector "complex-double" "Z" "D" define-complex-blas-vector
>> >>

8
basis/pack/pack.factor
View File

@ -87,12 +87,12 @@ CONSTANT: packed-length-table
{ CHAR: D 8 } { CHAR: D 8 }
} }
PRIVATE>
MACRO: pack ( str -- quot ) MACRO: pack ( str -- quot )
[ pack-table at '[ _ execute ] ] { } map-as [ pack-table at '[ _ execute ] ] { } map-as
'[ [ [ _ spread ] input<sequence ] B{ } append-outputs-as ] ; '[ [ [ _ spread ] input<sequence ] B{ } append-outputs-as ] ;
PRIVATE>
: ch>packed-length ( ch -- n ) : ch>packed-length ( ch -- n )
packed-length-table at ; inline packed-length-table at ; inline
@ -113,14 +113,14 @@ PRIVATE>
: start/end ( seq -- seq1 seq2 ) : start/end ( seq -- seq1 seq2 )
[ 0 [ + ] accumulate nip dup ] keep v+ ; inline [ 0 [ + ] accumulate nip dup ] keep v+ ; inline
PRIVATE>
MACRO: unpack ( str -- quot ) MACRO: unpack ( str -- quot )
[ [ ch>packed-length ] { } map-as start/end ] [ [ ch>packed-length ] { } map-as start/end ]
[ [ unpack-table at '[ @ ] ] { } map-as ] bi [ [ unpack-table at '[ @ ] ] { } map-as ] bi
[ '[ [ _ _ ] dip <slice> @ ] ] 3map [ '[ [ _ _ ] dip <slice> @ ] ] 3map
'[ [ _ cleave ] output>array ] ; '[ [ _ cleave ] output>array ] ;
PRIVATE>
: unpack-native ( seq str -- seq ) : unpack-native ( seq str -- seq )
'[ _ _ unpack ] with-native-endian ; inline '[ _ _ unpack ] with-native-endian ; inline

2
basis/shuffle/shuffle-tests.factor
View File

@ -1,3 +1,5 @@
USING: shuffle tools.test ; USING: shuffle tools.test ;
[ 1 2 3 4 ] [ 3 4 1 2 2swap ] 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

22
basis/shuffle/shuffle.factor
View File

@ -1,9 +1,27 @@
! Copyright (C) 2007 Chris Double, Doug Coleman. ! Copyright (C) 2007 Chris Double, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel generalizations ; USING: accessors assocs combinators effects.parser generalizations
hashtables kernel locals locals.backend macros make math
parser sequences ;
IN: shuffle IN: shuffle
<PRIVATE
: >index-assoc ( sequence -- assoc )
dup length zip >hashtable ;
PRIVATE>
MACRO: shuffle-effect ( effect -- )
[ out>> ] [ in>> >index-assoc ] bi
[
[ nip assoc-size , \ narray , ]
[ [ at \ swap \ nth [ ] 3sequence ] curry map , \ cleave , ] 2bi
] [ ] make ;
: shuffle(
")" parse-effect parsed \ shuffle-effect parsed ; parsing
: 2swap ( x y z t -- z t x y ) 2 2 mnswap ; inline : 2swap ( x y z t -- z t x y ) 2 2 mnswap ; inline
: 4dup ( a b c d -- a b c d a b c d ) 4 ndup ; inline : 4dup ( a b c d -- a b c d a b c d ) 4 ndup ; inline

13
basis/specialized-arrays/complex-double/complex-double-tests.factor Normal file
View File

@ -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

4
basis/specialized-arrays/complex-double/complex-double.factor Normal file
View File

@ -0,0 +1,4 @@
USE: specialized-arrays.functor
IN: specialized-arrays.complex-double
<< "complex-double" define-array >>

4
basis/specialized-arrays/complex-float/complex-float.factor Normal file
View File

@ -0,0 +1,4 @@
USE: specialized-arrays.functor
IN: specialized-arrays.complex-float
<< "complex-float" define-array >>

4
basis/specialized-arrays/direct/complex-double/complex-double.factor Normal file
View File

@ -0,0 +1,4 @@
USING: specialized-arrays.complex-double specialized-arrays.direct.functor ;
IN: specialized-arrays.direct.complex-double
<< "complex-double" define-direct-array >>

4
basis/specialized-arrays/direct/complex-float/complex-float.factor Normal file
View File

@ -0,0 +1,4 @@
USING: specialized-arrays.complex-float specialized-arrays.direct.functor ;
IN: specialized-arrays.direct.complex-float
<< "complex-float" define-direct-array >>

2
basis/specialized-arrays/direct/functor/functor.factor
View File

@ -14,7 +14,7 @@ A' IS ${T}-array
A DEFINES-CLASS direct-${T}-array A DEFINES-CLASS direct-${T}-array
<A> DEFINES <${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 ] SET-NTH [ T dup c-setter array-accessor ]
WHERE WHERE

2
basis/specialized-arrays/functor/functor.factor
View File

@ -22,7 +22,7 @@ A DEFINES-CLASS ${T}-array
byte-array>A DEFINES byte-array>${A} byte-array>A DEFINES byte-array>${A}
A{ DEFINES ${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 ] SET-NTH [ T dup c-setter array-accessor ]
WHERE WHERE

2
basis/tools/deploy/backend/backend.factor Normal file → Executable file
View File

@ -11,7 +11,7 @@ tools.deploy.config.editor bootstrap.image io.encodings.utf8
destructors accessors ; destructors accessors ;
IN: tools.deploy.backend 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 ; [ prepend-path ] dip append vm over copy-file ;
: copy-fonts ( name dir -- ) : copy-fonts ( name dir -- )

2
basis/tools/deploy/macosx/macosx.factor Normal file → Executable file
View File

@ -49,7 +49,7 @@ IN: tools.deploy.macosx
tri tri
] ]
[ create-app-plist ] [ create-app-plist ]
[ "Contents/MacOS/" append-path "" copy-vm ] 2tri [ "Contents/MacOS/" append-path copy-vm ] 2tri
dup OCT: 755 set-file-permissions ; dup OCT: 755 set-file-permissions ;
: deploy.app-image ( vocab bundle-name -- str ) : deploy.app-image ( vocab bundle-name -- str )

2
basis/tools/deploy/unix/unix.factor Normal file → Executable file
View File

@ -8,7 +8,7 @@ IN: tools.deploy.unix
: create-app-dir ( vocab bundle-name -- vm ) : create-app-dir ( vocab bundle-name -- vm )
dup "" copy-fonts dup "" copy-fonts
"" copy-vm copy-vm
dup OCT: 755 set-file-permissions ; dup OCT: 755 set-file-permissions ;
: bundle-name ( -- str ) : bundle-name ( -- str )

23
basis/tools/deploy/windows/windows.factor
View File

@ -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. ! See http://factorcode.org/license.txt for BSD license.
USING: io io.files io.directories kernel namespaces sequences system USING: io io.files io.pathnames io.directories kernel namespaces
tools.deploy.backend tools.deploy.config sequences locals system splitting tools.deploy.backend
tools.deploy.config.editor assocs hashtables prettyprint tools.deploy.config tools.deploy.config.editor assocs hashtables
combinators windows.shell32 windows.user32 ; prettyprint combinators windows.shell32 windows.user32 ;
IN: tools.deploy.windows IN: tools.deploy.windows
: copy-dll ( bundle-name -- ) : copy-dll ( bundle-name -- )
@ -15,13 +15,18 @@ IN: tools.deploy.windows
"resource:zlib1.dll" "resource:zlib1.dll"
} swap copy-files-into ; } 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 ) : create-exe-dir ( vocab bundle-name -- vm )
dup copy-dll dup copy-dll
deploy-ui? get [ deploy-ui? get [
dup copy-freetype [ copy-freetype ]
dup "" copy-fonts [ "" copy-fonts ]
] when [ ".exe" copy-vm ] tri
".exe" copy-vm ; ] [ ".com" copy-vm ] if ;
M: winnt deploy* M: winnt deploy*
"resource:" [ "resource:" [

8
basis/xml-rpc/xml-rpc.factor
View File

@ -126,11 +126,11 @@ TAG: int xml>item children>number ;
TAG: double xml>item children>number ; TAG: double xml>item children>number ;
TAG: boolean xml>item TAG: boolean xml>item
dup children>string { children>string {
{ [ dup "1" = ] [ 2drop t ] } { "1" [ t ] }
{ [ "0" = ] [ drop f ] } { "0" [ f ] }
[ "Bad boolean" server-error ] [ "Bad boolean" server-error ]
} cond ; } case ;
: unstruct-member ( tag -- ) : unstruct-member ( tag -- )
children-tags first2 children-tags first2

1
core/slots/slots.factor Normal file → Executable file
View File

@ -151,6 +151,7 @@ M: class initial-value* no-initial-value ;
{ [ array bootstrap-word over class<= ] [ { } ] } { [ array bootstrap-word over class<= ] [ { } ] }
{ [ byte-array bootstrap-word over class<= ] [ B{ } ] } { [ byte-array bootstrap-word over class<= ] [ B{ } ] }
{ [ simple-alien bootstrap-word over class<= ] [ <bad-alien> ] } { [ simple-alien bootstrap-word over class<= ] [ <bad-alien> ] }
{ [ quotation bootstrap-word over class<= ] [ [ ] ] }
[ dup initial-value* ] [ dup initial-value* ]
} cond nip ; } cond nip ;

4
extra/graphics/tiff/tiff-tests.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2009 Your name. ! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: tools.test graphics.tiff ; USING: tools.test graphics.tiff ;
IN: graphics.tiff.tests IN: graphics.tiff.tests
@ -6,4 +6,6 @@ IN: graphics.tiff.tests
: tiff-test-path ( -- path ) : tiff-test-path ( -- path )
"resource:extra/graphics/tiff/rgb.tiff" ; "resource:extra/graphics/tiff/rgb.tiff" ;
: tiff-test-path2 ( -- path )
"resource:extra/graphics/tiff/octagon.tiff" ;

336
extra/graphics/tiff/tiff.factor
View File

@ -2,142 +2,123 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators io io.encodings.binary io.files USING: accessors combinators io io.encodings.binary io.files
kernel pack endian tools.hexdump constructors sequences arrays kernel pack endian 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 ;
IN: graphics.tiff IN: graphics.tiff
TUPLE: tiff TUPLE: tiff endianness the-answer ifd-offset ifds ;
endianness
the-answer
ifd-offset
ifds ;
CONSTRUCTOR: tiff ( -- tiff ) CONSTRUCTOR: tiff ( -- tiff )
V{ } clone >>ifds ; 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 ) ; 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/value -- ifd-entry ) ;
CONSTRUCTOR: ifd-entry ( tag type count offset -- ifd-entry ) ;
TUPLE: photometric-interpretation color ;
CONSTRUCTOR: photometric-interpretation ( color -- object ) ;
SINGLETONS: white-is-zero black-is-zero rgb palette-color ;
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 ; ERROR: bad-photometric-interpretation n ;
: lookup-photometric-interpretation ( n -- singleton ) : lookup-photometric-interpretation ( n -- singleton )
{ {
{ 0 [ white-is-zero ] } { 0 [ photometric-interpretation-white-is-zero ] }
{ 1 [ black-is-zero ] } { 1 [ photometric-interpretation-black-is-zero ] }
{ 2 [ rgb ] } { 2 [ photometric-interpretation-rgb ] }
{ 3 [ palette-color ] } { 3 [ photometric-interpretation-palette-color ] }
[ bad-photometric-interpretation ] [ bad-photometric-interpretation ]
} case <photometric-interpretation> ; } case ;
TUPLE: compression method ;
CONSTRUCTOR: compression ( method -- object ) ;
SINGLETONS: no-compression CCITT-2 pack-bits lzw ;
SINGLETONS: compression
compression-none
compression-CCITT-2
compression-lzw
compression-pack-bits ;
ERROR: bad-compression n ; ERROR: bad-compression n ;
: lookup-compression ( n -- compression ) : lookup-compression ( n -- compression )
{ {
{ 1 [ no-compression ] } { 1 [ compression-none ] }
{ 2 [ CCITT-2 ] } { 2 [ compression-CCITT-2 ] }
{ 5 [ lzw ] } { 5 [ compression-lzw ] }
{ 32773 [ pack-bits ] } { 32773 [ compression-pack-bits ] }
[ bad-compression ] [ bad-compression ]
} case <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 ) ;
SINGLETONS: resolution-unit
resolution-unit-none
resolution-unit-inch
resolution-unit-centimeter ;
ERROR: bad-resolution-unit n ; ERROR: bad-resolution-unit n ;
: lookup-resolution-unit ( n -- object ) : lookup-resolution-unit ( n -- object )
{ {
{ 1 [ no-resolution-unit ] } { 1 [ resolution-unit-none ] }
{ 2 [ inch-resolution-unit ] } { 2 [ resolution-unit-inch ] }
{ 3 [ centimeter-resolution-unit ] } { 3 [ resolution-unit-centimeter ] }
[ bad-resolution-unit ] [ bad-resolution-unit ]
} case <resolution-unit> ; } case ;
TUPLE: predictor type ;
CONSTRUCTOR: predictor ( type -- object ) ;
SINGLETONS: no-predictor horizontal-differencing-predictor ;
SINGLETONS: predictor
predictor-none
predictor-horizontal-differencing ;
ERROR: bad-predictor n ; ERROR: bad-predictor n ;
: lookup-predictor ( n -- object ) : lookup-predictor ( n -- object )
{ {
{ 1 [ no-predictor ] } { 1 [ predictor-none ] }
{ 2 [ horizontal-differencing-predictor ] } { 2 [ predictor-horizontal-differencing ] }
[ bad-predictor ] [ bad-predictor ]
} case <predictor> ; } case ;
TUPLE: planar-configuration type ;
CONSTRUCTOR: planar-configuration ( type -- object ) ;
SINGLETONS: chunky planar ;
SINGLETONS: planar-configuration
planar-configuration-chunky
planar-configuration-planar ;
ERROR: bad-planar-configuration n ; ERROR: bad-planar-configuration n ;
: lookup-planar-configuration ( n -- object ) : lookup-planar-configuration ( n -- object )
{ {
{ 1 [ no-predictor ] } { 1 [ planar-configuration-chunky ] }
{ 2 [ horizontal-differencing-predictor ] } { 2 [ planar-configuration-planar ] }
[ bad-predictor ] [ bad-planar-configuration ]
} case <planar-configuration> ; } case ;
ERROR: bad-sample-format n ;
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-format-unsigned-integer ] }
{ 2 [ sample-format-signed-integer ] }
{ 3 [ sample-format-ieee-float ] }
{ 4 [ sample-format-undefined-data ] }
[ bad-sample-format ]
} case
] map ;
TUPLE: new-subfile-type n ; ERROR: bad-extra-samples n ;
CONSTRUCTOR: new-subfile-type ( n -- object ) ; SINGLETONS: extra-samples
extra-samples-unspecified-alpha-data
extra-samples-associated-alpha-data
extra-samples-unassociated-alpha-data ;
: lookup-extra-samples ( seq -- object )
{
{ 0 [ extra-samples-unspecified-alpha-data ] }
{ 1 [ extra-samples-associated-alpha-data ] }
{ 2 [ extra-samples-unassociated-alpha-data ] }
[ bad-extra-samples ]
} case ;
SINGLETONS: image-length image-width x-resolution y-resolution
rows-per-strip strip-offsets strip-byte-counts bits-per-sample
samples-per-pixel new-subfile-type orientation
unhandled-ifd-entry ;
ERROR: bad-tiff-magic bytes ; ERROR: bad-tiff-magic bytes ;
: tiff-endianness ( byte-array -- ? ) : tiff-endianness ( byte-array -- ? )
{ {
{ B{ CHAR: M CHAR: M } [ big-endian ] } { B{ CHAR: M CHAR: M } [ big-endian ] }
@ -145,9 +126,6 @@ ERROR: bad-tiff-magic bytes ;
[ bad-tiff-magic ] [ bad-tiff-magic ]
} case ; } case ;
: with-tiff-endianness ( tiff quot -- tiff )
[ dup endianness>> ] dip with-endianness ; inline
: read-header ( tiff -- tiff ) : read-header ( tiff -- tiff )
2 read tiff-endianness [ >>endianness ] keep 2 read tiff-endianness [ >>endianness ] keep
[ [
@ -155,8 +133,7 @@ ERROR: bad-tiff-magic bytes ;
4 read endian> >>ifd-offset 4 read endian> >>ifd-offset
] with-endianness ; ] with-endianness ;
: push-ifd ( tiff ifd -- tiff ) : push-ifd ( tiff ifd -- tiff ) over ifds>> push ;
over ifds>> push ;
: read-ifd ( -- ifd ) : read-ifd ( -- ifd )
2 read endian> 2 read endian>
@ -165,63 +142,130 @@ ERROR: bad-tiff-magic bytes ;
4 read endian> <ifd-entry> ; 4 read endian> <ifd-entry> ;
: read-ifds ( tiff -- tiff ) : read-ifds ( tiff -- tiff )
[ dup ifd-offset>> seek-absolute seek-input
dup ifd-offset>> seek-absolute seek-input 2 read endian>
2 read endian> dup [ read-ifd ] replicate
dup [ read-ifd ] replicate 4 read endian>
4 read endian> [ <ifd> push-ifd ] [ 0 = [ read-ifds ] unless ] bi ;
[ <ifd> push-ifd ] [ 0 = [ read-ifds ] unless ] bi
] with-tiff-endianness ; 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 ) : read-strips ( ifd -- ifd )
dup processed-tags>> dup
[ [ strip-byte-counts instance? ] find nip n>> ] [ strip-byte-counts find-tag ]
[ [ strip-offsets instance? ] find nip n>> ] bi [ strip-offsets find-tag ] bi
[ seek-absolute seek-input read ] { } 2map-as >>strips ; 2dup [ integer? ] both? [
seek-absolute seek-input read 1array
] [
[ seek-absolute seek-input read ] { } 2map-as
] if >>strips ;
! ERROR: unhandled-ifd-entry data n ; ERROR: unknown-ifd-type n ;
: unhandled-ifd-entry ; : 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 <sliced-groups> [ endian> ] map ] }
{ 4 [ 4 <sliced-groups> [ endian> ] map ] }
{ 5 [ 8 <sliced-groups> [ "II" unpack first2 / ] map ] }
{ 6 [ [ 8 >signed ] map ] }
{ 7 [ ] } ! blank
{ 8 [ 2 <sliced-groups> [ endian> 16 >signed ] map ] }
{ 9 [ 4 <sliced-groups> [ 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 ) : ifd-entry-value ( ifd-entry -- n )
dup count>> 1 = [ dup value-length 4 <= [
offset>> 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 ; ] if ;
: process-ifd-entry ( ifd-entry -- object ) : process-ifd-entry ( ifd-entry -- value class )
[ ifd-entry-value ] [ tag>> ] bi { [ ifd-entry-value ] [ tag>> ] bi {
{ 254 [ <new-subfile-type> ] } { 254 [ new-subfile-type ] }
{ 256 [ <image-width> ] } { 256 [ image-width ] }
{ 257 [ <image-length> ] } { 257 [ image-length ] }
{ 258 [ <bits-per-sample> ] } { 258 [ bits-per-sample ] }
{ 259 [ lookup-compression ] } { 259 [ lookup-compression compression ] }
{ 262 [ lookup-photometric-interpretation ] } { 262 [ lookup-photometric-interpretation photometric-interpretation ] }
{ 273 [ <strip-offsets> ] } { 273 [ strip-offsets ] }
{ 277 [ <samples-per-pixel> ] } { 274 [ orientation ] }
{ 278 [ <rows-per-strip> ] } { 277 [ samples-per-pixel ] }
{ 279 [ <strip-byte-counts> ] } { 278 [ rows-per-strip ] }
{ 282 [ <x-resolution> ] } { 279 [ strip-byte-counts ] }
{ 283 [ <y-resolution> ] } { 282 [ x-resolution ] }
{ 284 [ <planar-configuration> ] } { 283 [ y-resolution ] }
{ 296 [ lookup-resolution-unit ] } { 284 [ planar-configuration ] }
{ 317 [ lookup-predictor ] } { 296 [ lookup-resolution-unit resolution-unit ] }
[ unhandled-ifd-entry swap 2array ] { 317 [ lookup-predictor predictor ] }
{ 338 [ lookup-extra-samples extra-samples ] }
{ 339 [ lookup-sample-format sample-format ] }
[ nip unhandled-ifd-entry ]
} case ; } case ;
: process-ifd ( ifd -- ifd ) : process-ifd ( ifd -- ifd )
dup ifd-entries>> [ process-ifd-entry ] map >>processed-tags ; dup ifd-entries>>
[ process-ifd-entry swap ] H{ } map>assoc >>processed-tags ;
: strips>buffer ( ifd -- ifd )
dup strips>> concat >>buffer ;
: (load-tiff) ( path -- tiff ) : (load-tiff) ( path -- tiff )
binary [ binary [
<tiff> <tiff>
read-header read-header dup endianness>> [
read-ifds read-ifds
dup ifds>> [ process-ifd read-strips drop ] each dup ifds>> [ process-ifd read-strips strips>buffer drop ] each
] with-endianness
] with-file-reader ; ] with-file-reader ;
: load-tiff ( path -- tiff ) : load-tiff ( path -- tiff ) (load-tiff) ;
(load-tiff) ;
! TODO: duplicate ifds = error, seeking out of bounds = error

30
extra/graphics/viewer/viewer.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators graphics.bitmap kernel math USING: accessors arrays combinators graphics.bitmap kernel math
math.functions namespaces opengl opengl.gl ui ui.gadgets 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 IN: graphics.viewer
TUPLE: graphics-gadget < gadget image ; TUPLE: graphics-gadget < gadget image ;
@ -21,6 +21,14 @@ M: graphics-gadget draw-gadget* ( gadget -- )
\ graphics-gadget new-gadget \ graphics-gadget new-gadget
swap >>image ; swap >>image ;
: bits>gl-params ( n -- gl-bgr gl-format )
{
{ 32 [ GL_BGRA GL_UNSIGNED_BYTE ] }
{ 24 [ GL_BGR GL_UNSIGNED_BYTE ] }
{ 8 [ GL_BGR GL_UNSIGNED_BYTE ] }
{ 4 [ GL_BGR GL_UNSIGNED_BYTE ] }
} case ;
M: bitmap draw-image ( bitmap -- ) M: bitmap draw-image ( bitmap -- )
dup height>> 0 < [ dup height>> 0 < [
0 0 glRasterPos2i 0 0 glRasterPos2i
@ -32,12 +40,7 @@ M: bitmap draw-image ( bitmap -- )
[ width>> ] keep [ width>> ] keep
[ [
[ height>> abs ] keep [ height>> abs ] keep
bit-count>> { bit-count>> bits>gl-params
{ 32 [ GL_BGRA GL_UNSIGNED_BYTE ] }
{ 24 [ GL_BGR GL_UNSIGNED_BYTE ] }
{ 8 [ GL_BGR GL_UNSIGNED_BYTE ] }
{ 4 [ GL_BGR GL_UNSIGNED_BYTE ] }
} case
] keep array>> glDrawPixels ; ] keep array>> glDrawPixels ;
M: bitmap width ( bitmap -- ) width>> ; M: bitmap width ( bitmap -- ) width>> ;
@ -48,3 +51,16 @@ M: bitmap height ( bitmap -- ) height>> ;
: bitmap-window ( path -- gadget ) : bitmap-window ( path -- gadget )
load-bitmap <graphics-gadget> [ "bitmap" open-window ] keep ; load-bitmap <graphics-gadget> [ "bitmap" open-window ] keep ;
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 ]
[ image-length find-tag ]
[ bits-per-sample find-tag sum bits>gl-params ]
[ buffer>> ]
} cleave glDrawPixels ;

3
extra/taxes/usa/futa/futa.factor
View File

@ -11,5 +11,4 @@ IN: taxes.usa.futa
: futa-tax ( salary w4 -- x ) : futa-tax ( salary w4 -- x )
drop futa-base-rate min drop futa-base-rate min
futa-tax-rate futa-tax-offset-credit - futa-tax-rate futa-tax-offset-credit - * ;
* ;

4
extra/taxes/usa/usa.factor
View File

@ -1,7 +1,9 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs kernel math math.intervals 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 IN: taxes.usa
! Withhold: FICA, Medicare, Federal (FICA is social security) ! Withhold: FICA, Medicare, Federal (FICA is social security)