From c24bc639d11f792f4eadd14e8fbe7e6da4584574 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Thu, 5 Feb 2009 15:29:59 -0600
Subject: [PATCH 01/35] unit tests for alien.fortran

---
 basis/alien/fortran/fortran-tests.factor | 141 +++++++++++++++++++++++
 1 file changed, 141 insertions(+)
 create mode 100644 basis/alien/fortran/fortran-tests.factor

diff --git a/basis/alien/fortran/fortran-tests.factor b/basis/alien/fortran/fortran-tests.factor
new file mode 100644
index 0000000000..29bd024930
--- /dev/null
+++ b/basis/alien/fortran/fortran-tests.factor
@@ -0,0 +1,141 @@
+USING: alien.fortran alien.syntax tools.test ;
+IN: alien.fortran.tests
+
+C-STRUCT: fortran_test_struct
+    { "int" "foo" }
+    { "float" "bar" }
+    { "char[4]" "bas" } ;
+
+! F-RECORD: fortran_test_record
+!     { "integer" "foo" }
+!     { "real" "bar" }
+!     { "character*4" "bar" }
+
+! fortran-name>symbol-name
+
+[ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test
+[ "fun_times__" ] [ "Fun_Times" fortran-name>symbol-name ] unit-test
+
+! fortran-type>c-type
+
+[ "short" ]
+[ "integer*2" fortran-type>c-type ] unit-test
+
+[ "int" ]
+[ "integer*4" fortran-type>c-type ] unit-test
+
+[ "int" ]
+[ "integer" fortran-type>c-type ] unit-test
+
+[ "longlong" ]
+[ "iNteger*8" fortran-type>c-type ] unit-test
+
+[ "int[0]" ]
+[ "integer(*)" fortran-type>c-type ] unit-test
+
+[ "int[0]" ]
+[ "integer(3,*)" fortran-type>c-type ] unit-test
+
+[ "int[3]" ]
+[ "integer(3)" fortran-type>c-type ] unit-test
+
+[ "int[6]" ]
+[ "integer(3,2)" fortran-type>c-type ] unit-test
+
+[ "int[24]" ]
+[ "integer(4,3,2)" fortran-type>c-type ] unit-test
+
+[ "char[1]" ]
+[ "character" fortran-type>c-type ] unit-test
+
+[ "char[17]" ]
+[ "character*17" fortran-type>c-type ] unit-test
+
+[ "char[17]" ]
+[ "character(17)" fortran-type>c-type ] unit-test
+
+[ "int" ]
+[ "logical" fortran-type>c-type ] unit-test
+
+[ "float" ]
+[ "real" fortran-type>c-type ] unit-test
+
+[ "double" ]
+[ "double precision" fortran-type>c-type ] unit-test
+
+[ "float" ]
+[ "real*4" fortran-type>c-type ] unit-test
+
+[ "double" ]
+[ "real*8" fortran-type>c-type ] unit-test
+
+[ "(fortran-complex)" ]
+[ "complex" fortran-type>c-type ] unit-test
+
+[ "(fortran-double-complex)" ]
+[ "double complex" fortran-type>c-type ] unit-test
+
+[ "(fortran-complex)" ]
+[ "complex*8" fortran-type>c-type ] unit-test
+
+[ "(fortran-double-complex)" ]
+[ "complex*16" fortran-type>c-type ] unit-test
+
+[ "(fortran-double-complex)" ]
+[ "complex*16" fortran-type>c-type ] unit-test
+
+[ "fortran_test_struct" ]
+[ "fortran_test_struct" fortran-type>c-type ] unit-test
+
+[ "fortran_test_record" ]
+[ "fortran_test_record" fortran-type>c-type ] unit-test
+
+! fortran-arg-type>c-type
+
+[ "int*" { } ]
+[ "integer" fortran-arg-type>c-type ] unit-test
+
+[ "int*" { } ]
+[ "integer(3)" fortran-arg-type>c-type ] unit-test
+
+[ "int*" { } ]
+[ "integer(*)" fortran-arg-type>c-type ] unit-test
+
+[ "fortran_test_struct*" { } ]
+[ "fortran_test_struct" fortran-arg-type>c-type ] unit-test
+
+[ "char*" { "long" } ]
+[ "character" fortran-arg-type>c-type ] unit-test
+
+[ "char*" { "long" } ]
+[ "character(17)" fortran-arg-type>c-type ] unit-test
+
+! fortran-ret-type>c-type
+
+[ "void" { "char*" "long" } ]
+[ "character(17)" fortran-ret-type>c-type ] unit-test
+
+[ "int" { } ]
+[ "integer" fortran-ret-type>c-type ] unit-test
+
+[ "int" { } ]
+[ "logical" fortran-ret-type>c-type ] unit-test
+
+[ "double" { } ]
+[ "real" fortran-ret-type>c-type ] unit-test
+
+[ "double" { } ]
+[ "double precision" fortran-ret-type>c-type ] unit-test
+
+[ "void" { "(fortran-complex)*" } ]
+[ "complex" fortran-ret-type>c-type ] unit-test
+
+[ "void" { "(fortran-double-complex)*" } ]
+[ "double complex" fortran-ret-type>c-type ] unit-test
+
+[ "void" { "int*" } ]
+[ "integer(*)" fortran-ret-type>c-type ] unit-test
+
+[ "void" { "fortran_test_record*" } ]
+[ "fortran_test_record" fortran-ret-type>c-type ] unit-test
+

From 4f1dc5cd0c46693d31ab51f7deaf6b2af41f8089 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Thu, 5 Feb 2009 15:31:58 -0600
Subject: [PATCH 02/35] implement fortran-name>symbol-name and
 fortran-type>c-type

---
 basis/alien/fortran/fortran.factor | 140 +++++++++++++++++++++++++++++
 1 file changed, 140 insertions(+)
 create mode 100644 basis/alien/fortran/fortran.factor

diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor
new file mode 100644
index 0000000000..d83df9bd45
--- /dev/null
+++ b/basis/alien/fortran/fortran.factor
@@ -0,0 +1,140 @@
+USING: accessors alien alien.c-types alien.syntax arrays ascii
+assocs combinators fry kernel macros math.parser sequences splitting ;
+IN: alien.fortran
+
+! XXX this currently only supports the gfortran/f2c abi.
+! XXX we should also support ifort at some point for commercial BLASes
+
+C-STRUCT: (fortran-complex)
+    { "float" "r" }
+    { "float" "i" } ;
+C-STRUCT: (fortran-double-complex)
+    { "double" "r" }
+    { "double" "i" } ;
+
+: fortran-c-abi ( -- abi ) "cdecl" ;
+
+: fortran-name>symbol-name ( fortran-name -- c-name )
+    >lower CHAR: _ over member? 
+    [ "__" append ] [ "_" append ] if ;
+
+ERROR: invalid-fortran-type type ;
+
+<PRIVATE
+
+TUPLE: fortran-type dims size ;
+
+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 ( dims size class -- type )
+    new [ (>>size) ] [ (>>dims) ] [ ] tri ;
+
+GENERIC: (fortran-type>c-type) ( type -- c-type )
+
+M: integer-type (fortran-type>c-type)
+    {
+        { f [ "int"      ] }
+        { 2 [ "short"    ] }
+        { 4 [ "int"      ] }
+        { 8 [ "longlong" ] }
+    } size-case-type ;
+M: real-type (fortran-type>c-type)
+    {
+        { f [ "float"  ] }
+        { 4 [ "float"  ] }
+        { 8 [ "double" ] }
+    } size-case-type ;
+M: complex-type (fortran-type>c-type)
+    {
+        {  f [ "(fortran-complex)"        ] }
+        {  8 [ "(fortran-complex)"        ] }
+        { 16 [ "(fortran-double-complex)" ] }
+    } size-case-type ;
+
+M: double-precision-type (fortran-type>c-type)
+    "double" simple-type ;
+M: double-complex-type (fortran-type>c-type)
+    "(fortran-double-complex)" simple-type ;
+M: misc-type (fortran-type>c-type)
+    dup name>> simple-type ;
+
+: fix-character-type ( character-type -- character-type' )
+    clone dup size>>
+    [ dup dims>> [ invalid-fortran-type ] [ dup size>> 1array >>dims f >>size ] if ]
+    [ dup dims>> [ ] [ { 1 } >>dims ] if ] if ;
+
+M: character-type (fortran-type>c-type)
+    fix-character-type "char" simple-type ;
+
+: dimension>number ( string -- number )
+    dup "*" = [ drop 0 ] [ string>number ] if ;
+
+: parse-dims ( string -- string' dim )
+    "(" split1 dup
+    [ ")" ?tail drop "," split [ [ blank? ] trim dimension>number ] map ] when ;
+
+: parse-size ( string -- string' size )
+    "*" split1 dup [ string>number ] when ;
+
+: parse-fortran-type ( fortran-type-string -- type )
+    parse-dims swap parse-size swap
+    dup >lower fortran>c-types at*
+    [ nip new-fortran-type ] [ drop misc-type boa ] if ;
+
+: c-type>pointer ( c-type -- c-type* )
+    "[" split1 drop "*" append ;
+
+GENERIC: added-c-args ( type -- args )
+
+M: fortran-type added-c-args drop { } ;
+M: character-type added-c-args drop { "long" } ;
+
+PRIVATE>
+
+: fortran-type>c-type ( fortran-type -- c-type )
+    parse-fortran-type (fortran-type>c-type) ;
+
+: fortran-arg-type>c-type ( fortran-type -- c-type added-args ) { } ;
+: fortran-ret-type>c-type ( fortran-type -- c-type added-args ) { } ;
+
+: fortran-sig>c-sig ( fortran-return fortran-args -- c-return c-args ) ;
+
+! : F-RECORD: ... ; parsing
+! : F-ABI: ... ; parsing
+! : F-SUBROUTINE: ... ; parsing
+! : F-FUNCTION: ... ; parsing
+

From 4429c17f63840647ce2467dbb385126fd9a081ef Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Thu, 5 Feb 2009 16:39:23 -0600
Subject: [PATCH 03/35] implement fortran-arg-type>c-type and
 fortran-ret-type>c-type

---
 basis/alien/fortran/fortran.factor | 29 +++++++++++++++++++++++++++--
 1 file changed, 27 insertions(+), 2 deletions(-)

diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor
index d83df9bd45..0c30258895 100644
--- a/basis/alien/fortran/fortran.factor
+++ b/basis/alien/fortran/fortran.factor
@@ -123,13 +123,38 @@ GENERIC: added-c-args ( type -- args )
 M: fortran-type added-c-args drop { } ;
 M: character-type added-c-args drop { "long" } ;
 
+GENERIC: added-c-arg-values ( type -- arg-values )
+
+M: fortran-type added-c-arg-values drop { } ;
+M: character-type added-c-arg-values
+    fix-character-type dims>> first 1array ;
+
+GENERIC: returns-by-value? ( type -- ? )
+
+M: fortran-type returns-by-value? drop f ;
+M: number-type returns-by-value? dims>> not ;
+M: complex-type returns-by-value? drop f ;
+
+GENERIC: (fortran-ret-type>c-type) ( type -- c-type )
+
+M: fortran-type (fortran-ret-type>c-type) (fortran-type>c-type) ;
+M: real-type (fortran-ret-type>c-type) drop "double" ;
+
 PRIVATE>
 
 : fortran-type>c-type ( fortran-type -- c-type )
     parse-fortran-type (fortran-type>c-type) ;
 
-: fortran-arg-type>c-type ( fortran-type -- c-type added-args ) { } ;
-: fortran-ret-type>c-type ( fortran-type -- c-type added-args ) { } ;
+: fortran-arg-type>c-type ( fortran-type -- c-type added-args )
+    parse-fortran-type
+    [ (fortran-type>c-type) c-type>pointer ]
+    [ added-c-args ] bi ;
+: fortran-ret-type>c-type ( fortran-type -- c-type added-args )
+    parse-fortran-type dup returns-by-value?
+    [ (fortran-ret-type>c-type) { } ] [
+        "void" swap 
+        [ added-c-args ] [ (fortran-ret-type>c-type) c-type>pointer ] bi prefix
+    ] if ;
 
 : fortran-sig>c-sig ( fortran-return fortran-args -- c-return c-args ) ;
 

From 7b1f16ae5ed2ee0b788456db20a84eb7922f14d2 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Thu, 5 Feb 2009 18:51:50 -0600
Subject: [PATCH 04/35] fortran records

---
 basis/alien/fortran/fortran-tests.factor | 62 ++++++++++++++++++------
 basis/alien/fortran/fortran.factor       | 28 +++++++++--
 basis/alien/structs/structs.factor       |  7 ++-
 3 files changed, 75 insertions(+), 22 deletions(-)

diff --git a/basis/alien/fortran/fortran-tests.factor b/basis/alien/fortran/fortran-tests.factor
index 29bd024930..11f0a2efc7 100644
--- a/basis/alien/fortran/fortran-tests.factor
+++ b/basis/alien/fortran/fortran-tests.factor
@@ -1,15 +1,11 @@
-USING: alien.fortran alien.syntax tools.test ;
+USING: accessors alien alien.c-types alien.fortran alien.structs
+alien.syntax arrays assocs kernel namespaces sequences tools.test ;
 IN: alien.fortran.tests
 
-C-STRUCT: fortran_test_struct
-    { "int" "foo" }
-    { "float" "bar" }
-    { "char[4]" "bas" } ;
-
-! F-RECORD: fortran_test_record
-!     { "integer" "foo" }
-!     { "real" "bar" }
-!     { "character*4" "bar" }
+F-RECORD: fortran_test_record
+    { "integer"     "foo" }
+    { "real"        "bar" }
+    { "character*4" "bas" } ;
 
 ! fortran-name>symbol-name
 
@@ -25,7 +21,7 @@ C-STRUCT: fortran_test_struct
 [ "integer*4" fortran-type>c-type ] unit-test
 
 [ "int" ]
-[ "integer" fortran-type>c-type ] unit-test
+[ "INTEGER" fortran-type>c-type ] unit-test
 
 [ "longlong" ]
 [ "iNteger*8" fortran-type>c-type ] unit-test
@@ -84,9 +80,6 @@ C-STRUCT: fortran_test_struct
 [ "(fortran-double-complex)" ]
 [ "complex*16" fortran-type>c-type ] unit-test
 
-[ "fortran_test_struct" ]
-[ "fortran_test_struct" fortran-type>c-type ] unit-test
-
 [ "fortran_test_record" ]
 [ "fortran_test_record" fortran-type>c-type ] unit-test
 
@@ -101,8 +94,8 @@ C-STRUCT: fortran_test_struct
 [ "int*" { } ]
 [ "integer(*)" fortran-arg-type>c-type ] unit-test
 
-[ "fortran_test_struct*" { } ]
-[ "fortran_test_struct" fortran-arg-type>c-type ] unit-test
+[ "fortran_test_record*" { } ]
+[ "fortran_test_record" fortran-arg-type>c-type ] unit-test
 
 [ "char*" { "long" } ]
 [ "character" fortran-arg-type>c-type ] unit-test
@@ -139,3 +132,40 @@ C-STRUCT: fortran_test_struct
 [ "void" { "fortran_test_record*" } ]
 [ "fortran_test_record" fortran-ret-type>c-type ] unit-test
 
+! fortran-sig>c-sig
+
+[ "double" { "int*" "char*" "float*" "double*" "long" } ]
+[ "real" { "integer" "character*17" "real" "real*8" } fortran-sig>c-sig ]
+unit-test
+
+[ "void" { "char*" "long" "char*" "char*" "int*" "long" "long" } ]
+[ "character*18" { "character*17" "character" "integer" } fortran-sig>c-sig ]
+unit-test
+
+[ "void" { "(fortran-complex)*" "char*" "char*" "int*" "long" "long" } ]
+[ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ]
+unit-test
+
+! fortran-record>c-struct
+
+[ {
+    { "double"   "ex"  }
+    { "float"    "wye" }
+    { "int"      "zee" }
+    { "char[20]" "woo" }
+} ] [
+    {
+        { "DOUBLE PRECISION" "EX"  }
+        { "REAL"             "WYE" }
+        { "INTEGER"          "ZEE" }
+        { "CHARACTER(20)"    "WOO" }
+    } fortran-record>c-struct
+] unit-test
+
+! F-RECORD:
+
+[ 12 ] [ "fortran_test_record" heap-size ] unit-test
+[  0 ] [ "foo" "fortran_test_record" offset-of ] unit-test
+[  4 ] [ "bar" "fortran_test_record" offset-of ] unit-test
+[  8 ] [ "bas" "fortran_test_record" offset-of ] unit-test
+
diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor
index 0c30258895..327db12909 100644
--- a/basis/alien/fortran/fortran.factor
+++ b/basis/alien/fortran/fortran.factor
@@ -1,5 +1,6 @@
-USING: accessors alien alien.c-types alien.syntax arrays ascii
-assocs combinators fry kernel macros math.parser sequences splitting ;
+USING: accessors alien alien.c-types alien.structs alien.syntax
+arrays ascii assocs combinators fry kernel lexer macros math.parser
+namespaces parser sequences splitting vectors vocabs.parser ;
 IN: alien.fortran
 
 ! XXX this currently only supports the gfortran/f2c abi.
@@ -65,9 +66,12 @@ MACRO: size-case-type ( cases -- )
 
 GENERIC: (fortran-type>c-type) ( type -- c-type )
 
+M: f (fortran-type>c-type) ;
+
 M: integer-type (fortran-type>c-type)
     {
         { f [ "int"      ] }
+        { 1 [ "char"     ] }
         { 2 [ "short"    ] }
         { 4 [ "int"      ] }
         { 8 [ "longlong" ] }
@@ -140,6 +144,9 @@ GENERIC: (fortran-ret-type>c-type) ( type -- c-type )
 M: fortran-type (fortran-ret-type>c-type) (fortran-type>c-type) ;
 M: real-type (fortran-ret-type>c-type) drop "double" ;
 
+: suffix! ( seq   elt   -- seq   ) over push     ; inline
+: append! ( seq-a seq-b -- seq-a ) over push-all ; inline
+
 PRIVATE>
 
 : fortran-type>c-type ( fortran-type -- c-type )
@@ -156,10 +163,21 @@ PRIVATE>
         [ added-c-args ] [ (fortran-ret-type>c-type) c-type>pointer ] bi prefix
     ] if ;
 
-: fortran-sig>c-sig ( fortran-return fortran-args -- c-return c-args ) ;
+: fortran-arg-types>c-types ( fortran-types -- c-types )
+    [ length <vector> 1 <vector> ] keep
+    [ fortran-arg-type>c-type swapd [ suffix! ] [ append! ] 2bi* ] each
+    append >array ;
 
-! : F-RECORD: ... ; parsing
-! : F-ABI: ... ; parsing
+: fortran-sig>c-sig ( fortran-return fortran-args -- c-return c-args )
+    [ fortran-ret-type>c-type ] [ fortran-arg-types>c-types ] bi* append ;
+
+: fortran-record>c-struct ( record -- struct )
+    [ first2 [ fortran-type>c-type ] [ >lower ] bi* 2array ] map ;
+
+: define-record ( name vocab fields -- )
+    [ >lower ] [ ] [ fortran-record>c-struct ] tri* define-struct ;
+
+: F-RECORD: scan in get parse-definition define-record ; parsing
 ! : F-SUBROUTINE: ... ; parsing
 ! : F-FUNCTION: ... ; parsing
 
diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor
index 42923fb28b..cb3f90d358 100644
--- a/basis/alien/structs/structs.factor
+++ b/basis/alien/structs/structs.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays generic hashtables kernel kernel.private
+USING: accessors arrays assocs generic hashtables kernel kernel.private
 math namespaces parser sequences strings words libc fry
 alien.c-types alien.structs.fields cpu.architecture math.order ;
 IN: alien.structs
@@ -61,3 +61,8 @@ M: struct-type stack-size
     [ expand-constants ] map
     [ [ heap-size ] [ max ] map-reduce ] keep
     compute-struct-align f (define-struct) ;
+
+: offset-of ( field struct -- offset )
+    c-types get at fields>> 
+    [ name>> = ] with find nip offset>> ;
+

From 7e2ac604e718b29bf3e6e8052ac75e22390d92e1 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Fri, 6 Feb 2009 10:06:22 -0600
Subject: [PATCH 05/35] some initial work on invoking fortran functions

---
 basis/alien/fortran/fortran-tests.factor | 46 +++++++++++++--
 basis/alien/fortran/fortran.factor       | 72 ++++++++++++++++++++----
 2 files changed, 103 insertions(+), 15 deletions(-)

diff --git a/basis/alien/fortran/fortran-tests.factor b/basis/alien/fortran/fortran-tests.factor
index 11f0a2efc7..a1f2443b30 100644
--- a/basis/alien/fortran/fortran-tests.factor
+++ b/basis/alien/fortran/fortran-tests.factor
@@ -1,3 +1,4 @@
+! (c) 2009 Joe Groff, see BSD license
 USING: accessors alien alien.c-types alien.fortran alien.structs
 alien.syntax arrays assocs kernel namespaces sequences tools.test ;
 IN: alien.fortran.tests
@@ -11,6 +12,7 @@ F-RECORD: fortran_test_record
 
 [ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test
 [ "fun_times__" ] [ "Fun_Times" fortran-name>symbol-name ] unit-test
+[ "funtimes___" ] [ "FunTimes_" fortran-name>symbol-name ] unit-test
 
 ! fortran-type>c-type
 
@@ -57,7 +59,7 @@ F-RECORD: fortran_test_record
 [ "real" fortran-type>c-type ] unit-test
 
 [ "double" ]
-[ "double precision" fortran-type>c-type ] unit-test
+[ "double-precision" fortran-type>c-type ] unit-test
 
 [ "float" ]
 [ "real*4" fortran-type>c-type ] unit-test
@@ -69,7 +71,7 @@ F-RECORD: fortran_test_record
 [ "complex" fortran-type>c-type ] unit-test
 
 [ "(fortran-double-complex)" ]
-[ "double complex" fortran-type>c-type ] unit-test
+[ "double-complex" fortran-type>c-type ] unit-test
 
 [ "(fortran-complex)" ]
 [ "complex*8" fortran-type>c-type ] unit-test
@@ -118,13 +120,13 @@ F-RECORD: fortran_test_record
 [ "real" fortran-ret-type>c-type ] unit-test
 
 [ "double" { } ]
-[ "double precision" fortran-ret-type>c-type ] unit-test
+[ "double-precision" fortran-ret-type>c-type ] unit-test
 
 [ "void" { "(fortran-complex)*" } ]
 [ "complex" fortran-ret-type>c-type ] unit-test
 
 [ "void" { "(fortran-double-complex)*" } ]
-[ "double complex" fortran-ret-type>c-type ] unit-test
+[ "double-complex" fortran-ret-type>c-type ] unit-test
 
 [ "void" { "int*" } ]
 [ "integer(*)" fortran-ret-type>c-type ] unit-test
@@ -155,7 +157,7 @@ unit-test
     { "char[20]" "woo" }
 } ] [
     {
-        { "DOUBLE PRECISION" "EX"  }
+        { "DOUBLE-PRECISION" "EX"  }
         { "REAL"             "WYE" }
         { "INTEGER"          "ZEE" }
         { "CHARACTER(20)"    "WOO" }
@@ -169,3 +171,37 @@ unit-test
 [  4 ] [ "bar" "fortran_test_record" offset-of ] unit-test
 [  8 ] [ "bas" "fortran_test_record" offset-of ] unit-test
 
+! fortran-arg>c-args
+
+[ B{ 128 } { } ]
+[ 128 "integer*1" fortran-arg>c-args ] unit-test
+
+little-endian? [ B{ 128 0 } { } ] [ B{ 0 128 } { } ] ?
+[ 128 "integer*2" fortran-arg>c-args ] unit-test
+
+little-endian? [ B{ 128 0 0 0 } { } ] [ B{ 0 0 0 128 } { } ] ?
+[ 128 "integer*4" fortran-arg>c-args ] unit-test
+
+little-endian? [ B{ 128 0 0 0 0 0 0 0 } { } ] [ B{ 0 0 0 0 0 0 0 128 } { } ] ?
+[ 128 "integer*8" fortran-arg>c-args ] unit-test
+
+[ B{ CHAR: h CHAR: e CHAR: l CHAR: l CHAR: o } { 5 } ]
+[ "hello" "character*5" fortran-arg>c-args ] unit-test
+
+little-endian? [ B{ 0 0 128 63 } { } ] [ B{ 63 128 0 0 } { } ] ?
+[ 1.0 "real" fortran-arg>c-args ] unit-test
+
+little-endian? [ B{ 0 0 128 63 0 0 0 64 } { } ] [ B{ 63 128 0 0 64 0 0 0 } { } ] ?
+[ C{ 1.0 2.0 } "complex" fortran-arg>c-args ] unit-test
+
+little-endian? [ B{ 0 0 0 0 0 0 240 63 } { } ] [ B{ 63 240 0 0 0 0 0 0 } { } ] ?
+[ 1.0 "double-precision" fortran-arg>c-args ] unit-test
+
+little-endian?
+[ B{ 0 0 0 0 0 0 240 63 0 0 0 0 0 0 0 64 } { } ] 
+[ B{ 63 240 0 0 0 0 0 0 64 0 0 0 0 0 0 0 } { } ] ?
+[ C{ 1.0 2.0 } "double-complex" fortran-arg>c-args ] unit-test
+
+[ B{ 1 0 0 0 2 0 0 0 } { } ]
+[ B{ 1 0 0 0 2 0 0 0 } "integer(2)" fortran-arg>c-args ] unit-test
+
diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor
index 327db12909..faec9b5b86 100644
--- a/basis/alien/fortran/fortran.factor
+++ b/basis/alien/fortran/fortran.factor
@@ -1,6 +1,7 @@
+! (c) 2009 Joe Groff, see BSD license
 USING: accessors alien alien.c-types alien.structs alien.syntax
 arrays ascii assocs combinators fry kernel lexer macros math.parser
-namespaces parser sequences splitting vectors vocabs.parser ;
+namespaces parser sequences splitting vectors vocabs.parser locals ;
 IN: alien.fortran
 
 ! XXX this currently only supports the gfortran/f2c abi.
@@ -43,9 +44,9 @@ CONSTANT: fortran>c-types H{
     { "integer"          integer-type          }
     { "logical"          logical-type          }
     { "real"             real-type             }
-    { "double precision" double-precision-type }
+    { "double-precision" double-precision-type }
     { "complex"          real-complex-type     }
-    { "double complex"   double-complex-type   }
+    { "double-complex"   double-complex-type   }
 }
 
 : append-dimensions ( base-c-type type -- c-type )
@@ -82,7 +83,7 @@ M: real-type (fortran-type>c-type)
         { 4 [ "float"  ] }
         { 8 [ "double" ] }
     } size-case-type ;
-M: complex-type (fortran-type>c-type)
+M: real-complex-type (fortran-type>c-type)
     {
         {  f [ "(fortran-complex)"        ] }
         {  8 [ "(fortran-complex)"        ] }
@@ -127,12 +128,6 @@ GENERIC: added-c-args ( type -- args )
 M: fortran-type added-c-args drop { } ;
 M: character-type added-c-args drop { "long" } ;
 
-GENERIC: added-c-arg-values ( type -- arg-values )
-
-M: fortran-type added-c-arg-values drop { } ;
-M: character-type added-c-arg-values
-    fix-character-type dims>> first 1array ;
-
 GENERIC: returns-by-value? ( type -- ? )
 
 M: fortran-type returns-by-value? drop f ;
@@ -147,6 +142,56 @@ M: real-type (fortran-ret-type>c-type) drop "double" ;
 : suffix! ( seq   elt   -- seq   ) over push     ; inline
 : append! ( seq-a seq-b -- seq-a ) over push-all ; inline
 
+: <real-complex> ( complex -- byte-array )
+    "(fortran-complex)" c-object
+    [ [ real-part      ] dip set-(fortran-complex)-r ]
+    [ [ imaginary-part ] dip set-(fortran-complex)-i ]
+    [ ] tri ;
+
+: <double-complex> ( complex -- byte-array )
+    "(fortran-double-complex)" c-object
+    [ [ real-part      ] dip set-(fortran-complex)-r ]
+    [ [ imaginary-part ] dip set-(fortran-complex)-i ]
+    [ ] tri ;
+
+GENERIC: [fortran-arg>c-args] ( type -- main-quot added-quot )
+
+M: integer-type [fortran-arg>c-args]
+    size>> {
+        { f [ [ <int>      ] [ drop ] ] }
+        { 1 [ [ <char>     ] [ drop ] ] }
+        { 2 [ [ <short>    ] [ drop ] ] }
+        { 4 [ [ <int>      ] [ drop ] ] }
+        { 8 [ [ <longlong> ] [ drop ] ] }
+        [ invalid-fortran-type ]
+    } case ;
+
+M: real-type [fortran-arg>c-args]
+    size>> {
+        { f [ [ <float>  ] [ drop ] ] }
+        { 4 [ [ <float>  ] [ drop ] ] }
+        { 8 [ [ <double> ] [ drop ] ] }
+        [ invalid-fortran-type ]
+    } case ;
+
+M: real-complex-type [fortran-arg>c-args]
+    size>> {
+        {  f [ [ <real-complex>   ] [ drop ] ] }
+        {  8 [ [ <real-complex>   ] [ drop ] ] }
+        { 16 [ [ <double-complex> ] [ drop ] ] }
+        [ invalid-fortran-type ]
+    } case ;
+
+M: real-complex-type [fortran-arg>c-args]
+    size>> {
+        {  f [ [ <real-complex>   ] [ drop ] ] }
+        {  8 [ [ <real-complex>   ] [ drop ] ] }
+        { 16 [ [ <double-complex> ] [ drop ] ] }
+        [ invalid-fortran-type ]
+    } case ;
+
+M: 
+
 PRIVATE>
 
 : fortran-type>c-type ( fortran-type -- c-type )
@@ -178,6 +223,13 @@ PRIVATE>
     [ >lower ] [ ] [ fortran-record>c-struct ] tri* define-struct ;
 
 : F-RECORD: scan in get parse-definition define-record ; parsing
+
+:: define-fortran-function ( return library function parameters -- )
+    ;    
+
+: F-SUBROUTINE:
+    
+
 ! : F-SUBROUTINE: ... ; parsing
 ! : F-FUNCTION: ... ; parsing
 

From 118f2de4667d47a79563b7a3d9c07308781c14b5 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Fri, 6 Feb 2009 19:05:56 -0600
Subject: [PATCH 06/35] fortran-invoke sketch

---
 basis/alien/complex/complex-tests.factor   |   2 +-
 basis/alien/complex/functor/functor.factor |  14 +-
 basis/alien/fortran/fortran-tests.factor   | 170 ++++++++++++++------
 basis/alien/fortran/fortran.factor         | 178 +++++++++++++++------
 4 files changed, 260 insertions(+), 104 deletions(-)

diff --git a/basis/alien/complex/complex-tests.factor b/basis/alien/complex/complex-tests.factor
index bfb2c1137c..0bff73b898 100644
--- a/basis/alien/complex/complex-tests.factor
+++ b/basis/alien/complex/complex-tests.factor
@@ -15,4 +15,4 @@ C-STRUCT: complex-holder
     C{ 1.0 2.0 } <complex-holder> "h" set
 ] unit-test
 
-[ C{ 1.0 2.0 } ] [ "h" get complex-holder-z ] unit-test
\ No newline at end of file
+[ C{ 1.0 2.0 } ] [ "h" get complex-holder-z ] unit-test
diff --git a/basis/alien/complex/functor/functor.factor b/basis/alien/complex/functor/functor.factor
index 1d12bb0ff4..c6644eba1d 100644
--- a/basis/alien/complex/functor/functor.factor
+++ b/basis/alien/complex/functor/functor.factor
@@ -12,15 +12,15 @@ T-imaginary DEFINES ${T}-imaginary
 set-T-real DEFINES set-${T}-real
 set-T-imaginary DEFINES set-${T}-imaginary
 
->T DEFINES >${T}
-T> DEFINES ${T}>
+<T> DEFINES <${T}>
+*T DEFINES *${T}
 
 WHERE
 
-: >T ( z -- alien )
+: <T> ( z -- alien )
     >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 in get
@@ -28,8 +28,8 @@ T in get
 define-struct
 
 T c-type
-T> 1quotation >>boxer-quot
->T 1quotation >>unboxer-quot
+<T> 1quotation >>boxer-quot
+*T 1quotation >>unboxer-quot
 drop
 
-;FUNCTOR
\ No newline at end of file
+;FUNCTOR
diff --git a/basis/alien/fortran/fortran-tests.factor b/basis/alien/fortran/fortran-tests.factor
index a1f2443b30..0a86cba7e3 100644
--- a/basis/alien/fortran/fortran-tests.factor
+++ b/basis/alien/fortran/fortran-tests.factor
@@ -1,12 +1,13 @@
 ! (c) 2009 Joe Groff, see BSD license
 USING: accessors alien alien.c-types alien.fortran alien.structs
-alien.syntax arrays assocs kernel namespaces sequences tools.test ;
+alien.syntax arrays assocs kernel macros namespaces sequences
+tools.test fry ;
 IN: alien.fortran.tests
 
-F-RECORD: fortran_test_record
-    { "integer"     "foo" }
-    { "real"        "bar" }
-    { "character*4" "bas" } ;
+RECORD: FORTRAN_TEST_RECORD
+    { "INTEGER"     "FOO" }
+    { "REAL(2)"     "BAR" }
+    { "CHARACTER*4" "BAS" } ;
 
 ! fortran-name>symbol-name
 
@@ -67,19 +68,16 @@ F-RECORD: fortran_test_record
 [ "double" ]
 [ "real*8" fortran-type>c-type ] unit-test
 
-[ "(fortran-complex)" ]
+[ "complex-float" ]
 [ "complex" fortran-type>c-type ] unit-test
 
-[ "(fortran-double-complex)" ]
+[ "complex-double" ]
 [ "double-complex" fortran-type>c-type ] unit-test
 
-[ "(fortran-complex)" ]
+[ "complex-float" ]
 [ "complex*8" fortran-type>c-type ] unit-test
 
-[ "(fortran-double-complex)" ]
-[ "complex*16" fortran-type>c-type ] unit-test
-
-[ "(fortran-double-complex)" ]
+[ "complex-double" ]
 [ "complex*16" fortran-type>c-type ] unit-test
 
 [ "fortran_test_record" ]
@@ -122,10 +120,10 @@ F-RECORD: fortran_test_record
 [ "double" { } ]
 [ "double-precision" fortran-ret-type>c-type ] unit-test
 
-[ "void" { "(fortran-complex)*" } ]
+[ "void" { "complex-float*" } ]
 [ "complex" fortran-ret-type>c-type ] unit-test
 
-[ "void" { "(fortran-double-complex)*" } ]
+[ "void" { "complex-double*" } ]
 [ "double-complex" fortran-ret-type>c-type ] unit-test
 
 [ "void" { "int*" } ]
@@ -144,7 +142,7 @@ unit-test
 [ "character*18" { "character*17" "character" "integer" } fortran-sig>c-sig ]
 unit-test
 
-[ "void" { "(fortran-complex)*" "char*" "char*" "int*" "long" "long" } ]
+[ "void" { "complex-float*" "char*" "char*" "int*" "long" "long" } ]
 [ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ]
 unit-test
 
@@ -164,44 +162,126 @@ unit-test
     } fortran-record>c-struct
 ] unit-test
 
-! F-RECORD:
+! RECORD:
 
-[ 12 ] [ "fortran_test_record" heap-size ] unit-test
+[ 16 ] [ "fortran_test_record" heap-size ] unit-test
 [  0 ] [ "foo" "fortran_test_record" offset-of ] unit-test
 [  4 ] [ "bar" "fortran_test_record" offset-of ] unit-test
-[  8 ] [ "bas" "fortran_test_record" offset-of ] unit-test
+[ 12 ] [ "bas" "fortran_test_record" offset-of ] unit-test
 
-! fortran-arg>c-args
+! fortran-invoke
 
-[ B{ 128 } { } ]
-[ 128 "integer*1" fortran-arg>c-args ] unit-test
+: fortran-invoke-expansion ( return library function parameters -- quot )
+    '[ _ _ _ _ fortran-invoke ] expand-macros ; inline
 
-little-endian? [ B{ 128 0 } { } ] [ B{ 0 128 } { } ] ?
-[ 128 "integer*2" fortran-arg>c-args ] unit-test
+[ [
+    ! [fortran-args>c-args]
+    {
+        [ {
+            [ ascii string>alien ]
+            [ <int> ]
+            [ <float> ]
+            [ <complex-float> ]
+            [ 1 0 ? <short> ]
+        } spread ]
+        [ { [ length ] [ drop ] [ drop ] [ drop ] [ drop ] } spread ]
+    } 5 ncleave
+    ! [fortran-invoke]
+    [ 
+        "void" "foopack" "funtimes_"
+        { "char*" "int*" "float*" "complex-float*" "short*" "long" }
+        alien-invoke
+    ] 6 nkeep
+    ! [fortran-results>]
+    {
+        [ drop ]
+        [ drop ]
+        [ *float ]
+        [ drop ]
+        [ drop ]
+        [ drop ]
+    } spread
+] ] [
+    f "foopack" "FUNTIMES" { "CHARACTER*12" "INTEGER*8" "!REAL" "COMPLEX" "LOGICAL*2" }
+    fortran-invoke-expansion
+] unit-test
 
-little-endian? [ B{ 128 0 0 0 } { } ] [ B{ 0 0 0 128 } { } ] ?
-[ 128 "integer*4" fortran-arg>c-args ] unit-test
+[ [
+    ! [fortran-invoke]
+    "double" "foopack" "fun_times__"
+    { "float*" } 
+    alien-invoke
+] ] [
+    "REAL" "foopack" "FUN_TIMES" { "REAL(*)" }
+    fortran-invoke-expansion
+] unit-test
 
-little-endian? [ B{ 128 0 0 0 0 0 0 0 } { } ] [ B{ 0 0 0 0 0 0 0 128 } { } ] ?
-[ 128 "integer*8" fortran-arg>c-args ] unit-test
+[ [
+    ! [<fortran-result>]
+    [ "complex-float" <c-object> ] 1 ndip
+    ! [fortran-invoke]
+    [
+        "void" "foopack" "fun_times__"
+        { "complex-float*" "float*" } 
+        alien-invoke
+    ] 2 nkeep
+    ! [fortran-results>]
+    {
+        [ *complex-float ]
+        [ drop ]
+    } spread
+] ] [
+    "COMPLEX" "foopack" "FUN_TIMES" { "REAL(*)" }
+    fortran-invoke-expansion
+] unit-test
 
-[ B{ CHAR: h CHAR: e CHAR: l CHAR: l CHAR: o } { 5 } ]
-[ "hello" "character*5" fortran-arg>c-args ] unit-test
+[ [
+    ! [<fortran-result>]
+    [ 20 <byte-array> 20 ] 1 ndip
+    ! [fortran-invoke]
+    [
+        "void" "foopack" "fun_times__"
+        { "char*" "long" "float*" } 
+        alien-invoke
+    ] 3 nkeep
+    ! [fortran-results>]
+    {
+        [ ]
+        [ ascii alien>nstring ]
+        [ drop ]
+    } spread
+] ] [
+    "CHARACTER*20" "foopack" "FUN_TIMES" { }
+    fortran-invoke-expansion
+] unit-test
 
-little-endian? [ B{ 0 0 128 63 } { } ] [ B{ 63 128 0 0 } { } ] ?
-[ 1.0 "real" fortran-arg>c-args ] unit-test
-
-little-endian? [ B{ 0 0 128 63 0 0 0 64 } { } ] [ B{ 63 128 0 0 64 0 0 0 } { } ] ?
-[ C{ 1.0 2.0 } "complex" fortran-arg>c-args ] unit-test
-
-little-endian? [ B{ 0 0 0 0 0 0 240 63 } { } ] [ B{ 63 240 0 0 0 0 0 0 } { } ] ?
-[ 1.0 "double-precision" fortran-arg>c-args ] unit-test
-
-little-endian?
-[ B{ 0 0 0 0 0 0 240 63 0 0 0 0 0 0 0 64 } { } ] 
-[ B{ 63 240 0 0 0 0 0 0 64 0 0 0 0 0 0 0 } { } ] ?
-[ C{ 1.0 2.0 } "double-complex" fortran-arg>c-args ] unit-test
-
-[ B{ 1 0 0 0 2 0 0 0 } { } ]
-[ B{ 1 0 0 0 2 0 0 0 } "integer(2)" fortran-arg>c-args ] unit-test
+[ [
+    ! [<fortran-result>]
+    [ 10 <byte-array> 10 ] 2 ndip
+    ! [fortran-args>c-args]
+    {
+        [ {
+            [ ascii string>alien ]
+            [ <float> ]
+        } spread ]
+        [ { [ length ] [ drop ] } spread ]
+    } 2 ncleave
+    ! [fortran-invoke]
+    [
+        "void" "foopack" "fun_times__"
+        { "char*" "long" "char*" "float*" "long" } 
+        alien-invoke
+    ] 5 nkeep
+    ! [fortran-results>]
+    {
+        [ ]
+        [ ascii alien>nstring ]
+        [ ]
+        [ *float swap ]
+        [ ascii alien>nstring ]
+    } spread
+] ] [
+    "CHARACTER*10" "foopack" "FUN_TIMES" { "!CHARACTER*20" "!REAL" }
+    fortran-invoke-expansion
+] unit-test
 
diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor
index faec9b5b86..b0bbedd716 100644
--- a/basis/alien/fortran/fortran.factor
+++ b/basis/alien/fortran/fortran.factor
@@ -1,20 +1,15 @@
 ! (c) 2009 Joe Groff, see BSD license
 USING: accessors alien alien.c-types alien.structs alien.syntax
 arrays ascii assocs combinators fry kernel lexer macros math.parser
-namespaces parser sequences splitting vectors vocabs.parser locals ;
+namespaces parser sequences splitting vectors vocabs.parser locals
+io.encodings.ascii io.encodings.string ;
 IN: alien.fortran
 
 ! XXX this currently only supports the gfortran/f2c abi.
 ! XXX we should also support ifort at some point for commercial BLASes
 
-C-STRUCT: (fortran-complex)
-    { "float" "r" }
-    { "float" "i" } ;
-C-STRUCT: (fortran-double-complex)
-    { "double" "r" }
-    { "double" "i" } ;
-
-: fortran-c-abi ( -- abi ) "cdecl" ;
+: alien>nstring ( alien len encoding -- string )
+    [ memory>byte-array ] dip decode ;
 
 : fortran-name>symbol-name ( fortran-name -- c-name )
     >lower CHAR: _ over member? 
@@ -22,9 +17,11 @@ C-STRUCT: (fortran-double-complex)
 
 ERROR: invalid-fortran-type type ;
 
+DEFER: fortran-sig>c-sig
+
 <PRIVATE
 
-TUPLE: fortran-type dims size ;
+TUPLE: fortran-type dims size out? ;
 
 TUPLE: number-type < fortran-type ;
 TUPLE: integer-type < number-type ;
@@ -62,12 +59,12 @@ MACRO: size-case-type ( cases -- )
     [ dup size>> [ invalid-fortran-type ] [ drop ] if ]
     [ append-dimensions ] bi ;
 
-: new-fortran-type ( dims size class -- type )
-    new [ (>>size) ] [ (>>dims) ] [ ] tri ;
+: new-fortran-type ( out? dims size class -- type )
+    new [ [ (>>size) ] [ (>>dims) ] [ (>>out?) ] tri ] keep ;
 
 GENERIC: (fortran-type>c-type) ( type -- c-type )
 
-M: f (fortran-type>c-type) ;
+M: f (fortran-type>c-type) drop "void" ;
 
 M: integer-type (fortran-type>c-type)
     {
@@ -85,9 +82,9 @@ M: real-type (fortran-type>c-type)
     } size-case-type ;
 M: real-complex-type (fortran-type>c-type)
     {
-        {  f [ "(fortran-complex)"        ] }
-        {  8 [ "(fortran-complex)"        ] }
-        { 16 [ "(fortran-double-complex)" ] }
+        {  f [ "complex-float"  ] }
+        {  8 [ "complex-float"  ] }
+        { 16 [ "complex-double" ] }
     } size-case-type ;
 
 M: double-precision-type (fortran-type>c-type)
@@ -108,6 +105,9 @@ M: character-type (fortran-type>c-type)
 : dimension>number ( string -- number )
     dup "*" = [ drop 0 ] [ string>number ] if ;
 
+: parse-out ( string -- string' out? )
+    "!" ?head ;
+
 : parse-dims ( string -- string' dim )
     "(" split1 dup
     [ ")" ?tail drop "," split [ [ blank? ] trim dimension>number ] map ] when ;
@@ -115,10 +115,13 @@ M: character-type (fortran-type>c-type)
 : parse-size ( string -- string' size )
     "*" split1 dup [ string>number ] when ;
 
-: parse-fortran-type ( fortran-type-string -- type )
-    parse-dims swap parse-size swap
+: (parse-fortran-type) ( fortran-type-string -- type )
+    parse-out swap parse-dims swap parse-size swap
     dup >lower fortran>c-types at*
-    [ nip new-fortran-type ] [ drop misc-type boa ] if ;
+    [ nip new-fortran-type ] [ drop f misc-type boa ] if ;
+
+: parse-fortran-type ( fortran-type-string/f -- type/f )
+    dup [ (parse-fortran-type) ] when ;
 
 : c-type>pointer ( c-type -- c-type* )
     "[" split1 drop "*" append ;
@@ -130,33 +133,23 @@ M: character-type added-c-args drop { "long" } ;
 
 GENERIC: returns-by-value? ( type -- ? )
 
+M: f returns-by-value? drop t ;
 M: fortran-type returns-by-value? drop f ;
 M: number-type returns-by-value? dims>> not ;
 M: complex-type returns-by-value? drop f ;
 
 GENERIC: (fortran-ret-type>c-type) ( type -- c-type )
 
+M: f (fortran-ret-type>c-type) drop "void" ;
 M: fortran-type (fortran-ret-type>c-type) (fortran-type>c-type) ;
 M: real-type (fortran-ret-type>c-type) drop "double" ;
 
 : suffix! ( seq   elt   -- seq   ) over push     ; inline
 : append! ( seq-a seq-b -- seq-a ) over push-all ; inline
 
-: <real-complex> ( complex -- byte-array )
-    "(fortran-complex)" c-object
-    [ [ real-part      ] dip set-(fortran-complex)-r ]
-    [ [ imaginary-part ] dip set-(fortran-complex)-i ]
-    [ ] tri ;
+GENERIC: (fortran-arg>c-args) ( type -- main-quot added-quot )
 
-: <double-complex> ( complex -- byte-array )
-    "(fortran-double-complex)" c-object
-    [ [ real-part      ] dip set-(fortran-complex)-r ]
-    [ [ imaginary-part ] dip set-(fortran-complex)-i ]
-    [ ] tri ;
-
-GENERIC: [fortran-arg>c-args] ( type -- main-quot added-quot )
-
-M: integer-type [fortran-arg>c-args]
+M: integer-type (fortran-arg>c-args)
     size>> {
         { f [ [ <int>      ] [ drop ] ] }
         { 1 [ [ <char>     ] [ drop ] ] }
@@ -166,7 +159,10 @@ M: integer-type [fortran-arg>c-args]
         [ invalid-fortran-type ]
     } case ;
 
-M: real-type [fortran-arg>c-args]
+M: logical-type (fortran-arg>c-args)
+    call-next-method [ [ 1 0 ? ] prepend ] dip ;
+
+M: real-type (fortran-arg>c-args)
     size>> {
         { f [ [ <float>  ] [ drop ] ] }
         { 4 [ [ <float>  ] [ drop ] ] }
@@ -174,23 +170,92 @@ M: real-type [fortran-arg>c-args]
         [ invalid-fortran-type ]
     } case ;
 
-M: real-complex-type [fortran-arg>c-args]
+M: real-complex-type (fortran-arg>c-args)
     size>> {
-        {  f [ [ <real-complex>   ] [ drop ] ] }
-        {  8 [ [ <real-complex>   ] [ drop ] ] }
-        { 16 [ [ <double-complex> ] [ drop ] ] }
+        {  f [ [ <complex-float>  ] [ drop ] ] }
+        {  8 [ [ <complex-float>  ] [ drop ] ] }
+        { 16 [ [ <complex-double> ] [ drop ] ] }
         [ invalid-fortran-type ]
     } case ;
 
-M: real-complex-type [fortran-arg>c-args]
+M: double-precision-type (fortran-arg>c-args)
+    drop [ <double> ] [ drop ] ;
+
+M: double-complex-type (fortran-arg>c-args)
+    drop [ <complex-double> ] [ drop ] ;
+
+M: character-type (fortran-arg>c-args)
+    drop [ ascii string>alien ] [ length ] ;
+
+M: misc-type (fortran-arg>c-args)
+    drop [ ] [ drop ] ;
+
+GENERIC: (fortran-result>) ( type -- quot )
+
+M: integer-type (fortran-result>)
     size>> {
-        {  f [ [ <real-complex>   ] [ drop ] ] }
-        {  8 [ [ <real-complex>   ] [ drop ] ] }
-        { 16 [ [ <double-complex> ] [ drop ] ] }
+        { f [ [ *int      ] ] }
+        { 1 [ [ *char     ] ] }
+        { 2 [ [ *short    ] ] }
+        { 4 [ [ *int      ] ] }
+        { 8 [ [ *longlong ] ] }
         [ invalid-fortran-type ]
     } case ;
 
-M: 
+M: logical-type (fortran-result>)
+    call-next-method [ zero? not ] append ;
+
+M: real-type (fortran-result>)
+    size>> {
+        { f [ [ *float  ] ] }
+        { 4 [ [ *float  ] ] }
+        { 8 [ [ *double ] ] }
+        [ invalid-fortran-type ]
+    } case ;
+
+M: real-complex-type (fortran-result>)
+    size>> {
+        {  f [ [ *complex-float  ] ] }
+        {  8 [ [ *complex-float  ] ] }
+        { 16 [ [ *complex-double ] ] }
+        [ invalid-fortran-type ]
+    } case ;
+
+M: double-precision-type (fortran-result>)
+    drop [ *double ] ;
+
+M: double-complex-type (fortran-result>)
+    drop [ *complex-double ] ;
+
+M: character-type (fortran-result>)
+    drop [ ascii alien>nstring ] ;
+
+M: misc-type (fortran-result>)
+    drop [ ] ;
+
+GENERIC: (<fortran-result>) ( type -- quot )
+
+M: fortran-type (<fortran-result>) 
+    (fortran-type>c-type) '[ _ <c-object> ] ;
+
+: [<fortran-result>] ( return parameters -- quot )
+    [ parse-fortran-type ] dip
+    over returns-by-value?
+    [ 2drop [ ] ]
+    [ [ (<fortran-result>) ] [ '[ _ _ ndip ] ] bi* ] if ;
+
+: [fortran-args>c-args] ( parameters -- quot )
+    [ parse-fortran-type (fortran-arg>c-args) 2array ] map flip first2
+    [ [ '[ _ spread ] ] bi@ 2array ] [ length ] bi 
+    '[ _ _ ncleave ] ;
+
+:: [fortran-invoke] ( return library function parameters -- quot ) 
+    return parameters fortran-sig>c-sig :> c-parameters :> c-return
+    function fortran-name>symbol-name :> c-function
+    [ c-return library c-function c-parameters alien-invoke ] ;
+
+: [fortran-results>] ( return parameters -- quot )
+    2drop [ ] ;
 
 PRIVATE>
 
@@ -219,17 +284,28 @@ PRIVATE>
 : fortran-record>c-struct ( record -- struct )
     [ first2 [ fortran-type>c-type ] [ >lower ] bi* 2array ] map ;
 
-: define-record ( name vocab fields -- )
+: define-fortran-record ( name vocab fields -- )
     [ >lower ] [ ] [ fortran-record>c-struct ] tri* define-struct ;
 
-: F-RECORD: scan in get parse-definition define-record ; parsing
+: RECORD: scan in get parse-definition define-fortran-record ; parsing
+
+MACRO: fortran-invoke ( return library function parameters -- )
+    {
+        [ 2nip [<fortran-result>] ]
+        [ nip nip nip [fortran-args>c-args] ]
+        [ [fortran-invoke] ]
+        [ 2nip [fortran-results>] ]
+    } 4 ncleave 3append ;
 
 :: define-fortran-function ( return library function parameters -- )
-    ;    
+    function create-in dup reset-generic 
+    return library function parameters return parse-arglist
+    [ '[ _ _ _ _ fortran-invoke ] ] dip define-declared ;
 
-: F-SUBROUTINE:
-    
-
-! : F-SUBROUTINE: ... ; parsing
-! : F-FUNCTION: ... ; parsing
+: SUBROUTINE: 
+    f "c-library" get scan ";" parse-tokens
+    [ "()" subseq? not ] filter define-fortran-function ; parsing
+: FUNCTION:
+    scan "c-library" get scan ";" parse-tokens
+    [ "()" subseq? not ] filter define-fortran-function ; parsing
 

From ea46845ac16fdce6122812b3733a029e9b090dea Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-103.local>
Date: Sun, 8 Feb 2009 20:32:11 -0600
Subject: [PATCH 07/35] Slight furnace cleanup

---
 basis/furnace/chloe-tags/chloe-tags.factor    | 13 ++++++++++---
 basis/furnace/utilities/utilities-docs.factor |  6 +++---
 basis/furnace/utilities/utilities.factor      | 12 ++++++------
 3 files changed, 19 insertions(+), 12 deletions(-)

diff --git a/basis/furnace/chloe-tags/chloe-tags.factor b/basis/furnace/chloe-tags/chloe-tags.factor
index d7d9ae9ebb..8003ab208b 100644
--- a/basis/furnace/chloe-tags/chloe-tags.factor
+++ b/basis/furnace/chloe-tags/chloe-tags.factor
@@ -81,11 +81,18 @@ CHLOE: a
 CHLOE: base
     compile-a-url [ [XML <base href=<->/> XML] ] [xml-code] ;
 
+: hidden-nested-fields ( -- xml )
+    nested-forms get " " join f like nested-forms-key
+    hidden-form-field ;
+
+: render-hidden ( for -- xml )
+    "," split [ hidden render>xml ] map ;
+
 : compile-hidden-form-fields ( for -- )
     '[
-        _ [ "," split [ hidden render>xml ] map ] [ f ] if*
-        nested-forms get " " join f like nested-forms-key hidden-form-field>xml
-        [ [ modify-form ] each-responder ] with-string-writer <unescaped>
+        _ render-hidden
+        hidden-nested-fields
+        form-modifications
         [XML <div style="display: none;"><-><-><-></div> XML]
     ] [code] ;
 
diff --git a/basis/furnace/utilities/utilities-docs.factor b/basis/furnace/utilities/utilities-docs.factor
index d2291786df..62f73d4f09 100644
--- a/basis/furnace/utilities/utilities-docs.factor
+++ b/basis/furnace/utilities/utilities-docs.factor
@@ -20,8 +20,8 @@ HELP: each-responder
 { $description "Applies the quotation to each responder involved in processing the current request." } ;
 
 HELP: hidden-form-field
-{ $values { "value" string } { "name" string } }
-{ $description "Renders an HTML hidden form field tag." }
+{ $values { "value" string } { "name" string } { "xml" "an XML chunk" } }
+{ $description "Renders an HTML hidden form field tag as XML." }
 { $notes "This word is used by session management, conversation scope and asides." }
 { $examples
     { $example
@@ -38,7 +38,7 @@ HELP: link-attr
 { $examples "Conversation scope adds attributes to link tags." } ;
 
 HELP: modify-form
-{ $values { "responder" "a responder" } }
+{ $values { "responder" "a responder" } { "xml/f" "an XML chunk or f" } }
 { $contract "Emits hidden form fields using " { $link hidden-form-field } "." }
 { $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." }
 { $examples "Session management, conversation scope and asides use hidden form fields to pass state." } ;
diff --git a/basis/furnace/utilities/utilities.factor b/basis/furnace/utilities/utilities.factor
index a2d4c4d996..2f998e039a 100755
--- a/basis/furnace/utilities/utilities.factor
+++ b/basis/furnace/utilities/utilities.factor
@@ -77,18 +77,18 @@ GENERIC: link-attr ( tag responder -- )
 
 M: object link-attr 2drop ;
 
-GENERIC: modify-form ( responder -- )
+GENERIC: modify-form ( responder -- xml/f )
 
-M: object modify-form drop ;
+M: object modify-form f ;
 
-: hidden-form-field>xml ( value name -- xml )
+: form-modifications ( -- xml )
+    [ [ modify-form [ , ] when ] each-responder ] { } make ;
+
+: hidden-form-field ( value name -- xml )
     over [
         [XML <input type="hidden" value=<-> name=<->/> XML]
     ] [ drop ] if ;
 
-: hidden-form-field ( value name -- )
-    hidden-form-field>xml write-xml ;
-
 : nested-forms-key "__n" ;
 
 : request-params ( request -- assoc )

From c3f5dc2e96d52cdc4e361f08ae201540365ce5b2 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-103.local>
Date: Sun, 8 Feb 2009 21:17:59 -0600
Subject: [PATCH 08/35] Help-lint edit for furnace.utilities

---
 basis/furnace/utilities/utilities.factor | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/basis/furnace/utilities/utilities.factor b/basis/furnace/utilities/utilities.factor
index 2f998e039a..4fc68f7735 100755
--- a/basis/furnace/utilities/utilities.factor
+++ b/basis/furnace/utilities/utilities.factor
@@ -79,10 +79,10 @@ M: object link-attr 2drop ;
 
 GENERIC: modify-form ( responder -- xml/f )
 
-M: object modify-form f ;
+M: object modify-form drop f ;
 
 : form-modifications ( -- xml )
-    [ [ modify-form [ , ] when ] each-responder ] { } make ;
+    [ [ modify-form [ , ] when* ] each-responder ] { } make ;
 
 : hidden-form-field ( value name -- xml )
     over [

From 3bc557467e7b01b472bc4372927634a84489847a Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Mon, 9 Feb 2009 11:40:05 -0600
Subject: [PATCH 09/35] shuffle( -- ) arbitrary stack shuffling word

---
 basis/shuffle/shuffle-tests.factor |  2 ++
 basis/shuffle/shuffle.factor       | 23 +++++++++++++++++++++--
 2 files changed, 23 insertions(+), 2 deletions(-)

diff --git a/basis/shuffle/shuffle-tests.factor b/basis/shuffle/shuffle-tests.factor
index f190544e19..8202146b3d 100644
--- a/basis/shuffle/shuffle-tests.factor
+++ b/basis/shuffle/shuffle-tests.factor
@@ -3,3 +3,5 @@ USING: shuffle tools.test ;
 [ 8 ] [ 5 6 7 8 3nip ] unit-test
 [ 3 1 2 3 ] [ 1 2 3 tuckd ] unit-test
 [ 1 2 3 4 ] [ 3 4 1 2 2swap ] unit-test
+
+[ 4 2 3 ] [ 1 2 3 4 shuffle( a b c d -- d b c ) ] unit-test
diff --git a/basis/shuffle/shuffle.factor b/basis/shuffle/shuffle.factor
index b195e4abf9..632c09e338 100644
--- a/basis/shuffle/shuffle.factor
+++ b/basis/shuffle/shuffle.factor
@@ -1,9 +1,28 @@
 ! Copyright (C) 2007 Chris Double, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel generalizations ;
-
+USING: accessors assocs effects.parser generalizations
+hashtables kernel locals locals.backend macros make math
+parser sequences ;
 IN: shuffle
 
+<PRIVATE
+
+: >locals-assoc ( sequence -- assoc )
+    dup length dup 1- [ - ] curry map zip >hashtable ;
+
+PRIVATE>
+
+MACRO: shuffle-effect ( effect -- )
+    [ out>> ] [ in>> >locals-assoc ] bi
+    [
+        [ nip assoc-size , \ load-locals , ]
+        [ [ at , \ get-local , ] curry each ]
+        [ nip assoc-size , \ drop-locals , ] 2tri
+    ] [ ] make ;
+
+: shuffle(
+    ")" parse-effect parsed \ shuffle-effect parsed ; parsing
+
 : 2swap ( x y z t -- z t x y ) 2 2 mnswap ; inline
 
 : nipd ( a b c -- b c ) rot drop ; inline

From 4dd500b5b1ab7d96fb1608f176782a5f57a1abc5 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Mon, 9 Feb 2009 13:29:50 -0600
Subject: [PATCH 10/35] fortran-invoke works(?)

---
 basis/alien/fortran/fortran-tests.factor |  98 ++++++------
 basis/alien/fortran/fortran.factor       | 194 +++++++++++++++--------
 2 files changed, 184 insertions(+), 108 deletions(-)

diff --git a/basis/alien/fortran/fortran-tests.factor b/basis/alien/fortran/fortran-tests.factor
index 0a86cba7e3..9b618ef513 100644
--- a/basis/alien/fortran/fortran-tests.factor
+++ b/basis/alien/fortran/fortran-tests.factor
@@ -1,7 +1,9 @@
 ! (c) 2009 Joe Groff, see BSD license
-USING: accessors alien alien.c-types alien.fortran alien.structs
-alien.syntax arrays assocs kernel macros namespaces sequences
-tools.test fry ;
+USING: accessors alien alien.c-types alien.complex
+alien.fortran alien.strings alien.structs alien.syntax arrays
+assocs byte-arrays combinators fry generalizations
+io.encodings.ascii kernel macros macros.expander namespaces
+sequences shuffle tools.test ;
 IN: alien.fortran.tests
 
 RECORD: FORTRAN_TEST_RECORD
@@ -169,17 +171,14 @@ unit-test
 [  4 ] [ "bar" "fortran_test_record" offset-of ] unit-test
 [ 12 ] [ "bas" "fortran_test_record" offset-of ] unit-test
 
-! fortran-invoke
-
-: fortran-invoke-expansion ( return library function parameters -- quot )
-    '[ _ _ _ _ fortran-invoke ] expand-macros ; inline
+! (fortran-invoke)
 
 [ [
     ! [fortran-args>c-args]
     {
         [ {
             [ ascii string>alien ]
-            [ <int> ]
+            [ <longlong> ]
             [ <float> ]
             [ <complex-float> ]
             [ 1 0 ? <short> ]
@@ -188,100 +187,109 @@ unit-test
     } 5 ncleave
     ! [fortran-invoke]
     [ 
-        "void" "foopack" "funtimes_"
-        { "char*" "int*" "float*" "complex-float*" "short*" "long" }
+        "void" "funpack" "funtimes_"
+        { "char*" "longlong*" "float*" "complex-float*" "short*" "long" }
         alien-invoke
     ] 6 nkeep
     ! [fortran-results>]
+    shuffle( aa ba ca da ea ab -- aa ab ba ca da ea ) 
     {
+        [ drop ]
         [ drop ]
         [ drop ]
         [ *float ]
         [ drop ]
         [ drop ]
-        [ drop ]
     } spread
 ] ] [
-    f "foopack" "FUNTIMES" { "CHARACTER*12" "INTEGER*8" "!REAL" "COMPLEX" "LOGICAL*2" }
-    fortran-invoke-expansion
+    f "funpack" "FUNTIMES" { "CHARACTER*12" "INTEGER*8" "!REAL" "COMPLEX" "LOGICAL*2" }
+    (fortran-invoke)
 ] unit-test
 
 [ [
+    ! [fortran-args>c-args]
+    {
+        [ { [ ] } spread ]
+        [ { [ drop ] } spread ]
+    } 1 ncleave
     ! [fortran-invoke]
-    "double" "foopack" "fun_times__"
-    { "float*" } 
-    alien-invoke
+    [ "double" "funpack" "fun_times__" { "float*" } alien-invoke ]
+    1 nkeep
+    ! [fortran-results>]
+    shuffle( reta aa -- reta aa ) 
+    { [ ] [ drop ] } spread
 ] ] [
-    "REAL" "foopack" "FUN_TIMES" { "REAL(*)" }
-    fortran-invoke-expansion
+    "REAL" "funpack" "FUN_TIMES" { "REAL(*)" }
+    (fortran-invoke)
 ] unit-test
 
 [ [
     ! [<fortran-result>]
     [ "complex-float" <c-object> ] 1 ndip
+    ! [fortran-args>c-args]
+    { [ { [ ] } spread ] [ { [ drop ] } spread ] } 1 ncleave
     ! [fortran-invoke]
     [
-        "void" "foopack" "fun_times__"
+        "void" "funpack" "fun_times__"
         { "complex-float*" "float*" } 
         alien-invoke
     ] 2 nkeep
     ! [fortran-results>]
-    {
-        [ *complex-float ]
-        [ drop ]
-    } spread
+    shuffle( reta aa -- reta aa )
+    { [ *complex-float ] [ drop ] } spread
 ] ] [
-    "COMPLEX" "foopack" "FUN_TIMES" { "REAL(*)" }
-    fortran-invoke-expansion
+    "COMPLEX" "funpack" "FUN_TIMES" { "REAL(*)" }
+    (fortran-invoke)
 ] unit-test
 
 [ [
     ! [<fortran-result>]
-    [ 20 <byte-array> 20 ] 1 ndip
+    [ 20 <byte-array> 20 ] 0 ndip
     ! [fortran-invoke]
     [
-        "void" "foopack" "fun_times__"
-        { "char*" "long" "float*" } 
+        "void" "funpack" "fun_times__"
+        { "char*" "long" } 
         alien-invoke
-    ] 3 nkeep
+    ] 2 nkeep
     ! [fortran-results>]
-    {
-        [ ]
-        [ ascii alien>nstring ]
-        [ drop ]
-    } spread
+    shuffle( reta retb -- reta retb ) 
+    { [ ] [ ascii alien>nstring ] } spread
 ] ] [
-    "CHARACTER*20" "foopack" "FUN_TIMES" { }
-    fortran-invoke-expansion
+    "CHARACTER*20" "funpack" "FUN_TIMES" { }
+    (fortran-invoke)
 ] unit-test
 
 [ [
     ! [<fortran-result>]
-    [ 10 <byte-array> 10 ] 2 ndip
+    [ 10 <byte-array> 10 ] 3 ndip
     ! [fortran-args>c-args]
     {
         [ {
             [ ascii string>alien ]
             [ <float> ]
+            [ ascii string>alien ]
         } spread ]
-        [ { [ length ] [ drop ] } spread ]
-    } 2 ncleave
+        [ { [ length ] [ drop ] [ length ] } spread ]
+    } 3 ncleave
     ! [fortran-invoke]
     [
-        "void" "foopack" "fun_times__"
-        { "char*" "long" "char*" "float*" "long" } 
+        "void" "funpack" "fun_times__"
+        { "char*" "long" "char*" "float*" "char*" "long" "long" } 
         alien-invoke
-    ] 5 nkeep
+    ] 7 nkeep
     ! [fortran-results>]
+    shuffle( reta retb aa ba ca ab cb -- reta retb aa ab ba ca cb ) 
     {
         [ ]
         [ ascii alien>nstring ]
         [ ]
-        [ *float swap ]
+        [ ascii alien>nstring ]
+        [ *float ]
+        [ ]
         [ ascii alien>nstring ]
     } spread
 ] ] [
-    "CHARACTER*10" "foopack" "FUN_TIMES" { "!CHARACTER*20" "!REAL" }
-    fortran-invoke-expansion
+    "CHARACTER*10" "funpack" "FUN_TIMES" { "!CHARACTER*20" "!REAL" "!CHARACTER*30" }
+    (fortran-invoke)
 ] unit-test
 
diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor
index b0bbedd716..85fa0e536e 100644
--- a/basis/alien/fortran/fortran.factor
+++ b/basis/alien/fortran/fortran.factor
@@ -1,8 +1,11 @@
 ! (c) 2009 Joe Groff, see BSD license
-USING: accessors alien alien.c-types alien.structs alien.syntax
-arrays ascii assocs combinators fry kernel lexer macros math.parser
-namespaces parser sequences splitting vectors vocabs.parser locals
-io.encodings.ascii io.encodings.string ;
+USING: accessors alien alien.c-types alien.complex alien.parser
+alien.strings alien.structs alien.syntax arrays ascii assocs
+byte-arrays combinators combinators.short-circuit fry generalizations
+kernel lexer macros math math.parser namespaces parser sequences
+splitting stack-checker vectors vocabs.parser words locals
+io.encodings.ascii io.encodings.string shuffle effects math.ranges
+math.order sorting ;
 IN: alien.fortran
 
 ! XXX this currently only supports the gfortran/f2c abi.
@@ -18,6 +21,8 @@ IN: alien.fortran
 ERROR: invalid-fortran-type type ;
 
 DEFER: fortran-sig>c-sig
+DEFER: fortran-ret-type>c-type
+DEFER: fortran-arg-type>c-type
 
 <PRIVATE
 
@@ -90,7 +95,7 @@ M: real-complex-type (fortran-type>c-type)
 M: double-precision-type (fortran-type>c-type)
     "double" simple-type ;
 M: double-complex-type (fortran-type>c-type)
-    "(fortran-double-complex)" simple-type ;
+    "complex-double" simple-type ;
 M: misc-type (fortran-type>c-type)
     dup name>> simple-type ;
 
@@ -118,7 +123,7 @@ M: character-type (fortran-type>c-type)
 : (parse-fortran-type) ( fortran-type-string -- type )
     parse-out swap parse-dims swap parse-size swap
     dup >lower fortran>c-types at*
-    [ nip new-fortran-type ] [ drop f misc-type boa ] if ;
+    [ nip new-fortran-type ] [ drop misc-type boa ] if ;
 
 : parse-fortran-type ( fortran-type-string/f -- type/f )
     dup [ (parse-fortran-type) ] when ;
@@ -149,40 +154,49 @@ M: real-type (fortran-ret-type>c-type) drop "double" ;
 
 GENERIC: (fortran-arg>c-args) ( type -- main-quot added-quot )
 
+: args?dims ( type quot -- main-quot added-quot )
+    [ dup dims>> [ drop [ ] [ drop ] ] ] dip if ; inline
+
 M: integer-type (fortran-arg>c-args)
-    size>> {
-        { f [ [ <int>      ] [ drop ] ] }
-        { 1 [ [ <char>     ] [ drop ] ] }
-        { 2 [ [ <short>    ] [ drop ] ] }
-        { 4 [ [ <int>      ] [ drop ] ] }
-        { 8 [ [ <longlong> ] [ drop ] ] }
-        [ invalid-fortran-type ]
-    } case ;
+    [
+        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 ;
+    [ 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 ;
+    [
+        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 ;
+    [
+        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 ] ;
+    [ drop [ <double> ] [ drop ] ] args?dims ;
 
 M: double-complex-type (fortran-arg>c-args)
-    drop [ <complex-double> ] [ drop ] ;
+    [ drop [ <complex-double> ] [ drop ] ] args?dims ;
 
 M: character-type (fortran-arg>c-args)
     drop [ ascii string>alien ] [ length ] ;
@@ -190,72 +204,122 @@ M: character-type (fortran-arg>c-args)
 M: misc-type (fortran-arg>c-args)
     drop [ ] [ drop ] ;
 
-GENERIC: (fortran-result>) ( type -- quot )
+GENERIC: (fortran-result>) ( type -- quots )
+
+: result?dims ( type quot -- quot )
+    [ dup dims>> [ drop { [ ] } ] ] dip if ; inline
 
 M: integer-type (fortran-result>)
-    size>> {
-        { f [ [ *int      ] ] }
-        { 1 [ [ *char     ] ] }
-        { 2 [ [ *short    ] ] }
-        { 4 [ [ *int      ] ] }
-        { 8 [ [ *longlong ] ] }
+    [ size>> {
+        { f [ { [ *int      ] } ] }
+        { 1 [ { [ *char     ] } ] }
+        { 2 [ { [ *short    ] } ] }
+        { 4 [ { [ *int      ] } ] }
+        { 8 [ { [ *longlong ] } ] }
         [ invalid-fortran-type ]
-    } case ;
+    } case ] result?dims ;
 
 M: logical-type (fortran-result>)
-    call-next-method [ zero? not ] append ;
+    [ call-next-method first [ zero? not ] append 1array ] result?dims ;
 
 M: real-type (fortran-result>)
-    size>> {
-        { f [ [ *float  ] ] }
-        { 4 [ [ *float  ] ] }
-        { 8 [ [ *double ] ] }
+    [ size>> {
+        { f [ { [ *float  ] } ] }
+        { 4 [ { [ *float  ] } ] }
+        { 8 [ { [ *double ] } ] }
         [ invalid-fortran-type ]
-    } case ;
+    } case ] result?dims ;
 
 M: real-complex-type (fortran-result>)
-    size>> {
-        {  f [ [ *complex-float  ] ] }
-        {  8 [ [ *complex-float  ] ] }
-        { 16 [ [ *complex-double ] ] }
+    [ size>> {
+        {  f [ { [ *complex-float  ] } ] }
+        {  8 [ { [ *complex-float  ] } ] }
+        { 16 [ { [ *complex-double ] } ] }
         [ invalid-fortran-type ]
-    } case ;
+    } case ] result?dims ;
 
 M: double-precision-type (fortran-result>)
-    drop [ *double ] ;
+    [ drop { [ *double ] } ] result?dims ;
 
 M: double-complex-type (fortran-result>)
-    drop [ *complex-double ] ;
+    [ drop { [ *complex-double ] } ] result?dims ;
 
 M: character-type (fortran-result>)
-    drop [ ascii alien>nstring ] ;
+    drop { [ ] [ ascii alien>nstring ] } ;
 
 M: misc-type (fortran-result>)
-    drop [ ] ;
+    drop { [ ] } ;
 
 GENERIC: (<fortran-result>) ( type -- quot )
 
 M: fortran-type (<fortran-result>) 
-    (fortran-type>c-type) '[ _ <c-object> ] ;
+    (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>) ] [ '[ _ _ ndip ] ] bi* ] if ;
+    [ [ (<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 ] ] bi@ 2array ] [ length ] bi 
-    '[ _ _ ncleave ] ;
+    [ [ ] ] [
+        [ parse-fortran-type (fortran-arg>c-args) 2array ] map flip first2
+        [ [ \ spread [ ] 2sequence ] bi@ 2array ] [ length ] bi 
+        \ ncleave [ ] 3sequence
+    ] if-empty ;
 
-:: [fortran-invoke] ( return library function parameters -- quot ) 
+:: [fortran-invoke] ( [args>args] return library function parameters -- [args>args] quot ) 
     return parameters fortran-sig>c-sig :> c-parameters :> c-return
     function fortran-name>symbol-name :> c-function
-    [ c-return library c-function c-parameters alien-invoke ] ;
+    [args>args] 
+    c-return library c-function c-parameters \ alien-invoke
+    5 [ ] nsequence
+    c-parameters length \ nkeep
+    [ ] 3sequence ;
+
+: [fortran-out-param>] ( parameter -- quot )
+    parse-fortran-type
+    [ (fortran-result>) ] [ out?>> ] bi
+    [ ] [ [ drop [ drop ] ] map ] if ;
+
+: [fortran-return>] ( return -- quot )
+    parse-fortran-type {
+        { [ dup not ] [ drop { } ] }
+        { [ dup returns-by-value? ] [ drop { [ ] } ] }
+        [ (fortran-result>) ]
+    } cond ;
+
+: letters ( -- seq ) CHAR: a CHAR: z [a,b] ;
+
+: (shuffle-map) ( return parameters -- ret par )
+    [
+        fortran-ret-type>c-type length swap "void" = [ 1+ ] unless
+        letters swap head [ "ret" swap suffix ] map
+    ] [
+        [ fortran-arg-type>c-type nip length 1+ ] map letters swap zip
+        [ first2 letters swap head [ "" 2sequence ] with map ] map concat
+    ] bi* ;
+
+: (fortran-in-shuffle) ( ret par -- seq )
+    [ [ second ] bi@ <=> ] sort append ;
+
+: (fortran-out-shuffle) ( ret par -- seq )
+    append ;
+
+: [fortran-result-shuffle] ( return parameters -- quot )
+    (shuffle-map) [ (fortran-in-shuffle) ] [ (fortran-out-shuffle) ] 2bi <effect>
+    \ shuffle-effect [ ] 2sequence ;
 
 : [fortran-results>] ( return parameters -- quot )
-    2drop [ ] ;
+    [ [fortran-result-shuffle] ]
+    [ drop [fortran-return>] ]
+    [ nip [ [fortran-out-param>] ] map concat ] 2tri
+    append
+    \ spread [ ] 2sequence append ;
 
 PRIVATE>
 
@@ -289,22 +353,26 @@ PRIVATE>
 
 : RECORD: scan in get parse-definition define-fortran-record ; parsing
 
-MACRO: fortran-invoke ( return library function parameters -- )
+: (fortran-invoke) ( return library function parameters -- quot )
     {
         [ 2nip [<fortran-result>] ]
         [ nip nip nip [fortran-args>c-args] ]
         [ [fortran-invoke] ]
         [ 2nip [fortran-results>] ]
-    } 4 ncleave 3append ;
+    } 4 ncleave 4 nappend ;
+
+MACRO: fortran-invoke ( return library function parameters -- )
+    (fortran-invoke) ;
 
 :: define-fortran-function ( return library function parameters -- )
     function create-in dup reset-generic 
     return library function parameters return parse-arglist
-    [ '[ _ _ _ _ fortran-invoke ] ] dip define-declared ;
+    [ \ fortran-invoke 5 [ ] nsequence ] dip define-declared ;
 
 : SUBROUTINE: 
     f "c-library" get scan ";" parse-tokens
     [ "()" subseq? not ] filter define-fortran-function ; parsing
+
 : FUNCTION:
     scan "c-library" get scan ";" parse-tokens
     [ "()" subseq? not ] filter define-fortran-function ; parsing

From 0522f63e5fe9154bbfada242e65f14f262650c9e Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Mon, 9 Feb 2009 14:20:29 -0600
Subject: [PATCH 11/35] alien.fortran metadata

---
 basis/alien/fortran/authors.txt | 1 +
 basis/alien/fortran/summary.txt | 1 +
 basis/alien/fortran/tags.txt    | 2 ++
 3 files changed, 4 insertions(+)
 create mode 100644 basis/alien/fortran/authors.txt
 create mode 100644 basis/alien/fortran/summary.txt
 create mode 100644 basis/alien/fortran/tags.txt

diff --git a/basis/alien/fortran/authors.txt b/basis/alien/fortran/authors.txt
new file mode 100644
index 0000000000..f13c9c1e77
--- /dev/null
+++ b/basis/alien/fortran/authors.txt
@@ -0,0 +1 @@
+Joe Groff
diff --git a/basis/alien/fortran/summary.txt b/basis/alien/fortran/summary.txt
new file mode 100644
index 0000000000..8ed8b0ca00
--- /dev/null
+++ b/basis/alien/fortran/summary.txt
@@ -0,0 +1 @@
+GNU Fortran/G77/F2C alien interface
diff --git a/basis/alien/fortran/tags.txt b/basis/alien/fortran/tags.txt
new file mode 100644
index 0000000000..2a9b5def7a
--- /dev/null
+++ b/basis/alien/fortran/tags.txt
@@ -0,0 +1,2 @@
+fortran
+ffi

From 3b83d9f760304b55617f7664db5d795fdcce34dc Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Mon, 9 Feb 2009 14:20:52 -0600
Subject: [PATCH 12/35] fortran ffi for blas

---
 basis/math/blas/ffi/authors.txt |   1 +
 basis/math/blas/ffi/ffi.factor  | 528 ++++++++++++++++++++++++++++++++
 basis/math/blas/ffi/summary.txt |   1 +
 basis/math/blas/ffi/tags.txt    |   3 +
 4 files changed, 533 insertions(+)
 create mode 100644 basis/math/blas/ffi/authors.txt
 create mode 100644 basis/math/blas/ffi/ffi.factor
 create mode 100644 basis/math/blas/ffi/summary.txt
 create mode 100644 basis/math/blas/ffi/tags.txt

diff --git a/basis/math/blas/ffi/authors.txt b/basis/math/blas/ffi/authors.txt
new file mode 100644
index 0000000000..f13c9c1e77
--- /dev/null
+++ b/basis/math/blas/ffi/authors.txt
@@ -0,0 +1 @@
+Joe Groff
diff --git a/basis/math/blas/ffi/ffi.factor b/basis/math/blas/ffi/ffi.factor
new file mode 100644
index 0000000000..7b0138357a
--- /dev/null
+++ b/basis/math/blas/ffi/ffi.factor
@@ -0,0 +1,528 @@
+USING: alien alien.fortran kernel system combinators ;
+IN: math.blas.ffi
+
+<<
+"blas" {
+    { [ os macosx? ] [ "libblas.dylib" "cdecl" add-library ] }
+    { [ os windows? ] [ "blas.dll" "cdecl" add-library ] }
+    [ "libblas.so" "cdecl" add-library ]
+} cond
+>>
+
+LIBRARY: blas
+
+! Level 1 BLAS (scalar-vector and vector-vector)
+
+FUNCTION: REAL SDSDOT
+    ( INTEGER N, REAL ALPHA, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ;
+FUNCTION: DOUBLE-PRECISION DSDOT
+    ( INTEGER N, DOUBLE-PRECISION-PRECISION(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ;
+FUNCTION: REAL SDOT
+    ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ;
+FUNCTION: DOUBLE-PRECISION DDOT
+    ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
+
+FUNCTION: COMPLEX CDOTU
+    ( INTEGER N, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ;
+FUNCTION: COMPLEX CDOTC
+    ( INTEGER N, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ;
+
+SUBROUTINE: DOUBLE-COMPLEX ZDOTU
+    ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
+SUBROUTINE: DOUBLE-COMPLEX ZDOTC
+    ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
+
+FUNCTION: REAL SNRM2
+    ( INTEGER N, REAL(*) X, INTEGER INCX ) ;
+FUNCTION: REAL SASUM
+    ( INTEGER N, REAL(*) X, INTEGER INCX ) ;
+
+FUNCTION: DOUBLE-PRECISION DNRM2
+    ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
+FUNCTION: DOUBLE-PRECISION DASUM
+    ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
+
+FUNCTION: REAL SCNRM2
+    ( INTEGER N, COMPLEX(*) X, INTEGER INCX ) ;
+FUNCTION: REAL SCASUM
+    ( INTEGER N, COMPLEX(*) X, INTEGER INCX ) ;
+
+FUNCTION: DOUBLE-PRECISION DZNRM2
+    ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
+FUNCTION: DOUBLE-PRECISION DZASUM
+    ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
+
+FUNCTION: INTEGER ISAMAX
+    ( INTEGER N, REAL(*) X, INTEGER INCX ) ;
+FUNCTION: INTEGER IDAMAX
+    ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
+FUNCTION: INTEGER ICAMAX
+    ( INTEGER N, COMPLEX(*) X, INTEGER INCX ) ;
+FUNCTION: INTEGER IZAMAX
+    ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
+
+SUBROUTINE: SSWAP
+    ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ;
+SUBROUTINE: SCOPY
+    ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ;
+SUBROUTINE: SAXPY
+    ( INTEGER N, REAL ALPHA, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ;
+
+SUBROUTINE: DSWAP
+    ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
+SUBROUTINE: DCOPY
+    ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
+SUBROUTINE: DAXPY
+    ( INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
+
+SUBROUTINE: CSWAP
+    ( INTEGER N, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ;
+SUBROUTINE: CCOPY
+    ( INTEGER N, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ;
+SUBROUTINE: CAXPY
+    ( INTEGER N, COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ;
+
+SUBROUTINE: ZSWAP
+    ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
+SUBROUTINE: ZCOPY
+    ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
+SUBROUTINE: ZAXPY
+    ( INTEGER N, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
+
+SUBROUTINE: SSCAL
+    ( INTEGER N, REAL ALPHA, REAL(*) X, INTEGER INCX ) ;
+SUBROUTINE: DSCAL
+    ( INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
+SUBROUTINE: CSCAL
+    ( INTEGER N, COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX ) ;
+SUBROUTINE: ZSCAL
+    ( INTEGER N, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
+SUBROUTINE: CSSCAL
+    ( INTEGER N, REAL ALPHA, COMPLEX(*) X, INTEGER INCX ) ;
+SUBROUTINE: ZDSCAL
+    ( INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
+
+SUBROUTINE: SROTG
+    ( REAL(*) A, REAL(*) B, REAL(*) C, REAL(*) S ) ;
+SUBROUTINE: SROTMG
+    ( REAL(*) D1, REAL(*) D2, REAL(*) B1, REAL B2, REAL(*) P ) ;
+SUBROUTINE: SROT
+    ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY, REAL C, REAL S ) ;
+SUBROUTINE: SROTM
+    ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY, REAL(*) P ) ;
+
+SUBROUTINE: DROTG
+    ( DOUBLE-PRECISION(*) A, DOUBLE-PRECISION(*) B, DOUBLE-PRECISION(*) C, DOUBLE-PRECISION(*) S ) ;
+SUBROUTINE: DROTMG
+    ( DOUBLE-PRECISION(*) D1, DOUBLE-PRECISION(*) D2, DOUBLE-PRECISION(*) B1, DOUBLE-PRECISION B2, DOUBLE-PRECISION(*) P ) ;
+SUBROUTINE: DROT
+    ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION C, DOUBLE-PRECISION S ) ;
+SUBROUTINE: DROTM
+    ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION(*) P ) ;
+ 
+! LEVEL 2 BLAS (MATRIX-VECTOR)
+
+SUBROUTINE: SGEMV ( CHARACTER*1 ORDER,
+                 CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
+                 REAL ALPHA, REAL(*) A, INTEGER LDA,
+                 REAL(*) X, INTEGER INCX, REAL BETA,
+                 REAL(*) Y, INTEGER INCY ) ;
+SUBROUTINE: SGBMV ( CHARACTER*1 ORDER,
+                 CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
+                 INTEGER KL, INTEGER KU, REAL ALPHA,
+                 REAL(*) A, INTEGER LDA, REAL(*) X,
+                 INTEGER INCX, REAL BETA, REAL(*) Y, INTEGER INCY ) ;
+SUBROUTINE: STRMV ( CHARACTER*1 UPLO,
+                 CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+                 INTEGER N, REAL(*) A, INTEGER LDA,
+                 REAL(*) X, INTEGER INCX ) ;
+SUBROUTINE: STBMV ( CHARACTER*1 UPLO,
+                 CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+                 INTEGER N, INTEGER K, REAL(*) A, INTEGER LDA,
+                 REAL(*) X, INTEGER INCX ) ;
+SUBROUTINE: STPMV ( CHARACTER*1 UPLO,
+                 CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+                 INTEGER N, REAL(*) AP, REAL(*) X, INTEGER INCX ) ;
+SUBROUTINE: STRSV ( CHARACTER*1 UPLO,
+                 CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+                 INTEGER N, REAL(*) A, INTEGER LDA, REAL(*) X,
+                 INTEGER INCX ) ;
+SUBROUTINE: STBSV ( CHARACTER*1 UPLO,
+                 CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+                 INTEGER N, INTEGER K, REAL(*) A, INTEGER LDA,
+                 REAL(*) X, INTEGER INCX ) ;
+SUBROUTINE: STPSV ( CHARACTER*1 UPLO,
+                 CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+                 INTEGER N, REAL(*) AP, REAL(*) X, INTEGER INCX ) ;
+
+SUBROUTINE: DGEMV ( CHARACTER*1 ORDER,
+                 CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
+                 DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA,
+                 DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION BETA,
+                 DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
+SUBROUTINE: DGBMV ( CHARACTER*1 ORDER,
+                 CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
+                 INTEGER KL, INTEGER KU, DOUBLE-PRECISION ALPHA,
+                 DOUBLE-PRECISION(*) A, INTEGER LDA, DOUBLE-PRECISION(*) X,
+                 INTEGER INCX, DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
+SUBROUTINE: DTRMV ( CHARACTER*1 UPLO,
+                 CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+                 INTEGER N, DOUBLE-PRECISION(*) A, INTEGER LDA,
+                 DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
+SUBROUTINE: DTBMV ( CHARACTER*1 UPLO,
+                 CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+                 INTEGER N, INTEGER K, DOUBLE-PRECISION(*) A, INTEGER LDA,
+                 DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
+SUBROUTINE: DTPMV ( CHARACTER*1 UPLO,
+                 CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+                 INTEGER N, DOUBLE-PRECISION(*) AP, DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
+SUBROUTINE: DTRSV ( CHARACTER*1 UPLO,
+                 CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+                 INTEGER N, DOUBLE-PRECISION(*) A, INTEGER LDA, DOUBLE-PRECISION(*) X,
+                 INTEGER INCX ) ;
+SUBROUTINE: DTBSV ( CHARACTER*1 UPLO,
+                 CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+                 INTEGER N, INTEGER K, DOUBLE-PRECISION(*) A, INTEGER LDA,
+                 DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
+SUBROUTINE: DTPSV ( CHARACTER*1 UPLO,
+                 CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+                 INTEGER N, DOUBLE-PRECISION(*) AP, DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
+
+SUBROUTINE: CGEMV ( CHARACTER*1 ORDER,
+                 CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
+                 COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA,
+                 COMPLEX(*) X, INTEGER INCX, COMPLEX BETA,
+                 COMPLEX(*) Y, INTEGER INCY ) ;
+SUBROUTINE: CGBMV ( CHARACTER*1 ORDER,
+                 CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
+                 INTEGER KL, INTEGER KU, COMPLEX ALPHA,
+                 COMPLEX(*) A, INTEGER LDA, COMPLEX(*) X,
+                 INTEGER INCX, COMPLEX BETA, COMPLEX(*) Y, INTEGER INCY ) ;
+SUBROUTINE: CTRMV ( CHARACTER*1 UPLO,
+                 CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+                 INTEGER N, COMPLEX(*) A, INTEGER LDA,
+                 COMPLEX(*) X, INTEGER INCX ) ;
+SUBROUTINE: CTBMV ( CHARACTER*1 UPLO,
+                 CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+                 INTEGER N, INTEGER K, COMPLEX(*) A, INTEGER LDA,
+                 COMPLEX(*) X, INTEGER INCX ) ;
+SUBROUTINE: CTPMV ( CHARACTER*1 UPLO,
+                 CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+                 INTEGER N, COMPLEX(*) AP, COMPLEX(*) X, INTEGER INCX ) ;
+SUBROUTINE: CTRSV ( CHARACTER*1 UPLO,
+                 CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+                 INTEGER N, COMPLEX(*) A, INTEGER LDA, COMPLEX(*) X,
+                 INTEGER INCX ) ;
+SUBROUTINE: CTBSV ( CHARACTER*1 UPLO,
+                 CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+                 INTEGER N, INTEGER K, COMPLEX(*) A, INTEGER LDA,
+                 COMPLEX(*) X, INTEGER INCX ) ;
+SUBROUTINE: CTPSV ( CHARACTER*1 UPLO,
+                 CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+                 INTEGER N, COMPLEX(*) AP, COMPLEX(*) X, INTEGER INCX ) ;
+
+SUBROUTINE: ZGEMV ( CHARACTER*1 ORDER,
+                 CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
+                 DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
+                 DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX BETA,
+                 DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
+SUBROUTINE: ZGBMV ( CHARACTER*1 ORDER,
+                 CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
+                 INTEGER KL, INTEGER KU, DOUBLE-COMPLEX ALPHA,
+                 DOUBLE-COMPLEX(*) A, INTEGER LDA, DOUBLE-COMPLEX(*) X,
+                 INTEGER INCX, DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
+SUBROUTINE: ZTRMV ( CHARACTER*1 UPLO,
+                 CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+                 INTEGER N, DOUBLE-COMPLEX(*) A, INTEGER LDA,
+                 DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
+SUBROUTINE: ZTBMV ( CHARACTER*1 UPLO,
+                 CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+                 INTEGER N, INTEGER K, DOUBLE-COMPLEX(*) A, INTEGER LDA,
+                 DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
+SUBROUTINE: ZTPMV ( CHARACTER*1 UPLO,
+                 CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+                 INTEGER N, DOUBLE-COMPLEX(*) AP, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
+SUBROUTINE: ZTRSV ( CHARACTER*1 UPLO,
+                 CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+                 INTEGER N, DOUBLE-COMPLEX(*) A, INTEGER LDA, DOUBLE-COMPLEX(*) X,
+                 INTEGER INCX ) ;
+SUBROUTINE: ZTBSV ( CHARACTER*1 UPLO,
+                 CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+                 INTEGER N, INTEGER K, DOUBLE-COMPLEX(*) A, INTEGER LDA,
+                 DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
+SUBROUTINE: ZTPSV ( CHARACTER*1 UPLO,
+                 CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+                 INTEGER N, DOUBLE-COMPLEX(*) AP, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
+
+
+SUBROUTINE: SSYMV ( CHARACTER*1 UPLO,
+                 INTEGER N, REAL ALPHA, REAL(*) A,
+                 INTEGER LDA, REAL(*) X, INTEGER INCX,
+                 REAL BETA, REAL(*) Y, INTEGER INCY ) ;
+SUBROUTINE: SSBMV ( CHARACTER*1 UPLO,
+                 INTEGER N, INTEGER K, REAL ALPHA, REAL(*) A,
+                 INTEGER LDA, REAL(*) X, INTEGER INCX,
+                 REAL BETA, REAL(*) Y, INTEGER INCY ) ;
+SUBROUTINE: SSPMV ( CHARACTER*1 UPLO,
+                 INTEGER N, REAL ALPHA, REAL(*) AP,
+                 REAL(*) X, INTEGER INCX,
+                 REAL BETA, REAL(*) Y, INTEGER INCY ) ;
+SUBROUTINE: SGER ( INTEGER M, INTEGER N,
+                REAL ALPHA, REAL(*) X, INTEGER INCX,
+                REAL(*) Y, INTEGER INCY, REAL(*) A, INTEGER LDA ) ;
+SUBROUTINE: SSYR ( CHARACTER*1 UPLO,
+                INTEGER N, REAL ALPHA, REAL(*) X,
+                INTEGER INCX, REAL(*) A, INTEGER LDA ) ;
+SUBROUTINE: SSPR ( CHARACTER*1 UPLO,
+                INTEGER N, REAL ALPHA, REAL(*) X,
+                INTEGER INCX, REAL(*) AP ) ;
+SUBROUTINE: SSYR2 ( CHARACTER*1 UPLO,
+                INTEGER N, REAL ALPHA, REAL(*) X,
+                INTEGER INCX, REAL(*) Y, INTEGER INCY, REAL(*) A,
+                INTEGER LDA ) ;
+SUBROUTINE: SSPR2 ( CHARACTER*1 UPLO,
+                INTEGER N, REAL ALPHA, REAL(*) X,
+                INTEGER INCX, REAL(*) Y, INTEGER INCY, REAL(*) A ) ;
+
+SUBROUTINE: DSYMV ( CHARACTER*1 UPLO,
+                 INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A,
+                 INTEGER LDA, DOUBLE-PRECISION(*) X, INTEGER INCX,
+                 DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
+SUBROUTINE: DSBMV ( CHARACTER*1 UPLO,
+                 INTEGER N, INTEGER K, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A,
+                 INTEGER LDA, DOUBLE-PRECISION(*) X, INTEGER INCX,
+                 DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
+SUBROUTINE: DSPMV ( CHARACTER*1 UPLO,
+                 INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) AP,
+                 DOUBLE-PRECISION(*) X, INTEGER INCX,
+                 DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
+SUBROUTINE: DGER ( INTEGER M, INTEGER N,
+                DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X, INTEGER INCX,
+                DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION(*) A, INTEGER LDA ) ;
+SUBROUTINE: DSYR ( CHARACTER*1 UPLO,
+                INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X,
+                INTEGER INCX, DOUBLE-PRECISION(*) A, INTEGER LDA ) ;
+SUBROUTINE: DSPR ( CHARACTER*1 UPLO,
+                INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X,
+                INTEGER INCX, DOUBLE-PRECISION(*) AP ) ;
+SUBROUTINE: DSYR2 ( CHARACTER*1 UPLO,
+                INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X,
+                INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION(*) A,
+                INTEGER LDA ) ;
+SUBROUTINE: DSPR2 ( CHARACTER*1 UPLO,
+                INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X,
+                INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION(*) A ) ;
+
+
+SUBROUTINE: CHEMV ( CHARACTER*1 UPLO,
+                 INTEGER N, COMPLEX ALPHA, COMPLEX(*) A,
+                 INTEGER LDA, COMPLEX(*) X, INTEGER INCX,
+                 COMPLEX BETA, COMPLEX(*) Y, INTEGER INCY ) ;
+SUBROUTINE: CHBMV ( CHARACTER*1 UPLO,
+                 INTEGER N, INTEGER K, COMPLEX ALPHA, COMPLEX(*) A,
+                 INTEGER LDA, COMPLEX(*) X, INTEGER INCX,
+                 COMPLEX BETA, COMPLEX(*) Y, INTEGER INCY ) ;
+SUBROUTINE: CHPMV ( CHARACTER*1 UPLO,
+                 INTEGER N, COMPLEX ALPHA, COMPLEX(*) AP,
+                 COMPLEX(*) X, INTEGER INCX,
+                 COMPLEX BETA, COMPLEX(*) Y, INTEGER INCY ) ;
+SUBROUTINE: CGERU ( INTEGER M, INTEGER N,
+                 COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX,
+                 COMPLEX(*) Y, INTEGER INCY, COMPLEX(*) A, INTEGER LDA ) ;
+SUBROUTINE: CGERC ( INTEGER M, INTEGER N,
+                 COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX,
+                 COMPLEX(*) Y, INTEGER INCY, COMPLEX(*) A, INTEGER LDA ) ;
+SUBROUTINE: CHER ( CHARACTER*1 UPLO,
+                INTEGER N, REAL ALPHA, COMPLEX(*) X, INTEGER INCX,
+                COMPLEX(*) A, INTEGER LDA ) ;
+SUBROUTINE: CHPR ( CHARACTER*1 UPLO,
+                INTEGER N, REAL ALPHA, COMPLEX(*) X,
+                INTEGER INCX, COMPLEX(*) A ) ;
+SUBROUTINE: CHER2 ( CHARACTER*1 UPLO, INTEGER N,
+                COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX,
+                COMPLEX(*) Y, INTEGER INCY, COMPLEX(*) A, INTEGER LDA ) ;
+SUBROUTINE: CHPR2 ( CHARACTER*1 UPLO, INTEGER N,
+                COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX,
+                COMPLEX(*) Y, INTEGER INCY, COMPLEX(*) AP ) ;
+
+SUBROUTINE: ZHEMV ( CHARACTER*1 UPLO,
+                 INTEGER N, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A,
+                 INTEGER LDA, DOUBLE-COMPLEX(*) X, INTEGER INCX,
+                 DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
+SUBROUTINE: ZHBMV ( CHARACTER*1 UPLO,
+                 INTEGER N, INTEGER K, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A,
+                 INTEGER LDA, DOUBLE-COMPLEX(*) X, INTEGER INCX,
+                 DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
+SUBROUTINE: ZHPMV ( CHARACTER*1 UPLO,
+                 INTEGER N, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) AP,
+                 DOUBLE-COMPLEX(*) X, INTEGER INCX,
+                 DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
+SUBROUTINE: ZGERU ( INTEGER M, INTEGER N,
+                 DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX,
+                 DOUBLE-COMPLEX(*) Y, INTEGER INCY, DOUBLE-COMPLEX(*) A, INTEGER LDA ) ;
+SUBROUTINE: ZGERC ( INTEGER M, INTEGER N,
+                 DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX,
+                 DOUBLE-COMPLEX(*) Y, INTEGER INCY, DOUBLE-COMPLEX(*) A, INTEGER LDA ) ;
+SUBROUTINE: ZHER ( CHARACTER*1 UPLO,
+                INTEGER N, REAL ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX,
+                DOUBLE-COMPLEX(*) A, INTEGER LDA ) ;
+SUBROUTINE: ZHPR ( CHARACTER*1 UPLO,
+                INTEGER N, REAL ALPHA, DOUBLE-COMPLEX(*) X,
+                INTEGER INCX, DOUBLE-COMPLEX(*) A ) ;
+SUBROUTINE: ZHER2 ( CHARACTER*1 UPLO, INTEGER N,
+                DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX,
+                DOUBLE-COMPLEX(*) Y, INTEGER INCY, DOUBLE-COMPLEX(*) A, INTEGER LDA ) ;
+SUBROUTINE: ZHPR2 ( CHARACTER*1 UPLO, INTEGER N,
+                DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX,
+                DOUBLE-COMPLEX(*) Y, INTEGER INCY, DOUBLE-COMPLEX(*) AP ) ;
+
+! LEVEL 3 BLAS (MATRIX-MATRIX) 
+
+SUBROUTINE: SGEMM ( CHARACTER*1 TRANSA,
+                 CHARACTER*1 TRANSB, INTEGER M, INTEGER N,
+                 INTEGER K, REAL ALPHA, REAL(*) A,
+                 INTEGER LDA, REAL(*) B, INTEGER LDB,
+                 REAL BETA, REAL(*) C, INTEGER LDC ) ;
+SUBROUTINE: SSYMM ( CHARACTER*1 SIDE,
+                 CHARACTER*1 UPLO, INTEGER M, INTEGER N,
+                 REAL ALPHA, REAL(*) A, INTEGER LDA,
+                 REAL(*) B, INTEGER LDB, REAL BETA,
+                 REAL(*) C, INTEGER LDC ) ;
+SUBROUTINE: SSYRK ( CHARACTER*1 UPLO,
+                 CHARACTER*1 TRANS, INTEGER N, INTEGER K,
+                 REAL ALPHA, REAL(*) A, INTEGER LDA,
+                 REAL BETA, REAL(*) C, INTEGER LDC ) ;
+SUBROUTINE: SSYR2K ( CHARACTER*1 UPLO,
+                  CHARACTER*1 TRANS, INTEGER N, INTEGER K,
+                  REAL ALPHA, REAL(*) A, INTEGER LDA,
+                  REAL(*) B, INTEGER LDB, REAL BETA,
+                  REAL(*) C, INTEGER LDC ) ;
+SUBROUTINE: STRMM ( CHARACTER*1 SIDE,
+                 CHARACTER*1 UPLO, CHARACTER*1 TRANSA,
+                 CHARACTER*1 DIAG, INTEGER M, INTEGER N,
+                 REAL ALPHA, REAL(*) A, INTEGER LDA,
+                 REAL(*) B, INTEGER LDB ) ;
+SUBROUTINE: STRSM ( CHARACTER*1 SIDE,
+                 CHARACTER*1 UPLO, CHARACTER*1 TRANSA,
+                 CHARACTER*1 DIAG, INTEGER M, INTEGER N,
+                 REAL ALPHA, REAL(*) A, INTEGER LDA,
+                 REAL(*) B, INTEGER LDB ) ;
+
+SUBROUTINE: DGEMM ( CHARACTER*1 TRANSA,
+                 CHARACTER*1 TRANSB, INTEGER M, INTEGER N,
+                 INTEGER K, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A,
+                 INTEGER LDA, DOUBLE-PRECISION(*) B, INTEGER LDB,
+                 DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) C, INTEGER LDC ) ;
+SUBROUTINE: DSYMM ( CHARACTER*1 SIDE,
+                 CHARACTER*1 UPLO, INTEGER M, INTEGER N,
+                 DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA,
+                 DOUBLE-PRECISION(*) B, INTEGER LDB, DOUBLE-PRECISION BETA,
+                 DOUBLE-PRECISION(*) C, INTEGER LDC ) ;
+SUBROUTINE: DSYRK ( CHARACTER*1 UPLO,
+                 CHARACTER*1 TRANS, INTEGER N, INTEGER K,
+                 DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA,
+                 DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) C, INTEGER LDC ) ;
+SUBROUTINE: DSYR2K ( CHARACTER*1 UPLO,
+                  CHARACTER*1 TRANS, INTEGER N, INTEGER K,
+                  DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA,
+                  DOUBLE-PRECISION(*) B, INTEGER LDB, DOUBLE-PRECISION BETA,
+                  DOUBLE-PRECISION(*) C, INTEGER LDC ) ;
+SUBROUTINE: DTRMM ( CHARACTER*1 SIDE,
+                 CHARACTER*1 UPLO, CHARACTER*1 TRANSA,
+                 CHARACTER*1 DIAG, INTEGER M, INTEGER N,
+                 DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA,
+                 DOUBLE-PRECISION(*) B, INTEGER LDB ) ;
+SUBROUTINE: DTRSM ( CHARACTER*1 SIDE,
+                 CHARACTER*1 UPLO, CHARACTER*1 TRANSA,
+                 CHARACTER*1 DIAG, INTEGER M, INTEGER N,
+                 DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA,
+                 DOUBLE-PRECISION(*) B, INTEGER LDB ) ;
+
+SUBROUTINE: CGEMM ( CHARACTER*1 TRANSA,
+                 CHARACTER*1 TRANSB, INTEGER M, INTEGER N,
+                 INTEGER K, COMPLEX ALPHA, COMPLEX(*) A,
+                 INTEGER LDA, COMPLEX(*) B, INTEGER LDB,
+                 COMPLEX BETA, COMPLEX(*) C, INTEGER LDC ) ;
+SUBROUTINE: CSYMM ( CHARACTER*1 SIDE,
+                 CHARACTER*1 UPLO, INTEGER M, INTEGER N,
+                 COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA,
+                 COMPLEX(*) B, INTEGER LDB, COMPLEX BETA,
+                 COMPLEX(*) C, INTEGER LDC ) ;
+SUBROUTINE: CSYRK ( CHARACTER*1 UPLO,
+                 CHARACTER*1 TRANS, INTEGER N, INTEGER K,
+                 COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA,
+                 COMPLEX BETA, COMPLEX(*) C, INTEGER LDC ) ;
+SUBROUTINE: CSYR2K ( CHARACTER*1 UPLO,
+                  CHARACTER*1 TRANS, INTEGER N, INTEGER K,
+                  COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA,
+                  COMPLEX(*) B, INTEGER LDB, COMPLEX BETA,
+                  COMPLEX(*) C, INTEGER LDC ) ;
+SUBROUTINE: CTRMM ( CHARACTER*1 SIDE,
+                 CHARACTER*1 UPLO, CHARACTER*1 TRANSA,
+                 CHARACTER*1 DIAG, INTEGER M, INTEGER N,
+                 COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA,
+                 COMPLEX(*) B, INTEGER LDB ) ;
+SUBROUTINE: CTRSM ( CHARACTER*1 SIDE,
+                 CHARACTER*1 UPLO, CHARACTER*1 TRANSA,
+                 CHARACTER*1 DIAG, INTEGER M, INTEGER N,
+                 COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA,
+                 COMPLEX(*) B, INTEGER LDB ) ;
+
+SUBROUTINE: ZGEMM ( CHARACTER*1 TRANSA,
+                 CHARACTER*1 TRANSB, INTEGER M, INTEGER N,
+                 INTEGER K, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A,
+                 INTEGER LDA, DOUBLE-COMPLEX(*) B, INTEGER LDB,
+                 DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) C, INTEGER LDC ) ;
+SUBROUTINE: ZSYMM ( CHARACTER*1 SIDE,
+                 CHARACTER*1 UPLO, INTEGER M, INTEGER N,
+                 DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
+                 DOUBLE-COMPLEX(*) B, INTEGER LDB, DOUBLE-COMPLEX BETA,
+                 DOUBLE-COMPLEX(*) C, INTEGER LDC ) ;
+SUBROUTINE: ZSYRK ( CHARACTER*1 UPLO,
+                 CHARACTER*1 TRANS, INTEGER N, INTEGER K,
+                 DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
+                 DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) C, INTEGER LDC ) ;
+SUBROUTINE: ZSYR2K ( CHARACTER*1 UPLO,
+                  CHARACTER*1 TRANS, INTEGER N, INTEGER K,
+                  DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
+                  DOUBLE-COMPLEX(*) B, INTEGER LDB, DOUBLE-COMPLEX BETA,
+                  DOUBLE-COMPLEX(*) C, INTEGER LDC ) ;
+SUBROUTINE: ZTRMM ( CHARACTER*1 SIDE,
+                 CHARACTER*1 UPLO, CHARACTER*1 TRANSA,
+                 CHARACTER*1 DIAG, INTEGER M, INTEGER N,
+                 DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
+                 DOUBLE-COMPLEX(*) B, INTEGER LDB ) ;
+SUBROUTINE: ZTRSM ( CHARACTER*1 SIDE,
+                 CHARACTER*1 UPLO, CHARACTER*1 TRANSA,
+                 CHARACTER*1 DIAG, INTEGER M, INTEGER N,
+                 DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
+                 DOUBLE-COMPLEX(*) B, INTEGER LDB ) ;
+
+SUBROUTINE: CHEMM ( CHARACTER*1 SIDE,
+                 CHARACTER*1 UPLO, INTEGER M, INTEGER N,
+                 COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA,
+                 COMPLEX(*) B, INTEGER LDB, COMPLEX BETA,
+                 COMPLEX(*) C, INTEGER LDC ) ;
+SUBROUTINE: CHERK ( CHARACTER*1 UPLO,
+                 CHARACTER*1 TRANS, INTEGER N, INTEGER K,
+                 REAL ALPHA, COMPLEX(*) A, INTEGER LDA,
+                 REAL BETA, COMPLEX(*) C, INTEGER LDC ) ;
+SUBROUTINE: CHER2K ( CHARACTER*1 UPLO,
+                  CHARACTER*1 TRANS, INTEGER N, INTEGER K,
+                  COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA,
+                  COMPLEX(*) B, INTEGER LDB, REAL BETA,
+                  COMPLEX(*) C, INTEGER LDC ) ;
+SUBROUTINE: ZHEMM ( CHARACTER*1 SIDE,
+                 CHARACTER*1 UPLO, INTEGER M, INTEGER N,
+                 DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
+                 DOUBLE-COMPLEX(*) B, INTEGER LDB, DOUBLE-COMPLEX BETA,
+                 DOUBLE-COMPLEX(*) C, INTEGER LDC ) ;
+SUBROUTINE: ZHERK ( CHARACTER*1 UPLO,
+                 CHARACTER*1 TRANS, INTEGER N, INTEGER K,
+                 REAL ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
+                 REAL BETA, DOUBLE-COMPLEX(*) C, INTEGER LDC ) ;
+SUBROUTINE: ZHER2K ( CHARACTER*1 UPLO,
+                  CHARACTER*1 TRANS, INTEGER N, INTEGER K,
+                  DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
+                  DOUBLE-COMPLEX(*) B, INTEGER LDB, REAL BETA,
+                  DOUBLE-COMPLEX(*) C, INTEGER LDC ) ;
diff --git a/basis/math/blas/ffi/summary.txt b/basis/math/blas/ffi/summary.txt
new file mode 100644
index 0000000000..8c0106b173
--- /dev/null
+++ b/basis/math/blas/ffi/summary.txt
@@ -0,0 +1 @@
+Low-level bindings to the Basic Linear Algebra Subroutines (BLAS) library
diff --git a/basis/math/blas/ffi/tags.txt b/basis/math/blas/ffi/tags.txt
new file mode 100644
index 0000000000..f468a9989d
--- /dev/null
+++ b/basis/math/blas/ffi/tags.txt
@@ -0,0 +1,3 @@
+math
+bindings
+fortran

From 42265cbc62fbb50ee8b8a201603fb78624678160 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Mon, 9 Feb 2009 14:35:44 -0600
Subject: [PATCH 13/35] start hacking on math.blas.vectors to switch to fortran

---
 basis/alien/fortran/fortran.factor     | 10 ++++++++++
 basis/math/blas/vectors/vectors.factor | 25 +++++++++++++------------
 2 files changed, 23 insertions(+), 12 deletions(-)

diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor
index 85fa0e536e..00dd8583fc 100644
--- a/basis/alien/fortran/fortran.factor
+++ b/basis/alien/fortran/fortran.factor
@@ -11,6 +11,14 @@ IN: alien.fortran
 ! XXX this currently only supports the gfortran/f2c abi.
 ! XXX we should also support ifort at some point for commercial BLASes
 
+<< 
+: add-f2c-libraries ( -- )
+    "I77" "libI77.so" "cdecl" add-library
+    "F77" "libF77.so" "cdecl" add-library ;
+
+os netbsd? [ add-f2c-libraries ] when
+>>
+
 : alien>nstring ( alien len encoding -- string )
     [ memory>byte-array ] dip decode ;
 
@@ -377,3 +385,5 @@ MACRO: fortran-invoke ( return library function parameters -- )
     scan "c-library" get scan ";" parse-tokens
     [ "()" subseq? not ] filter define-fortran-function ; parsing
 
+: LIBRARY:
+    scan "c-library" set ; parsing
diff --git a/basis/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor
index 4e61f4478e..d111023456 100755
--- a/basis/math/blas/vectors/vectors.factor
+++ b/basis/math/blas/vectors/vectors.factor
@@ -1,10 +1,13 @@
 USING: accessors alien alien.c-types arrays byte-arrays combinators
-combinators.short-circuit fry kernel math math.blas.cblas
+combinators.short-circuit fry kernel math math.blas.ffi
 math.complex math.functions math.order sequences.complex
 sequences.complex-components sequences sequences.private
 functors words locals parser prettyprint.backend prettyprint.custom
 specialized-arrays.float specialized-arrays.double
-specialized-arrays.direct.float specialized-arrays.direct.double ;
+specialized-arrays.direct.float specialized-arrays.direct.double
+specialized-arrays.complex-float specialized-arrays.complex-double
+specialized-arrays.direct.complex-float
+specialized-arrays.direct.complex-double ;
 IN: math.blas.vectors
 
 TUPLE: blas-vector-base underlying length inc ;
@@ -130,9 +133,9 @@ FUNCTOR: (define-blas-vector) ( TYPE T -- )
 
 <DIRECT-ARRAY> IS <direct-${TYPE}-array>
 >ARRAY         IS >${TYPE}-array
-XCOPY          IS cblas_${T}copy
-XSWAP          IS cblas_${T}swap
-IXAMAX         IS cblas_i${T}amax
+XCOPY          IS ${T}COPY
+XSWAP          IS ${T}SWAP
+IXAMAX         IS I${T}AMAX
 
 VECTOR         DEFINES-CLASS ${TYPE}-blas-vector
 <VECTOR>       DEFINES <${TYPE}-blas-vector>
@@ -264,16 +267,14 @@ M: VECTOR n*V!
 : define-real-blas-vector ( TYPE T -- )
     [ (define-blas-vector) ]
     [ (define-real-blas-vector) ] 2bi ;
-:: define-complex-blas-vector ( TYPE C S -- )
-    TYPE (define-complex-helpers)
-    TYPE "-complex" append
-    [ C (define-blas-vector) ]
-    [ C S (define-complex-blas-vector) ] bi ;
+: define-complex-blas-vector ( TYPE C S -- )
+    [ drop (define-blas-vector) ]
+    [ (define-complex-blas-vector) ] 3bi ;
 
 "float"  "s" define-real-blas-vector
 "double" "d" define-real-blas-vector
-"float"  "c" "s" define-complex-blas-vector
-"double" "z" "d" define-complex-blas-vector
+"complex-float"  "c" "s" define-complex-blas-vector
+"complex-double" "z" "d" define-complex-blas-vector
 
 >>
 

From 32481f8e2f2909a50788532c58f8d9deff479ed9 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Mon, 9 Feb 2009 15:01:41 -0600
Subject: [PATCH 14/35] my stuped, let me show u it

---
 basis/alien/complex/functor/functor.factor | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/basis/alien/complex/functor/functor.factor b/basis/alien/complex/functor/functor.factor
index c6644eba1d..31af0291b4 100644
--- a/basis/alien/complex/functor/functor.factor
+++ b/basis/alien/complex/functor/functor.factor
@@ -28,8 +28,8 @@ T in get
 define-struct
 
 T c-type
-<T> 1quotation >>boxer-quot
-*T 1quotation >>unboxer-quot
+<T> 1quotation >>unboxer-quot
+*T 1quotation >>boxer-quot
 drop
 
 ;FUNCTOR

From d24b03098a58526dc43c2cb11142498ef512ed84 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Mon, 9 Feb 2009 15:11:27 -0600
Subject: [PATCH 15/35] specialized arrays for complex types

---
 basis/specialized-arrays/complex-double/complex-double.factor | 4 ++++
 basis/specialized-arrays/complex-float/complex-float.factor   | 4 ++++
 .../direct/complex-double/complex-double.factor               | 4 ++++
 .../direct/complex-float/complex-float.factor                 | 4 ++++
 4 files changed, 16 insertions(+)
 create mode 100644 basis/specialized-arrays/complex-double/complex-double.factor
 create mode 100644 basis/specialized-arrays/complex-float/complex-float.factor
 create mode 100644 basis/specialized-arrays/direct/complex-double/complex-double.factor
 create mode 100644 basis/specialized-arrays/direct/complex-float/complex-float.factor

diff --git a/basis/specialized-arrays/complex-double/complex-double.factor b/basis/specialized-arrays/complex-double/complex-double.factor
new file mode 100644
index 0000000000..00b07fb9b3
--- /dev/null
+++ b/basis/specialized-arrays/complex-double/complex-double.factor
@@ -0,0 +1,4 @@
+USE: specialized-arrays.functor
+IN: specialized-arrays.complex-double
+
+<< "complex-double" define-array >>
diff --git a/basis/specialized-arrays/complex-float/complex-float.factor b/basis/specialized-arrays/complex-float/complex-float.factor
new file mode 100644
index 0000000000..5348343bae
--- /dev/null
+++ b/basis/specialized-arrays/complex-float/complex-float.factor
@@ -0,0 +1,4 @@
+USE: specialized-arrays.functor
+IN: specialized-arrays.complex-float
+
+<< "complex-float" define-array >>
diff --git a/basis/specialized-arrays/direct/complex-double/complex-double.factor b/basis/specialized-arrays/direct/complex-double/complex-double.factor
new file mode 100644
index 0000000000..58af77b0c0
--- /dev/null
+++ b/basis/specialized-arrays/direct/complex-double/complex-double.factor
@@ -0,0 +1,4 @@
+USING: specialized-arrays.float specialized-arrays.direct.functor ;
+IN: specialized-arrays.direct.complex-double
+
+<< "complex-double" define-direct-array >>
diff --git a/basis/specialized-arrays/direct/complex-float/complex-float.factor b/basis/specialized-arrays/direct/complex-float/complex-float.factor
new file mode 100644
index 0000000000..d881c1e0d4
--- /dev/null
+++ b/basis/specialized-arrays/direct/complex-float/complex-float.factor
@@ -0,0 +1,4 @@
+USING: specialized-arrays.float specialized-arrays.direct.functor ;
+IN: specialized-arrays.direct.complex-float
+
+<< "complex-float" define-direct-array >>

From db6706434d711e5313ca1618302a8f83c9c3d817 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Mon, 9 Feb 2009 15:38:07 -0600
Subject: [PATCH 16/35] tweak specialized-arrays to box values returned by nth

---
 basis/alien/c-types/c-types.factor                     | 3 +++
 basis/alien/structs/fields/fields.factor               | 5 +----
 basis/specialized-arrays/direct/functor/functor.factor | 2 +-
 basis/specialized-arrays/functor/functor.factor        | 2 +-
 4 files changed, 6 insertions(+), 6 deletions(-)

diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor
index 89b3572daf..a4bc3d3f52 100644
--- a/basis/alien/c-types/c-types.factor
+++ b/basis/alien/c-types/c-types.factor
@@ -185,6 +185,9 @@ M: f byte-length drop 0 ;
         [ "Cannot read struct fields with this type" throw ]
     ] unless* ;
 
+: c-type-getter-boxer ( name -- quot )
+    [ c-getter ] [ c-type-boxer-quot ] bi append ;
+
 : c-setter ( name -- quot )
     c-type-setter [
         [ "Cannot write struct fields with this type" throw ]
diff --git a/basis/alien/structs/fields/fields.factor b/basis/alien/structs/fields/fields.factor
index f5537fa239..0477683442 100644
--- a/basis/alien/structs/fields/fields.factor
+++ b/basis/alien/structs/fields/fields.factor
@@ -58,10 +58,7 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ;
 : define-getter ( type spec -- )
     [ set-reader-props ] keep
     [ reader>> ]
-    [
-        type>>
-        [ c-getter ] [ c-type-boxer-quot ] bi append
-    ]
+    [ type>> c-type-getter-boxer ]
     [ ] tri
     (( c-ptr -- value )) define-struct-slot-word ;
 
diff --git a/basis/specialized-arrays/direct/functor/functor.factor b/basis/specialized-arrays/direct/functor/functor.factor
index 0c3999db44..e7e891fede 100755
--- a/basis/specialized-arrays/direct/functor/functor.factor
+++ b/basis/specialized-arrays/direct/functor/functor.factor
@@ -14,7 +14,7 @@ A'      IS ${T}-array
 A       DEFINES-CLASS direct-${T}-array
 <A>     DEFINES <${A}>
 
-NTH     [ T dup c-getter array-accessor ]
+NTH     [ T dup c-type-getter-boxer array-accessor ]
 SET-NTH [ T dup c-setter array-accessor ]
 
 WHERE
diff --git a/basis/specialized-arrays/functor/functor.factor b/basis/specialized-arrays/functor/functor.factor
index 3c2c53db31..09433a3b51 100644
--- a/basis/specialized-arrays/functor/functor.factor
+++ b/basis/specialized-arrays/functor/functor.factor
@@ -22,7 +22,7 @@ A            DEFINES-CLASS ${T}-array
 byte-array>A DEFINES byte-array>${A}
 A{           DEFINES ${A}{
 
-NTH          [ T dup c-getter array-accessor ]
+NTH          [ T dup c-type-getter-boxer array-accessor ]
 SET-NTH      [ T dup c-setter array-accessor ]
 
 WHERE

From 85620fc74118037dd35e908bd210e74ec03ea173 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Mon, 9 Feb 2009 15:51:47 -0600
Subject: [PATCH 17/35] C CONVERT VECTORS TO USE FORTRAN BLAS BINDINGS C
 INSTEAD OF CBLAS

---
 basis/math/blas/vectors/vectors.factor | 83 ++++++++------------------
 1 file changed, 25 insertions(+), 58 deletions(-)

diff --git a/basis/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor
index d111023456..9a2f9a4350 100755
--- a/basis/math/blas/vectors/vectors.factor
+++ b/basis/math/blas/vectors/vectors.factor
@@ -1,4 +1,4 @@
-USING: accessors alien alien.c-types arrays byte-arrays combinators
+USING: accessors alien alien.c-types arrays ascii byte-arrays combinators
 combinators.short-circuit fry kernel math math.blas.ffi
 math.complex math.functions math.order sequences.complex
 sequences.complex-components sequences sequences.private
@@ -141,7 +141,12 @@ VECTOR         DEFINES-CLASS ${TYPE}-blas-vector
 <VECTOR>       DEFINES <${TYPE}-blas-vector>
 >VECTOR        DEFINES >${TYPE}-blas-vector
 
-XVECTOR{       DEFINES ${T}vector{
+t              [ T >lower ]
+
+XVECTOR{       DEFINES ${t}vector{
+
+XAXPY          IS ${T}AXPY
+XSCAL          IS ${T}SCAL
 
 WHERE
 
@@ -170,6 +175,11 @@ M: VECTOR (blas-direct-array)
     [ [ length>> ] [ inc>> ] bi * ] bi
     <DIRECT-ARRAY> ;
 
+M: VECTOR n*V+V!
+    (prepare-axpy) [ XAXPY ] dip ;
+M: VECTOR n*V!
+    (prepare-scal) [ XSCAL ] dip ;
+
 : XVECTOR{ \ } [ >VECTOR ] parse-literal ; parsing
 
 M: VECTOR pprint-delims
@@ -181,11 +191,9 @@ M: VECTOR pprint-delims
 FUNCTOR: (define-real-blas-vector) ( TYPE T -- )
 
 VECTOR         IS ${TYPE}-blas-vector
-XDOT           IS cblas_${T}dot
-XNRM2          IS cblas_${T}nrm2
-XASUM          IS cblas_${T}asum
-XAXPY          IS cblas_${T}axpy
-XSCAL          IS cblas_${T}scal
+XDOT           IS ${T}DOT
+XNRM2          IS ${T}NRM2
+XASUM          IS ${T}ASUM
 
 WHERE
 
@@ -197,33 +205,6 @@ M: VECTOR Vnorm
     (prepare-nrm2) XNRM2 ;
 M: VECTOR Vasum
     (prepare-nrm2) XASUM ;
-M: VECTOR n*V+V!
-    (prepare-axpy) [ XAXPY ] dip ;
-M: VECTOR n*V!
-    (prepare-scal) [ XSCAL ] dip ;
-
-;FUNCTOR
-
-
-FUNCTOR: (define-complex-helpers) ( TYPE -- )
-
-<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
 
@@ -231,35 +212,21 @@ WHERE
 FUNCTOR: (define-complex-blas-vector) ( TYPE C S -- )
 
 VECTOR         IS ${TYPE}-blas-vector
-XDOTU_SUB      IS cblas_${C}dotu_sub
-XDOTC_SUB      IS cblas_${C}dotc_sub
-XXNRM2         IS cblas_${S}${C}nrm2
-XXASUM         IS cblas_${S}${C}asum
-XAXPY          IS cblas_${C}axpy
-XSCAL          IS cblas_${C}scal
-TYPE>ARG       IS ${TYPE}>arg
-ARG>TYPE       IS arg>${TYPE}
+XDOTU          IS ${C}DOTU
+XDOTC          IS ${C}DOTC
+XXNRM2         IS ${S}${C}NRM2
+XXASUM         IS ${S}${C}ASUM
 
 WHERE
 
 M: VECTOR V.
-    (prepare-dot) TYPE <c-object>
-    [ XDOTU_SUB ] keep
-    ARG>TYPE ;
+    (prepare-dot) XDOTU ;
 M: VECTOR V.conj
-    (prepare-dot) TYPE <c-object>
-    [ XDOTC_SUB ] keep
-    ARG>TYPE ;
+    (prepare-dot) XDOTC ;
 M: VECTOR Vnorm
     (prepare-nrm2) XXNRM2 ;
 M: VECTOR Vasum
     (prepare-nrm2) XXASUM ;
-M: VECTOR n*V+V!
-    [ TYPE>ARG ] 2dip
-    (prepare-axpy) [ XAXPY ] dip ;
-M: VECTOR n*V!
-    [ TYPE>ARG ] dip
-    (prepare-scal) [ XSCAL ] dip ;
 
 ;FUNCTOR
 
@@ -271,10 +238,10 @@ M: VECTOR n*V!
     [ drop (define-blas-vector) ]
     [ (define-complex-blas-vector) ] 3bi ;
 
-"float"  "s" define-real-blas-vector
-"double" "d" define-real-blas-vector
-"complex-float"  "c" "s" define-complex-blas-vector
-"complex-double" "z" "d" define-complex-blas-vector
+"float"  "S" define-real-blas-vector
+"double" "D" define-real-blas-vector
+"complex-float"  "C" "S" define-complex-blas-vector
+"complex-double" "Z" "D" define-complex-blas-vector
 
 >>
 

From 08b02fadc9ea836e6fb65da5da841ac1ce236fb6 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Mon, 9 Feb 2009 15:51:59 -0600
Subject: [PATCH 18/35] typos

---
 basis/alien/fortran/fortran.factor | 2 +-
 basis/math/blas/ffi/ffi.factor     | 4 ++--
 2 files changed, 3 insertions(+), 3 deletions(-)

diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor
index 00dd8583fc..c7688fbe3a 100644
--- a/basis/alien/fortran/fortran.factor
+++ b/basis/alien/fortran/fortran.factor
@@ -5,7 +5,7 @@ byte-arrays combinators combinators.short-circuit fry generalizations
 kernel lexer macros math math.parser namespaces parser sequences
 splitting stack-checker vectors vocabs.parser words locals
 io.encodings.ascii io.encodings.string shuffle effects math.ranges
-math.order sorting ;
+math.order sorting system ;
 IN: alien.fortran
 
 ! XXX this currently only supports the gfortran/f2c abi.
diff --git a/basis/math/blas/ffi/ffi.factor b/basis/math/blas/ffi/ffi.factor
index 7b0138357a..03043e54ed 100644
--- a/basis/math/blas/ffi/ffi.factor
+++ b/basis/math/blas/ffi/ffi.factor
@@ -27,9 +27,9 @@ FUNCTION: COMPLEX CDOTU
 FUNCTION: COMPLEX CDOTC
     ( INTEGER N, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ;
 
-SUBROUTINE: DOUBLE-COMPLEX ZDOTU
+FUNCTION: DOUBLE-COMPLEX ZDOTU
     ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
-SUBROUTINE: DOUBLE-COMPLEX ZDOTC
+FUNCTION: DOUBLE-COMPLEX ZDOTC
     ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
 
 FUNCTION: REAL SNRM2

From 0c589061ad895c6a3e8d1914ddc29cd49659cdbf Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-103.local>
Date: Mon, 9 Feb 2009 16:18:24 -0600
Subject: [PATCH 19/35] More docs for lazy lists, getting rid of lazy-map-with

---
 basis/lists/lazy/lazy-docs.factor             | 55 ++++++++++++++++---
 basis/lists/lazy/lazy-tests.factor            |  2 +-
 basis/lists/lazy/lazy.factor                  |  7 +--
 .../parser-combinators.factor                 |  8 +--
 4 files changed, 54 insertions(+), 18 deletions(-)

diff --git a/basis/lists/lazy/lazy-docs.factor b/basis/lists/lazy/lazy-docs.factor
index c402cdf15b..08fe3bbcba 100644
--- a/basis/lists/lazy/lazy-docs.factor
+++ b/basis/lists/lazy/lazy-docs.factor
@@ -1,11 +1,54 @@
 ! Copyright (C) 2006 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
-
 USING: help.markup help.syntax sequences strings lists ;
 IN: lists.lazy 
 
+ABOUT: "lists.lazy"
+
+ARTICLE: "lists.lazy" "Lazy lists"
+"The " { $vocab-link "lists.lazy" } " vocabulary implements lazy lists and standard operations to manipulate them."
+{ $subsection { "lists.lazy" "construction" } }
+{ $subsection { "lists.lazy" "manipulation" } }
+{ $subsection { "lists.lazy" "combinators" } }
+{ $subsection { "lists.lazy" "io" } } ;
+
+ARTICLE: { "lists.lazy" "combinators" } "Combinators for manipulating lazy lists"
+"The following combinators create lazy lists from other lazy lists:"
+{ $subsection lmap }
+{ $subsection lfilter }
+{ $subsection luntil }
+{ $subsection lwhile }
+{ $subsection lfrom-by }
+{ $subsection lcomp }
+{ $subsection lcomp* } ;
+
+ARTICLE: { "lists.lazy" "io" } "Lazy list I/O"
+"Input from a stream can be read through a lazy list, using the following words:"
+{ $subsection lcontents }
+{ $subsection llines } ;
+
+ARTICLE: { "lists.lazy" "construction" } "Constructing lazy lists"
+"Words for constructing lazy lists:"
+{ $subsection lazy-cons }
+{ $subsection 1lazy-list }
+{ $subsection 2lazy-list }
+{ $subsection 3lazy-list }
+{ $subsection seq>list }
+{ $subsection >list }
+{ $subsection lfrom } ;
+
+ARTICLE: { "lists.lazy" "manipulation" } "Manipulating lazy lists"
+"To make new lazy lists from old ones:"
+{ $subsection <memoized-cons> }
+{ $subsection lappend }
+{ $subsection lconcat }
+{ $subsection lcartesian-product }
+{ $subsection lcartesian-product* }
+{ $subsection lmerge }
+{ $subsection ltake } ;
+
 HELP: lazy-cons
-{ $values { "car" { $quotation "( -- X )" } } { "cdr" { $quotation "( -- cons )" } } { "promise" "the resulting cons object" } }
+{ $values { "car" { $quotation "( -- elt )" } } { "cdr" { $quotation "( -- cons )" } } { "promise" "the resulting cons object" } }
 { $description "Constructs a cons object for a lazy list from two quotations. The " { $snippet "car" } " quotation should return the head of the list, and the " { $snippet "cons" } " quotation the tail when called. When " { $link cons } " or " { $link cdr } " are called on the lazy-cons object then the appropriate quotation is called." } 
 { $see-also cons car cdr nil nil? } ;
 
@@ -28,16 +71,12 @@ HELP: <memoized-cons>
 { $description "Constructs a cons object that wraps an existing cons object. Requests for the car, cdr and nil? will be remembered after the first call, and the previous result returned on subsequent calls." } 
 { $see-also cons car cdr nil nil? } ;
 
-{ lazy-map lazy-map-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words
+{ lazy-map ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words
 
 HELP: lazy-map
 { $values { "list" "a cons object" } { "quot" { $quotation "( obj -- X )" } } { "result" "resulting cons object" } }
 { $description "Perform a similar functionality to that of the " { $link map } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-map> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
 
-HELP: lazy-map-with
-{ $values { "value" "an object" } { "list" "a cons object" } { "quot" { $quotation "( obj elt -- X )" } } { "result" "resulting cons object" } }
-{ $description "Variant of " { $link lazy-map } " which pushes a retained object on each invocation of the quotation." } ;
-
 HELP: ltake
 { $values { "n" "a non negative integer" } { "list" "a cons object" } { "result" "resulting cons object" } }
 { $description "Outputs a lazy list containing the first n items in the list. This is done a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-take> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
@@ -86,7 +125,7 @@ HELP: >list
 { $description "Convert the object into a list. Existing lists are passed through intact, sequences are converted using " { $link seq>list } " and other objects cause an error to be thrown." } 
 { $see-also seq>list } ;
     
-{ leach foldl lazy-map lazy-map-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words
+{ leach foldl lazy-map ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words
 
 HELP: lconcat
 { $values { "list" "a list of lists" } { "result" "a list" } }
diff --git a/basis/lists/lazy/lazy-tests.factor b/basis/lists/lazy/lazy-tests.factor
index 03221841c1..f4e55cba19 100644
--- a/basis/lists/lazy/lazy-tests.factor
+++ b/basis/lists/lazy/lazy-tests.factor
@@ -24,7 +24,7 @@ IN: lists.lazy.tests
 ] unit-test
 
 [ { 4 5 6 } ] [ 
-    3 { 1 2 3 } >list [ + ] lazy-map-with list>array
+    3 { 1 2 3 } >list [ + ] with lazy-map list>array
 ] unit-test
 
 [ [ ] lmap ] must-infer
diff --git a/basis/lists/lazy/lazy.factor b/basis/lists/lazy/lazy.factor
index 5adb7a8be5..d3b08a11fb 100644
--- a/basis/lists/lazy/lazy.factor
+++ b/basis/lists/lazy/lazy.factor
@@ -90,9 +90,6 @@ M: lazy-map cdr ( lazy-map -- cdr )
 M: lazy-map nil? ( lazy-map -- bool )
     cons>> nil? ;
 
-: lazy-map-with ( value list quot -- result )
-    with lazy-map ;
-
 TUPLE: lazy-take n cons ;
 
 C: <lazy-take> lazy-take
@@ -301,14 +298,14 @@ M: lazy-concat nil? ( lazy-concat -- bool )
     ] if ;
 
 : lcartesian-product ( list1 list2 -- result )
-    swap [ swap [ 2array ] lazy-map-with  ] lazy-map-with  lconcat ;
+    swap [ swap [ 2array ] with lazy-map  ] with lazy-map  lconcat ;
 
 : lcartesian-product* ( lists -- result )
     dup nil? [
         drop nil
     ] [
         [ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [
-            swap [ swap [ suffix ] lazy-map-with  ] lazy-map-with  lconcat
+            swap [ swap [ suffix ] with lazy-map  ] with lazy-map  lconcat
         ] reduce
     ] if ;
 
diff --git a/extra/parser-combinators/parser-combinators.factor b/extra/parser-combinators/parser-combinators.factor
index 347ab638ff..99e8099f38 100755
--- a/extra/parser-combinators/parser-combinators.factor
+++ b/extra/parser-combinators/parser-combinators.factor
@@ -149,8 +149,8 @@ TUPLE: and-parser parsers ;
             [ parsed>> ] dip
             [ parsed>> 2array ] keep
             unparsed>> <parse-result>
-        ] lazy-map-with
-    ] lazy-map-with lconcat ;
+        ] with lazy-map
+    ] with lazy-map lconcat ;
 
 M: and-parser parse ( input parser -- list )
     #! Parse 'input' by sequentially combining the
@@ -173,7 +173,7 @@ M: or-parser parse ( input parser1 -- list )
     #! of parser1 and parser2 being applied to the same
     #! input. This implements the choice parsing operator.
     parsers>> 0 swap seq>list
-    [ parse ] lazy-map-with lconcat ;
+    [ parse ] with lazy-map lconcat ;
 
 : trim-head-slice ( string -- string )
     #! Return a new string without any leading whitespace
@@ -218,7 +218,7 @@ M: apply-parser parse ( input parser -- result )
     -rot parse [
         [ parsed>> swap call ] keep
         unparsed>> <parse-result>
-    ] lazy-map-with ;
+    ] with lazy-map ;
 
 TUPLE: some-parser p1 ;
 

From ebdd135d6281e0758d2641e005fbff4253de5749 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Mon, 9 Feb 2009 16:36:46 -0600
Subject: [PATCH 20/35] gfortran returns float for REAL functions, not double
 like f2c

---
 basis/alien/fortran/fortran-tests.factor | 6 +++---
 basis/alien/fortran/fortran.factor       | 6 ++++--
 2 files changed, 7 insertions(+), 5 deletions(-)

diff --git a/basis/alien/fortran/fortran-tests.factor b/basis/alien/fortran/fortran-tests.factor
index 9b618ef513..1b2ffda4a9 100644
--- a/basis/alien/fortran/fortran-tests.factor
+++ b/basis/alien/fortran/fortran-tests.factor
@@ -116,7 +116,7 @@ RECORD: FORTRAN_TEST_RECORD
 [ "int" { } ]
 [ "logical" fortran-ret-type>c-type ] unit-test
 
-[ "double" { } ]
+[ "float" { } ]
 [ "real" fortran-ret-type>c-type ] unit-test
 
 [ "double" { } ]
@@ -136,7 +136,7 @@ RECORD: FORTRAN_TEST_RECORD
 
 ! fortran-sig>c-sig
 
-[ "double" { "int*" "char*" "float*" "double*" "long" } ]
+[ "float" { "int*" "char*" "float*" "double*" "long" } ]
 [ "real" { "integer" "character*17" "real" "real*8" } fortran-sig>c-sig ]
 unit-test
 
@@ -213,7 +213,7 @@ unit-test
         [ { [ drop ] } spread ]
     } 1 ncleave
     ! [fortran-invoke]
-    [ "double" "funpack" "fun_times__" { "float*" } alien-invoke ]
+    [ "float" "funpack" "fun_times__" { "float*" } alien-invoke ]
     1 nkeep
     ! [fortran-results>]
     shuffle( reta aa -- reta aa ) 
diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor
index c7688fbe3a..9327c7b02c 100644
--- a/basis/alien/fortran/fortran.factor
+++ b/basis/alien/fortran/fortran.factor
@@ -155,7 +155,9 @@ GENERIC: (fortran-ret-type>c-type) ( type -- c-type )
 
 M: f (fortran-ret-type>c-type) drop "void" ;
 M: fortran-type (fortran-ret-type>c-type) (fortran-type>c-type) ;
-M: real-type (fortran-ret-type>c-type) drop "double" ;
+! XXX F2C claims to return double for REAL typed functions
+! XXX OSX Accelerate.framework uses float 
+! M: real-type (fortran-ret-type>c-type) drop "double" ;
 
 : suffix! ( seq   elt   -- seq   ) over push     ; inline
 : append! ( seq-a seq-b -- seq-a ) over push-all ; inline
@@ -374,7 +376,7 @@ MACRO: fortran-invoke ( return library function parameters -- )
 
 :: define-fortran-function ( return library function parameters -- )
     function create-in dup reset-generic 
-    return library function parameters return parse-arglist
+    return library function parameters return [ "void" ] unless* parse-arglist
     [ \ fortran-invoke 5 [ ] nsequence ] dip define-declared ;
 
 : SUBROUTINE: 

From 4623e9bd683df29dd7fc405e0679db4d8fd47967 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Mon, 9 Feb 2009 16:37:01 -0600
Subject: [PATCH 21/35] another typo

---
 basis/math/blas/ffi/ffi.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/basis/math/blas/ffi/ffi.factor b/basis/math/blas/ffi/ffi.factor
index 03043e54ed..7e0694ae4f 100644
--- a/basis/math/blas/ffi/ffi.factor
+++ b/basis/math/blas/ffi/ffi.factor
@@ -16,7 +16,7 @@ LIBRARY: blas
 FUNCTION: REAL SDSDOT
     ( INTEGER N, REAL ALPHA, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ;
 FUNCTION: DOUBLE-PRECISION DSDOT
-    ( INTEGER N, DOUBLE-PRECISION-PRECISION(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ;
+    ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ;
 FUNCTION: REAL SDOT
     ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ;
 FUNCTION: DOUBLE-PRECISION DDOT

From ddf8afbb7ee49c8b3b894928168ab6c113417190 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Mon, 9 Feb 2009 16:37:12 -0600
Subject: [PATCH 22/35] more typos

---
 .../direct/complex-double/complex-double.factor                 | 2 +-
 .../direct/complex-float/complex-float.factor                   | 2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

diff --git a/basis/specialized-arrays/direct/complex-double/complex-double.factor b/basis/specialized-arrays/direct/complex-double/complex-double.factor
index 58af77b0c0..ae8d2b5fb3 100644
--- a/basis/specialized-arrays/direct/complex-double/complex-double.factor
+++ b/basis/specialized-arrays/direct/complex-double/complex-double.factor
@@ -1,4 +1,4 @@
-USING: specialized-arrays.float specialized-arrays.direct.functor ;
+USING: specialized-arrays.complex-double specialized-arrays.direct.functor ;
 IN: specialized-arrays.direct.complex-double
 
 << "complex-double" define-direct-array >>
diff --git a/basis/specialized-arrays/direct/complex-float/complex-float.factor b/basis/specialized-arrays/direct/complex-float/complex-float.factor
index d881c1e0d4..8971196297 100644
--- a/basis/specialized-arrays/direct/complex-float/complex-float.factor
+++ b/basis/specialized-arrays/direct/complex-float/complex-float.factor
@@ -1,4 +1,4 @@
-USING: specialized-arrays.float specialized-arrays.direct.functor ;
+USING: specialized-arrays.complex-float specialized-arrays.direct.functor ;
 IN: specialized-arrays.direct.complex-float
 
 << "complex-float" define-direct-array >>

From ad843a1bcf53f3a21f3ec13dbf24b5507dff0bc7 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Mon, 9 Feb 2009 16:37:45 -0600
Subject: [PATCH 23/35] iXamax returns a 1-based array index. decrement that
 shit

---
 basis/math/blas/vectors/vectors-docs.factor | 16 ++++++++--------
 basis/math/blas/vectors/vectors.factor      |  5 ++---
 2 files changed, 10 insertions(+), 11 deletions(-)

diff --git a/basis/math/blas/vectors/vectors-docs.factor b/basis/math/blas/vectors/vectors-docs.factor
index b37a4b966e..296437c32b 100644
--- a/basis/math/blas/vectors/vectors-docs.factor
+++ b/basis/math/blas/vectors/vectors-docs.factor
@@ -37,8 +37,8 @@ HELP: blas-vector-base
 { $list
     { { $link float-blas-vector } }
     { { $link double-blas-vector } }
-    { { $link float-complex-blas-vector } }
-    { { $link double-complex-blas-vector } }
+    { { $link complex-float-blas-vector } }
+    { { $link complex-double-blas-vector } }
 }
 "All of these subclasses share the same tuple layout:"
 { $list
@@ -51,10 +51,10 @@ HELP: float-blas-vector
 { $class-description "A vector of single-precision floating-point values. For details on the tuple layout, see " { $link blas-vector-base } "." } ;
 HELP: double-blas-vector
 { $class-description "A vector of double-precision floating-point values. For details on the tuple layout, see " { $link blas-vector-base } "." } ;
-HELP: float-complex-blas-vector
-{ $class-description "A vector of single-precision floating-point complex values. Complex values are stored in memory as two consecutive float values, real part then imaginary part. For details on the tuple layout, see " { $link blas-vector-base } "." } ;
-HELP: double-complex-blas-vector
-{ $class-description "A vector of single-precision floating-point complex values. Complex values are stored in memory as two consecutive float values, real part then imaginary part. For details on the tuple layout, see " { $link blas-vector-base } "." } ;
+HELP: complex-float-blas-vector
+{ $class-description "A vector of single-precision floating-point complex values. For details on the tuple layout, see " { $link blas-vector-base } "." } ;
+HELP: complex-double-blas-vector
+{ $class-description "A vector of double-precision floating-point complex values. For details on the tuple layout, see " { $link blas-vector-base } "." } ;
 
 HELP: n*V+V!
 { $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "y=alpha*x+y" blas-vector-base } }
@@ -145,11 +145,11 @@ HELP: dvector{
 
 HELP: cvector{
 { $syntax "cvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" }
-{ $description "Construct a literal " { $link float-complex-blas-vector } "." } ;
+{ $description "Construct a literal " { $link complex-float-blas-vector } "." } ;
 
 HELP: zvector{
 { $syntax "dvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" }
-{ $description "Construct a literal " { $link double-complex-blas-vector } "." } ;
+{ $description "Construct a literal " { $link complex-double-blas-vector } "." } ;
 
 {
     POSTPONE: svector{ POSTPONE: dvector{
diff --git a/basis/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor
index 9a2f9a4350..a373ec7c5a 100755
--- a/basis/math/blas/vectors/vectors.factor
+++ b/basis/math/blas/vectors/vectors.factor
@@ -1,7 +1,6 @@
 USING: accessors alien alien.c-types arrays ascii byte-arrays combinators
 combinators.short-circuit fry kernel math math.blas.ffi
-math.complex math.functions math.order sequences.complex
-sequences.complex-components sequences sequences.private
+math.complex math.functions math.order sequences sequences.private
 functors words locals parser prettyprint.backend prettyprint.custom
 specialized-arrays.float specialized-arrays.double
 specialized-arrays.direct.float specialized-arrays.direct.double
@@ -165,7 +164,7 @@ M: VECTOR element-type
 M: VECTOR Vswap
     (prepare-swap) [ XSWAP ] 2dip ;
 M: VECTOR Viamax
-    (prepare-nrm2) IXAMAX ;
+    (prepare-nrm2) IXAMAX 1- ;
 
 M: VECTOR (blas-vector-like)
     drop <VECTOR> ;

From 5a90a0aae5aeb1646eebddb5d4231b534cd0b797 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-103.local>
Date: Mon, 9 Feb 2009 16:41:23 -0600
Subject: [PATCH 24/35] Fixing bug in render-hidden

---
 basis/furnace/chloe-tags/chloe-tags.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/basis/furnace/chloe-tags/chloe-tags.factor b/basis/furnace/chloe-tags/chloe-tags.factor
index 8003ab208b..562fe5a614 100644
--- a/basis/furnace/chloe-tags/chloe-tags.factor
+++ b/basis/furnace/chloe-tags/chloe-tags.factor
@@ -86,7 +86,7 @@ CHLOE: base
     hidden-form-field ;
 
 : render-hidden ( for -- xml )
-    "," split [ hidden render>xml ] map ;
+    [ "," split [ hidden render>xml ] map ] [ f ] if* ;
 
 : compile-hidden-form-fields ( for -- )
     '[

From 1279d6e8ea2fff622ca556c6f7fa4b266a923ca9 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-103.local>
Date: Mon, 9 Feb 2009 16:46:02 -0600
Subject: [PATCH 25/35] Fixing furnace test/docs

---
 basis/furnace/furnace-tests.factor            | 4 ++--
 basis/furnace/utilities/utilities-docs.factor | 4 ++--
 2 files changed, 4 insertions(+), 4 deletions(-)

diff --git a/basis/furnace/furnace-tests.factor b/basis/furnace/furnace-tests.factor
index f01260c68b..c591b848ec 100644
--- a/basis/furnace/furnace-tests.factor
+++ b/basis/furnace/furnace-tests.factor
@@ -1,7 +1,7 @@
 IN: furnace.tests
 USING: http http.server.dispatchers http.server.responses
 http.server furnace furnace.utilities tools.test kernel
-namespaces accessors io.streams.string urls ;
+namespaces accessors io.streams.string urls xml.writer ;
 TUPLE: funny-dispatcher < dispatcher ;
 
 : <funny-dispatcher> funny-dispatcher new-dispatcher ;
@@ -31,7 +31,7 @@ M: base-path-check-responder call-responder*
 ] unit-test
 
 [ "<input type=\"hidden\" value=\"&amp;&amp;&amp;\" name=\"foo\"/>" ]
-[ [ "&&&" "foo" hidden-form-field ] with-string-writer ]
+[ "&&&" "foo" hidden-form-field xml>string ]
 unit-test
 
 [ f ] [ <request> request [ referrer ] with-variable ] unit-test
diff --git a/basis/furnace/utilities/utilities-docs.factor b/basis/furnace/utilities/utilities-docs.factor
index db44963f6e..e7fdaf64d6 100644
--- a/basis/furnace/utilities/utilities-docs.factor
+++ b/basis/furnace/utilities/utilities-docs.factor
@@ -25,8 +25,8 @@ HELP: hidden-form-field
 { $notes "This word is used by session management, conversation scope and asides." }
 { $examples
     { $example
-        "USING: furnace.utilities io ;"
-        "\"bar\" \"foo\" hidden-form-field nl"
+        "USING: furnace.utilities io xml.writer ;"
+        "\"bar\" \"foo\" hidden-form-field write-xml nl"
         "<input type=\"hidden\" value=\"bar\" name=\"foo\"/>"
     }
 } ;

From 35c54a91ac5d937795b2ff9912f8d0aa719fb6bf Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Mon, 9 Feb 2009 16:59:00 -0600
Subject: [PATCH 26/35] oops, leftover ORDER arguments from converting from
 CBLAS

---
 basis/math/blas/ffi/ffi.factor | 24 ++++++++----------------
 1 file changed, 8 insertions(+), 16 deletions(-)

diff --git a/basis/math/blas/ffi/ffi.factor b/basis/math/blas/ffi/ffi.factor
index 7e0694ae4f..77cee1aa82 100644
--- a/basis/math/blas/ffi/ffi.factor
+++ b/basis/math/blas/ffi/ffi.factor
@@ -122,13 +122,11 @@ SUBROUTINE: DROTM
  
 ! LEVEL 2 BLAS (MATRIX-VECTOR)
 
-SUBROUTINE: SGEMV ( CHARACTER*1 ORDER,
-                 CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
+SUBROUTINE: SGEMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
                  REAL ALPHA, REAL(*) A, INTEGER LDA,
                  REAL(*) X, INTEGER INCX, REAL BETA,
                  REAL(*) Y, INTEGER INCY ) ;
-SUBROUTINE: SGBMV ( CHARACTER*1 ORDER,
-                 CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
+SUBROUTINE: SGBMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
                  INTEGER KL, INTEGER KU, REAL ALPHA,
                  REAL(*) A, INTEGER LDA, REAL(*) X,
                  INTEGER INCX, REAL BETA, REAL(*) Y, INTEGER INCY ) ;
@@ -155,13 +153,11 @@ SUBROUTINE: STPSV ( CHARACTER*1 UPLO,
                  CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
                  INTEGER N, REAL(*) AP, REAL(*) X, INTEGER INCX ) ;
 
-SUBROUTINE: DGEMV ( CHARACTER*1 ORDER,
-                 CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
+SUBROUTINE: DGEMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
                  DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA,
                  DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION BETA,
                  DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
-SUBROUTINE: DGBMV ( CHARACTER*1 ORDER,
-                 CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
+SUBROUTINE: DGBMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
                  INTEGER KL, INTEGER KU, DOUBLE-PRECISION ALPHA,
                  DOUBLE-PRECISION(*) A, INTEGER LDA, DOUBLE-PRECISION(*) X,
                  INTEGER INCX, DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
@@ -188,13 +184,11 @@ SUBROUTINE: DTPSV ( CHARACTER*1 UPLO,
                  CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
                  INTEGER N, DOUBLE-PRECISION(*) AP, DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
 
-SUBROUTINE: CGEMV ( CHARACTER*1 ORDER,
-                 CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
+SUBROUTINE: CGEMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
                  COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA,
                  COMPLEX(*) X, INTEGER INCX, COMPLEX BETA,
                  COMPLEX(*) Y, INTEGER INCY ) ;
-SUBROUTINE: CGBMV ( CHARACTER*1 ORDER,
-                 CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
+SUBROUTINE: CGBMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
                  INTEGER KL, INTEGER KU, COMPLEX ALPHA,
                  COMPLEX(*) A, INTEGER LDA, COMPLEX(*) X,
                  INTEGER INCX, COMPLEX BETA, COMPLEX(*) Y, INTEGER INCY ) ;
@@ -221,13 +215,11 @@ SUBROUTINE: CTPSV ( CHARACTER*1 UPLO,
                  CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
                  INTEGER N, COMPLEX(*) AP, COMPLEX(*) X, INTEGER INCX ) ;
 
-SUBROUTINE: ZGEMV ( CHARACTER*1 ORDER,
-                 CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
+SUBROUTINE: ZGEMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
                  DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
                  DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX BETA,
                  DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
-SUBROUTINE: ZGBMV ( CHARACTER*1 ORDER,
-                 CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
+SUBROUTINE: ZGBMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
                  INTEGER KL, INTEGER KU, DOUBLE-COMPLEX ALPHA,
                  DOUBLE-COMPLEX(*) A, INTEGER LDA, DOUBLE-COMPLEX(*) X,
                  INTEGER INCX, DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;

From d160b80dacbcf7e598613930fb83781df8804e7d Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Mon, 9 Feb 2009 16:59:26 -0600
Subject: [PATCH 27/35] convert math.blas.matrices to use fortran calls

---
 basis/math/blas/matrices/matrices-docs.factor | 40 +++++------
 basis/math/blas/matrices/matrices.factor      | 72 +++++++++----------
 2 files changed, 54 insertions(+), 58 deletions(-)

diff --git a/basis/math/blas/matrices/matrices-docs.factor b/basis/math/blas/matrices/matrices-docs.factor
index f20a565e1f..b6e118836e 100644
--- a/basis/math/blas/matrices/matrices-docs.factor
+++ b/basis/math/blas/matrices/matrices-docs.factor
@@ -14,34 +14,34 @@ ARTICLE: "math.blas-types" "BLAS interface types"
 "BLAS vectors come in single- and double-precision, real and complex flavors:"
 { $subsection float-blas-vector }
 { $subsection double-blas-vector }
-{ $subsection float-complex-blas-vector }
-{ $subsection double-complex-blas-vector }
+{ $subsection complex-float-blas-vector }
+{ $subsection complex-double-blas-vector }
 "These vector types all follow the " { $link sequence } " protocol. In addition, there are corresponding types for matrix data:"
 { $subsection float-blas-matrix }
 { $subsection double-blas-matrix }
-{ $subsection float-complex-blas-matrix }
-{ $subsection double-complex-blas-matrix } 
+{ $subsection complex-float-blas-matrix }
+{ $subsection complex-double-blas-matrix } 
 "There are BOA constructors for all vector and matrix types, which provide the most flexibility in specifying memory layout:"
 { $subsection <float-blas-vector> }
 { $subsection <double-blas-vector> }
-{ $subsection <float-complex-blas-vector> }
-{ $subsection <double-complex-blas-vector> }
+{ $subsection <complex-float-blas-vector> }
+{ $subsection <complex-double-blas-vector> }
 { $subsection <float-blas-matrix> }
 { $subsection <double-blas-matrix> }
-{ $subsection <float-complex-blas-matrix> }
-{ $subsection <double-complex-blas-matrix> }
+{ $subsection <complex-float-blas-matrix> }
+{ $subsection <complex-double-blas-matrix> }
 "For the simple case of creating a dense, zero-filled vector or matrix, simple empty object constructors are provided:"
 { $subsection <empty-vector> }
 { $subsection <empty-matrix> }
 "BLAS vectors and matrices can also be constructed from other Factor sequences:"
 { $subsection >float-blas-vector }
 { $subsection >double-blas-vector }
-{ $subsection >float-complex-blas-vector }
-{ $subsection >double-complex-blas-vector }
+{ $subsection >complex-float-blas-vector }
+{ $subsection >complex-double-blas-vector }
 { $subsection >float-blas-matrix }
 { $subsection >double-blas-matrix }
-{ $subsection >float-complex-blas-matrix }
-{ $subsection >double-complex-blas-matrix } ;
+{ $subsection >complex-float-blas-matrix }
+{ $subsection >complex-double-blas-matrix } ;
 
 ARTICLE: "math.blas.matrices" "BLAS interface matrix operations"
 "Transposing and slicing matrices:"
@@ -87,8 +87,8 @@ HELP: blas-matrix-base
 { $list
     { { $link float-blas-matrix } }
     { { $link double-blas-matrix } }
-    { { $link float-complex-blas-matrix } }
-    { { $link double-complex-blas-matrix } }
+    { { $link complex-float-blas-matrix } }
+    { { $link complex-double-blas-matrix } }
 }
 "All of these subclasses share the same tuple layout:"
 { $list
@@ -104,14 +104,14 @@ HELP: float-blas-matrix
 { $class-description "A matrix of single-precision floating-point values. For details on the tuple layout, see " { $link blas-matrix-base } "." } ;
 HELP: double-blas-matrix
 { $class-description "A matrix of double-precision floating-point values. For details on the tuple layout, see " { $link blas-matrix-base } "." } ;
-HELP: float-complex-blas-matrix
+HELP: complex-float-blas-matrix
 { $class-description "A matrix of single-precision floating-point complex values. Complex values are stored in memory as two consecutive float values, real part then imaginary part. For details on the tuple layout, see " { $link blas-matrix-base } "." } ;
-HELP: double-complex-blas-matrix
+HELP: complex-double-blas-matrix
 { $class-description "A matrix of double-precision floating-point complex values. Complex values are stored in memory as two consecutive float values, real part then imaginary part. For details on the tuple layout, see " { $link blas-matrix-base } "." } ;
 
 {
-    float-blas-matrix double-blas-matrix float-complex-blas-matrix double-complex-blas-matrix
-    float-blas-vector double-blas-vector float-complex-blas-vector double-complex-blas-vector
+    float-blas-matrix double-blas-matrix complex-float-blas-matrix complex-double-blas-matrix
+    float-blas-vector double-blas-vector complex-float-blas-vector complex-double-blas-vector
 } related-words
 
 HELP: Mwidth
@@ -272,7 +272,7 @@ HELP: cmatrix{
     { 0.0 0.0          -1.0 3.0           }
     { 0.0 0.0           0.0 C{ 0.0 -1.0 } }
 } "> }
-{ $description "Construct a literal " { $link float-complex-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
+{ $description "Construct a literal " { $link complex-float-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
 
 HELP: zmatrix{
 { $syntax <" zmatrix{
@@ -281,7 +281,7 @@ HELP: zmatrix{
     { 0.0 0.0          -1.0 3.0           }
     { 0.0 0.0           0.0 C{ 0.0 -1.0 } }
 } "> }
-{ $description "Construct a literal " { $link double-complex-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
+{ $description "Construct a literal " { $link complex-double-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
 
 {
     POSTPONE: smatrix{ POSTPONE: dmatrix{
diff --git a/basis/math/blas/matrices/matrices.factor b/basis/math/blas/matrices/matrices.factor
index d9653fca6f..6a948b6fe1 100755
--- a/basis/math/blas/matrices/matrices.factor
+++ b/basis/math/blas/matrices/matrices.factor
@@ -1,11 +1,13 @@
 USING: accessors alien alien.c-types arrays byte-arrays combinators
 combinators.short-circuit fry kernel locals macros
-math math.blas.cblas math.blas.vectors math.blas.vectors.private
+math math.blas.ffi math.blas.vectors math.blas.vectors.private
 math.complex math.functions math.order functors words
 sequences sequences.merged sequences.private shuffle
 specialized-arrays.direct.float specialized-arrays.direct.double
 specialized-arrays.float specialized-arrays.double
-parser prettyprint.backend prettyprint.custom ;
+specialized-arrays.direct.complex-float specialized-arrays.direct.complex-double
+specialized-arrays.complex-float specialized-arrays.complex-double
+parser prettyprint.backend prettyprint.custom ascii ;
 IN: math.blas.matrices
 
 TUPLE: blas-matrix-base underlying ld rows cols transpose ;
@@ -25,7 +27,7 @@ GENERIC: n*M.M+n*M! ( alpha A B beta C -- C=alpha*A.B+beta*C )
 <PRIVATE
 
 : (blas-transpose) ( matrix -- integer )
-    transpose>> [ CblasTrans ] [ CblasNoTrans ] if ;
+    transpose>> [ "T" ] [ "N" ] if ;
 
 GENERIC: (blas-matrix-like) ( data ld rows cols transpose exemplar -- matrix )
 
@@ -38,19 +40,18 @@ GENERIC: (blas-matrix-like) ( data ld rows cols transpose exemplar -- matrix )
     unless ;
 
 :: (prepare-gemv)
-    ( alpha A x beta y >c-arg -- order A-trans m n alpha A-data A-ld x-data x-inc beta y-data y-inc
-                                 y )
+    ( alpha A x beta y -- A-trans m n alpha A-data A-ld x-data x-inc beta y-data y-inc
+                          y )
     A x y (validate-gemv)
-    CblasColMajor
     A (blas-transpose)
     A rows>>
     A cols>>
-    alpha >c-arg call
+    alpha
     A underlying>>
     A ld>>
     x underlying>>
     x inc>>
-    beta >c-arg call
+    beta
     y underlying>>
     y inc>>
     y ; inline
@@ -64,13 +65,12 @@ GENERIC: (blas-matrix-like) ( data ld rows cols transpose exemplar -- matrix )
     unless ;
 
 :: (prepare-ger)
-    ( alpha x y A >c-arg -- order m n alpha x-data x-inc y-data y-inc A-data A-ld
-                            A )
+    ( alpha x y A -- m n alpha x-data x-inc y-data y-inc A-data A-ld
+                     A )
     x y A (validate-ger)
-    CblasColMajor
     A rows>>
     A cols>>
-    alpha >c-arg call
+    alpha
     x underlying>>
     x inc>>
     y underlying>>
@@ -89,21 +89,20 @@ GENERIC: (blas-matrix-like) ( data ld rows cols transpose exemplar -- matrix )
     unless ;
 
 :: (prepare-gemm)
-    ( alpha A B beta C >c-arg -- order A-trans B-trans m n k alpha A-data A-ld B-data B-ld beta C-data C-ld
-                                 C )
+    ( alpha A B beta C -- A-trans B-trans m n k alpha A-data A-ld B-data B-ld beta C-data C-ld
+                          C )
     A B C (validate-gemm)
-    CblasColMajor
     A (blas-transpose)
     B (blas-transpose)
     C rows>>
     C cols>>
     A Mwidth
-    alpha >c-arg call
+    alpha
     A underlying>>
     A ld>>
     B underlying>>
     B ld>>
-    beta >c-arg call
+    beta
     C underlying>>
     C ld>>
     C f >>transpose ; inline
@@ -250,16 +249,18 @@ FUNCTOR: (define-blas-matrix) ( TYPE T U C -- )
 VECTOR      IS ${TYPE}-blas-vector
 <VECTOR>    IS <${TYPE}-blas-vector>
 >ARRAY      IS >${TYPE}-array
-TYPE>ARG    IS ${TYPE}>arg
-XGEMV       IS cblas_${T}gemv
-XGEMM       IS cblas_${T}gemm
-XGERU       IS cblas_${T}ger${U}
-XGERC       IS cblas_${T}ger${C}
+XGEMV       IS ${T}GEMV
+XGEMM       IS ${T}GEMM
+XGERU       IS ${T}GER${U}
+XGERC       IS ${T}GER${C}
 
 MATRIX      DEFINES-CLASS ${TYPE}-blas-matrix
 <MATRIX>    DEFINES <${TYPE}-blas-matrix>
 >MATRIX     DEFINES >${TYPE}-blas-matrix
-XMATRIX{    DEFINES ${T}matrix{
+
+t           [ T >lower ]
+
+XMATRIX{    DEFINES ${t}matrix{
 
 WHERE
 
@@ -277,21 +278,16 @@ M: MATRIX (blas-vector-like)
     drop <VECTOR> ;
 
 : >MATRIX ( arrays -- matrix )
-    [ >ARRAY underlying>> ] (>matrix)
-    <MATRIX> ;
+    [ >ARRAY underlying>> ] (>matrix) <MATRIX> ;
 
 M: VECTOR n*M.V+n*V!
-    [ TYPE>ARG ] (prepare-gemv)
-    [ XGEMV ] dip ;
+    (prepare-gemv) [ XGEMV ] dip ;
 M: MATRIX n*M.M+n*M!
-    [ TYPE>ARG ] (prepare-gemm)
-    [ XGEMM ] dip ;
+    (prepare-gemm) [ XGEMM ] dip ;
 M: MATRIX n*V(*)V+M!
-    [ TYPE>ARG ] (prepare-ger)
-    [ XGERU ] dip ;
+    (prepare-ger) [ XGERU ] dip ;
 M: MATRIX n*V(*)Vconj+M!
-    [ TYPE>ARG ] (prepare-ger)
-    [ XGERC ] dip ;
+    (prepare-ger) [ XGERC ] dip ;
 
 : XMATRIX{ \ } [ >MATRIX ] parse-literal ; parsing
 
@@ -304,12 +300,12 @@ M: MATRIX pprint-delims
 : define-real-blas-matrix ( TYPE T -- )
     "" "" (define-blas-matrix) ;
 : define-complex-blas-matrix ( TYPE T -- )
-    "u" "c" (define-blas-matrix) ;
+    "U" "C" (define-blas-matrix) ;
 
-"float"          "s" define-real-blas-matrix
-"double"         "d" define-real-blas-matrix
-"float-complex"  "c" define-complex-blas-matrix
-"double-complex" "z" define-complex-blas-matrix
+"float"          "S" define-real-blas-matrix
+"double"         "D" define-real-blas-matrix
+"complex-float"  "C" define-complex-blas-matrix
+"complex-double" "Z" define-complex-blas-matrix
 
 >>
 

From 4325f5a7a9a08c6c9b67eccd2141acf6b353138f Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Mon, 9 Feb 2009 17:04:37 -0600
Subject: [PATCH 28/35] kill math.blas.cblas

---
 basis/math/blas/cblas/authors.txt             |   1 -
 basis/math/blas/cblas/cblas.factor            | 574 ------------------
 basis/math/blas/cblas/summary.txt             |   1 -
 basis/math/blas/cblas/tags.txt                |   2 -
 basis/math/blas/matrices/matrices-docs.factor |   2 +-
 5 files changed, 1 insertion(+), 579 deletions(-)
 delete mode 100644 basis/math/blas/cblas/authors.txt
 delete mode 100644 basis/math/blas/cblas/cblas.factor
 delete mode 100644 basis/math/blas/cblas/summary.txt
 delete mode 100644 basis/math/blas/cblas/tags.txt

diff --git a/basis/math/blas/cblas/authors.txt b/basis/math/blas/cblas/authors.txt
deleted file mode 100644
index f13c9c1e77..0000000000
--- a/basis/math/blas/cblas/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Joe Groff
diff --git a/basis/math/blas/cblas/cblas.factor b/basis/math/blas/cblas/cblas.factor
deleted file mode 100644
index 2a2e9e3a72..0000000000
--- a/basis/math/blas/cblas/cblas.factor
+++ /dev/null
@@ -1,574 +0,0 @@
-USING: alien alien.c-types alien.syntax kernel system
-combinators ;
-IN: math.blas.cblas
-
-<<
-: load-atlas ( -- )
-    "atlas" "libatlas.so" "cdecl" add-library ;
-: load-fortran ( -- )
-    "I77" "libI77.so" "cdecl" add-library
-    "F77" "libF77.so" "cdecl" add-library ;
-: load-blas ( -- )
-    "blas" "libblas.so" "cdecl" add-library ;
-
-"cblas" {
-    { [ os macosx? ] [ "libblas.dylib" "cdecl" add-library ] }
-    { [ os windows? ] [ "blas.dll" "cdecl" add-library ] }
-    { [ os openbsd? ] [ "libcblas.so" "cdecl" add-library load-blas ] }
-    { [ os netbsd? ] [ 
-        load-fortran load-blas
-        "/usr/local/lib/libcblas.so" "cdecl" add-library
-    ] }
-    { [ os freebsd? ] [ "libcblas.so" "cdecl" add-library load-atlas ] }
-    [ "libblas.so" "cdecl" add-library ]
-} cond
->>
-
-LIBRARY: cblas
-
-TYPEDEF: int CBLAS_ORDER
-CONSTANT: CblasRowMajor 101
-CONSTANT: CblasColMajor 102
-
-TYPEDEF: int CBLAS_TRANSPOSE
-CONSTANT: CblasNoTrans   111
-CONSTANT: CblasTrans     112
-CONSTANT: CblasConjTrans 113
-
-TYPEDEF: int CBLAS_UPLO
-CONSTANT: CblasUpper 121
-CONSTANT: CblasLower 122
-
-TYPEDEF: int CBLAS_DIAG
-CONSTANT: CblasNonUnit 131
-CONSTANT: CblasUnit    132
-
-TYPEDEF: int CBLAS_SIDE
-CONSTANT: CblasLeft  141
-CONSTANT: CblasRight 142
-
-TYPEDEF: int CBLAS_INDEX
-
-C-STRUCT: float-complex
-    { "float" "real" }
-    { "float" "imag" } ;
-C-STRUCT: double-complex
-    { "double" "real" }
-    { "double" "imag" } ;
-
-! Level 1 BLAS (scalar-vector and vector-vector)
-
-FUNCTION: float  cblas_sdsdot
-    ( int N, float    alpha, float*   X, int incX, float*   Y, int incY ) ;
-FUNCTION: double cblas_dsdot
-    ( int N,                 float*   X, int incX, float*   Y, int incY ) ;
-FUNCTION: float  cblas_sdot
-    ( int N,                 float*   X, int incX, float*   Y, int incY ) ;
-FUNCTION: double cblas_ddot
-    ( int N,                 double*  X, int incX, double*  Y, int incY ) ;
-
-FUNCTION: void   cblas_cdotu_sub
-    ( int N,                 void*    X, int incX, void*    Y, int incY, void*    dotu ) ;
-FUNCTION: void   cblas_cdotc_sub
-    ( int N,                 void*    X, int incX, void*    Y, int incY, void*    dotc ) ;
-
-FUNCTION: void   cblas_zdotu_sub
-    ( int N,                 void*    X, int incX, void*    Y, int incY, void*    dotu ) ;
-FUNCTION: void   cblas_zdotc_sub
-    ( int N,                 void*    X, int incX, void*    Y, int incY, void*    dotc ) ;
-
-FUNCTION: float  cblas_snrm2
-    ( int N,                 float*   X, int incX ) ;
-FUNCTION: float  cblas_sasum
-    ( int N,                 float*   X, int incX ) ;
-
-FUNCTION: double cblas_dnrm2
-    ( int N,                 double*  X, int incX ) ;
-FUNCTION: double cblas_dasum
-    ( int N,                 double*  X, int incX ) ;
-
-FUNCTION: float  cblas_scnrm2
-    ( int N,                 void*    X, int incX ) ;
-FUNCTION: float  cblas_scasum
-    ( int N,                 void*    X, int incX ) ;
-
-FUNCTION: double cblas_dznrm2
-    ( int N,                 void*    X, int incX ) ;
-FUNCTION: double cblas_dzasum
-    ( int N,                 void*    X, int incX ) ;
-
-FUNCTION: CBLAS_INDEX cblas_isamax
-    ( int N,                 float*   X, int incX ) ;
-FUNCTION: CBLAS_INDEX cblas_idamax
-    ( int N,                 double*  X, int incX ) ;
-FUNCTION: CBLAS_INDEX cblas_icamax
-    ( int N,                 void*    X, int incX ) ;
-FUNCTION: CBLAS_INDEX cblas_izamax
-    ( int N,                 void*    X, int incX ) ;
-
-FUNCTION: void cblas_sswap
-    ( int N,                 float*   X, int incX, float*   Y, int incY ) ;
-FUNCTION: void cblas_scopy
-    ( int N,                 float*   X, int incX, float*   Y, int incY ) ;
-FUNCTION: void cblas_saxpy
-    ( int N, float    alpha, float*   X, int incX, float*   Y, int incY ) ;
-
-FUNCTION: void cblas_dswap
-    ( int N,                 double*  X, int incX, double*  Y, int incY ) ;
-FUNCTION: void cblas_dcopy
-    ( int N,                 double*  X, int incX, double*  Y, int incY ) ;
-FUNCTION: void cblas_daxpy
-    ( int N, double   alpha, double*  X, int incX, double*  Y, int incY ) ;
-
-FUNCTION: void cblas_cswap
-    ( int N,                 void*    X, int incX, void*    Y, int incY ) ;
-FUNCTION: void cblas_ccopy
-    ( int N,                 void*    X, int incX, void*    Y, int incY ) ;
-FUNCTION: void cblas_caxpy
-    ( int N, void*    alpha, void*    X, int incX, void*    Y, int incY ) ;
-
-FUNCTION: void cblas_zswap
-    ( int N,                 void*    X, int incX, void*    Y, int incY ) ;
-FUNCTION: void cblas_zcopy
-    ( int N,                 void*    X, int incX, void*    Y, int incY ) ;
-FUNCTION: void cblas_zaxpy
-    ( int N, void*    alpha, void*    X, int incX, void*    Y, int incY ) ;
-
-FUNCTION: void cblas_sscal
-    ( int N, float    alpha, float*   X, int incX ) ;
-FUNCTION: void cblas_dscal
-    ( int N, double   alpha, double*  X, int incX ) ;
-FUNCTION: void cblas_cscal
-    ( int N, void*    alpha, void*    X, int incX ) ;
-FUNCTION: void cblas_zscal
-    ( int N, void*    alpha, void*    X, int incX ) ;
-FUNCTION: void cblas_csscal
-    ( int N, float    alpha, void*    X, int incX ) ;
-FUNCTION: void cblas_zdscal
-    ( int N, double   alpha, void*    X, int incX ) ;
-
-FUNCTION: void cblas_srotg
-    ( float* a, float* b, float* c, float* s ) ;
-FUNCTION: void cblas_srotmg
-    ( float* d1, float* d2, float* b1, float b2, float* P ) ;
-FUNCTION: void cblas_srot
-    ( int N, float* X, int incX, float* Y, int incY, float c, float s ) ;
-FUNCTION: void cblas_srotm
-    ( int N, float* X, int incX, float* Y, int incY, float* P ) ;
-
-FUNCTION: void cblas_drotg
-    ( double* a, double* b, double* c, double* s ) ;
-FUNCTION: void cblas_drotmg
-    ( double* d1, double* d2, double* b1, double b2, double* P ) ;
-FUNCTION: void cblas_drot
-    ( int N, double* X, int incX, double* Y, int incY, double c, double s ) ;
-FUNCTION: void cblas_drotm
-    ( int N, double* X, int incX, double* Y, int incY, double* P ) ;
- 
-! Level 2 BLAS (matrix-vector)
-
-FUNCTION: void cblas_sgemv ( CBLAS_ORDER Order,
-                 CBLAS_TRANSPOSE TransA, int M, int N,
-                 float alpha, float* A, int lda,
-                 float* X, int incX, float beta,
-                 float* Y, int incY ) ;
-FUNCTION: void cblas_sgbmv ( CBLAS_ORDER Order,
-                 CBLAS_TRANSPOSE TransA, int M, int N,
-                 int KL, int KU, float alpha,
-                 float* A, int lda, float* X,
-                 int incX, float beta, float* Y, int incY ) ;
-FUNCTION: void cblas_strmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                 CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
-                 int N, float* A, int lda,
-                 float* X, int incX ) ;
-FUNCTION: void cblas_stbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                 CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
-                 int N, int K, float* A, int lda,
-                 float* X, int incX ) ;
-FUNCTION: void cblas_stpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                 CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
-                 int N, float* Ap, float* X, int incX ) ;
-FUNCTION: void cblas_strsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                 CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
-                 int N, float* A, int lda, float* X,
-                 int incX ) ;
-FUNCTION: void cblas_stbsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                 CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
-                 int N, int K, float* A, int lda,
-                 float* X, int incX ) ;
-FUNCTION: void cblas_stpsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                 CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
-                 int N, float* Ap, float* X, int incX ) ;
-
-FUNCTION: void cblas_dgemv ( CBLAS_ORDER Order,
-                 CBLAS_TRANSPOSE TransA, int M, int N,
-                 double alpha, double* A, int lda,
-                 double* X, int incX, double beta,
-                 double* Y, int incY ) ;
-FUNCTION: void cblas_dgbmv ( CBLAS_ORDER Order,
-                 CBLAS_TRANSPOSE TransA, int M, int N,
-                 int KL, int KU, double alpha,
-                 double* A, int lda, double* X,
-                 int incX, double beta, double* Y, int incY ) ;
-FUNCTION: void cblas_dtrmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                 CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
-                 int N, double* A, int lda,
-                 double* X, int incX ) ;
-FUNCTION: void cblas_dtbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                 CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
-                 int N, int K, double* A, int lda,
-                 double* X, int incX ) ;
-FUNCTION: void cblas_dtpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                 CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
-                 int N, double* Ap, double* X, int incX ) ;
-FUNCTION: void cblas_dtrsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                 CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
-                 int N, double* A, int lda, double* X,
-                 int incX ) ;
-FUNCTION: void cblas_dtbsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                 CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
-                 int N, int K, double* A, int lda,
-                 double* X, int incX ) ;
-FUNCTION: void cblas_dtpsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                 CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
-                 int N, double* Ap, double* X, int incX ) ;
-
-FUNCTION: void cblas_cgemv ( CBLAS_ORDER Order,
-                 CBLAS_TRANSPOSE TransA, int M, int N,
-                 void* alpha, void* A, int lda,
-                 void* X, int incX, void* beta,
-                 void* Y, int incY ) ;
-FUNCTION: void cblas_cgbmv ( CBLAS_ORDER Order,
-                 CBLAS_TRANSPOSE TransA, int M, int N,
-                 int KL, int KU, void* alpha,
-                 void* A, int lda, void* X,
-                 int incX, void* beta, void* Y, int incY ) ;
-FUNCTION: void cblas_ctrmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                 CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
-                 int N, void* A, int lda,
-                 void* X, int incX ) ;
-FUNCTION: void cblas_ctbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                 CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
-                 int N, int K, void* A, int lda,
-                 void* X, int incX ) ;
-FUNCTION: void cblas_ctpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                 CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
-                 int N, void* Ap, void* X, int incX ) ;
-FUNCTION: void cblas_ctrsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                 CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
-                 int N, void* A, int lda, void* X,
-                 int incX ) ;
-FUNCTION: void cblas_ctbsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                 CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
-                 int N, int K, void* A, int lda,
-                 void* X, int incX ) ;
-FUNCTION: void cblas_ctpsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                 CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
-                 int N, void* Ap, void* X, int incX ) ;
-
-FUNCTION: void cblas_zgemv ( CBLAS_ORDER Order,
-                 CBLAS_TRANSPOSE TransA, int M, int N,
-                 void* alpha, void* A, int lda,
-                 void* X, int incX, void* beta,
-                 void* Y, int incY ) ;
-FUNCTION: void cblas_zgbmv ( CBLAS_ORDER Order,
-                 CBLAS_TRANSPOSE TransA, int M, int N,
-                 int KL, int KU, void* alpha,
-                 void* A, int lda, void* X,
-                 int incX, void* beta, void* Y, int incY ) ;
-FUNCTION: void cblas_ztrmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                 CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
-                 int N, void* A, int lda,
-                 void* X, int incX ) ;
-FUNCTION: void cblas_ztbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                 CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
-                 int N, int K, void* A, int lda,
-                 void* X, int incX ) ;
-FUNCTION: void cblas_ztpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                 CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
-                 int N, void* Ap, void* X, int incX ) ;
-FUNCTION: void cblas_ztrsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                 CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
-                 int N, void* A, int lda, void* X,
-                 int incX ) ;
-FUNCTION: void cblas_ztbsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                 CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
-                 int N, int K, void* A, int lda,
-                 void* X, int incX ) ;
-FUNCTION: void cblas_ztpsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                 CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
-                 int N, void* Ap, void* X, int incX ) ;
-
-
-FUNCTION: void cblas_ssymv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                 int N, float alpha, float* A,
-                 int lda, float* X, int incX,
-                 float beta, float* Y, int incY ) ;
-FUNCTION: void cblas_ssbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                 int N, int K, float alpha, float* A,
-                 int lda, float* X, int incX,
-                 float beta, float* Y, int incY ) ;
-FUNCTION: void cblas_sspmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                 int N, float alpha, float* Ap,
-                 float* X, int incX,
-                 float beta, float* Y, int incY ) ;
-FUNCTION: void cblas_sger ( CBLAS_ORDER Order, int M, int N,
-                float alpha, float* X, int incX,
-                float* Y, int incY, float* A, int lda ) ;
-FUNCTION: void cblas_ssyr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                int N, float alpha, float* X,
-                int incX, float* A, int lda ) ;
-FUNCTION: void cblas_sspr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                int N, float alpha, float* X,
-                int incX, float* Ap ) ;
-FUNCTION: void cblas_ssyr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                int N, float alpha, float* X,
-                int incX, float* Y, int incY, float* A,
-                int lda ) ;
-FUNCTION: void cblas_sspr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                int N, float alpha, float* X,
-                int incX, float* Y, int incY, float* A ) ;
-
-FUNCTION: void cblas_dsymv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                 int N, double alpha, double* A,
-                 int lda, double* X, int incX,
-                 double beta, double* Y, int incY ) ;
-FUNCTION: void cblas_dsbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                 int N, int K, double alpha, double* A,
-                 int lda, double* X, int incX,
-                 double beta, double* Y, int incY ) ;
-FUNCTION: void cblas_dspmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                 int N, double alpha, double* Ap,
-                 double* X, int incX,
-                 double beta, double* Y, int incY ) ;
-FUNCTION: void cblas_dger ( CBLAS_ORDER Order, int M, int N,
-                double alpha, double* X, int incX,
-                double* Y, int incY, double* A, int lda ) ;
-FUNCTION: void cblas_dsyr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                int N, double alpha, double* X,
-                int incX, double* A, int lda ) ;
-FUNCTION: void cblas_dspr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                int N, double alpha, double* X,
-                int incX, double* Ap ) ;
-FUNCTION: void cblas_dsyr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                int N, double alpha, double* X,
-                int incX, double* Y, int incY, double* A,
-                int lda ) ;
-FUNCTION: void cblas_dspr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                int N, double alpha, double* X,
-                int incX, double* Y, int incY, double* A ) ;
-
-
-FUNCTION: void cblas_chemv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                 int N, void* alpha, void* A,
-                 int lda, void* X, int incX,
-                 void* beta, void* Y, int incY ) ;
-FUNCTION: void cblas_chbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                 int N, int K, void* alpha, void* A,
-                 int lda, void* X, int incX,
-                 void* beta, void* Y, int incY ) ;
-FUNCTION: void cblas_chpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                 int N, void* alpha, void* Ap,
-                 void* X, int incX,
-                 void* beta, void* Y, int incY ) ;
-FUNCTION: void cblas_cgeru ( CBLAS_ORDER Order, int M, int N,
-                 void* alpha, void* X, int incX,
-                 void* Y, int incY, void* A, int lda ) ;
-FUNCTION: void cblas_cgerc ( CBLAS_ORDER Order, int M, int N,
-                 void* alpha, void* X, int incX,
-                 void* Y, int incY, void* A, int lda ) ;
-FUNCTION: void cblas_cher ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                int N, float alpha, void* X, int incX,
-                void* A, int lda ) ;
-FUNCTION: void cblas_chpr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                int N, float alpha, void* X,
-                int incX, void* A ) ;
-FUNCTION: void cblas_cher2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, int N,
-                void* alpha, void* X, int incX,
-                void* Y, int incY, void* A, int lda ) ;
-FUNCTION: void cblas_chpr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, int N,
-                void* alpha, void* X, int incX,
-                void* Y, int incY, void* Ap ) ;
-
-FUNCTION: void cblas_zhemv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                 int N, void* alpha, void* A,
-                 int lda, void* X, int incX,
-                 void* beta, void* Y, int incY ) ;
-FUNCTION: void cblas_zhbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                 int N, int K, void* alpha, void* A,
-                 int lda, void* X, int incX,
-                 void* beta, void* Y, int incY ) ;
-FUNCTION: void cblas_zhpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                 int N, void* alpha, void* Ap,
-                 void* X, int incX,
-                 void* beta, void* Y, int incY ) ;
-FUNCTION: void cblas_zgeru ( CBLAS_ORDER Order, int M, int N,
-                 void* alpha, void* X, int incX,
-                 void* Y, int incY, void* A, int lda ) ;
-FUNCTION: void cblas_zgerc ( CBLAS_ORDER Order, int M, int N,
-                 void* alpha, void* X, int incX,
-                 void* Y, int incY, void* A, int lda ) ;
-FUNCTION: void cblas_zher ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                int N, double alpha, void* X, int incX,
-                void* A, int lda ) ;
-FUNCTION: void cblas_zhpr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                int N, double alpha, void* X,
-                int incX, void* A ) ;
-FUNCTION: void cblas_zher2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, int N,
-                void* alpha, void* X, int incX,
-                void* Y, int incY, void* A, int lda ) ;
-FUNCTION: void cblas_zhpr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, int N,
-                void* alpha, void* X, int incX,
-                void* Y, int incY, void* Ap ) ;
-
-! Level 3 BLAS (matrix-matrix) 
-
-FUNCTION: void cblas_sgemm ( CBLAS_ORDER Order, CBLAS_TRANSPOSE TransA,
-                 CBLAS_TRANSPOSE TransB, int M, int N,
-                 int K, float alpha, float* A,
-                 int lda, float* B, int ldb,
-                 float beta, float* C, int ldc ) ;
-FUNCTION: void cblas_ssymm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
-                 CBLAS_UPLO Uplo, int M, int N,
-                 float alpha, float* A, int lda,
-                 float* B, int ldb, float beta,
-                 float* C, int ldc ) ;
-FUNCTION: void cblas_ssyrk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                 CBLAS_TRANSPOSE Trans, int N, int K,
-                 float alpha, float* A, int lda,
-                 float beta, float* C, int ldc ) ;
-FUNCTION: void cblas_ssyr2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                  CBLAS_TRANSPOSE Trans, int N, int K,
-                  float alpha, float* A, int lda,
-                  float* B, int ldb, float beta,
-                  float* C, int ldc ) ;
-FUNCTION: void cblas_strmm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
-                 CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA,
-                 CBLAS_DIAG Diag, int M, int N,
-                 float alpha, float* A, int lda,
-                 float* B, int ldb ) ;
-FUNCTION: void cblas_strsm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
-                 CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA,
-                 CBLAS_DIAG Diag, int M, int N,
-                 float alpha, float* A, int lda,
-                 float* B, int ldb ) ;
-
-FUNCTION: void cblas_dgemm ( CBLAS_ORDER Order, CBLAS_TRANSPOSE TransA,
-                 CBLAS_TRANSPOSE TransB, int M, int N,
-                 int K, double alpha, double* A,
-                 int lda, double* B, int ldb,
-                 double beta, double* C, int ldc ) ;
-FUNCTION: void cblas_dsymm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
-                 CBLAS_UPLO Uplo, int M, int N,
-                 double alpha, double* A, int lda,
-                 double* B, int ldb, double beta,
-                 double* C, int ldc ) ;
-FUNCTION: void cblas_dsyrk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                 CBLAS_TRANSPOSE Trans, int N, int K,
-                 double alpha, double* A, int lda,
-                 double beta, double* C, int ldc ) ;
-FUNCTION: void cblas_dsyr2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                  CBLAS_TRANSPOSE Trans, int N, int K,
-                  double alpha, double* A, int lda,
-                  double* B, int ldb, double beta,
-                  double* C, int ldc ) ;
-FUNCTION: void cblas_dtrmm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
-                 CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA,
-                 CBLAS_DIAG Diag, int M, int N,
-                 double alpha, double* A, int lda,
-                 double* B, int ldb ) ;
-FUNCTION: void cblas_dtrsm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
-                 CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA,
-                 CBLAS_DIAG Diag, int M, int N,
-                 double alpha, double* A, int lda,
-                 double* B, int ldb ) ;
-
-FUNCTION: void cblas_cgemm ( CBLAS_ORDER Order, CBLAS_TRANSPOSE TransA,
-                 CBLAS_TRANSPOSE TransB, int M, int N,
-                 int K, void* alpha, void* A,
-                 int lda, void* B, int ldb,
-                 void* beta, void* C, int ldc ) ;
-FUNCTION: void cblas_csymm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
-                 CBLAS_UPLO Uplo, int M, int N,
-                 void* alpha, void* A, int lda,
-                 void* B, int ldb, void* beta,
-                 void* C, int ldc ) ;
-FUNCTION: void cblas_csyrk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                 CBLAS_TRANSPOSE Trans, int N, int K,
-                 void* alpha, void* A, int lda,
-                 void* beta, void* C, int ldc ) ;
-FUNCTION: void cblas_csyr2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                  CBLAS_TRANSPOSE Trans, int N, int K,
-                  void* alpha, void* A, int lda,
-                  void* B, int ldb, void* beta,
-                  void* C, int ldc ) ;
-FUNCTION: void cblas_ctrmm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
-                 CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA,
-                 CBLAS_DIAG Diag, int M, int N,
-                 void* alpha, void* A, int lda,
-                 void* B, int ldb ) ;
-FUNCTION: void cblas_ctrsm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
-                 CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA,
-                 CBLAS_DIAG Diag, int M, int N,
-                 void* alpha, void* A, int lda,
-                 void* B, int ldb ) ;
-
-FUNCTION: void cblas_zgemm ( CBLAS_ORDER Order, CBLAS_TRANSPOSE TransA,
-                 CBLAS_TRANSPOSE TransB, int M, int N,
-                 int K, void* alpha, void* A,
-                 int lda, void* B, int ldb,
-                 void* beta, void* C, int ldc ) ;
-FUNCTION: void cblas_zsymm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
-                 CBLAS_UPLO Uplo, int M, int N,
-                 void* alpha, void* A, int lda,
-                 void* B, int ldb, void* beta,
-                 void* C, int ldc ) ;
-FUNCTION: void cblas_zsyrk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                 CBLAS_TRANSPOSE Trans, int N, int K,
-                 void* alpha, void* A, int lda,
-                 void* beta, void* C, int ldc ) ;
-FUNCTION: void cblas_zsyr2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                  CBLAS_TRANSPOSE Trans, int N, int K,
-                  void* alpha, void* A, int lda,
-                  void* B, int ldb, void* beta,
-                  void* C, int ldc ) ;
-FUNCTION: void cblas_ztrmm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
-                 CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA,
-                 CBLAS_DIAG Diag, int M, int N,
-                 void* alpha, void* A, int lda,
-                 void* B, int ldb ) ;
-FUNCTION: void cblas_ztrsm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
-                 CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA,
-                 CBLAS_DIAG Diag, int M, int N,
-                 void* alpha, void* A, int lda,
-                 void* B, int ldb ) ;
-
-FUNCTION: void cblas_chemm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
-                 CBLAS_UPLO Uplo, int M, int N,
-                 void* alpha, void* A, int lda,
-                 void* B, int ldb, void* beta,
-                 void* C, int ldc ) ;
-FUNCTION: void cblas_cherk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                 CBLAS_TRANSPOSE Trans, int N, int K,
-                 float alpha, void* A, int lda,
-                 float beta, void* C, int ldc ) ;
-FUNCTION: void cblas_cher2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                  CBLAS_TRANSPOSE Trans, int N, int K,
-                  void* alpha, void* A, int lda,
-                  void* B, int ldb, float beta,
-                  void* C, int ldc ) ;
-FUNCTION: void cblas_zhemm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
-                 CBLAS_UPLO Uplo, int M, int N,
-                 void* alpha, void* A, int lda,
-                 void* B, int ldb, void* beta,
-                 void* C, int ldc ) ;
-FUNCTION: void cblas_zherk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                 CBLAS_TRANSPOSE Trans, int N, int K,
-                 double alpha, void* A, int lda,
-                 double beta, void* C, int ldc ) ;
-FUNCTION: void cblas_zher2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
-                  CBLAS_TRANSPOSE Trans, int N, int K,
-                  void* alpha, void* A, int lda,
-                  void* B, int ldb, double beta,
-                  void* C, int ldc ) ;
-
diff --git a/basis/math/blas/cblas/summary.txt b/basis/math/blas/cblas/summary.txt
deleted file mode 100644
index c72e78eb0d..0000000000
--- a/basis/math/blas/cblas/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-Low-level bindings to the C Basic Linear Algebra Subroutines (BLAS) library
diff --git a/basis/math/blas/cblas/tags.txt b/basis/math/blas/cblas/tags.txt
deleted file mode 100644
index 241ec1ecda..0000000000
--- a/basis/math/blas/cblas/tags.txt
+++ /dev/null
@@ -1,2 +0,0 @@
-math
-bindings
diff --git a/basis/math/blas/matrices/matrices-docs.factor b/basis/math/blas/matrices/matrices-docs.factor
index b6e118836e..17d2f9ccd1 100644
--- a/basis/math/blas/matrices/matrices-docs.factor
+++ b/basis/math/blas/matrices/matrices-docs.factor
@@ -8,7 +8,7 @@ ARTICLE: "math.blas-summary" "Basic Linear Algebra Subroutines (BLAS) interface"
 { $subsection "math.blas.vectors" }
 "Vector-matrix and matrix-matrix operations are available in the " { $vocab-link "math.blas.matrices" } " vocabulary:"
 { $subsection "math.blas.matrices" }
-"The low-level BLAS C interface can be accessed directly through the " { $vocab-link "math.blas.cblas" } " vocabulary." ;
+"The low-level BLAS Fortran interface can be accessed directly through the " { $vocab-link "math.blas.ffi" } " vocabulary." ;
 
 ARTICLE: "math.blas-types" "BLAS interface types"
 "BLAS vectors come in single- and double-precision, real and complex flavors:"

From bfc2af7ea13679158f5a88df190f4730b5dde946 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Mon, 9 Feb 2009 17:22:43 -0600
Subject: [PATCH 29/35] remove unnecessary calls to underlying>> from math.blas

---
 basis/math/blas/vectors/vectors.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/basis/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor
index a373ec7c5a..84b5fd9e6f 100755
--- a/basis/math/blas/vectors/vectors.factor
+++ b/basis/math/blas/vectors/vectors.factor
@@ -33,7 +33,7 @@ GENERIC: (blas-direct-array) ( blas-vector -- direct-array )
 : shorter-length ( v1 v2 -- length )
     [ length>> ] bi@ min ; inline
 : data-and-inc ( v -- data inc )
-    [ underlying>> ] [ inc>> ] bi ; inline
+    [ ] [ inc>> ] bi ; inline
 : datas-and-incs ( v1 v2 -- v1-data v1-inc v2-data v2-inc )
     [ data-and-inc ] bi@ ; inline
 

From fecc9890985d2d75f04de117356e4f85f616ebfd Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Mon, 9 Feb 2009 17:23:56 -0600
Subject: [PATCH 30/35] get rid of underlying>>s, again

---
 basis/math/blas/matrices/matrices.factor | 28 ++++++++++++------------
 1 file changed, 14 insertions(+), 14 deletions(-)

diff --git a/basis/math/blas/matrices/matrices.factor b/basis/math/blas/matrices/matrices.factor
index 6a948b6fe1..6fad545501 100755
--- a/basis/math/blas/matrices/matrices.factor
+++ b/basis/math/blas/matrices/matrices.factor
@@ -47,19 +47,19 @@ GENERIC: (blas-matrix-like) ( data ld rows cols transpose exemplar -- matrix )
     A rows>>
     A cols>>
     alpha
-    A underlying>>
+    A
     A ld>>
-    x underlying>>
+    x
     x inc>>
     beta
-    y underlying>>
+    y
     y inc>>
     y ; inline
 
 : (validate-ger) ( x y A -- )
     {
-        [ nip  [ length>> ] [ Mheight ] bi* = ]
-        [ nipd [ length>> ] [ Mwidth  ] bi* = ]
+        [ [ length>> ] [ drop     ] [ Mheight ] tri* = ]
+        [ [ drop     ] [ length>> ] [ Mwidth  ] tri* = ]
     } 3&&
     [ "Mismatched vertices and matrix in vector outer product" throw ]
     unless ;
@@ -71,19 +71,19 @@ GENERIC: (blas-matrix-like) ( data ld rows cols transpose exemplar -- matrix )
     A rows>>
     A cols>>
     alpha
-    x underlying>>
+    x
     x inc>>
-    y underlying>>
+    y
     y inc>>
-    A underlying>>
+    A
     A ld>>
     A f >>transpose ; inline
 
 : (validate-gemm) ( A B C -- )
     {
-        [ drop [ Mwidth  ] [ Mheight ] bi* = ]
-        [ nip  [ Mheight ] bi@ = ]
-        [ nipd [ Mwidth  ] bi@ = ]
+        [ [ Mwidth  ] [ Mheight ] [ drop    ] tri* = ]
+        [ [ Mheight ] [ drop    ] [ Mheight ] tri* = ]
+        [ [ drop    ] [ Mwidth  ] [ Mwidth  ] tri* = ]
     } 3&&
     [ "Mismatched matrices in matrix multiplication" throw ]
     unless ;
@@ -98,12 +98,12 @@ GENERIC: (blas-matrix-like) ( data ld rows cols transpose exemplar -- matrix )
     C cols>>
     A Mwidth
     alpha
-    A underlying>>
+    A
     A ld>>
-    B underlying>>
+    B
     B ld>>
     beta
-    C underlying>>
+    C
     C ld>>
     C f >>transpose ; inline
 

From 296a1ce0a93e9c66dd0220e436df76c7b31c9ddc Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Mon, 9 Feb 2009 17:26:12 -0600
Subject: [PATCH 31/35] unit tests for complex specialized-arrays

---
 .../complex-double/complex-double-tests.factor      | 13 +++++++++++++
 1 file changed, 13 insertions(+)
 create mode 100644 basis/specialized-arrays/complex-double/complex-double-tests.factor

diff --git a/basis/specialized-arrays/complex-double/complex-double-tests.factor b/basis/specialized-arrays/complex-double/complex-double-tests.factor
new file mode 100644
index 0000000000..9f2bcc99b7
--- /dev/null
+++ b/basis/specialized-arrays/complex-double/complex-double-tests.factor
@@ -0,0 +1,13 @@
+USING: kernel sequences specialized-arrays.complex-double tools.test ;
+IN: specialized-arrays.complex-double.tests
+
+[ C{ 3.0 2.0 } ]
+[ complex-double-array{ 1.0 C{ 3.0 2.0 } 5.0 } second ] unit-test
+
+[ C{ 1.0 0.0 } ]
+[ complex-double-array{ 1.0 C{ 3.0 2.0 } 5.0 } first ] unit-test
+
+[ complex-double-array{ 1.0 C{ 6.0 -7.0 } 5.0 } ] [
+    complex-double-array{ 1.0 C{ 3.0 2.0 } 5.0 } 
+    dup [ C{ 6.0 -7.0 } 1 ] dip set-nth
+] unit-test

From 4ee82b19f66a4b6ac27a946466cc3d68442c2bbf Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Mon, 9 Feb 2009 17:47:55 -0600
Subject: [PATCH 32/35] rewrite shuffle( -- ) to avoid locals primitives

---
 basis/shuffle/shuffle.factor | 13 ++++++-------
 1 file changed, 6 insertions(+), 7 deletions(-)

diff --git a/basis/shuffle/shuffle.factor b/basis/shuffle/shuffle.factor
index 632c09e338..d375ec9c20 100644
--- a/basis/shuffle/shuffle.factor
+++ b/basis/shuffle/shuffle.factor
@@ -1,23 +1,22 @@
 ! Copyright (C) 2007 Chris Double, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs effects.parser generalizations
+USING: accessors assocs combinators effects.parser generalizations
 hashtables kernel locals locals.backend macros make math
 parser sequences ;
 IN: shuffle
 
 <PRIVATE
 
-: >locals-assoc ( sequence -- assoc )
-    dup length dup 1- [ - ] curry map zip >hashtable ;
+: >index-assoc ( sequence -- assoc )
+    dup length zip >hashtable ;
 
 PRIVATE>
 
 MACRO: shuffle-effect ( effect -- )
-    [ out>> ] [ in>> >locals-assoc ] bi
+    [ out>> ] [ in>> >index-assoc ] bi
     [
-        [ nip assoc-size , \ load-locals , ]
-        [ [ at , \ get-local , ] curry each ]
-        [ nip assoc-size , \ drop-locals , ] 2tri
+        [ nip assoc-size , \ narray , ]
+        [ [ at \ swap \ nth [ ] 3sequence ] curry map , \ cleave , ] 2bi
     ] [ ] make ;
 
 : shuffle(

From efc88c5b696f070916cbdd835f01a175f08b3c01 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 9 Feb 2009 18:11:42 -0600
Subject: [PATCH 33/35] Remove nipd, 3nip, 4nip and tuckd from basis/shuffle

---
 basis/csv/csv-tests.factor                | 4 ++--
 basis/db/postgresql/lib/lib.factor        | 6 +++---
 basis/math/polynomials/polynomials.factor | 4 ++--
 basis/regexp/traversal/traversal.factor   | 5 ++---
 basis/shuffle/shuffle-tests.factor        | 2 --
 basis/shuffle/shuffle.factor              | 8 --------
 extra/project-euler/002/002.factor        | 4 ++--
 extra/reports/noise/noise.factor          | 3 ---
 8 files changed, 11 insertions(+), 25 deletions(-)

diff --git a/basis/csv/csv-tests.factor b/basis/csv/csv-tests.factor
index 4d78c2af86..50bc3836f5 100644
--- a/basis/csv/csv-tests.factor
+++ b/basis/csv/csv-tests.factor
@@ -1,11 +1,11 @@
-USING: io.streams.string csv tools.test shuffle kernel strings
+USING: io.streams.string csv tools.test kernel strings
 io.pathnames io.files.unique io.encodings.utf8 io.files
 io.directories ;
 IN: csv.tests
 
 ! I like to name my unit tests
 : named-unit-test ( name output input -- ) 
-  nipd unit-test ; inline
+  unit-test drop ; inline
 
 ! tests nicked from the wikipedia csv article
 ! http://en.wikipedia.org/wiki/Comma-separated_values
diff --git a/basis/db/postgresql/lib/lib.factor b/basis/db/postgresql/lib/lib.factor
index 05114a4deb..0d50d1ab2c 100644
--- a/basis/db/postgresql/lib/lib.factor
+++ b/basis/db/postgresql/lib/lib.factor
@@ -3,7 +3,7 @@
 USING: arrays continuations db io kernel math namespaces
 quotations sequences db.postgresql.ffi alien alien.c-types
 db.types tools.walker ascii splitting math.parser combinators
-libc shuffle calendar.format byte-arrays destructors prettyprint
+libc calendar.format byte-arrays destructors prettyprint
 accessors strings serialize io.encodings.binary io.encodings.utf8
 alien.strings io.streams.byte-array summary present urls
 specialized-arrays.uint specialized-arrays.alien db.private ;
@@ -117,7 +117,7 @@ M: postgresql-result-null summary ( obj -- str )
 
 : pq-get-string ( handle row column -- obj )
     3dup PQgetvalue utf8 alien>string
-    dup empty? [ [ pq-get-is-null f ] dip ? ] [ 3nip ] if ;
+    dup empty? [ [ pq-get-is-null f ] dip ? ] [ [ 3drop ] dip ] if ;
 
 : pq-get-number ( handle row column -- obj )
     pq-get-string dup [ string>number ] when ;
@@ -134,7 +134,7 @@ M: postgresql-malloc-destructor dispose ( obj -- )
 : pq-get-blob ( handle row column -- obj/f )
     [ PQgetvalue ] 3keep 3dup PQgetlength
     dup 0 > [
-        3nip
+        [ 3drop ] dip
         [
             memory>byte-array >string
             0 <uint>
diff --git a/basis/math/polynomials/polynomials.factor b/basis/math/polynomials/polynomials.factor
index 1ece3d915e..749bde3a10 100644
--- a/basis/math/polynomials/polynomials.factor
+++ b/basis/math/polynomials/polynomials.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel make math math.order math.vectors sequences shuffle
+USING: arrays kernel make math math.order math.vectors sequences
     splitting vectors ;
 IN: math.polynomials
 
@@ -75,7 +75,7 @@ PRIVATE>
 PRIVATE>
 
 : pgcd ( p q -- a d )
-    swap V{ 0 } clone V{ 1 } clone 2swap (pgcd) [ >array ] bi@ ;
+    [ V{ 0 } clone V{ 1 } clone ] 2dip swap (pgcd) [ >array ] bi@ ;
 
 : pdiff ( p -- p' )
     dup length v* { 0 } ?head drop ;
diff --git a/basis/regexp/traversal/traversal.factor b/basis/regexp/traversal/traversal.factor
index d8c25eda18..104a6c2ce1 100644
--- a/basis/regexp/traversal/traversal.factor
+++ b/basis/regexp/traversal/traversal.factor
@@ -2,8 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs combinators kernel math
 quotations sequences regexp.parser regexp.classes fry arrays
-combinators.short-circuit regexp.utils prettyprint regexp.nfa
-shuffle ;
+combinators.short-circuit regexp.utils prettyprint regexp.nfa ;
 IN: regexp.traversal
 
 TUPLE: dfa-traverser
@@ -170,7 +169,7 @@ M: capture-group-off flag-action ( dfa-traverser flag -- )
     ] [ drop ] if ;
 
 : match-default ( transition from-state table -- to-state/f )
-    nipd transitions>> at t swap at ;
+    [ drop ] 2dip transitions>> at t swap at ;
 
 : match-transition ( obj from-state dfa -- to-state/f )
     { [ match-literal ] [ match-class ] [ match-default ] } 3|| ;
diff --git a/basis/shuffle/shuffle-tests.factor b/basis/shuffle/shuffle-tests.factor
index f190544e19..f8f83a9c08 100644
--- a/basis/shuffle/shuffle-tests.factor
+++ b/basis/shuffle/shuffle-tests.factor
@@ -1,5 +1,3 @@
 USING: shuffle tools.test ;
 
-[ 8 ] [ 5 6 7 8 3nip ] unit-test
-[ 3 1 2 3 ] [ 1 2 3 tuckd ] unit-test
 [ 1 2 3 4 ] [ 3 4 1 2 2swap ] unit-test
diff --git a/basis/shuffle/shuffle.factor b/basis/shuffle/shuffle.factor
index b195e4abf9..10fb8b01dd 100644
--- a/basis/shuffle/shuffle.factor
+++ b/basis/shuffle/shuffle.factor
@@ -6,14 +6,6 @@ IN: shuffle
 
 : 2swap ( x y z t -- z t x y ) 2 2 mnswap ; inline
 
-: nipd ( a b c -- b c ) rot drop ; inline
-
-: 3nip ( a b c d -- d ) 3 nnip ; inline
-
-: 4nip ( a b c d e -- e ) 4 nnip ; inline
-
 : 4dup ( a b c d -- a b c d a b c d ) 4 ndup ; inline
 
 : 4drop ( a b c d -- ) 3drop drop ; inline
-
-: tuckd ( x y z -- z x y z ) 2 ntuck ; inline
diff --git a/extra/project-euler/002/002.factor b/extra/project-euler/002/002.factor
index da20c874b5..9c462b6b2e 100644
--- a/extra/project-euler/002/002.factor
+++ b/extra/project-euler/002/002.factor
@@ -1,6 +1,6 @@
 ! Copyright (c) 2007, 2008 Aaron Schaefer, Alexander Solovyov, Vishal Talwar.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math sequences shuffle ;
+USING: kernel math sequences ;
 IN: project-euler.002
 
 ! http://projecteuler.net/index.php?section=problems&id=2
@@ -41,7 +41,7 @@ PRIVATE>
 ! -------------------
 
 : fib-upto* ( n -- seq )
-    0 1 [ pick over >= ] [ tuck + dup ] [ ] produce 3nip
+    0 1 [ pick over >= ] [ tuck + dup ] [ ] produce [ 3drop ] dip
     but-last-slice { 0 1 } prepend ;
 
 : euler002a ( -- answer )
diff --git a/extra/reports/noise/noise.factor b/extra/reports/noise/noise.factor
index 3e47adac0b..89e00f88c5 100755
--- a/extra/reports/noise/noise.factor
+++ b/extra/reports/noise/noise.factor
@@ -25,7 +25,6 @@ IN: reports.noise
         { 3drop 1 }
         { 3dup 2 }
         { 3keep 3 }
-        { 3nip 4 }
         { 3slip 3 }
         { 4drop 2 }
         { 4dup 3 }
@@ -50,7 +49,6 @@ IN: reports.noise
         { ndrop 2 }
         { ndup 3 }
         { nip 2 }
-        { nipd 3 }
         { nkeep 5 }
         { npick 6 }
         { nrot 5 }
@@ -66,7 +64,6 @@ IN: reports.noise
         { swap 1 }
         { swapd 3 }
         { tuck 2 }
-        { tuckd 4 }
         { with 1/2 }
 
         { bi 1/2 }

From b5a96dccdf7f44ce9f3df5eac2d2f5767dc3c6ef Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-103.local>
Date: Mon, 9 Feb 2009 18:36:36 -0600
Subject: [PATCH 34/35] Slight cleanup in xml-rpc

---
 basis/xml-rpc/xml-rpc.factor | 8 ++++----
 1 file changed, 4 insertions(+), 4 deletions(-)

diff --git a/basis/xml-rpc/xml-rpc.factor b/basis/xml-rpc/xml-rpc.factor
index 9632cbb1ac..690ebe94f8 100644
--- a/basis/xml-rpc/xml-rpc.factor
+++ b/basis/xml-rpc/xml-rpc.factor
@@ -126,11 +126,11 @@ TAG: int xml>item children>number ;
 TAG: double xml>item children>number ;
 
 TAG: boolean xml>item
-    dup children>string {
-        { [ dup "1" = ] [ 2drop t ] }
-        { [ "0" = ] [ drop f ] }
+    children>string {
+        { "1" [ t ] }
+        { "0" [ f ] }
         [ "Bad boolean" server-error ]
-    } cond ;
+    } case ;
 
 : unstruct-member ( tag -- )
     children-tags first2

From 03f7a72d41fb448943f771b3a5f535f6560bbfb8 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Mon, 9 Feb 2009 18:44:36 -0600
Subject: [PATCH 35/35] alien.fortran docs

---
 basis/alien/fortran/fortran-docs.factor | 56 +++++++++++++++++++++++++
 1 file changed, 56 insertions(+)
 create mode 100644 basis/alien/fortran/fortran-docs.factor

diff --git a/basis/alien/fortran/fortran-docs.factor b/basis/alien/fortran/fortran-docs.factor
new file mode 100644
index 0000000000..1b942d30c5
--- /dev/null
+++ b/basis/alien/fortran/fortran-docs.factor
@@ -0,0 +1,56 @@
+! Copyright (C) 2009 Joe Groff
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel quotations sequences strings ;
+QUALIFIED-WITH: alien.syntax c
+IN: alien.fortran
+
+ARTICLE: "alien.fortran-types" "Fortran types"
+"The Fortran FFI recognizes the following Fortran types:"
+{ $list
+    { { $snippet "INTEGER" } " specifies a four-byte integer value. Sized integers can be specified with " { $snippet "INTEGER*1" } ", " { $snippet "INTEGER*2" } ", " { $snippet "INTEGER*4" } ", and " { $snippet "INTEGER*8" } "." }
+    { { $snippet "LOGICAL" } " specifies a four-byte boolean value. Sized booleans can be specified with " { $snippet "LOGICAL*1" } ", " { $snippet "LOGICAL*2" } ", " { $snippet "LOGICAL*4" } ", and " { $snippet "LOGICAL*8" } "." }
+    { { $snippet "REAL" } " specifies a single-precision floating-point real value." }
+    { { $snippet "DOUBLE-PRECISION" } " specifies a double-precision floating-point real value. The alias " { $snippet "REAL*8" } " is also recognized." }
+    { { $snippet "COMPLEX" } " specifies a single-precision floating-point complex value." }
+    { { $snippet "DOUBLE-COMPLEX" } " specifies a double-precision floating-point complex value. The alias " { $snippet "COMPLEX*16" } " is also recognized." }
+    { { $snippet "CHARACTER(n)" } " specifies a character string of length " { $snippet "n" } ". The Fortran 77 syntax " { $snippet "CHARACTER*n" } " is also recognized." }
+    { "Fortran arrays can be specified by suffixing a comma-separated set of dimensions in parentheses, e.g. " { $snippet "REAL(2,3,4)" } ". Arrays of unspecified length can be specified using " { $snippet "*" } " as a dimension. Arrays are passed in as flat " { $link "specialized-arrays" } "." }
+    { "Fortran records defined by " { $link POSTPONE: RECORD: } " and C structs defined by " { $link POSTPONE: c:C-STRUCT: } " are also supported as parameters." }
+}
+"When declaring the parameters of Fortran functions, an output argument can be specified by prefixing an exclamation point to the type name. This will cause the function word to leave the final value of the parameter on the stack." ;
+
+HELP: FUNCTION:
+{ $syntax "FUNCTION: RETURN-TYPE NAME ( [!]ARGUMENT-TYPE NAME, ... ) ;" }
+{ $description "Declares a Fortran function binding with the given return type and arguments. See " { $link "alien.fortran-types" } " for a list of supported types." } ;
+
+HELP: SUBROUTINE:
+{ $syntax "SUBROUTINE: NAME ( [!]ARGUMENT-TYPE NAME, ... ) ;" }
+{ $description "Declares a Fortran subroutine binding with the given arguments. See " { $link "alien.fortran-types" } " for a list of supported types." } ;
+
+HELP: LIBRARY:
+{ $syntax "LIBRARY: name" }
+{ $values { "name" "a logical library name" } }
+{ $description "Sets the logical library for subsequent " { $link POSTPONE: FUNCTION: } " and " { $link POSTPONE: SUBROUTINE: } " definitions." } ;
+
+HELP: RECORD:
+{ $syntax "RECORD: NAME { \"TYPE\" \"SLOT\" } ... ;" }
+{ $description "Defines a Fortran record type with the given slots." } ;
+
+HELP: fortran-invoke
+{ $values
+     { "return" string } { "library" string } { "procedure" string } { "parameters" sequence }
+}
+{ $description "Invokes the Fortran subroutine or function " { $snippet "procedure" } " in " { $snippet "library" } " with parameters specified by the " { $link "alien.fortran-types" } " specified in the " { $snippet "parameters" } " sequence. If the " { $snippet "return" } " value is " { $link f } ", no return value is expected, otherwise a return value of the specified Fortran type is expected. Input values are taken off the top of the datastack, and output values are left for the return value (if any) and any parameters specified as out parameters by prepending " { $snippet "\"!\"" } "." }
+;
+
+ARTICLE: "alien.fortran" "Fortran FFI"
+"The " { $vocab-link "alien.fortran" } " vocabulary provides an interface to code shared libraries written in Fortran."
+{ $subsection "alien.fortran-types" }
+{ $subsection POSTPONE: LIBRARY: }
+{ $subsection POSTPONE: FUNCTION: }
+{ $subsection POSTPONE: SUBROUTINE: }
+{ $subsection POSTPONE: RECORD: }
+{ $subsection fortran-invoke }
+;
+
+ABOUT: "alien.fortran"