Changeset 14621 in project


Ignore:
Timestamp:
05/14/09 04:38:09 (10 years ago)
Author:
Ivan Raikov
Message:

blas ported to Chicken 4

Location:
release/4/blas
Files:
1 deleted
6 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/4/blas/trunk/blas-eggdoc.scm

    r6636 r14621  
    1212
    1313     (author ((url "mailto:felix@call-with-current-continuation.org" "Felix Winkelmann") " and "
    14               (url "mailto:iraikov@ece.gatech.edu" "Ivan Raikov")))
     14              (url "http://chicken.wiki.br/users/ivan-raikov" "Ivan Raikov")))
    1515
    1616     (history
     17      (version "2.6" "Ported to Chicken 4")
    1718      (version "2.5" "Build script updated for better cross-platform compatibility")
    1819      (version "2.4" "Added iger procedures; fixed a bug in the default arguments of level 2 routines")
     
    630631     (license
    631632"Copyright (c) 2003-2006, Felix L. Winkelmann
    632 Copyright (c) 2007, Ivan Raikov
     633Copyright (c) 2007-2009 Ivan Raikov
    633634
    634635All rights reserved.
  • release/4/blas/trunk/blas.html

    r6636 r14621  
    33<html>
    44<head>
    5 <title>Eggs Unlimited - blas</title><style type="text/css"> <!--
    6       CODE {
    7             color: #666666;
    8           }
    9 /*   DT.definition EM { font-weight: bold; font-style: normal; } */
    10 
    11      DT.definition {
    12                    background: #eee;
     5<title>Eggs Unlimited - blas</title><style type="text/css"><!--
     6       CODE {
     7             color: #666666;
     8           }
     9 /*   DT.definition EM { font-weight: bold; font-style: normal; } */
     10;      DT.definition {
     11                    background: #eee;
    1312                   color: black;
    1413                   padding: 0.2em 1em 0.2em 0.7em;
     
    153152<h3>Description</h3>An interface to level 1, 2 and 3 BLAS linear algebra routines.</div>
    154153<div class="section">
    155 <h3>Author</h3><a href="mailto:felix@call-with-current-continuation.org">Felix Winkelmann</a> and <a href="mailto:iraikov@ece.gatech.edu">Ivan Raikov</a></div>
     154<h3>Author</h3><a href="mailto:felix@call-with-current-continuation.org">Felix Winkelmann</a> and <a href="http://chicken.wiki.br/users/ivan-raikov">Ivan Raikov</a></div>
    156155<div class="section">
    157156<h3>Version</h3>
    158157<ul>
     158<li>2.6 Ported to Chicken 4</li>
    159159<li>2.5 Build script updated for better cross-platform compatibility</li>
    160160<li>2.4 Added iger procedures; fixed a bug in the default arguments of level 2 routines</li>
     
    667667<h3>License</h3>
    668668<pre id="license">Copyright (c) 2003-2006, Felix L. Winkelmann
    669 Copyright (c) 2007, Ivan Raikov
     669Copyright (c) 2007-2009 Ivan Raikov
    670670
    671671All rights reserved.
  • release/4/blas/trunk/blas.meta

    r5765 r14621  
    1 ;;; blas.meta -*- Hen -*-
     1;; -*- Hen -*-
    22
    33((egg "blas.egg")
     
    99 (category math)
    1010
    11  (needs eggdoc easyffi testbase)
     11 (needs test eggdoc easyffi )
    1212
    1313 (eggdoc "blas-eggdoc.scm")
    1414
    15  (author "<a href=\"mailto:felix@call-with-current-continuation.org\">felix</a>")
     15 (author "felix")
     16
     17 (maintainer "Ivan Raikov")
    1618
    1719 (files "blas.setup" "blas.scm" "blas-eggdoc.scm"))
  • release/4/blas/trunk/blas.scm

    r6051 r14621  
    1 ;;;; blas.scm
    2 
    3 (require-extension srfi-4)
    4 
    5 (define-extension blas)
    6 
    7 (declare (export blas:RowMajor
    8                  blas:ColMajor
    9                  blas:NoTrans
    10                  blas:Trans
    11                  blas:ConjTrans
    12                  blas:Left
    13                  blas:Right
    14                  blas:Upper
    15                  blas:Lower
    16                  blas:Unit
    17                  blas:NonUnit
    18                  blas:sicopy
    19                  blas:dicopy
    20                  blas:cicopy
    21                  blas:zicopy
    22                  blas:scopy
    23                  blas:dcopy
    24                  blas:ccopy
    25                  blas:zcopy
    26                  unsafe-blas:sgemm!
    27                  unsafe-blas:dgemm!
    28                  unsafe-blas:cgemm!
    29                  unsafe-blas:zgemm!
    30                  blas:sgemm!
    31                  blas:dgemm!
    32                  blas:cgemm!
    33                  blas:zgemm!
    34                  blas:sgemm
    35                  blas:dgemm
    36                  blas:cgemm
    37                  blas:zgemm
    38                  unsafe-blas:ssymm!
    39                  unsafe-blas:dsymm!
    40                  unsafe-blas:csymm!
    41                  unsafe-blas:zsymm!
    42                  blas:ssymm!
    43                  blas:dsymm!
    44                  blas:csymm!
    45                  blas:zsymm!
    46                  blas:ssymm
    47                  blas:dsymm
    48                  blas:csymm
    49                  blas:zsymm
    50                  unsafe-blas:chemm!
    51                  unsafe-blas:zhemm!
    52                  blas:chemm!
    53                  blas:zhemm!
    54                  blas:chemm
    55                  blas:zhemm
    56                  unsafe-blas:ssyrk!
    57                  unsafe-blas:dsyrk!
    58                  unsafe-blas:csyrk!
    59                  unsafe-blas:zsyrk!
    60                  blas:ssyrk!
    61                  blas:dsyrk!
    62                  blas:csyrk!
    63                  blas:zsyrk!
    64                  blas:ssyrk
    65                  blas:dsyrk
    66                  blas:csyrk
    67                  blas:zsyrk
    68                  unsafe-blas:cherk!
    69                  unsafe-blas:zherk!
    70                  blas:cherk!
    71                  blas:zherk!
    72                  blas:cherk
    73                  blas:zherk
    74                  unsafe-blas:ssyr2k!
    75                  unsafe-blas:dsyr2k!
    76                  unsafe-blas:csyr2k!
    77                  unsafe-blas:zsyr2k!
    78                  blas:ssyr2k!
    79                  blas:dsyr2k!
    80                  blas:csyr2k!
    81                  blas:zsyr2k!
    82                  blas:ssyr2k
    83                  blas:dsyr2k
    84                  blas:csyr2k
    85                  blas:zsyr2k
    86                  unsafe-blas:cher2k!
    87                  unsafe-blas:zher2k!
    88                  blas:cher2k!
    89                  blas:zher2k!
    90                  blas:cher2k
    91                  blas:zher2k
    92                  unsafe-blas:strmm!
    93                  unsafe-blas:dtrmm!
    94                  unsafe-blas:ctrmm!
    95                  unsafe-blas:ztrmm!
    96                  blas:strmm!
    97                  blas:dtrmm!
    98                  blas:ctrmm!
    99                  blas:ztrmm!
    100                  blas:strmm
    101                  blas:dtrmm
    102                  blas:ctrmm
    103                  blas:ztrmm
    104                  unsafe-blas:strsm!
    105                  unsafe-blas:dtrsm!
    106                  unsafe-blas:ctrsm!
    107                  unsafe-blas:ztrsm!
    108                  blas:strsm!
    109                  blas:dtrsm!
    110                  blas:ctrsm!
    111                  blas:ztrsm!
    112                  blas:strsm
    113                  blas:dtrsm
    114                  blas:ctrsm
    115                  blas:ztrsm
    116                  unsafe-blas:sgemv!
    117                  unsafe-blas:dgemv!
    118                  unsafe-blas:cgemv!
    119                  unsafe-blas:zgemv!
    120                  blas:sgemv!
    121                  blas:dgemv!
    122                  blas:cgemv!
    123                  blas:zgemv!
    124                  blas:sgemv
    125                  blas:dgemv
    126                  blas:cgemv
    127                  blas:zgemv
    128                  unsafe-blas:chemv!
    129                  unsafe-blas:zhemv!
    130                  blas:chemv!
    131                  blas:zhemv!
    132                  blas:chemv
    133                  blas:zhemv
    134                  unsafe-blas:chbmv!
    135                  unsafe-blas:zhbmv!
    136                  blas:chbmv!
    137                  blas:zhbmv!
    138                  blas:chbmv
    139                  blas:zhbmv
    140                  unsafe-blas:chpmv!
    141                  unsafe-blas:zhpmv!
    142                  blas:chpmv!
    143                  blas:zhpmv!
    144                  blas:chpmv
    145                  blas:zhpmv
    146                  unsafe-blas:ssymv!
    147                  unsafe-blas:dsymv!
    148                  blas:ssymv!
    149                  blas:dsymv!
    150                  blas:ssymv
    151                  blas:dsymv
    152                  unsafe-blas:ssbmv!
    153                  unsafe-blas:dsbmv!
    154                  blas:ssbmv!
    155                  blas:dsbmv!
    156                  blas:ssbmv
    157                  blas:dsbmv
    158                  unsafe-blas:sspmv!
    159                  unsafe-blas:dspmv!
    160                  blas:sspmv!
    161                  blas:dspmv!
    162                  blas:sspmv
    163                  blas:dspmv
    164                  unsafe-blas:strmv!
    165                  unsafe-blas:dtrmv!
    166                  unsafe-blas:ctrmv!
    167                  unsafe-blas:ztrmv!
    168                  blas:strmv!
    169                  blas:dtrmv!
    170                  blas:ctrmv!
    171                  blas:ztrmv!
    172                  blas:strmv
    173                  blas:dtrmv
    174                  blas:ctrmv
    175                  blas:ztrmv
    176                  unsafe-blas:stbmv!
    177                  unsafe-blas:dtbmv!
    178                  unsafe-blas:ctbmv!
    179                  unsafe-blas:ztbmv!
    180                  blas:stbmv!
    181                  blas:dtbmv!
    182                  blas:ctbmv!
    183                  blas:ztbmv!
    184                  blas:stbmv
    185                  blas:dtbmv
    186                  blas:ctbmv
    187                  blas:ztbmv
    188                  unsafe-blas:stpmv!
    189                  unsafe-blas:dtpmv!
    190                  unsafe-blas:ctpmv!
    191                  unsafe-blas:ztpmv!
    192                  blas:stpmv!
    193                  blas:dtpmv!
    194                  blas:ctpmv!
    195                  blas:ztpmv!
    196                  blas:stpmv
    197                  blas:dtpmv
    198                  blas:ctpmv
    199                  blas:ztpmv
    200                  unsafe-blas:strsv!
    201                  unsafe-blas:dtrsv!
    202                  unsafe-blas:ctrsv!
    203                  unsafe-blas:ztrsv!
    204                  blas:strsv!
    205                  blas:dtrsv!
    206                  blas:ctrsv!
    207                  blas:ztrsv!
    208                  blas:strsv
    209                  blas:dtrsv
    210                  blas:ctrsv
    211                  blas:ztrsv
    212                  unsafe-blas:stbsv!
    213                  unsafe-blas:dtbsv!
    214                  unsafe-blas:ctbsv!
    215                  unsafe-blas:ztbsv!
    216                  blas:stbsv!
    217                  blas:dtbsv!
    218                  blas:ctbsv!
    219                  blas:ztbsv!
    220                  blas:stbsv
    221                  blas:dtbsv
    222                  blas:ctbsv
    223                  blas:ztbsv
    224                  unsafe-blas:stpsv!
    225                  unsafe-blas:dtpsv!
    226                  unsafe-blas:ctpsv!
    227                  unsafe-blas:ztpsv!
    228                  blas:stpsv!
    229                  blas:dtpsv!
    230                  blas:ctpsv!
    231                  blas:ztpsv!
    232                  blas:stpsv
    233                  blas:dtpsv
    234                  blas:ctpsv
    235                  blas:ztpsv
    236                  unsafe-blas:sger!
    237                  unsafe-blas:dger!
    238                  blas:sger!
    239                  blas:dger!
    240                  blas:sger
    241                  blas:dger
    242                  unsafe-blas:siger!
    243                  unsafe-blas:diger!
    244                  blas:siger!
    245                  blas:diger!
    246                  blas:siger
    247                  blas:diger
    248                  unsafe-blas:cgeru!
    249                  unsafe-blas:zgeru!
    250                  blas:cgeru!
    251                  blas:zgeru!
    252                  blas:cgeru
    253                  blas:zgeru
    254                  unsafe-blas:cgerc!
    255                  unsafe-blas:zgerc!
    256                  blas:cgerc!
    257                  blas:zgerc!
    258                  blas:cgerc
    259                  blas:zgerc
    260                  unsafe-blas:cher!
    261                  unsafe-blas:zher!
    262                  blas:cher!
    263                  blas:zher!
    264                  blas:cher
    265                  blas:zher
    266                  unsafe-blas:chpr!
    267                  unsafe-blas:zhpr!
    268                  blas:chpr!
    269                  blas:zhpr!
    270                  blas:chpr
    271                  blas:zhpr
    272                  unsafe-blas:cher2!
    273                  unsafe-blas:zher2!
    274                  blas:cher2!
    275                  blas:zher2!
    276                  blas:cher2
    277                  blas:zher2
    278                  unsafe-blas:chpr2!
    279                  unsafe-blas:zhpr2!
    280                  blas:chpr2!
    281                  blas:zhpr2!
    282                  blas:chpr2
    283                  blas:zhpr2
    284                  unsafe-blas:ssyr!
    285                  unsafe-blas:dsyr!
    286                  blas:ssyr!
    287                  blas:dsyr!
    288                  blas:ssyr
    289                  blas:dsyr
    290                  unsafe-blas:sspr!
    291                  unsafe-blas:dspr!
    292                  blas:sspr!
    293                  blas:dspr!
    294                  blas:sspr
    295                  blas:dspr
    296                  unsafe-blas:ssyr2!
    297                  unsafe-blas:dsyr2!
    298                  blas:ssyr2!
    299                  blas:dsyr2!
    300                  blas:ssyr2
    301                  blas:dsyr2
    302                  unsafe-blas:sspr2!
    303                  unsafe-blas:dspr2!
    304                  blas:sspr2!
    305                  blas:dspr2!
    306                  blas:sspr2
    307                  blas:dspr2
    308                  unsafe-blas:srot!
    309                  unsafe-blas:drot!
    310                  blas:srot!
    311                  blas:drot!
    312                  blas:srot
    313                  blas:drot
    314                  unsafe-blas:srotm!
    315                  unsafe-blas:drotm!
    316                  blas:srotm!
    317                  blas:drotm!
    318                  blas:srotm
    319                  blas:drotm
    320                  unsafe-blas:sswap!
    321                  unsafe-blas:dswap!
    322                  unsafe-blas:cswap!
    323                  unsafe-blas:zswap!
    324                  blas:sswap!
    325                  blas:dswap!
    326                  blas:cswap!
    327                  blas:zswap!
    328                  blas:sswap
    329                  blas:dswap
    330                  blas:cswap
    331                  blas:zswap
    332                  unsafe-blas:sscal!
    333                  unsafe-blas:dscal!
    334                  unsafe-blas:cscal!
    335                  unsafe-blas:zscal!
    336                  blas:sscal!
    337                  blas:dscal!
    338                  blas:cscal!
    339                  blas:zscal!
    340                  blas:sscal
    341                  blas:dscal
    342                  blas:cscal
    343                  blas:zscal
    344                  unsafe-blas:saxpy!
    345                  unsafe-blas:daxpy!
    346                  unsafe-blas:caxpy!
    347                  unsafe-blas:zaxpy!
    348                  blas:saxpy!
    349                  blas:daxpy!
    350                  blas:caxpy!
    351                  blas:zaxpy!
    352                  blas:saxpy
    353                  blas:daxpy
    354                  blas:caxpy
    355                  blas:zaxpy
    356                  unsafe-blas:siaxpy!
    357                  unsafe-blas:diaxpy!
    358                  unsafe-blas:ciaxpy!
    359                  unsafe-blas:ziaxpy!
    360                  blas:siaxpy!
    361                  blas:diaxpy!
    362                  blas:ciaxpy!
    363                  blas:ziaxpy!
    364                  blas:siaxpy
    365                  blas:diaxpy
    366                  blas:ciaxpy
    367                  blas:ziaxpy
    368                  blas:sdot
    369                  blas:ddot
    370                  blas:cdotu
    371                  blas:zdotu
    372                  blas:cdotc
    373                  blas:zdotc
    374                  blas:snrm2
    375                  blas:dnrm2
    376                  blas:cnrm2
    377                  blas:znrm2
    378                  blas:sasum
    379                  blas:dasum
    380                  blas:casum
    381                  blas:zasum
    382                  blas:samax
    383                  blas:damax
    384                  blas:camax
    385                  blas:zamax))
     1;; blas.scm
     2
     3(module blas
     4
     5
     6        (blas:RowMajor
     7         blas:ColMajor
     8         blas:NoTrans
     9         blas:Trans
     10         blas:ConjTrans
     11         blas:Left
     12         blas:Right
     13         blas:Upper
     14         blas:Lower
     15         blas:Unit
     16         blas:NonUnit
     17
     18         blas:sicopy
     19         blas:dicopy
     20         blas:cicopy
     21         blas:zicopy
     22
     23         blas:scopy
     24         blas:dcopy
     25         blas:ccopy
     26         blas:zcopy
     27
     28         unsafe-blas:sgemm!
     29         unsafe-blas:dgemm!
     30         unsafe-blas:cgemm!
     31         unsafe-blas:zgemm!
     32         blas:sgemm!
     33         blas:dgemm!
     34         blas:cgemm!
     35         blas:zgemm!
     36         blas:sgemm
     37         blas:dgemm
     38         blas:cgemm
     39         blas:zgemm
     40
     41         unsafe-blas:ssymm!
     42         unsafe-blas:dsymm!
     43         unsafe-blas:csymm!
     44         unsafe-blas:zsymm!
     45         blas:ssymm!
     46         blas:dsymm!
     47         blas:csymm!
     48         blas:zsymm!
     49         blas:ssymm
     50         blas:dsymm
     51         blas:csymm
     52         blas:zsymm
     53
     54         unsafe-blas:chemm!
     55         unsafe-blas:zhemm!
     56         blas:chemm!
     57         blas:zhemm!
     58         blas:chemm
     59         blas:zhemm
     60
     61         unsafe-blas:ssyrk!
     62         unsafe-blas:dsyrk!
     63         unsafe-blas:csyrk!
     64         unsafe-blas:zsyrk!
     65         blas:ssyrk!
     66         blas:dsyrk!
     67         blas:csyrk!
     68         blas:zsyrk!
     69         blas:ssyrk
     70         blas:dsyrk
     71         blas:csyrk
     72         blas:zsyrk
     73
     74         unsafe-blas:cherk!
     75         unsafe-blas:zherk!
     76         blas:cherk!
     77         blas:zherk!
     78         blas:cherk
     79         blas:zherk
     80
     81         unsafe-blas:ssyr2k!
     82         unsafe-blas:dsyr2k!
     83         unsafe-blas:csyr2k!
     84         unsafe-blas:zsyr2k!
     85         blas:ssyr2k!
     86         blas:dsyr2k!
     87         blas:csyr2k!
     88         blas:zsyr2k!
     89         blas:ssyr2k
     90         blas:dsyr2k
     91         blas:csyr2k
     92         blas:zsyr2k
     93
     94         unsafe-blas:cher2k!
     95         unsafe-blas:zher2k!
     96         blas:cher2k!
     97         blas:zher2k!
     98         blas:cher2k
     99         blas:zher2k
     100
     101         unsafe-blas:strmm!
     102         unsafe-blas:dtrmm!
     103         unsafe-blas:ctrmm!
     104         unsafe-blas:ztrmm!
     105         blas:strmm!
     106         blas:dtrmm!
     107         blas:ctrmm!
     108         blas:ztrmm!
     109         blas:strmm
     110         blas:dtrmm
     111         blas:ctrmm
     112         blas:ztrmm
     113
     114         unsafe-blas:strsm!
     115         unsafe-blas:dtrsm!
     116         unsafe-blas:ctrsm!
     117         unsafe-blas:ztrsm!
     118         blas:strsm!
     119         blas:dtrsm!
     120         blas:ctrsm!
     121         blas:ztrsm!
     122         blas:strsm
     123         blas:dtrsm
     124         blas:ctrsm
     125         blas:ztrsm
     126
     127         unsafe-blas:sgemv!
     128         unsafe-blas:dgemv!
     129         unsafe-blas:cgemv!
     130         unsafe-blas:zgemv!
     131         blas:sgemv!
     132         blas:dgemv!
     133         blas:cgemv!
     134         blas:zgemv!
     135         blas:sgemv
     136         blas:dgemv
     137         blas:cgemv
     138         blas:zgemv
     139
     140         unsafe-blas:chemv!
     141         unsafe-blas:zhemv!
     142         blas:chemv!
     143         blas:zhemv!
     144         blas:chemv
     145         blas:zhemv
     146         unsafe-blas:chbmv!
     147         unsafe-blas:zhbmv!
     148         blas:chbmv!
     149         blas:zhbmv!
     150         blas:chbmv
     151         blas:zhbmv
     152         unsafe-blas:chpmv!
     153         unsafe-blas:zhpmv!
     154         blas:chpmv!
     155         blas:zhpmv!
     156         blas:chpmv
     157         blas:zhpmv
     158         unsafe-blas:ssymv!
     159         unsafe-blas:dsymv!
     160         blas:ssymv!
     161         blas:dsymv!
     162         blas:ssymv
     163         blas:dsymv
     164         unsafe-blas:ssbmv!
     165         unsafe-blas:dsbmv!
     166         blas:ssbmv!
     167         blas:dsbmv!
     168         blas:ssbmv
     169         blas:dsbmv
     170         unsafe-blas:sspmv!
     171         unsafe-blas:dspmv!
     172         blas:sspmv!
     173         blas:dspmv!
     174         blas:sspmv
     175         blas:dspmv
     176         unsafe-blas:strmv!
     177         unsafe-blas:dtrmv!
     178         unsafe-blas:ctrmv!
     179         unsafe-blas:ztrmv!
     180         blas:strmv!
     181         blas:dtrmv!
     182         blas:ctrmv!
     183         blas:ztrmv!
     184         blas:strmv
     185         blas:dtrmv
     186         blas:ctrmv
     187         blas:ztrmv
     188         unsafe-blas:stbmv!
     189         unsafe-blas:dtbmv!
     190         unsafe-blas:ctbmv!
     191         unsafe-blas:ztbmv!
     192         blas:stbmv!
     193         blas:dtbmv!
     194         blas:ctbmv!
     195         blas:ztbmv!
     196         blas:stbmv
     197         blas:dtbmv
     198         blas:ctbmv
     199         blas:ztbmv
     200         unsafe-blas:stpmv!
     201         unsafe-blas:dtpmv!
     202         unsafe-blas:ctpmv!
     203         unsafe-blas:ztpmv!
     204         blas:stpmv!
     205         blas:dtpmv!
     206         blas:ctpmv!
     207         blas:ztpmv!
     208         blas:stpmv
     209         blas:dtpmv
     210         blas:ctpmv
     211         blas:ztpmv
     212         unsafe-blas:strsv!
     213         unsafe-blas:dtrsv!
     214         unsafe-blas:ctrsv!
     215         unsafe-blas:ztrsv!
     216         blas:strsv!
     217         blas:dtrsv!
     218         blas:ctrsv!
     219         blas:ztrsv!
     220         blas:strsv
     221         blas:dtrsv
     222         blas:ctrsv
     223         blas:ztrsv
     224         unsafe-blas:stbsv!
     225         unsafe-blas:dtbsv!
     226         unsafe-blas:ctbsv!
     227         unsafe-blas:ztbsv!
     228         blas:stbsv!
     229         blas:dtbsv!
     230         blas:ctbsv!
     231         blas:ztbsv!
     232         blas:stbsv
     233         blas:dtbsv
     234         blas:ctbsv
     235         blas:ztbsv
     236         unsafe-blas:stpsv!
     237         unsafe-blas:dtpsv!
     238         unsafe-blas:ctpsv!
     239         unsafe-blas:ztpsv!
     240         blas:stpsv!
     241         blas:dtpsv!
     242         blas:ctpsv!
     243         blas:ztpsv!
     244         blas:stpsv
     245         blas:dtpsv
     246         blas:ctpsv
     247         blas:ztpsv
     248         unsafe-blas:sger!
     249         unsafe-blas:dger!
     250         blas:sger!
     251         blas:dger!
     252         blas:sger
     253         blas:dger
     254         unsafe-blas:siger!
     255         unsafe-blas:diger!
     256         blas:siger!
     257         blas:diger!
     258         blas:siger
     259         blas:diger
     260         unsafe-blas:cgeru!
     261         unsafe-blas:zgeru!
     262         blas:cgeru!
     263         blas:zgeru!
     264         blas:cgeru
     265         blas:zgeru
     266         unsafe-blas:cgerc!
     267         unsafe-blas:zgerc!
     268         blas:cgerc!
     269         blas:zgerc!
     270         blas:cgerc
     271         blas:zgerc
     272         unsafe-blas:cher!
     273         unsafe-blas:zher!
     274         blas:cher!
     275         blas:zher!
     276         blas:cher
     277         blas:zher
     278         unsafe-blas:chpr!
     279         unsafe-blas:zhpr!
     280         blas:chpr!
     281         blas:zhpr!
     282         blas:chpr
     283         blas:zhpr
     284         unsafe-blas:cher2!
     285         unsafe-blas:zher2!
     286         blas:cher2!
     287         blas:zher2!
     288         blas:cher2
     289         blas:zher2
     290         unsafe-blas:chpr2!
     291         unsafe-blas:zhpr2!
     292         blas:chpr2!
     293         blas:zhpr2!
     294         blas:chpr2
     295         blas:zhpr2
     296         unsafe-blas:ssyr!
     297         unsafe-blas:dsyr!
     298         blas:ssyr!
     299         blas:dsyr!
     300         blas:ssyr
     301         blas:dsyr
     302         unsafe-blas:sspr!
     303         unsafe-blas:dspr!
     304         blas:sspr!
     305         blas:dspr!
     306         blas:sspr
     307         blas:dspr
     308         unsafe-blas:ssyr2!
     309         unsafe-blas:dsyr2!
     310         blas:ssyr2!
     311         blas:dsyr2!
     312         blas:ssyr2
     313         blas:dsyr2
     314         unsafe-blas:sspr2!
     315         unsafe-blas:dspr2!
     316         blas:sspr2!
     317         blas:dspr2!
     318         blas:sspr2
     319         blas:dspr2
     320
     321         unsafe-blas:srot!
     322         unsafe-blas:drot!
     323         blas:srot!
     324         blas:drot!
     325         blas:srot
     326         blas:drot
     327         unsafe-blas:srotm!
     328         unsafe-blas:drotm!
     329         blas:srotm!
     330         blas:drotm!
     331         blas:srotm
     332         blas:drotm
     333         unsafe-blas:sswap!
     334         unsafe-blas:dswap!
     335         unsafe-blas:cswap!
     336         unsafe-blas:zswap!
     337         blas:sswap!
     338         blas:dswap!
     339         blas:cswap!
     340         blas:zswap!
     341         blas:sswap
     342         blas:dswap
     343         blas:cswap
     344         blas:zswap
     345         unsafe-blas:sscal!
     346         unsafe-blas:dscal!
     347         unsafe-blas:cscal!
     348         unsafe-blas:zscal!
     349         blas:sscal!
     350         blas:dscal!
     351         blas:cscal!
     352         blas:zscal!
     353         blas:sscal
     354         blas:dscal
     355         blas:cscal
     356         blas:zscal
     357         unsafe-blas:saxpy!
     358         unsafe-blas:daxpy!
     359         unsafe-blas:caxpy!
     360         unsafe-blas:zaxpy!
     361         blas:saxpy!
     362         blas:daxpy!
     363         blas:caxpy!
     364         blas:zaxpy!
     365         blas:saxpy
     366         blas:daxpy
     367         blas:caxpy
     368         blas:zaxpy
     369         unsafe-blas:siaxpy!
     370         unsafe-blas:diaxpy!
     371         unsafe-blas:ciaxpy!
     372         unsafe-blas:ziaxpy!
     373         blas:siaxpy!
     374         blas:diaxpy!
     375         blas:ciaxpy!
     376         blas:ziaxpy!
     377         blas:siaxpy
     378         blas:diaxpy
     379         blas:ciaxpy
     380         blas:ziaxpy
     381         blas:sdot
     382         blas:ddot
     383         blas:cdotu
     384         blas:zdotu
     385         blas:cdotc
     386         blas:zdotc
     387         blas:snrm2
     388         blas:dnrm2
     389         blas:cnrm2
     390         blas:znrm2
     391         blas:sasum
     392         blas:dasum
     393         blas:casum
     394         blas:zasum
     395         blas:samax
     396         blas:damax
     397         blas:camax
     398         blas:zamax
     399         )
     400
     401  (import scheme chicken data-structures foreign)
     402
     403  (require-extension srfi-4 easyffi)
     404
     405(define (blas:error x . rest)
     406  (let ((port (open-output-string)))
     407    (let loop ((objs (if (symbol? x) rest (cons x rest))))
     408      (if (null? objs)
     409          (begin
     410            (newline port)
     411            (error (if (symbol? x) x 'blas)
     412                   (get-output-string port)))
     413          (begin (display (car objs) port)
     414                 (display " " port)
     415                 (loop (cdr objs)))))))
    386416
    387417
    388418#>!
     419
    389420typedef float CCOMPLEX;
    390421typedef double ZCOMPLEX;
     
    405436enum CBLAS_SIDE {CblasLeft=141, CblasRight=142};
    406437
     438/*
     439 * ===========================================================================
     440 * Prototypes for level 1 BLAS routines
     441 * ===========================================================================
     442 */
     443
     444/*
     445 * Routines with standard 4 prefixes (s, d, c, z)
     446 */
     447void cblas_sswap(const int N, float *X, const int incX,
     448                 float *Y, const int incY);
     449void cblas_scopy(const int N, const float *X, const int incX,
     450                 float *Y, const int incY);
     451void cblas_saxpy(const int N, const float alpha, const float *X,
     452                 const int incX, float *Y, const int incY);
     453
     454void cblas_dswap(const int N, double *X, const int incX,
     455                 double *Y, const int incY);
     456void cblas_dcopy(const int N, const double *X, const int incX,
     457                 double *Y, const int incY);
     458void cblas_daxpy(const int N, const double alpha, const double *X,
     459                 const int incX, double *Y, const int incY);
     460
     461void cblas_cswap(const int N, CCOMPLEX *X, const int incX,
     462                 CCOMPLEX *Y, const int incY);
     463void cblas_ccopy(const int N, const CCOMPLEX *X, const int incX,
     464                 CCOMPLEX *Y, const int incY);
     465void cblas_caxpy(const int N, const CCOMPLEX *alpha, const CCOMPLEX *X,
     466                 const int incX, CCOMPLEX *Y, const int incY);
     467
     468void cblas_zswap(const int N, ZCOMPLEX *X, const int incX,
     469                 ZCOMPLEX *Y, const int incY);
     470void cblas_zcopy(const int N, const ZCOMPLEX *X, const int incX,
     471                 ZCOMPLEX *Y, const int incY);
     472void cblas_zaxpy(const int N, const ZCOMPLEX *alpha, const ZCOMPLEX *X,
     473                 const int incX, ZCOMPLEX *Y, const int incY);
     474
     475
     476/*
     477 * Routines with S and D prefix only
     478 */
     479void cblas_srotg(float *a, float *b, float *c, float *s);
     480void cblas_srotmg(float *d1, float *d2, float *b1, const float b2, float *P);
     481void cblas_srot(const int N, float *X, const int incX,
     482                float *Y, const int incY, const float c, const float s);
     483void cblas_srotm(const int N, float *X, const int incX,
     484                float *Y, const int incY, const float *P);
     485
     486void cblas_drotg(double *a, double *b, double *c, double *s);
     487void cblas_drotmg(double *d1, double *d2, double *b1, const double b2, double *P);
     488void cblas_drot(const int N, double *X, const int incX,
     489                double *Y, const int incY, const double c, const double  s);
     490void cblas_drotm(const int N, double *X, const int incX,
     491                double *Y, const int incY, const double *P);
     492
     493
     494/*
     495 * Routines with S D C Z CS and ZD prefixes
     496 */
     497void cblas_sscal(const int N, const float alpha, float *X, const int incX);
     498void cblas_dscal(const int N, const double alpha, double *X, const int incX);
     499void cblas_cscal(const int N, const CCOMPLEX *alpha, CCOMPLEX *X, const int incX);
     500void cblas_zscal(const int N, const ZCOMPLEX *alpha, ZCOMPLEX *X, const int incX);
     501void cblas_csscal(const int N, const float alpha, CCOMPLEX *X, const int incX);
     502void cblas_zdscal(const int N, const double alpha, ZCOMPLEX *X, const int incX);
     503
     504
     505/* Offset variations of the copy, axpy routines */
     506
     507void sicopy(const int N, const float *X, const int incX, const
     508                  int offsetX, float *Y, const int incY, const int offsetY)
     509{
     510  cblas_scopy (N, X+offsetX, incX, Y+offsetY, incY);
     511}
     512
     513void dicopy(const int N, const double *X, const int incX, const
     514                  int offsetX, double *Y, const int incY, const int offsetY)
     515{
     516  cblas_dcopy (N, X+offsetX, incX, Y+offsetY, incY);
     517}
     518
     519
     520void cicopy(const int N, const CCOMPLEX *X, const int incX, const
     521                  int offsetX, CCOMPLEX *Y, const int incY, const int offsetY)
     522{
     523  cblas_ccopy (N, X+(2*offsetX), incX, Y+(2*offsetY), incY);
     524}
     525
     526void zicopy(const int N, const ZCOMPLEX *X, const int incX, const
     527                  int offsetX, ZCOMPLEX *Y, const int incY, const int offsetY)
     528{
     529  cblas_zcopy (N, X+(2*offsetX), incX, Y+(2*offsetY), incY);
     530}
     531
     532
     533void cblas_siaxpy(const int N, const float alpha,
     534                        const float *X, const int incX, const int offsetX,
     535                        float *Y, const int incY, const int offsetY)
     536{
     537
     538 cblas_saxpy(N, alpha, X+offsetX, incX, Y+offsetY, incY);
     539}
     540
     541
     542void cblas_diaxpy(const int N, const double alpha,
     543                        const double *X, const int incX, const int offsetX,
     544                        double *Y, const int incY, const int offsetY)
     545{
     546
     547 cblas_daxpy(N, alpha, X+offsetX, incX, Y+offsetY, incY);
     548}
     549
     550
     551void cblas_ciaxpy(const int N, const CCOMPLEX *alpha,
     552                        const CCOMPLEX *X, const int incX, const int offsetX,
     553                        CCOMPLEX *Y, const int incY, const int offsetY)
     554{
     555 cblas_caxpy(N, alpha, X+(2*offsetX), incX, Y+(2*offsetY), incY);
     556}
     557
     558
     559void cblas_ziaxpy(const int N, const ZCOMPLEX *alpha,
     560                        const ZCOMPLEX *X, const int incX, const int offsetX,
     561                        ZCOMPLEX *Y, const int incY, const int offsetY)
     562{
     563 cblas_zaxpy(N, alpha, X+(2*offsetX), incX, Y+(2*offsetY), incY);
     564}
     565
     566
     567
     568<#
     569
     570(define (blas:scopy x)
     571  (let ((n (f32vector-length x)))
     572    (let ((y  (make-f32vector n)))
     573      (cblas:scopy n x 1 y 1)
     574      y)))
     575
     576(define (blas:dcopy x)
     577  (let ((n (f64vector-length x)))
     578    (let ((y  (make-f64vector n)))
     579      (cblas:dcopy n x 1 y 1)
     580      y)))
     581
     582(define (blas:ccopy x)
     583  (let ((n (fx/ (f32vector-length x) 2)))
     584    (let ((y  (make-f32vector (fx* 2 n))))
     585      (cblas:ccopy n x 1 y 1)
     586      y)))
     587
     588(define (blas:zcopy x)
     589  (let ((n (fx/ (f64vector-length x) 2)))
     590    (let ((y  (make-f64vector (fx* 2 n))))
     591      (cblas:zcopy n x 1 y 1)
     592      y)))
     593
     594
     595(define-syntax icopy-wrapper
     596  (lambda (x r c)
     597    (let* ((copy            (cadr x))
     598           (vector-length   (caddr x))
     599           (make-vector     (cadddr x))
     600           (name            (string->symbol (string-concatenate (list "blas:" (symbol->string copy)))))
     601           (%define         (r 'define))
     602           (%let            (r 'let))
     603           (%cond           (r 'cond))
     604           (%or             (r 'or))
     605           (%if             (r 'if))
     606           (%let-optionals  (r 'let-optionals)))
     607         
     608    `(,%define (,name n x . rest)
     609       (,%let-optionals rest ((y #f) (offsetX 0) (offsetY 0) (incX 1) (incY 1))
     610         (,%let ((xlen  (,vector-length x))
     611               (ylen (,%if y (,vector-length y) (fx- n offsetX))))
     612             (,%cond ((not (fx= n xlen))
     613                    (blas:error ',name " n is not equal to the length of X (" xlen ")"))
     614                   ((fx< offsetX 0)
     615                    (blas:error ',name "offset of vector X (" offsetX ") is negative"))
     616                   ((fx>= offsetX xlen)
     617                    (blas:error ',name "offset of vector X (" offsetX ") is greater than or equal to its length: " xlen))
     618                   ((fx< offsetX 0)
     619                    (blas:error ',name "offset of vector X (" offsetX ") is negative"))
     620                   ((fx>= offsetY ylen)
     621                    (blas:error ',name "offset of vector Y (" offsetY ") is greater than or equal to its length: " ylen))
     622                   ((fx> (- ylen offsetY) (- xlen offsetX))
     623                    (blas:error ',name "range of vector Y (" (- ylen offsetY)
     624                                ") is greater than range of vector X: " ( - xlen offsetX))))
     625             (,%let ((y (,%or y (,make-vector ylen))))
     626               (,copy n x incX offsetX y incY offsetY)
     627               y))))))
     628  )
     629
     630(icopy-wrapper sicopy f32vector-length make-f32vector)
     631(icopy-wrapper dicopy f64vector-length make-f64vector)
     632(icopy-wrapper cicopy
     633               (lambda (x) (fx/ (f32vector-length x) 2))
     634               (lambda (n) (make-f32vector (fx* 2 n))))
     635(icopy-wrapper zicopy
     636               (lambda (x) (fx/ (f64vector-length x) 2))
     637               (lambda (n) (make-f64vector (fx* 2 n))))
     638
     639
     640
     641
     642
     643#>!
     644
     645___declare(export_constants, yes)
     646___declare(substitute,"cblas_;cblas:")
     647___declare(substitute,"Cblas;blas:")
    407648
    408649/*
     
    458699CBLAS_INDEX cblas_icamax(const int N, const void   *X, const int incX);
    459700CBLAS_INDEX cblas_izamax(const int N, const void   *X, const int incX);
    460 
    461 /*
    462  * ===========================================================================
    463  * Prototypes for level 1 BLAS routines
    464  * ===========================================================================
    465  */
    466 
    467 /*
    468  * Routines with standard 4 prefixes (s, d, c, z)
    469  */
    470 void cblas_sswap(const int N, float *X, const int incX,
    471                  float *Y, const int incY);
    472 void cblas_scopy(const int N, const float *X, const int incX,
    473                  float *Y, const int incY);
    474 void cblas_saxpy(const int N, const float alpha, const float *X,
    475                  const int incX, float *Y, const int incY);
    476 
    477 void cblas_dswap(const int N, double *X, const int incX,
    478                  double *Y, const int incY);
    479 void cblas_dcopy(const int N, const double *X, const int incX,
    480                  double *Y, const int incY);
    481 void cblas_daxpy(const int N, const double alpha, const double *X,
    482                  const int incX, double *Y, const int incY);
    483 
    484 void cblas_cswap(const int N, CCOMPLEX *X, const int incX,
    485                  CCOMPLEX *Y, const int incY);
    486 void cblas_ccopy(const int N, const CCOMPLEX *X, const int incX,
    487                  CCOMPLEX *Y, const int incY);
    488 void cblas_caxpy(const int N, const CCOMPLEX *alpha, const CCOMPLEX *X,
    489                  const int incX, CCOMPLEX *Y, const int incY);
    490 
    491 void cblas_zswap(const int N, ZCOMPLEX *X, const int incX,
    492                  ZCOMPLEX *Y, const int incY);
    493 void cblas_zcopy(const int N, const ZCOMPLEX *X, const int incX,
    494                  ZCOMPLEX *Y, const int incY);
    495 void cblas_zaxpy(const int N, const ZCOMPLEX *alpha, const ZCOMPLEX *X,
    496                  const int incX, ZCOMPLEX *Y, const int incY);
    497 
    498 
    499 /*
    500  * Routines with S and D prefix only
    501  */
    502 void cblas_srotg(float *a, float *b, float *c, float *s);
    503 void cblas_srotmg(float *d1, float *d2, float *b1, const float b2, float *P);
    504 void cblas_srot(const int N, float *X, const int incX,
    505                 float *Y, const int incY, const float c, const float s);
    506 void cblas_srotm(const int N, float *X, const int incX,
    507                 float *Y, const int incY, const float *P);
    508 
    509 void cblas_drotg(double *a, double *b, double *c, double *s);
    510 void cblas_drotmg(double *d1, double *d2, double *b1, const double b2, double *P);
    511 void cblas_drot(const int N, double *X, const int incX,
    512                 double *Y, const int incY, const double c, const double  s);
    513 void cblas_drotm(const int N, double *X, const int incX,
    514                 double *Y, const int incY, const double *P);
    515 
    516 
    517 /*
    518  * Routines with S D C Z CS and ZD prefixes
    519  */
    520 void cblas_sscal(const int N, const float alpha, float *X, const int incX);
    521 void cblas_dscal(const int N, const double alpha, double *X, const int incX);
    522 void cblas_cscal(const int N, const CCOMPLEX *alpha, CCOMPLEX *X, const int incX);
    523 void cblas_zscal(const int N, const ZCOMPLEX *alpha, ZCOMPLEX *X, const int incX);
    524 void cblas_csscal(const int N, const float alpha, CCOMPLEX *X, const int incX);
    525 void cblas_zdscal(const int N, const double alpha, ZCOMPLEX *X, const int incX);
    526701
    527702/*
     
    9581133
    9591134
    960 
    961 /* Offset variations of the copy, axpy, ger routines */
    962 
    963 void sicopy(const int N, const float *X, const int incX, const
    964                   int offsetX, float *Y, const int incY, const int offsetY)
    965 {
    966   cblas_scopy (N, X+offsetX, incX, Y+offsetY, incY);
    967 }
    968 
    969 void dicopy(const int N, const double *X, const int incX, const
    970                   int offsetX, double *Y, const int incY, const int offsetY)
    971 {
    972   cblas_dcopy (N, X+offsetX, incX, Y+offsetY, incY);
    973 }
    974 
    975 
    976 void cicopy(const int N, const CCOMPLEX *X, const int incX, const
    977                   int offsetX, CCOMPLEX *Y, const int incY, const int offsetY)
    978 {
    979   cblas_ccopy (N, X+(2*offsetX), incX, Y+(2*offsetY), incY);
    980 }
    981 
    982 void zicopy(const int N, const ZCOMPLEX *X, const int incX, const
    983                   int offsetX, ZCOMPLEX *Y, const int incY, const int offsetY)
    984 {
    985   cblas_zcopy (N, X+(2*offsetX), incX, Y+(2*offsetY), incY);
    986 }
    987 
    988 
    989 void cblas_siaxpy(const int N, const float alpha,
    990                         const float *X, const int incX, const int offsetX,
    991                         float *Y, const int incY, const int offsetY)
    992 {
    993 
    994  cblas_saxpy(N, alpha, X+offsetX, incX, Y+offsetY, incY);
    995 }
    996 
    997 
    998 void cblas_diaxpy(const int N, const double alpha,
    999                         const double *X, const int incX, const int offsetX,
    1000                         double *Y, const int incY, const int offsetY)
    1001 {
    1002 
    1003  cblas_daxpy(N, alpha, X+offsetX, incX, Y+offsetY, incY);
    1004 }
    1005 
    1006 
    1007 void cblas_ciaxpy(const int N, const CCOMPLEX *alpha,
    1008                         const CCOMPLEX *X, const int incX, const int offsetX,
    1009                         CCOMPLEX *Y, const int incY, const int offsetY)
    1010 {
    1011  cblas_caxpy(N, alpha, X+(2*offsetX), incX, Y+(2*offsetY), incY);
    1012 }
    1013 
    1014 
    1015 void cblas_ziaxpy(const int N, const ZCOMPLEX *alpha,
    1016                         const ZCOMPLEX *X, const int incX, const int offsetX,
    1017                         ZCOMPLEX *Y, const int incY, const int offsetY)
    1018 {
    1019  cblas_zaxpy(N, alpha, X+(2*offsetX), incX, Y+(2*offsetY), incY);
    1020 }
    1021 
     1135/* Offset variants of ger routines */
    10221136
    10231137void cblas_siger(const enum CBLAS_ORDER order, const int M, const int N,
     
    11111225<#
    11121226
    1113 (define (blas:error x . rest)
    1114   (let ((port (open-output-string)))
    1115     (let loop ((objs (if (symbol? x) rest (cons x rest))))
    1116       (if (null? objs)
    1117           (begin
    1118             (newline port)
    1119             (error (if (symbol? x) x 'blas)
    1120                    (get-output-string port)))
    1121           (begin (display (car objs) port)
    1122                  (display " " port)
    1123                  (loop (cdr objs)))))))
    1124 
    1125 (define-macro (icopy-wrapper copy vector-length make-vector)
    1126   (let ((name  (string->symbol (string-concatenate (list "blas:" (symbol->string copy))))))
    1127     `(define (,name n x . rest)
    1128        (let-optionals rest ((y #f) (offsetX 0) (offsetY 0) (incX 1) (incY 1))
    1129          (let ((xlen  (,vector-length x))
    1130                (ylen (if y (,vector-length y) (fx- n offsetX))))
    1131              (cond ((not (fx= n xlen))
    1132                     (blas:error ',name " n is not equal to the length of X (" xlen ")"))
    1133                    ((fx< offsetX 0)
    1134                     (blas:error ',name "offset of vector X (" offsetX ") is negative"))
    1135                    ((fx>= offsetX xlen)
    1136                     (blas:error ',name "offset of vector X (" offsetX ") is greater than or equal to its length: " xlen))
    1137                    ((fx< offsetX 0)
    1138                     (blas:error ',name "offset of vector X (" offsetX ") is negative"))
    1139                    ((fx>= offsetY ylen)
    1140                     (blas:error ',name "offset of vector Y (" offsetY ") is greater than or equal to its length: " ylen))
    1141                    ((fx> (- ylen offsetY) (- xlen offsetX))
    1142                     (blas:error ',name "range of vector Y (" (- ylen offsetY)
    1143                                 ") is greater than range of vector X: " ( - xlen offsetX))))
    1144              (let ((y (or y (,make-vector ylen))))
    1145                (,copy n x incX offsetX y incY offsetY)
    1146                y))))))
    1147 
    1148 (icopy-wrapper sicopy f32vector-length make-f32vector)
    1149 (icopy-wrapper dicopy f64vector-length make-f64vector)
    1150 (icopy-wrapper cicopy
    1151                (lambda (x) (fx/ (f32vector-length x) 2))
    1152                (lambda (n) (make-f32vector (fx* 2 n))))
    1153 (icopy-wrapper zicopy
    1154                (lambda (x) (fx/ (f64vector-length x) 2))
    1155                (lambda (n) (make-f64vector (fx* 2 n))))
    1156 
    1157 (define (blas:scopy x)
    1158   (let ((n (f32vector-length x)))
    1159     (let ((y  (make-f32vector n)))
    1160       (cblas:scopy n x 1 y 1)
    1161       y)))
    1162 
    1163 (define (blas:dcopy x)
    1164   (let ((n (f64vector-length x)))
    1165     (let ((y  (make-f64vector n)))
    1166       (cblas:dcopy n x 1 y 1)
    1167       y)))
    1168 
    1169 (define (blas:ccopy x)
    1170   (let ((n (fx/ (f32vector-length x) 2)))
    1171     (let ((y  (make-f32vector (fx* 2 n))))
    1172       (cblas:ccopy n x 1 y 1)
    1173       y)))
    1174 
    1175 (define (blas:zcopy x)
    1176   (let ((n (fx/ (f64vector-length x) 2)))
    1177     (let ((y  (make-f64vector (fx* 2 n))))
    1178       (cblas:zcopy n x 1 y 1)
    1179       y)))
    1180 
    1181 
    1182 
    1183 (define-macro (blas-level3-wrap fn ret err vsize copy)
    1184   (let ((cfname (string->symbol (conc "c" (symbol->string (car fn)))))
    1185         (fname (string->symbol (conc (if vsize "" "unsafe-")
    1186                                      (symbol->string (car fn))
    1187                                      (if copy "" "!"))))
    1188         (args  (reverse (cdr fn))))
    1189     (let ((fsig  (let loop ((args args) (sig 'rest))
    1190                    (if (null? args) (cons fname sig)
    1191                        (let ((x (car args)))
    1192                          (let ((sig (case x
    1193                                       ((lda)     sig)
    1194                                       ((ldb)     sig)
    1195                                       ((ldc)     sig)
    1196                                       (else      (cons x sig)))))
    1197                            (loop (cdr args) sig))))))
    1198           (opts  (append
    1199                   (if (memq 'lda fn) 
    1200                       `((lda
    1201                          ,(cond ((memq 'side fn)
    1202                                  `(if (= side blas:Left) m n))
    1203                                 ((memq 'transA fn)
    1204                                  `(if (= transA blas:NoTrans) k ,(if (memq 'm fn) 'm 'n)))
    1205                                 ((memq 'trans fn)
    1206                                  `(if (= trans blas:NoTrans) k n))
    1207                                 (else   
    1208                                  (cond ((memq 'm fn) 'm)
    1209                                        (else 'n))))))
    1210                       `())
    1211                   (if (memq 'ldb fn)   
    1212                       `((ldb ,(cond ((memq 'transB fn)
    1213                                      `(if (= transB blas:NoTrans) n k))
    1214                                     ((memq 'trans fn)
    1215                                      `(if (= trans blas:NoTrans) k n))
    1216                                     (else 'n))))
    1217                       `())
    1218                   (if (memq 'ldc fn) 
    1219                       `((ldc  n)) `()))))
    1220       `(define ,fsig
    1221          (let-optionals rest ,opts
     1227
     1228(letrec-syntax
     1229    (
     1230     (blas-level3-wrap
     1231      (lambda (x r c)
     1232        (let* ((fn      (cadr x))
     1233               (ret     (caddr x))
     1234               (err     (cadddr x))
     1235               (vsize   (car (cddddr x)))
     1236               (copy    (cadr (cddddr x)))
     1237               (cfname  (string->symbol (conc "c" (symbol->string (car fn)))))
     1238               (fname   (string->symbol (conc (if vsize "" "unsafe-")
     1239                                              (symbol->string (car fn))
     1240                                              (if copy "" "!"))))
     1241               (%define         (r 'define))
     1242               (%begin          (r 'begin))
     1243               (%let            (r 'let))
     1244               (%cond           (r 'cond))
     1245               (%or             (r 'or))
     1246               (%if             (r 'if))
     1247               (%let-optionals  (r 'let-optionals))
     1248               
     1249               (ka              (r 'ka))
     1250               (kb              (r 'kb))
     1251               (kc              (r 'kc))
     1252               (asize           (r 'asize))
     1253               (bsize           (r 'bsize))
     1254               (csize           (r 'csize))
     1255               
     1256               (args   (reverse (cdr fn)))
     1257
     1258               (fsig  (let loop ((args args) (sig 'rest))
     1259                        (if (null? args) (cons fname sig)
     1260                            (let ((x (car args)))
     1261                              (let ((sig (case x
     1262                                          ((lda)     sig)
     1263                                          ((ldb)     sig)
     1264                                          ((ldc)     sig)
     1265                                          (else      (cons x sig)))))
     1266                                (loop (cdr args) sig))))))
     1267
     1268               (opts  (append
     1269                       (if (memq 'lda fn) 
     1270                           `((lda
     1271                              ,(cond ((memq 'side fn)
     1272                                      `(,%if (= side blas:Left) m n))
     1273                                     ((memq 'transA fn)
     1274                                      `(,%if (= transA blas:NoTrans) k ,(if (memq 'm fn) 'm 'n)))
     1275                                     ((memq 'trans fn)
     1276                                      `(,%if (= trans blas:NoTrans) k n))
     1277                                     (else   
     1278                                      (cond ((memq 'm fn) 'm)
     1279                                            (else 'n))))))
     1280                           `())
     1281                       (if (memq 'ldb fn)   
     1282                           `((ldb ,(cond ((memq 'transB fn)
     1283                                          `(,%if (= transB blas:NoTrans) n k))
     1284                                         ((memq 'trans fn)
     1285                                          `(,%if (= trans blas:NoTrans) k n))
     1286                                         (else 'n))))
     1287                           `())
     1288                       (if (memq 'ldc fn) 
     1289                           `((ldc  n)) `()))))
     1290
     1291          `(,%define ,fsig
     1292                     (,%let-optionals rest ,opts
     1293                      ,(if vsize
     1294                           `(,%begin
     1295                             (,%let ((,asize (,vsize a))
     1296                                     (,ka    ,(cond ((memq 'side fn)
     1297                                                     `(,%if (= side blas:Left) m n))
     1298                                                    ((memq 'transA fn)
     1299                                                     `(,%if (= transA blas:NoTrans)
     1300                                                            ,(if (memq 'm fn) 'm 'n) k))
     1301                                                    ((memq 'trans fn)
     1302                                                     `(,%if (= trans blas:NoTrans)
     1303                                                            ,(if (memq 'm fn) 'm 'n) k))
     1304                                                    (else (if (memq 'm fn) 'm 'n)))))
     1305                                    (,%if (< ,asize (fx* lda ,ka))
     1306                                          (blas:error ',fname (conc "matrix A is allocated " ,asize " elements "
     1307                                                                    "but given dimensions are " ,ka " by " lda))))
     1308                             ,(if (memq 'b fn)
     1309                                  `(,%let ((,bsize (,vsize b))
     1310                                           (,kb    ,(cond ((memq 'transB fn)
     1311                                                           `(,%if (= transB blas:NoTrans) k n))
     1312                                                          ((memq 'trans fn)
     1313                                                           `(,%if (= trans blas:NoTrans) n k))
     1314                                                          (else 'm))))
     1315                                          (,%if (< ,bsize (fx* ldb ,kb))
     1316                                                (blas:error ',fname (conc "matrix B is allocated " ,bsize " elements "
     1317                                                                          "but given dimensions are " ,kb " by " ldb))))
     1318                                  `(noop))
     1319                             ,(if (memq 'c fn)
     1320                                  `(let ((,csize (,vsize c))
     1321                                         (,kc    ,(if (memq 'm fn) 'm 'n)))
     1322                                     (if (< ,csize (fx* ldc ,kc))
     1323                                         (blas:error ',fname (conc "matrix C is allocated " ,csize " elements "
     1324                                                                   "but given dimensions are " ,kc " by " ldc))))
     1325                                  `(noop)))
     1326                           `(noop))
     1327                      (,%let ,(let loop ((fn fn) (bnds '()))
     1328                                (if (null? fn) bnds
     1329                                    (let ((x (car fn)))
     1330                                      (let ((bnds (case x
     1331                                                    (else    (if (and copy (memq x ret))
     1332                                                                 (cons `(,x (,copy ,x)) bnds)
     1333                                                                 bnds)))))
     1334                                        (loop (cdr fn) bnds)))))
     1335                             (,%begin (,cfname . ,(cdr fn))
     1336                                      (values . ,ret))))))))
     1337     
     1338  (blas-level3-wrapx
     1339   (lambda (x r c)
     1340     (let* ((fn     (cadr x))
     1341            (ret    (caddr x))
     1342            (errs   (cadddr x)))
     1343       
     1344       `(begin
     1345         (blas-level3-wrap ,(cons (string->symbol (conc "blas:s" (symbol->string (car fn)))) (cdr fn))
     1346                           ,ret ,errs #f #f)
     1347         (blas-level3-wrap ,(cons (string->symbol (conc "blas:d" (symbol->string (car fn)))) (cdr fn))
     1348                           ,ret ,errs #f #f)
     1349         (blas-level3-wrap ,(cons (string->symbol (conc "blas:c" (symbol->string (car fn)))) (cdr fn))
     1350                           ,ret ,errs #f #f)
     1351         (blas-level3-wrap ,(cons (string->symbol (conc "blas:z" (symbol->string (car fn)))) (cdr fn))
     1352                           ,ret ,errs #f #f)
     1353         
     1354         (blas-level3-wrap ,(cons (string->symbol (conc "blas:s" (symbol->string (car fn)))) (cdr fn))
     1355                           ,ret ,errs f32vector-length #f)
     1356         (blas-level3-wrap ,(cons (string->symbol (conc "blas:d" (symbol->string (car fn)))) (cdr fn))
     1357                           ,ret ,errs f64vector-length #f)
     1358         (blas-level3-wrap ,(cons (string->symbol (conc "blas:c" (symbol->string (car fn)))) (cdr fn))
     1359                           ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) #f)
     1360         (blas-level3-wrap ,(cons (string->symbol (conc "blas:z" (symbol->string (car fn)))) (cdr fn))
     1361                           ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) #f)
     1362         
     1363         (blas-level3-wrap ,(cons (string->symbol (conc "blas:s" (symbol->string (car fn)))) (cdr fn))
     1364                           ,ret ,errs f32vector-length  blas:scopy)
     1365         (blas-level3-wrap ,(cons (string->symbol (conc "blas:d" (symbol->string (car fn)))) (cdr fn))
     1366                           ,ret ,errs f64vector-length  blas:dcopy)
     1367         (blas-level3-wrap ,(cons (string->symbol (conc "blas:c" (symbol->string (car fn)))) (cdr fn))
     1368                           ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) blas:ccopy)
     1369         (blas-level3-wrap ,(cons (string->symbol (conc "blas:z" (symbol->string (car fn)))) (cdr fn))
     1370                           ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) blas:zcopy)))
     1371
     1372     ))
     1373
     1374  (blas-level3-cz-wrapx
     1375   (lambda (x r c)
     1376     (let* ((fn      (cadr x))
     1377            (ret     (caddr x))
     1378            (errs    (cadddr x)))
     1379       
     1380       `(begin
     1381         (blas-level3-wrap ,(cons (string->symbol (conc "blas:c" (symbol->string (car fn)))) (cdr fn))
     1382                           ,ret ,errs #f #f)
     1383         (blas-level3-wrap ,(cons (string->symbol (conc "blas:z" (symbol->string (car fn)))) (cdr fn))
     1384                           ,ret ,errs #f #f)
     1385         
     1386         (blas-level3-wrap ,(cons (string->symbol (conc "blas:c" (symbol->string (car fn)))) (cdr fn))
     1387                           ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) #f)
     1388         (blas-level3-wrap ,(cons (string->symbol (conc "blas:z" (symbol->string (car fn)))) (cdr fn))
     1389                           ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) #f)
     1390         
     1391         (blas-level3-wrap ,(cons (string->symbol (conc "blas:c" (symbol->string (car fn)))) (cdr fn))
     1392                           ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) blas:ccopy)
     1393         (blas-level3-wrap ,(cons (string->symbol (conc "blas:z" (symbol->string (car fn)))) (cdr fn))
     1394                           ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) blas:zcopy)))))
     1395  )
     1396
     1397  (blas-level3-wrapx (gemm order transA transB m n k alpha a lda b ldb beta c ldc)
     1398                     (c)
     1399                     (lambda (i) (cond ((= i 3)  "M < 0")
     1400                                       ((= i 4)  "N < 0")
     1401                                       ((= i 5)  "K < 0")
     1402                                       ((= i 8)  "LDA < max(1, M or K)")
     1403                                       ((= i 10) "LDB < max(1, N or K)")
     1404                                       ((= i 13) "LDC < max(1, M)")
     1405                                       (else (conc "error code " i)))))
     1406 
     1407  (blas-level3-wrapx (symm order side uplo  m n alpha a lda b ldb beta c ldc)
     1408                     (c)
     1409                     (lambda (i) (cond ((= i 3)  "M < 0")
     1410                                     ((= i 4)  "N < 0")
     1411                                     ((= i 5)  "K < 0")
     1412                                     ((= i 8)  "LDA < max(1, M or K)")
     1413                                     ((= i 10) "LDB < max(1, N or K)")
     1414                                     ((= i 13) "LDC < max(1, M)")
     1415                                     (else (conc "error code " i)))))
     1416 
     1417  (blas-level3-cz-wrapx (hemm order side uplo  m n alpha a lda b ldb beta c ldc)
     1418                        (c)
     1419                        (lambda (i) (cond ((= i 3)  "M < 0")
     1420                                          ((= i 4)  "N < 0")
     1421                                          ((= i 5)  "K < 0")
     1422                                          ((= i 8)  "LDA < max(1, M or K)")
     1423                                          ((= i 10) "LDB < max(1, N or K)")
     1424                                          ((= i 13) "LDC < max(1, M)")
     1425                                          (else (conc "error code " i)))))
     1426 
     1427  (blas-level3-wrapx (syrk order uplo trans n k alpha a lda beta c ldc)
     1428                     (c)
     1429                     (lambda (i) (cond ((= i 3)  "M < 0")
     1430                                       ((= i 4)  "N < 0")
     1431                                       ((= i 5)  "K < 0")
     1432                                       ((= i 8)  "LDA < max(1, M or K)")
     1433                                       ((= i 10) "LDB < max(1, N or K)")
     1434                                       ((= i 13) "LDC < max(1, M)")
     1435                                       (else (conc "error code " i)))))
     1436 
     1437  (blas-level3-cz-wrapx (herk order uplo trans n k alpha a lda beta c ldc)
     1438                        (c)
     1439                        (lambda (i) (cond ((= i 3)  "M < 0")
     1440                                          ((= i 4)  "N < 0")
     1441                                          ((= i 5)  "K < 0")
     1442                                          ((= i 8)  "LDA < max(1, M or K)")
     1443                                          ((= i 10) "LDB < max(1, N or K)")
     1444                                          ((= i 13) "LDC < max(1, M)")
     1445                                          (else (conc "error code " i)))))
     1446 
     1447 
     1448  (blas-level3-wrapx (syr2k order uplo trans n k alpha a lda b ldb beta c ldc)
     1449                     (c)
     1450                     (lambda (i) (cond ((= i 3)  "M < 0")
     1451                                       ((= i 4)  "N < 0")
     1452                                       ((= i 5)  "K < 0")
     1453                                       ((= i 8)  "LDA < max(1, M or K)")
     1454                                       ((= i 10) "LDB < max(1, N or K)")
     1455                                       ((= i 13) "LDC < max(1, M)")
     1456                                       (else (conc "error code " i)))))
     1457 
     1458  (blas-level3-cz-wrapx (her2k order uplo trans n k alpha a lda b ldb beta c ldc)
     1459                        (c)
     1460                        (lambda (i) (cond ((= i 3)  "M < 0")
     1461                                          ((= i 4)  "N < 0")
     1462                                          ((= i 5)  "K < 0")
     1463                                          ((= i 8)  "LDA < max(1, M or K)")
     1464                                          ((= i 10) "LDB < max(1, N or K)")
     1465                                          ((= i 13) "LDC < max(1, M)")
     1466                                          (else (conc "error code " i)))))
     1467 
     1468  (blas-level3-wrapx (trmm order side uplo transA diag m n alpha a lda b ldb)
     1469                     (b)
     1470                     (lambda (i) (cond ((= i 3)  "M < 0")
     1471                                       ((= i 4)  "N < 0")
     1472                                       ((= i 5)  "K < 0")
     1473                                       ((= i 8)  "LDA < max(1, M or K)")
     1474                                       ((= i 10) "LDB < max(1, N or K)")
     1475                                       ((= i 13) "LDC < max(1, M)")
     1476                                       (else (conc "error code " i)))))
     1477 
     1478 
     1479  (blas-level3-wrapx (trsm order side uplo transA diag m n alpha a lda b ldb)
     1480                     (b)
     1481                     (lambda (i) (cond ((= i 3)  "M < 0")
     1482                                       ((= i 4)  "N < 0")
     1483                                       ((= i 5)  "K < 0")
     1484                                       ((= i 8)  "LDA < max(1, M or K)")
     1485                                       ((= i 10) "LDB < max(1, N or K)")
     1486                                       ((= i 13) "LDC < max(1, M)")
     1487                                       (else (conc "error code " i)))))
     1488     
     1489  )
     1490
     1491(letrec-syntax
     1492    (
     1493     (blas-level2-wrap
     1494      (lambda (x r c)
     1495        (let* ((fn      (cadr x))
     1496               (ret     (caddr x))
     1497               (err     (cadddr x))
     1498               (vsize   (car (cddddr x)))
     1499               (copy    (cadr (cddddr x)))
     1500               (cfname  (string->symbol (conc "c" (symbol->string (car fn)))))
     1501               (fname   (string->symbol (conc (if vsize "" "unsafe-")
     1502                                              (symbol->string (car fn))
     1503                                              (if copy "" "!"))))
     1504               (%define         (r 'define))
     1505               (%begin          (r 'begin))
     1506               (%let            (r 'let))
     1507               (%cond           (r 'cond))
     1508               (%or             (r 'or))
     1509               (%if             (r 'if))
     1510               (%let-optionals  (r 'let-optionals))
     1511
     1512               (ka              (r 'ka))
     1513               (asize           (r 'asize))
     1514               (apsize          (r 'apsize))
     1515               (apdim           (r 'apdim))
     1516               (xsize           (r 'xsize))
     1517               (ysize           (r 'ysize))
     1518               (xdim            (r 'xdim))
     1519               (ydim            (r 'ydim))
     1520
     1521               (args  (reverse (cdr fn)))
     1522
     1523               (fsig  (let loop ((args args) (sig 'rest))
     1524                        (if (null? args) (cons fname sig)
     1525                            (let ((x (car args)))
     1526                              (let ((sig (case x
     1527                                          ((lda)      sig)
     1528                                          ((incx)     sig)
     1529                                          ((incy)     sig)
     1530                                          ((offx)     sig)
     1531                                          ((offy)     sig)
     1532                                          (else      (cons x sig)))))
     1533                                (loop (cdr args) sig))))))
     1534
     1535               (opts  (append
     1536                       (if (memq 'lda fn)  `((lda  ,(cond ((memq 'k fn) `(fx+ 1 k))
     1537                                                          (else 'n)))) `())
     1538                       (if (memq 'incy fn) `((incx 1) (incy 1) (offx 0) (offy 0)) `((incx 1)))))
     1539               )
     1540
     1541      `(,%define ,fsig
     1542         (,%let-optionals rest ,opts
    12221543          ,(if vsize
    1223                `(begin
    1224                   (let ((asize (,vsize a))
    1225                         (ka    ,(cond ((memq 'side fn)
    1226                                        `(if (= side blas:Left) m n))
    1227                                       ((memq 'transA fn)
    1228                                        `(if (= transA blas:NoTrans) ,(if (memq 'm fn) 'm 'n) k))
    1229                                       ((memq 'trans fn)
    1230                                        `(if (= trans blas:NoTrans) ,(if (memq 'm fn) 'm 'n) k))
    1231                                       (else (if (memq 'm fn) 'm 'n)))))
    1232                     (if (< asize (fx* lda ka))
    1233                         (blas:error ',fname (conc "matrix A is allocated " asize " elements "
    1234                                                   "but given dimensions are " ka " by " lda))))
    1235                   ,(if (memq 'b fn)
    1236                        `(let ((bsize (,vsize b))
    1237                               (kb    ,(cond ((memq 'transB fn)
    1238                                              `(if (= transB blas:NoTrans) k n))
    1239                                             ((memq 'trans fn)
    1240                                              `(if (= trans blas:NoTrans) n k))
    1241                                             (else 'm))))
    1242                           (if (< bsize (fx* ldb kb))
    1243                               (blas:error ',fname (conc "matrix B is allocated " bsize " elements "
    1244                                                        "but given dimensions are " kb " by " ldb))))
     1544               `(,%begin
     1545                  ,(if (memq 'a fn)
     1546                       `(,%let ((,asize (,vsize a))
     1547                                (,ka    ,(if (memq 'm fn) 'm 'n)))
     1548                          (,%if (< ,asize (fx* lda ,ka))
     1549                              (blas:error ',fname (conc "matrix A is allocated " ,asize " elements "
     1550                                                        "but given dimensions are " ,ka " by " lda))))
    12451551                       `(noop))
    1246                   ,(if (memq 'c fn)
    1247                        `(let ((csize (,vsize c))
    1248                               (kc    ,(if (memq 'm fn) 'm 'n)))
    1249                           (if (< csize (fx* ldc kc))
    1250                               (blas:error ',fname (conc "matrix C is allocated " csize " elements "
    1251                                                         "but given dimensions are " kc " by " ldc))))
     1552                  ,(if (memq 'ap fn)
     1553                       `(,%let ((,apsize (,vsize ap))
     1554                                (,apdim  (fx/ (fx* n (fx+ n 1)) 2)))
     1555                          (,%if (< ,apsize ,apdim)
     1556                                (blas:error ',fname (conc "vector Ap is allocated " ,apsize " elements "
     1557                                                          "but given dimension is " ,apdim))))
     1558                       `(noop))
     1559                  ,(if (memq 'y fn)
     1560                       `(,%let ((,ysize (,vsize y))
     1561                                (,ydim  ,(if (and (memq 'm fn) (memq 'trans fn))
     1562                                             `(,%if (= trans blas:NoTrans)
     1563                                                    (fx+ 1 (fx* (abs incy) (fx- (fx+ offy m) 1)))
     1564                                                    (fx+ 1 (fx* (abs incy) (fx- (fx+ offy n) 1))))
     1565                                             `(fx+ 1 (fx* (abs incy) (fx- n 1))))))
     1566                          (,%if (< ,ysize ,ydim)
     1567                                (blas:error ',fname (conc "vector Y is allocated " ,ysize " elements "
     1568                                                          "but given dimension is " ,ydim))))
     1569                       `(noop))
     1570                  ,(if (memq 'x fn)
     1571                       `(,%let ((,xsize (,vsize x))
     1572                                (,xdim  ,(if (and (memq 'm fn) (memq 'trans fn))
     1573                                             `(if (= trans blas:NoTrans)
     1574                                                  (fx+ 1 (fx* (abs incx) (fx- (fx+ offx n) 1)))
     1575                                                  (fx+ 1 (fx* (abs incx) (fx- (fx+ offx m) 1))))
     1576                                             `(fx+ 1 (fx* (abs incx) (fx- n 1))))))
     1577                          (,%if (< ,xsize ,xdim)
     1578                                (blas:error ',fname (conc "vector X is allocated " ,xsize " elements "
     1579                                                          "but given dimension is " ,xdim))))
    12521580                       `(noop)))
    12531581               `(noop))
     
    12631591                   (values . ,ret))))))))
    12641592
    1265 
    1266 (define-macro (blas-level3-wrapx fn ret errs)
    1267   `(begin
    1268      (blas-level3-wrap ,(cons (string->symbol (conc "blas:s" (symbol->string (car fn)))) (cdr fn))
    1269                        ,ret ,errs #f #f)
    1270      (blas-level3-wrap ,(cons (string->symbol (conc "blas:d" (symbol->string (car fn)))) (cdr fn))
    1271                        ,ret ,errs #f #f)
    1272      (blas-level3-wrap ,(cons (string->symbol (conc "blas:c" (symbol->string (car fn)))) (cdr fn))
    1273                        ,ret ,errs #f #f)
    1274      (blas-level3-wrap ,(cons (string->symbol (conc "blas:z" (symbol->string (car fn)))) (cdr fn))
    1275                        ,ret ,errs #f #f)
    1276 
    1277      (blas-level3-wrap ,(cons (string->symbol (conc "blas:s" (symbol->string (car fn)))) (cdr fn))
    1278                    ,ret ,errs f32vector-length #f)
    1279      (blas-level3-wrap ,(cons (string->symbol (conc "blas:d" (symbol->string (car fn)))) (cdr fn))
    1280                    ,ret ,errs f64vector-length #f)
    1281      (blas-level3-wrap ,(cons (string->symbol (conc "blas:c" (symbol->string (car fn)))) (cdr fn))
    1282                    ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) #f)
    1283      (blas-level3-wrap ,(cons (string->symbol (conc "blas:z" (symbol->string (car fn)))) (cdr fn))
    1284                     ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) #f)
    1285 
    1286      (blas-level3-wrap ,(cons (string->symbol (conc "blas:s" (symbol->string (car fn)))) (cdr fn))
    1287                    ,ret ,errs f32vector-length  blas:scopy)
    1288      (blas-level3-wrap ,(cons (string->symbol (conc "blas:d" (symbol->string (car fn)))) (cdr fn))
    1289                    ,ret ,errs f64vector-length  blas:dcopy)
    1290      (blas-level3-wrap ,(cons (string->symbol (conc "blas:c" (symbol->string (car fn)))) (cdr fn))
    1291                   ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) blas:ccopy)
    1292      (blas-level3-wrap ,(cons (string->symbol (conc "blas:z" (symbol->string (car fn)))) (cdr fn))
    1293                         ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) blas:zcopy)))
    1294 
    1295 
    1296 (define-macro (blas-level3-cz-wrapx fn ret errs)
    1297   `(begin
    1298      (blas-level3-wrap ,(cons (string->symbol (conc "blas:c" (symbol->string (car fn)))) (cdr fn))
    1299                        ,ret ,errs #f #f)
    1300      (blas-level3-wrap ,(cons (string->symbol (conc "blas:z" (symbol->string (car fn)))) (cdr fn))
    1301                        ,ret ,errs #f #f)
    1302 
    1303      (blas-level3-wrap ,(cons (string->symbol (conc "blas:c" (symbol->string (car fn)))) (cdr fn))
    1304                    ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) #f)
    1305      (blas-level3-wrap ,(cons (string->symbol (conc "blas:z" (symbol->string (car fn)))) (cdr fn))
    1306                     ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) #f)
    1307 
    1308      (blas-level3-wrap ,(cons (string->symbol (conc "blas:c" (symbol->string (car fn)))) (cdr fn))
    1309                   ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) blas:ccopy)
    1310      (blas-level3-wrap ,(cons (string->symbol (conc "blas:z" (symbol->string (car fn)))) (cdr fn))
    1311                         ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) blas:zcopy)))
    1312 
    1313 
    1314 (blas-level3-wrapx (gemm order transA transB m n k alpha a lda b ldb beta c ldc)
    1315                    (c)
    1316                    (lambda (i) (cond ((= i 3)  "M < 0")
    1317                                      ((= i 4)  "N < 0")
    1318                                      ((= i 5)  "K < 0")
    1319                                      ((= i 8)  "LDA < max(1, M or K)")
    1320                                      ((= i 10) "LDB < max(1, N or K)")
    1321                                      ((= i 13) "LDC < max(1, M)")
     1593     (blas-level2-wrapx
     1594      (lambda (x r c)
     1595        (let* ((fn      (cadr x))
     1596               (ret     (caddr x))
     1597               (errs    (cadddr x)))
     1598         
     1599          `(begin
     1600            (blas-level2-wrap ,(cons (string->symbol (conc "blas:s" (symbol->string (car fn)))) (cdr fn))
     1601                              ,ret ,errs #f #f)
     1602            (blas-level2-wrap ,(cons (string->symbol (conc "blas:d" (symbol->string (car fn)))) (cdr fn))
     1603                              ,ret ,errs #f #f)
     1604            (blas-level2-wrap ,(cons (string->symbol (conc "blas:c" (symbol->string (car fn)))) (cdr fn))
     1605                              ,ret ,errs #f #f)
     1606            (blas-level2-wrap ,(cons (string->symbol (conc "blas:z" (symbol->string (car fn)))) (cdr fn))
     1607                              ,ret ,errs #f #f)
     1608           
     1609            (blas-level2-wrap ,(cons (string->symbol (conc "blas:s" (symbol->string (car fn)))) (cdr fn))
     1610                              ,ret ,errs f32vector-length #f)
     1611            (blas-level2-wrap ,(cons (string->symbol (conc "blas:d" (symbol->string (car fn)))) (cdr fn))
     1612                              ,ret ,errs f64vector-length #f)
     1613            (blas-level2-wrap ,(cons (string->symbol (conc "blas:c" (symbol->string (car fn)))) (cdr fn))
     1614                              ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) #f)
     1615            (blas-level2-wrap ,(cons (string->symbol (conc "blas:z" (symbol->string (car fn)))) (cdr fn))
     1616                              ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) #f)
     1617           
     1618            (blas-level2-wrap ,(cons (string->symbol (conc "blas:s" (symbol->string (car fn)))) (cdr fn))
     1619                              ,ret ,errs f32vector-length  blas:scopy)
     1620            (blas-level2-wrap ,(cons (string->symbol (conc "blas:d" (symbol->string (car fn)))) (cdr fn))
     1621                              ,ret ,errs f64vector-length  blas:dcopy)
     1622            (blas-level2-wrap ,(cons (string->symbol (conc "blas:c" (symbol->string (car fn)))) (cdr fn))
     1623                              ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) blas:ccopy)
     1624            (blas-level2-wrap ,(cons (string->symbol (conc "blas:z" (symbol->string (car fn)))) (cdr fn))
     1625                              ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) blas:zcopy)))
     1626        ))
     1627     
     1628     (blas-level2-sd-wrapx
     1629      (lambda (x r c)
     1630        (let* ((fn      (cadr x))
     1631               (ret     (caddr x))
     1632               (errs    (cadddr x)))
     1633         
     1634          `(begin
     1635            (blas-level2-wrap ,(cons (string->symbol (conc "blas:s" (symbol->string (car fn)))) (cdr fn))
     1636                              ,ret ,errs #f #f)
     1637            (blas-level2-wrap ,(cons (string->symbol (conc "blas:d" (symbol->string (car fn)))) (cdr fn))
     1638                              ,ret ,errs #f #f)
     1639           
     1640            (blas-level2-wrap ,(cons (string->symbol (conc "blas:s" (symbol->string (car fn)))) (cdr fn))
     1641                              ,ret ,errs f32vector-length #f)
     1642            (blas-level2-wrap ,(cons (string->symbol (conc "blas:d" (symbol->string (car fn)))) (cdr fn))
     1643                              ,ret ,errs f64vector-length #f)
     1644           
     1645            (blas-level2-wrap ,(cons (string->symbol (conc "blas:s" (symbol->string (car fn)))) (cdr fn))
     1646                              ,ret ,errs f32vector-length  blas:scopy)
     1647            (blas-level2-wrap ,(cons (string->symbol (conc "blas:d" (symbol->string (car fn)))) (cdr fn))
     1648                              ,ret ,errs f64vector-length  blas:dcopy))))
     1649      )
     1650     
     1651     (blas-level2-cz-wrapx
     1652      (lambda (x r c)
     1653        (let* ((fn      (cadr x))
     1654               (ret     (caddr x))
     1655               (errs    (cadddr x)))
     1656         
     1657          `(begin
     1658            (blas-level2-wrap ,(cons (string->symbol (conc "blas:c" (symbol->string (car fn)))) (cdr fn))
     1659                              ,ret ,errs #f #f)
     1660            (blas-level2-wrap ,(cons (string->symbol (conc "blas:z" (symbol->string (car fn)))) (cdr fn))
     1661                              ,ret ,errs #f #f)
     1662           
     1663            (blas-level2-wrap ,(cons (string->symbol (conc "blas:c" (symbol->string (car fn)))) (cdr fn))
     1664                              ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) #f)
     1665            (blas-level2-wrap ,(cons (string->symbol (conc "blas:z" (symbol->string (car fn)))) (cdr fn))
     1666                              ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) #f)
     1667           
     1668            (blas-level2-wrap ,(cons (string->symbol (conc "blas:c" (symbol->string (car fn)))) (cdr fn))
     1669                              ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) blas:ccopy)
     1670            (blas-level2-wrap ,(cons (string->symbol (conc "blas:z" (symbol->string (car fn)))) (cdr fn))
     1671                              ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) blas:zcopy)))))
     1672     )
     1673     
     1674  (blas-level2-wrapx (gemv order trans m n alpha a lda x incx beta y incy)
     1675                     (y)
     1676                     (lambda (i) (cond ((= i 2)  "M < 0")
     1677                                       ((= i 3)  "N < 0")
     1678                                       ((= i 6)  "LDA < max(1, M)")
     1679                                       ((= i 8)  "INCX = 0")
     1680                                       ((= i 11) "INCY < = 0")
     1681                                       (else (conc "error code " i)))))
     1682 
     1683  (blas-level2-cz-wrapx (hemv order uplo n alpha a lda x incx beta y incy)
     1684                        (y)
     1685                        (lambda (i) (cond ((= i 2)  "M < 0")
     1686                                          ((= i 3)  "N < 0")
     1687                                          ((= i 6)  "LDA < max(1, M)")
     1688                                          ((= i 8)  "INCX = 0")
     1689                                          ((= i 11) "INCY < = 0")
     1690                                          (else (conc "error code " i)))))
     1691 
     1692  (blas-level2-cz-wrapx (hbmv order uplo n k alpha a lda x incx beta y incy)
     1693                        (y)
     1694                        (lambda (i) (cond ((= i 2)  "M < 0")
     1695                                          ((= i 3)  "N < 0")
     1696                                          ((= i 6)  "LDA < max(1, M)")
     1697                                          ((= i 8)  "INCX = 0")
     1698                                          ((= i 11) "INCY < = 0")
     1699                                          (else (conc "error code " i)))))
     1700 
     1701  (blas-level2-cz-wrapx (hpmv order uplo n alpha ap x incx beta y incy)
     1702                        (y)
     1703                        (lambda (i) (cond ((= i 2)  "M < 0")
     1704                                          ((= i 3)  "N < 0")
     1705                                          ((= i 6)  "LDA < max(1, M)")
     1706                                          ((= i 8)  "INCX = 0")
     1707                                          ((= i 11) "INCY < = 0")
     1708                                          (else (conc "error code " i)))))
     1709 
     1710  (blas-level2-sd-wrapx (symv order uplo n alpha a lda x incx beta y incy)
     1711                        (y)
     1712                        (lambda (i) (cond ((= i 2)  "M < 0")
     1713                                          ((= i 3)  "N < 0")
     1714                                          ((= i 6)  "LDA < max(1, M)")
     1715                                          ((= i 8)  "INCX = 0")
     1716                                          ((= i 11) "INCY < = 0")
     1717                                          (else (conc "error code " i)))))
     1718 
     1719  (blas-level2-sd-wrapx (sbmv order uplo n k alpha a lda x incx beta y incy)
     1720                        (y)
     1721                        (lambda (i) (cond ((= i 2)  "M < 0")
     1722                                          ((= i 3)  "N < 0")
     1723                                          ((= i 6)  "LDA < max(1, M)")
     1724                                          ((= i 8)  "INCX = 0")
     1725                                          ((= i 11) "INCY < = 0")
     1726                                          (else (conc "error code " i)))))
     1727 
     1728  (blas-level2-sd-wrapx (spmv order uplo n alpha ap x incx beta y incy)
     1729                        (y)
     1730                        (lambda (i) (cond ((= i 2)  "M < 0")
     1731                                          ((= i 3)  "N < 0")
     1732                                          ((= i 6)  "LDA < max(1, M)")
     1733                                          ((= i 8)  "INCX = 0")
     1734                                          ((= i 11) "INCY < = 0")
     1735                                          (else (conc "error code " i)))))
     1736 
     1737  (blas-level2-wrapx (trmv order uplo trans diag n a lda x incx)
     1738                     (x)
     1739                     (lambda (i) (cond ((= i 2)  "M < 0")
     1740                                       ((= i 3)  "N < 0")
     1741                                       ((= i 6)  "LDA < max(1, M)")
     1742                                       ((= i 8)  "INCX = 0")
     1743                                       ((= i 11) "INCY < = 0")
     1744                                       (else (conc "error code " i)))))
     1745 
     1746  (blas-level2-wrapx (tbmv order uplo trans diag n k a lda x incx)
     1747                     (x)
     1748                     (lambda (i) (cond ((= i 2)  "M < 0")
     1749                                       ((= i 3)  "N < 0")
     1750                                       ((= i 6)  "LDA < max(1, M)")
     1751                                       ((= i 8)  "INCX = 0")
     1752                                       ((= i 11) "INCY < = 0")
    13221753                                     (else (conc "error code " i)))))
    1323 
    1324 (blas-level3-wrapx (symm order side uplo  m n alpha a lda b ldb beta c ldc)
    1325                    (c)
    1326                    (lambda (i) (cond ((= i 3)  "M < 0")
    1327                                      ((= i 4)  "N < 0")
    1328                                      ((= i 5)  "K < 0")
    1329                                      ((= i 8)  "LDA < max(1, M or K)")
    1330                                      ((= i 10) "LDB < max(1, N or K)")
    1331                                      ((= i 13) "LDC < max(1, M)")
    1332                                      (else (conc "error code " i)))))
    1333 
    1334 (blas-level3-cz-wrapx (hemm order side uplo  m n alpha a lda b ldb beta c ldc)
    1335                       (c)
    1336                       (lambda (i) (cond ((= i 3)  "M < 0")
    1337                                         ((= i 4)  "N < 0")
    1338                                         ((= i 5)  "K < 0")
    1339                                         ((= i 8)  "LDA < max(1, M or K)")
    1340                                         ((= i 10) "LDB < max(1, N or K)")
    1341                                         ((= i 13) "LDC < max(1, M)")
    1342                                         (else (conc "error code " i)))))
    1343 
    1344 (blas-level3-wrapx (syrk order uplo trans n k alpha a lda beta c ldc)
    1345                    (c)
    1346                    (lambda (i) (cond ((= i 3)  "M < 0")
    1347                                      ((= i 4)  "N < 0")
    1348                                      ((= i 5)  "K < 0")
    1349                                      ((= i 8)  "LDA < max(1, M or K)")
    1350                                      ((= i 10) "LDB < max(1, N or K)")
    1351                                      ((= i 13) "LDC < max(1, M)")
    1352                                      (else (conc "error code " i)))))
     1754 
     1755  (blas-level2-wrapx (tpmv order uplo trans diag n ap x incx)
     1756                     (x)
     1757                     (lambda (i) (cond ((= i 2)  "M < 0")
     1758                                       ((= i 3)  "N < 0")
     1759                                       ((= i 6)  "LDA < max(1, M)")
     1760                                       ((= i 8)  "INCX = 0")
     1761                                       ((= i 11) "INCY < = 0")
     1762                                       (else (conc "error code " i)))))
     1763 
     1764  (blas-level2-wrapx (trsv order uplo trans diag n a lda x incx)
     1765                     (x)
     1766                     (lambda (i) (cond ((= i 2)  "M < 0")
     1767                                       ((= i 3)  "N < 0")
     1768                                       ((= i 6)  "LDA < max(1, M)")
     1769                                       ((= i 8)  "INCX = 0")
     1770                                       ((= i 11) "INCY < = 0")
     1771                                       (else (conc "error code " i)))))
     1772 
     1773  (blas-level2-wrapx (tbsv order uplo trans diag n k a lda x incx)
     1774                     (x)
     1775                     (lambda (i) (cond ((= i 2)  "M < 0")
     1776                                       ((= i 3)  "N < 0")
     1777                                       ((= i 6)  "LDA < max(1, M)")
     1778                                       ((= i 8)  "INCX = 0")
     1779                                       ((= i 11) "INCY < = 0")
     1780                                       (else (conc "error code " i)))))
     1781 
     1782  (blas-level2-wrapx (tpsv order uplo trans diag n ap x incx)
     1783                     (x)
     1784                     (lambda (i) (cond ((= i 2)  "M < 0")
     1785                                       ((= i 3)  "N < 0")
     1786                                       ((= i 6)  "LDA < max(1, M)")
     1787                                       ((= i 8)  "INCX = 0")
     1788                                       ((= i 11) "INCY < = 0")
     1789                                       (else (conc "error code " i)))))
     1790 
     1791  (blas-level2-sd-wrapx (ger order m n alpha x incx y incy a lda)
     1792                        (a)
     1793                        (lambda (i) (cond ((= i 2)  "M < 0")
     1794                                          ((= i 3)  "N < 0")
     1795                                          ((= i 6)  "LDA < max(1, M)")
     1796                                          ((= i 8)  "INCX = 0")
     1797                                          ((= i 11) "INCY < = 0")
     1798                                          (else (conc "error code " i)))))
     1799 
     1800  (blas-level2-cz-wrapx (geru order m n alpha x incx y incy a lda)
     1801                        (a)
     1802                        (lambda (i) (cond ((= i 2)  "M < 0")
     1803                                          ((= i 3)  "N < 0")
     1804                                          ((= i 6)  "LDA < max(1, M)")
     1805                                          ((= i 8)  "INCX = 0")
     1806                                          ((= i 11) "INCY < = 0")
     1807                                          (else (conc "error code " i)))))
    13531808                             
    1354 (blas-level3-cz-wrapx (herk order uplo trans n k alpha a lda beta c ldc)
    1355                    (c)
    1356                    (lambda (i) (cond ((= i 3)  "M < 0")
    1357                                      ((= i 4)  "N < 0")
    1358                                      ((= i 5)  "K < 0")
    1359                                      ((= i 8)  "LDA < max(1, M or K)")
    1360                                      ((= i 10) "LDB < max(1, N or K)")
    1361                                      ((= i 13) "LDC < max(1, M)")
    1362                                      (else (conc "error code " i)))))
     1809  (blas-level2-cz-wrapx (gerc order m n alpha x incx y incy a lda)
     1810                        (a)
     1811                        (lambda (i) (cond ((= i 2)  "M < 0")
     1812                                          ((= i 3)  "N < 0")
     1813                                          ((= i 6)  "LDA < max(1, M)")
     1814                                          ((= i 8)  "INCX = 0")
     1815                                          ((= i 11) "INCY < = 0")
     1816                                          (else (conc "error code " i)))))
     1817 
    13631818                             
    1364            
    1365 (blas-level3-wrapx (syr2k order uplo trans n k alpha a lda b ldb beta c ldc)
    1366                    (c)
    1367                    (lambda (i) (cond ((= i 3)  "M < 0")
    1368                                      ((= i 4)  "N < 0")
    1369                                      ((= i 5)  "K < 0")
    1370                                      ((= i 8)  "LDA < max(1, M or K)")
    1371                                      ((= i 10) "LDB < max(1, N or K)")
    1372                                      ((= i 13) "LDC < max(1, M)")
    1373                                      (else (conc "error code " i)))))
     1819  (blas-level2-cz-wrapx (her order uplo n alpha x incx a lda)
     1820                        (a)
     1821                        (lambda (i) (cond ((= i 2)  "M < 0")
     1822                                          ((= i 3)  "N < 0")
     1823                                          ((= i 6)  "LDA < max(1, M)")
     1824                                          ((= i 8)  "INCX = 0")
     1825                                          ((= i 11) "INCY < = 0")
     1826                                          (else (conc "error code " i)))))
     1827 
     1828  (blas-level2-cz-wrapx (hpr order uplo n alpha x incx ap)
     1829                        (ap)
     1830                        (lambda (i) (cond ((= i 2)  "M < 0")
     1831                                          ((= i 3)  "N < 0")
     1832                                          ((= i 6)  "LDA < max(1, M)")
     1833                                          ((= i 8)  "INCX = 0")
     1834                                          ((= i 11) "INCY < = 0")
     1835                                          (else (conc "error code " i)))))
     1836 
     1837  (blas-level2-cz-wrapx (her2 order uplo n alpha x incx y incy a lda)
     1838                        (a)
     1839                        (lambda (i) (cond ((= i 2)  "M < 0")
     1840                                          ((= i 3)  "N < 0")
     1841                                          ((= i 6)  "LDA < max(1, M)")
     1842                                          ((= i 8)  "INCX = 0")
     1843                                          ((= i 11) "INCY < = 0")
     1844                                          (else (conc "error code " i)))))
     1845 
     1846  (blas-level2-cz-wrapx (hpr2 order uplo n alpha x incx y incy ap)
     1847                        (ap)
     1848                        (lambda (i) (cond ((= i 2)  "M < 0")
     1849                                          ((= i 3)  "N < 0")
     1850                                          ((= i 6)  "LDA < max(1, M)")
     1851                                          ((= i 8)  "INCX = 0")
     1852                                          ((= i 11) "INCY < = 0")
     1853                                          (else (conc "error code " i)))))
     1854 
     1855  (blas-level2-sd-wrapx (syr order uplo n alpha x incx a lda)
     1856                        (a)
     1857                        (lambda (i) (cond ((= i 2)  "M < 0")
     1858                                          ((= i 3)  "N < 0")
     1859                                          ((= i 6)  "LDA < max(1, M)")
     1860                                          ((= i 8)  "INCX = 0")
     1861                                          ((= i 11) "INCY < = 0")
     1862                                          (else (conc "error code " i)))))
    13741863                             
    1375 (blas-level3-cz-wrapx (her2k order uplo trans n k alpha a lda b ldb beta c ldc)
    1376                    (c)
    1377                    (lambda (i) (cond ((= i 3)  "M < 0")
    1378                                      ((= i 4)  "N < 0")
    1379                                      ((= i 5)  "K < 0")
    1380                                      ((= i 8)  "LDA < max(1, M or K)")
    1381                                      ((= i 10) "LDB < max(1, N or K)")
    1382                                      ((= i 13) "LDC < max(1, M)")
    1383                                      (else (conc "error code " i)))))
     1864  (blas-level2-sd-wrapx (spr order uplo n alpha x incx ap)
     1865                        (ap)
     1866                        (lambda (i) (cond ((= i 2)  "M < 0")
     1867                                          ((= i 3)  "N < 0")
     1868                                          ((= i 6)  "LDA < max(1, M)")
     1869                                          ((= i 8)  "INCX = 0")
     1870                                          ((= i 11) "INCY < = 0")
     1871                                          (else (conc "error code " i)))))
     1872 
     1873  (blas-level2-sd-wrapx (syr2 order uplo n alpha x incx y incy a lda)
     1874                        (a)
     1875                        (lambda (i) (cond ((= i 2)  "M < 0")
     1876                                          ((= i 3)  "N < 0")
     1877                                          ((= i 6)  "LDA < max(1, M)")
     1878                                          ((= i 8)  "INCX = 0")
     1879                                          ((= i 11) "INCY < = 0")
     1880                                          (else (conc "error code " i)))))
     1881 
     1882  (blas-level2-sd-wrapx (ger order m n alpha x incx y incy a lda)
     1883                        (a)
     1884                        (lambda (i) (cond ((= i 2)  "M < 0")
     1885                                          ((= i 3)  "N < 0")
     1886                                          ((= i 6)  "LDA < max(1, M)")
     1887                                          ((= i 8)  "INCX = 0")
     1888                                          ((= i 11) "INCY < = 0")
     1889                                          (else (conc "error code " i)))))
     1890 
     1891  (blas-level2-sd-wrapx (iger order m n alpha x incx offx y incy offy a lda)
     1892                        (a)
     1893                        (lambda (i) (cond ((= i 2)  "M < 0")
     1894                                          ((= i 3)  "N < 0")
     1895                                          ((= i 6)  "LDA < max(1, M)")
     1896                                          ((= i 8)  "INCX = 0")
     1897                                          ((= i 11) "INCY < = 0")
     1898                                          (else (conc "error code " i)))))
     1899 
     1900  (blas-level2-cz-wrapx (geru order m n alpha x incx y incy a lda)
     1901                        (a)
     1902                        (lambda (i) (cond ((= i 2)  "M < 0")
     1903                                          ((= i 3)  "N < 0")
     1904                                          ((= i 6)  "LDA < max(1, M)")
     1905                                          ((= i 8)  "INCX = 0")
     1906                                          ((= i 11) "INCY < = 0")
     1907                                          (else (conc "error code " i)))))
     1908 
     1909  (blas-level2-cz-wrapx (gerc order m n alpha x incx y incy a lda)
     1910                        (a)
     1911                        (lambda (i) (cond ((= i 2)  "M < 0")
     1912                                          ((= i 3)  "N < 0")
     1913                                          ((= i 6)  "LDA < max(1, M)")
     1914                                          ((= i 8)  "INCX = 0")
     1915                                          ((= i 11) "INCY < = 0")
     1916                                          (else (conc "error code " i)))))
     1917 
     1918 
     1919  (blas-level2-cz-wrapx (her order uplo n alpha x incx a lda)
     1920                        (a)
     1921                        (lambda (i) (cond ((= i 2)  "M < 0")
     1922                                          ((= i 3)  "N < 0")
     1923                                          ((= i 6)  "LDA < max(1, M)")
     1924                                          ((= i 8)  "INCX = 0")
     1925                                          ((= i 11) "INCY < = 0")
     1926                                          (else (conc "error code " i)))))
     1927 
     1928  (blas-level2-cz-wrapx (hpr order uplo n alpha x incx ap)
     1929                        (ap)
     1930                        (lambda (i) (cond ((= i 2)  "M < 0")
     1931                                          ((= i 3)  "N < 0")
     1932                                          ((= i 6)  "LDA < max(1, M)")
     1933                                          ((= i 8)  "INCX = 0")
     1934                                          ((= i 11) "INCY < = 0")
     1935                                          (else (conc "error code " i)))))
     1936 
     1937  (blas-level2-cz-wrapx (her2 order uplo n alpha x incx y incy a lda)
     1938                        (a)
     1939                        (lambda (i) (cond ((= i 2)  "M < 0")
     1940                                          ((= i 3)  "N < 0")
     1941                                          ((= i 6)  "LDA < max(1, M)")
     1942                                          ((= i 8)  "INCX = 0")
     1943                                          ((= i 11) "INCY < = 0")
     1944                                          (else (conc "error code " i)))))
     1945 
     1946  (blas-level2-cz-wrapx (hpr2 order uplo n alpha x incx y incy ap)
     1947                        (ap)
     1948                        (lambda (i) (cond ((= i 2)  "M < 0")
     1949                                          ((= i 3)  "N < 0")
     1950                                          ((= i 6)  "LDA < max(1, M)")
     1951                                          ((= i 8)  "INCX = 0")
     1952                                          ((= i 11) "INCY < = 0")
     1953                                          (else (conc "error code " i)))))
    13841954                             
    1385 (blas-level3-wrapx (trmm order side uplo transA diag m n alpha a lda b ldb)
    1386                    (b)
    1387                    (lambda (i) (cond ((= i 3)  "M < 0")
    1388                                      ((= i 4)  "N < 0")
    1389                                      ((= i 5)  "K < 0")
    1390                                      ((= i 8)  "LDA < max(1, M or K)")
    1391                                      ((= i 10) "LDB < max(1, N or K)")
    1392                                      ((= i 13) "LDC < max(1, M)")
    1393                                      (else (conc "error code " i)))))
     1955  (blas-level2-sd-wrapx (syr order uplo n alpha x incx a lda)
     1956                        (a)
     1957                        (lambda (i) (cond ((= i 2)  "M < 0")
     1958                                          ((= i 3)  "N < 0")
     1959                                          ((= i 6)  "LDA < max(1, M)")
     1960                                          ((= i 8)  "INCX = 0")
     1961                                          ((= i 11) "INCY < = 0")
     1962                                          (else (conc "error code " i)))))
     1963 
     1964  (blas-level2-sd-wrapx (spr order uplo n alpha x incx ap)
     1965                        (ap)
     1966                        (lambda (i) (cond ((= i 2)  "M < 0")
     1967                                          ((= i 3)  "N < 0")
     1968                                          ((= i 6)  "LDA < max(1, M)")
     1969                                          ((= i 8)  "INCX = 0")
     1970                                          ((= i 11) "INCY < = 0")
     1971                                          (else (conc "error code " i)))))
     1972 
     1973  (blas-level2-sd-wrapx (syr2 order uplo n alpha x incx y incy a lda)
     1974                        (a)
     1975                        (lambda (i) (cond ((= i 2)  "M < 0")
     1976                                          ((= i 3)  "N < 0")
     1977                                          ((= i 6)  "LDA < max(1, M)")
     1978                                          ((= i 8)  "INCX = 0")
     1979                                          ((= i 11) "INCY < = 0")
     1980                                          (else (conc "error code " i)))))
     1981 
     1982  (blas-level2-sd-wrapx (spr2 order uplo n alpha x incx y incy ap)
     1983                        (ap)
     1984                        (lambda (i) (cond ((= i 2)  "M < 0")
     1985                                          ((= i 3)  "N < 0")
     1986                                          ((= i 6)  "LDA < max(1, M)")
     1987                                          ((= i 8)  "INCX = 0")
     1988                                          ((= i 11) "INCY < = 0")
     1989                                          (else (conc "error code " i)))))
     1990 
     1991   )
     1992
     1993
     1994(letrec-syntax
     1995    (
     1996     (blas-level1-wrap
     1997      (lambda (x r c)
     1998        (let* ((fn            (cadr x))
     1999               (ret           (caddr x))
     2000               (err           (cadddr x))
     2001               (vsize         (car (cddddr x)))
     2002               (copy          (cadr (cddddr x)))
     2003               (make-return   (cddr (cddddr x)))
     2004               (cfname  (string->symbol (conc "c" (symbol->string (car fn)))))
     2005               (fname   (string->symbol (conc (if vsize "" "unsafe-")
     2006                                              (symbol->string (car fn))
     2007                                              (if copy "" "!"))))
     2008               
     2009               (%define         (r 'define))
     2010               (%begin          (r 'begin))
     2011               (%let            (r 'let))
     2012               (%cond           (r 'cond))
     2013               (%or             (r 'or))
     2014               (%if             (r 'if))
     2015               (%let-optionals  (r 'let-optionals))
     2016
     2017               (asize           (r 'asize))
     2018               (apsize          (r 'apsize))
     2019               (apdim           (r 'apdim))
     2020               (xsize           (r 'xsize))
     2021               (ysize           (r 'ysize))
     2022               (xdim            (r 'xdim))
     2023               (ydim            (r 'ydim))
     2024               (psize           (r 'psize))
     2025               (pdim            (r 'pdim))
     2026
     2027               (args   (reverse (cdr fn)))
     2028
     2029               (fsig  (let loop ((args args) (sig 'rest))
     2030                        (if (null? args) (cons fname sig)
     2031                            (let ((x (car args)))
     2032                              (let ((sig (case x
     2033                                          ((incx)     sig)
     2034                                          ((incy)     sig)
     2035                                          ((dotu)     sig)
     2036                                          ((dotc)     sig)
     2037                                          ((offx)     sig)
     2038                                          ((offy)     sig)
     2039                                          (else      (cons x sig)))))
     2040                                (loop (cdr args) sig))))))
     2041
     2042               (opts  (cond ((memq 'incy fn)  `((incx 1) (incy 1) (offx 0) (offy 0)))
     2043                            (else `((incx 1) (offx 0))))))
     2044
     2045          `(,%define ,fsig
     2046                     (,%let-optionals rest ,opts
     2047                      ,(if vsize
     2048                           `(,%begin
     2049                             ,(if (memq 'y fn)
     2050                                  `(,%let ((,ysize (,vsize y))
     2051                                           (,ydim  (fx+ 1 (fx* (abs incy) (fx- (fx+ offy n) 1)))))
     2052                                          (,%if (< ,ysize ,ydim)
     2053                                                (blas:error ',fname (conc "vector Y is allocated " ,ysize " elements "
     2054                                                                          "but given dimension is " ,ydim))))
     2055                                  `(noop))
     2056                             ,(if (memq 'x fn)
     2057                                  `(,%let ((,xsize (,vsize x))
     2058                                           (,xdim  (fx+ 1 (fx* (abs incx) (fx- (fx+ offx n) 1)))))
     2059                                          (,%if (< ,xsize ,xdim)
     2060                                                (blas:error ',fname (conc "vector X is allocated " ,xsize " elements "
     2061                                                                          "but given dimension is " ,xdim))))
     2062                                  `(noop))
     2063                             ,(if (memq 'param fn)
     2064                                  `(,%let ((,psize (,vsize param))
     2065                                           (,pdim  5))
     2066                                          (,%if (< ,psize ,pdim)
     2067                                                (blas:error ',fname (conc "vector PARAM is allocated " ,psize " elements "
     2068                                                                          "but dimension must be " ,pdim))))
     2069                                  `(noop)))
     2070                           
     2071                           `(noop))
     2072                      (let ,(let loop ((fn fn) (bnds '()))
     2073                              (if (null? fn) bnds
     2074                                  (let ((x (car fn)))
     2075                                    (let ((bnds (cond ((or (eq? x 'dotc) (eq? x 'dotu))
     2076                                                       (cons `(,x (,(car make-return))) bnds))
     2077                                                      ((and copy (memq x ret))
     2078                                                       (cons `(,x (,copy ,x)) bnds))
     2079                                                      (else bnds))))
     2080                                      (loop (cdr fn) bnds)))))
     2081                        ,(cond
     2082                          ((memq 'dotc fn)   `(begin (,cfname . ,(cdr fn))
     2083                                                     (values dotc)))
     2084                          ((memq 'dotu fn)   `(begin (,cfname . ,(cdr fn))
     2085                                                     (values dotu)))
     2086                          ((not ret)         `(,cfname . ,(cdr fn)))
     2087                          (else              `(begin (,cfname . ,(cdr fn))
     2088                                                     (values . ,ret)))))))))
     2089      )
     2090
     2091
     2092     ( blas-level1-wrapx
     2093       (lambda (x r c)
     2094         (let* ((fn      (cadr x))
     2095                (ret     (caddr x))
     2096                (errs    (cadddr x)))
     2097           
     2098           (if (not ret)
     2099               `(begin
     2100                 (blas-level1-wrap ,(cons (string->symbol (conc "blas:s" (symbol->string (car fn)))) (cdr fn))
     2101                               ,ret ,errs f32vector-length  blas:scopy)
     2102                 (blas-level1-wrap ,(cons (string->symbol (conc "blas:d" (symbol->string (car fn)))) (cdr fn))
     2103                                   ,ret ,errs f64vector-length  blas:dcopy)
     2104                 (blas-level1-wrap ,(cons (string->symbol (conc "blas:c" (symbol->string (car fn)))) (cdr fn))
     2105                                   ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) blas:ccopy)
     2106                 (blas-level1-wrap ,(cons (string->symbol (conc "blas:z" (symbol->string (car fn)))) (cdr fn))
     2107                                   ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) blas:zcopy))
     2108               
     2109               `(begin
     2110                 (blas-level1-wrap ,(cons (string->symbol (conc "blas:s" (symbol->string (car fn)))) (cdr fn))
     2111                                   ,ret ,errs #f #f)
     2112                 (blas-level1-wrap ,(cons (string->symbol (conc "blas:d" (symbol->string (car fn)))) (cdr fn))
     2113                                   ,ret ,errs #f #f)
     2114                 (blas-level1-wrap ,(cons (string->symbol (conc "blas:c" (symbol->string (car fn)))) (cdr fn))
     2115                                   ,ret ,errs #f #f)
     2116                 (blas-level1-wrap ,(cons (string->symbol (conc "blas:z" (symbol->string (car fn)))) (cdr fn))
     2117                                   ,ret ,errs #f #f)
     2118                 
     2119                 (blas-level1-wrap ,(cons (string->symbol (conc "blas:s" (symbol->string (car fn)))) (cdr fn))
     2120                                   ,ret ,errs f32vector-length #f)
     2121                 (blas-level1-wrap ,(cons (string->symbol (conc "blas:d" (symbol->string (car fn)))) (cdr fn))
     2122                                   ,ret ,errs f64vector-length #f)
     2123                 (blas-level1-wrap ,(cons (string->symbol (conc "blas:c" (symbol->string (car fn)))) (cdr fn))
     2124                                   ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) #f)
     2125                 (blas-level1-wrap ,(cons (string->symbol (conc "blas:z" (symbol->string (car fn)))) (cdr fn))
     2126                                   ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) #f)
     2127                 
     2128                 (blas-level1-wrap ,(cons (string->symbol (conc "blas:s" (symbol->string (car fn)))) (cdr fn))
     2129                                   ,ret ,errs f32vector-length  blas:scopy)
     2130                 (blas-level1-wrap ,(cons (string->symbol (conc "blas:d" (symbol->string (car fn)))) (cdr fn))
     2131                                   ,ret ,errs f64vector-length  blas:dcopy)
     2132                 (blas-level1-wrap ,(cons (string->symbol (conc "blas:c" (symbol->string (car fn)))) (cdr fn))
     2133                                   ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) blas:ccopy)
     2134                 (blas-level1-wrap ,(cons (string->symbol (conc "blas:z" (symbol->string (car fn)))) (cdr fn))
     2135                                   ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) blas:zcopy))))
     2136         ))
     2137
     2138     (blas-level1-sd-wrapx
     2139      (lambda (x r c)
     2140        (let* ((fn      (cadr x))
     2141               (ret     (caddr x))
     2142               (errs    (cadddr x)))
     2143          (if (not ret)
     2144             
     2145              `(begin
     2146                (blas-level1-wrap ,(cons (string->symbol (conc "blas:s" (symbol->string (car fn)))) (cdr fn))
     2147                                  ,ret ,errs f32vector-length  blas:scopy)
     2148                (blas-level1-wrap ,(cons (string->symbol (conc "blas:d" (symbol->string (car fn)))) (cdr fn))
     2149                                  ,ret ,errs f64vector-length  blas:dcopy))
     2150             
     2151              `(begin
     2152                (blas-level1-wrap ,(cons (string->symbol (conc "blas:s" (symbol->string (car fn)))) (cdr fn))
     2153                                  ,ret ,errs #f #f)
     2154                (blas-level1-wrap ,(cons (string->symbol (conc "blas:d" (symbol->string (car fn)))) (cdr fn))
     2155                                  ,ret ,errs #f #f)
     2156             
     2157                (blas-level1-wrap ,(cons (string->symbol (conc "blas:s" (symbol->string (car fn)))) (cdr fn))
     2158                                  ,ret ,errs f32vector-length #f)
     2159                (blas-level1-wrap ,(cons (string->symbol (conc "blas:d" (symbol->string (car fn)))) (cdr fn))
     2160                                  ,ret ,errs f64vector-length #f)
     2161               
     2162                (blas-level1-wrap ,(cons (string->symbol (conc "blas:s" (symbol->string (car fn)))) (cdr fn))
     2163                                  ,ret ,errs f32vector-length  blas:scopy)
     2164                (blas-level1-wrap ,(cons (string->symbol (conc "blas:d" (symbol->string (car fn)))) (cdr fn))
     2165                                  ,ret ,errs f64vector-length  blas:dcopy))))
     2166        ))
     2167
     2168
     2169     (blas-level1-cz-wrapx
     2170      (lambda (x r c)
     2171        (let* ((fn      (cadr x))
     2172               (ret     (caddr x))
     2173               (errs    (cadddr x)))
     2174         
     2175          (if (not ret)
     2176              `(begin
     2177                (blas-level1-wrap ,(cons (string->symbol (conc "blas:c" (symbol->string (car fn)))) (cdr fn))
     2178                                  ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v)))
     2179                                  blas:ccopy (lambda () (make-f32vector 2)))
     2180                (blas-level1-wrap ,(cons (string->symbol (conc "blas:z" (symbol->string (car fn)))) (cdr fn))
     2181                                  ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v)))
     2182                                  blas:zcopy (lambda () (make-f64vector 2))))
     2183             
     2184              `(begin
     2185                (blas-level1-wrap ,(cons (string->symbol (conc "blas:c" (symbol->string (car fn)))) (cdr fn))
     2186                                  ,ret ,errs #f #f)
     2187                (blas-level1-wrap ,(cons (string->symbol (conc "blas:z" (symbol->string (car fn)))) (cdr fn))
     2188                                  ,ret ,errs #f #f)
     2189               
     2190                (blas-level1-wrap ,(cons (string->symbol (conc "blas:c" (symbol->string (car fn)))) (cdr fn))
     2191                                  ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) #f)
     2192                (blas-level1-wrap ,(cons (string->symbol (conc "blas:z" (symbol->string (car fn)))) (cdr fn))
     2193                                  ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) #f)
     2194               
     2195                (blas-level1-wrap ,(cons (string->symbol (conc "blas:c" (symbol->string (car fn)))) (cdr fn))
     2196                                  ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) blas:ccopy)
     2197                (blas-level1-wrap ,(cons (string->symbol (conc "blas:z" (symbol->string (car fn)))) (cdr fn))
     2198                                  ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) blas:zcopy))))
     2199        ))
     2200     )
    13942201     
    1395                              
    1396 (blas-level3-wrapx (trsm order side uplo transA diag m n alpha a lda b ldb)
    1397                    (b)
    1398                    (lambda (i) (cond ((= i 3)  "M < 0")
    1399                                      ((= i 4)  "N < 0")
    1400                                      ((= i 5)  "K < 0")
    1401                                      ((= i 8)  "LDA < max(1, M or K)")
    1402                                      ((= i 10) "LDB < max(1, N or K)")
    1403                                      ((= i 13) "LDC < max(1, M)")
    1404                                      (else (conc "error code " i)))))
    1405      
    1406 
    1407 (define-macro (blas-level2-wrap fn ret err vsize copy)
    1408   (let ((cfname (string->symbol (conc "c" (symbol->string (car fn)))))
    1409         (fname (string->symbol (conc (if vsize "" "unsafe-")
    1410                                      (symbol->string (car fn))
    1411                                      (if copy "" "!"))))
    1412         (args  (reverse (cdr fn))))
    1413     (let ((fsig  (let loop ((args args) (sig 'rest))
    1414                    (if (null? args) (cons fname sig)
    1415                        (let ((x (car args)))
    1416                          (let ((sig (case x
    1417                                       ((lda)      sig)
    1418                                       ((incx)     sig)
    1419                                       ((incy)     sig)
    1420                                       ((offx)     sig)
    1421                                       ((offy)     sig)
    1422                                       (else      (cons x sig)))))
    1423                            (loop (cdr args) sig))))))
    1424           (opts  (append
    1425                   (if (memq 'lda fn)  `((lda  ,(cond ((memq 'k fn) `(fx+ 1 k))
    1426                                                      (else 'n)))) `())
    1427                   (if (memq 'incy fn) `((incx 1) (incy 1) (offx 0) (offy 0)) `((incx 1))))))
    1428       `(define ,fsig
    1429          (let-optionals rest ,opts
    1430           ,(if vsize
    1431                `(begin
    1432                   ,(if (memq 'a fn)
    1433                        `(let ((asize (,vsize a))
    1434                               (ka    ,(if (memq 'm fn) 'm 'n)))
    1435                           (if (< asize (fx* lda ka))
    1436                               (blas:error ',fname (conc "matrix A is allocated " asize " elements "
    1437                                                         "but given dimensions are " ka " by " lda))))
    1438                        `(noop))
    1439                   ,(if (memq 'ap fn)
    1440                        `(let ((apsize (,vsize ap))
    1441                               (apdim  (fx/ (fx* n (fx+ n 1)) 2)))
    1442                           (if (< apsize apdim)
    1443                               (blas:error ',fname (conc "vector Ap is allocated " apsize " elements "
    1444                                                         "but given dimension is " apdim))))
    1445                        `(noop))
    1446                   ,(if (memq 'y fn)
    1447                        `(let ((ysize (,vsize y))
    1448                               (ydim  ,(if (and (memq 'm fn) (memq 'trans fn))
    1449                                           `(if (= trans blas:NoTrans)
    1450                                                (fx+ 1 (fx* (abs incy) (fx- (fx+ offy m) 1)))
    1451                                                (fx+ 1 (fx* (abs incy) (fx- (fx+ offy n) 1))))
    1452                                           `(fx+ 1 (fx* (abs incy) (fx- n 1))))))
    1453                           (if (< ysize ydim)
    1454                               (blas:error ',fname (conc "vector Y is allocated " ysize " elements "
    1455                                                         "but given dimension is " ydim))))
    1456                        `(noop))
    1457                   ,(if (memq 'x fn)
    1458                        `(let ((xsize (,vsize x))
    1459                               (xdim  ,(if (and (memq 'm fn) (memq 'trans fn))
    1460                                           `(if (= trans blas:NoTrans)
    1461                                                (fx+ 1 (fx* (abs incx) (fx- (fx+ offx n) 1)))
    1462                                                (fx+ 1 (fx* (abs incx) (fx- (fx+ offx m) 1))))
    1463                                           `(fx+ 1 (fx* (abs incx) (fx- n 1))))))
    1464                           (if (< xsize xdim)
    1465                               (blas:error ',fname (conc "vector X is allocated " xsize " elements "
    1466                                                        "but given dimension is " xdim))))
    1467                        `(noop)))
    1468                `(noop))
    1469           (let ,(let loop ((fn fn) (bnds '()))
    1470                   (if (null? fn) bnds
    1471                       (let ((x (car fn)))
    1472                         (let ((bnds (case x
    1473                                       (else    (if (and copy (memq x ret))
    1474                                                    (cons `(,x (,copy ,x)) bnds)
    1475                                                    bnds)))))
    1476                           (loop (cdr fn) bnds)))))
    1477             (begin (,cfname . ,(cdr fn))
    1478                    (values . ,ret))))))))
    1479 
    1480 
    1481 (define-macro (blas-level2-wrapx fn ret errs)
    1482   `(begin
    1483      (blas-level2-wrap ,(cons (string->symbol (conc "blas:s" (symbol->string (car fn)))) (cdr fn))
    1484                        ,ret ,errs #f #f)
    1485      (blas-level2-wrap ,(cons (string->symbol (conc "blas:d" (symbol->string (car fn)))) (cdr fn))
    1486                        ,ret ,errs #f #f)
    1487      (blas-level2-wrap ,(cons (string->symbol (conc "blas:c" (symbol->string (car fn)))) (cdr fn))
    1488                        ,ret ,errs #f #f)
    1489      (blas-level2-wrap ,(cons (string->symbol (conc "blas:z" (symbol->string (car fn)))) (cdr fn))
    1490                        ,ret ,errs #f #f)
    1491 
    1492      (blas-level2-wrap ,(cons (string->symbol (conc "blas:s" (symbol->string (car fn)))) (cdr fn))
    1493                    ,ret ,errs f32vector-length #f)
    1494      (blas-level2-wrap ,(cons (string->symbol (conc "blas:d" (symbol->string (car fn)))) (cdr fn))
    1495                    ,ret ,errs f64vector-length #f)
    1496      (blas-level2-wrap ,(cons (string->symbol (conc "blas:c" (symbol->string (car fn)))) (cdr fn))
    1497                    ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) #f)
    1498      (blas-level2-wrap ,(cons (string->symbol (conc "blas:z" (symbol->string (car fn)))) (cdr fn))
    1499                     ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) #f)
    1500 
    1501      (blas-level2-wrap ,(cons (string->symbol (conc "blas:s" (symbol->string (car fn)))) (cdr fn))
    1502                    ,ret ,errs f32vector-length  blas:scopy)
    1503      (blas-level2-wrap ,(cons (string->symbol (conc "blas:d" (symbol->string (car fn)))) (cdr fn))
    1504                    ,ret ,errs f64vector-length  blas:dcopy)
    1505      (blas-level2-wrap ,(cons (string->symbol (conc "blas:c" (symbol->string (car fn)))) (cdr fn))
    1506                   ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) blas:ccopy)
    1507      (blas-level2-wrap ,(cons (string->symbol (conc "blas:z" (symbol->string (car fn)))) (cdr fn))
    1508                         ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) blas:zcopy)))
    1509 
    1510 
    1511 (define-macro (blas-level2-sd-wrapx fn ret errs)
    1512   `(begin
    1513      (blas-level2-wrap ,(cons (string->symbol (conc "blas:s" (symbol->string (car fn)))) (cdr fn))
    1514                        ,ret ,errs #f #f)
    1515      (blas-level2-wrap ,(cons (string->symbol (conc "blas:d" (symbol->string (car fn)))) (cdr fn))
    1516                        ,ret ,errs #f #f)
    1517 
    1518      (blas-level2-wrap ,(cons (string->symbol (conc "blas:s" (symbol->string (car fn)))) (cdr fn))
    1519                    ,ret ,errs f32vector-length #f)
    1520      (blas-level2-wrap ,(cons (string->symbol (conc "blas:d" (symbol->string (car fn)))) (cdr fn))
    1521                    ,ret ,errs f64vector-length #f)
    1522 
    1523      (blas-level2-wrap ,(cons (string->symbol (conc "blas:s" (symbol->string (car fn)))) (cdr fn))
    1524                    ,ret ,errs f32vector-length  blas:scopy)
    1525      (blas-level2-wrap ,(cons (string->symbol (conc "blas:d" (symbol->string (car fn)))) (cdr fn))
    1526                    ,ret ,errs f64vector-length  blas:dcopy)))
    1527 
    1528 
    1529 (define-macro (blas-level2-cz-wrapx fn ret errs)
    1530   `(begin
    1531      (blas-level2-wrap ,(cons (string->symbol (conc "blas:c" (symbol->string (car fn)))) (cdr fn))
    1532                        ,ret ,errs #f #f)
    1533      (blas-level2-wrap ,(cons (string->symbol (conc "blas:z" (symbol->string (car fn)))) (cdr fn))
    1534                        ,ret ,errs #f #f)
    1535 
    1536      (blas-level2-wrap ,(cons (string->symbol (conc "blas:c" (symbol->string (car fn)))) (cdr fn))
    1537                    ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) #f)
    1538      (blas-level2-wrap ,(cons (string->symbol (conc "blas:z" (symbol->string (car fn)))) (cdr fn))
    1539                     ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) #f)
    1540 
    1541      (blas-level2-wrap ,(cons (string->symbol (conc "blas:c" (symbol->string (car fn)))) (cdr fn))
    1542                   ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) blas:ccopy)
    1543      (blas-level2-wrap ,(cons (string->symbol (conc "blas:z" (symbol->string (car fn)))) (cdr fn))
    1544                         ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) blas:zcopy)))
    1545 
    1546 
    1547 (blas-level2-wrapx (gemv order trans m n alpha a lda x incx beta y incy)
    1548                    (y)
    1549                    (lambda (i) (cond ((= i 2)  "M < 0")
    1550                                      ((= i 3)  "N < 0")
    1551                                      ((= i 6)  "LDA < max(1, M)")
    1552                                      ((= i 8)  "INCX = 0")
    1553                                      ((= i 11) "INCY < = 0")
    1554                                      (else (conc "error code " i)))))
    1555 
    1556 (blas-level2-cz-wrapx (hemv order uplo n alpha a lda x incx beta y incy)
    1557                       (y)
    1558                       (lambda (i) (cond ((= i 2)  "M < 0")
    1559                                         ((= i 3)  "N < 0")
    1560                                         ((= i 6)  "LDA < max(1, M)")
    1561                                         ((= i 8)  "INCX = 0")
    1562                                         ((= i 11) "INCY < = 0")
    1563                                         (else (conc "error code " i)))))
    1564 
    1565 (blas-level2-cz-wrapx (hbmv order uplo n k alpha a lda x incx beta y incy)
    1566                       (y)
    1567                       (lambda (i) (cond ((= i 2)  "M < 0")
    1568                                         ((= i 3)  "N < 0")
    1569                                         ((= i 6)  "LDA < max(1, M)")
    1570                                         ((= i 8)  "INCX = 0")
    1571                                         ((= i 11) "INCY < = 0")
    1572                                         (else (conc "error code " i)))))
    1573 
    1574 (blas-level2-cz-wrapx (hpmv order uplo n alpha ap x incx beta y incy)
    1575                       (y)
    1576                       (lambda (i) (cond ((= i 2)  "M < 0")
    1577                                         ((= i 3)  "N < 0")
    1578                                         ((= i 6)  "LDA < max(1, M)")
    1579                                         ((= i 8)  "INCX = 0")
    1580                                         ((= i 11) "INCY < = 0")
    1581                                         (else (conc "error code " i)))))
    1582 
    1583 (blas-level2-sd-wrapx (symv order uplo n alpha a lda x incx beta y incy)
    1584                       (y)
    1585                       (lambda (i) (cond ((= i 2)  "M < 0")
    1586                                         ((= i 3)  "N < 0")
    1587                                         ((= i 6)  "LDA < max(1, M)")
    1588                                         ((= i 8)  "INCX = 0")
    1589                                         ((= i 11) "INCY < = 0")
    1590                                         (else (conc "error code " i)))))
    1591 
    1592 (blas-level2-sd-wrapx (sbmv order uplo n k alpha a lda x incx beta y incy)
    1593                       (y)
    1594                       (lambda (i) (cond ((= i 2)  "M < 0")
    1595                                         ((= i 3)  "N < 0")
    1596                                         ((= i 6)  "LDA < max(1, M)")
    1597                                         ((= i 8)  "INCX = 0")
    1598                                         ((= i 11) "INCY < = 0")
    1599                                         (else (conc "error code " i)))))
    1600 
    1601 (blas-level2-sd-wrapx (spmv order uplo n alpha ap x incx beta y incy)
    1602                       (y)
    1603                       (lambda (i) (cond ((= i 2)  "M < 0")
    1604                                         ((= i 3)  "N < 0")
    1605                                         ((= i 6)  "LDA < max(1, M)")
    1606                                         ((= i 8)  "INCX = 0")
    1607                                         ((= i 11) "INCY < = 0")
    1608                                         (else (conc "error code " i)))))
    1609                              
    1610 (blas-level2-wrapx (trmv order uplo trans diag n a lda x incx)
    1611                    (x)
    1612                    (lambda (i) (cond ((= i 2)  "M < 0")
    1613                                      ((= i 3)  "N < 0")
    1614                                      ((= i 6)  "LDA < max(1, M)")
    1615                                      ((= i 8)  "INCX = 0")
    1616                                      ((= i 11) "INCY < = 0")
    1617                                      (else (conc "error code " i)))))
    1618                              
    1619 (blas-level2-wrapx (tbmv order uplo trans diag n k a lda x incx)
    1620                    (x)
    1621                    (lambda (i) (cond ((= i 2)  "M < 0")
    1622                                      ((= i 3)  "N < 0")
    1623                                      ((= i 6)  "LDA < max(1, M)")
    1624                                      ((= i 8)  "INCX = 0")
    1625                                      ((= i 11) "INCY < = 0")
    1626                                      (else (conc "error code " i)))))
    1627 
    1628 (blas-level2-wrapx (tpmv order uplo trans diag n ap x incx)
    1629                       (x)
    1630                       (lambda (i) (cond ((= i 2)  "M < 0")
    1631                                         ((= i 3)  "N < 0")
    1632                                         ((= i 6)  "LDA < max(1, M)")
    1633                                         ((= i 8)  "INCX = 0")
    1634                                         ((= i 11) "INCY < = 0")
    1635                                         (else (conc "error code " i)))))
    1636 
    1637 (blas-level2-wrapx (trsv order uplo trans diag n a lda x incx)
    1638                    (x)
    1639                    (lambda (i) (cond ((= i 2)  "M < 0")
    1640                                      ((= i 3)  "N < 0")
    1641                                      ((= i 6)  "LDA < max(1, M)")
    1642                                      ((= i 8)  "INCX = 0")
    1643                                      ((= i 11) "INCY < = 0")
    1644                                      (else (conc "error code " i)))))
    1645 
    1646 (blas-level2-wrapx (tbsv order uplo trans diag n k a lda x incx)
    1647                    (x)
    1648                    (lambda (i) (cond ((= i 2)  "M < 0")
    1649                                      ((= i 3)  "N < 0")
    1650                                      ((= i 6)  "LDA < max(1, M)")
    1651                                      ((= i 8)  "INCX = 0")
    1652                                      ((= i 11) "INCY < = 0")
    1653                                      (else (conc "error code " i)))))
    1654 
    1655 (blas-level2-wrapx (tpsv order uplo trans diag n ap x incx)
    1656                       (x)
    1657                       (lambda (i) (cond ((= i 2)  "M < 0")
    1658                                         ((= i 3)  "N < 0")
    1659                                         ((= i 6)  "LDA < max(1, M)")
    1660                                         ((= i 8)  "INCX = 0")
    1661                                         ((= i 11) "INCY < = 0")
    1662                                         (else (conc "error code " i)))))
    1663 
    1664 (blas-level2-sd-wrapx (ger order m n alpha x incx y incy a lda)
    1665                       (a)
    1666                       (lambda (i) (cond ((= i 2)  "M < 0")
    1667                                         ((= i 3)  "N < 0")
    1668                                         ((= i 6)  "LDA < max(1, M)")
    1669                                         ((= i 8)  "INCX = 0")
    1670                                         ((= i 11) "INCY < = 0")
    1671                                         (else (conc "error code " i)))))
    1672                              
    1673 (blas-level2-cz-wrapx (geru order m n alpha x incx y incy a lda)
    1674                       (a)
    1675                       (lambda (i) (cond ((= i 2)  "M < 0")
    1676                                         ((= i 3)  "N < 0")
    1677                                         ((= i 6)  "LDA < max(1, M)")
    1678                                         ((= i 8)  "INCX = 0")
    1679                                         ((= i 11) "INCY < = 0")
    1680                                         (else (conc "error code " i)))))
    1681                              
    1682 (blas-level2-cz-wrapx (gerc order m n alpha x incx y incy a lda)
    1683                       (a)
    1684                       (lambda (i) (cond ((= i 2)  "M < 0")
    1685                                         ((= i 3)  "N < 0")
    1686                                         ((= i 6)  "LDA < max(1, M)")
    1687                                         ((= i 8)  "INCX = 0")
    1688                                         ((= i 11) "INCY < = 0")
    1689                                         (else (conc "error code " i)))))
    1690                              
    1691                              
    1692 (blas-level2-cz-wrapx (her order uplo n alpha x incx a lda)
    1693                       (a)
    1694                       (lambda (i) (cond ((= i 2)  "M < 0")
    1695                                         ((= i 3)  "N < 0")
    1696                                         ((= i 6)  "LDA < max(1, M)")
    1697                                         ((= i 8)  "INCX = 0")
    1698                                         ((= i 11) "INCY < = 0")
    1699                                         (else (conc "error code " i)))))
    1700                              
    1701 (blas-level2-cz-wrapx (hpr order uplo n alpha x incx ap)
    1702                       (ap)
    1703                       (lambda (i) (cond ((= i 2)  "M < 0")
    1704                                         ((= i 3)  "N < 0")
    1705                                         ((= i 6)  "LDA < max(1, M)")
    1706                                         ((= i 8)  "INCX = 0")
    1707                                         ((= i 11) "INCY < = 0")
    1708                                         (else (conc "error code " i)))))
    1709                              
    1710 (blas-level2-cz-wrapx (her2 order uplo n alpha x incx y incy a lda)
    1711                       (a)
    1712                       (lambda (i) (cond ((= i 2)  "M < 0")
    1713                                         ((= i 3)  "N < 0")
    1714                                         ((= i 6)  "LDA < max(1, M)")
    1715                                         ((= i 8)  "INCX = 0")
    1716                                         ((= i 11) "INCY < = 0")
    1717                                         (else (conc "error code " i)))))
    1718                              
    1719 (blas-level2-cz-wrapx (hpr2 order uplo n alpha x incx y incy ap)
    1720                       (ap)
    1721                       (lambda (i) (cond ((= i 2)  "M < 0")
    1722                                         ((= i 3)  "N < 0")
    1723                                         ((= i 6)  "LDA < max(1, M)")
    1724                                         ((= i 8)  "INCX = 0")
    1725                                         ((= i 11) "INCY < = 0")
    1726                                         (else (conc "error code " i)))))
    1727                              
    1728 (blas-level2-sd-wrapx (syr order uplo n alpha x incx a lda)
    1729                       (a)
    1730                       (lambda (i) (cond ((= i 2)  "M < 0")
    1731                                         ((= i 3)  "N < 0")
    1732                                         ((= i 6)  "LDA < max(1, M)")
    1733                                         ((= i 8)  "INCX = 0")
    1734                                         ((= i 11) "INCY < = 0")
    1735                                         (else (conc "error code " i)))))
    1736                              
    1737 (blas-level2-sd-wrapx (spr order uplo n alpha x incx ap)
    1738                       (ap)
    1739                       (lambda (i) (cond ((= i 2)  "M < 0")
    1740                                         ((= i 3)  "N < 0")
    1741                                         ((= i 6)  "LDA < max(1, M)")
    1742                                         ((= i 8)  "INCX = 0")
    1743                                         ((= i 11) "INCY < = 0")
    1744                                         (else (conc "error code " i)))))
    1745                              
    1746 (blas-level2-sd-wrapx (syr2 order uplo n alpha x incx y incy a lda)
    1747                       (a)
    1748                       (lambda (i) (cond ((= i 2)  "M < 0")
    1749                                         ((= i 3)  "N < 0")
    1750                                         ((= i 6)  "LDA < max(1, M)")
    1751                                         ((= i 8)  "INCX = 0")
    1752                                         ((= i 11) "INCY < = 0")
    1753                                         (else (conc "error code " i)))))
    1754                              
    1755 (blas-level2-sd-wrapx (ger order m n alpha x incx y incy a lda)
    1756                       (a)
    1757                       (lambda (i) (cond ((= i 2)  "M < 0")
    1758                                         ((= i 3)  "N < 0")
    1759                                         ((= i 6)  "LDA < max(1, M)")
    1760                                         ((= i 8)  "INCX = 0")
    1761                                         ((= i 11) "INCY < = 0")
    1762                                         (else (conc "error code " i)))))
    1763                              
    1764 (blas-level2-sd-wrapx (iger order m n alpha x incx offx y incy offy a lda)
    1765                       (a)
    1766                       (lambda (i) (cond ((= i 2)  "M < 0")
    1767                                         ((= i 3)  "N < 0")
    1768                                         ((= i 6)  "LDA < max(1, M)")
    1769                                         ((= i 8)  "INCX = 0")
    1770                                         ((= i 11) "INCY < = 0")
    1771                                         (else (conc "error code " i)))))
    1772                              
    1773 (blas-level2-cz-wrapx (geru order m n alpha x incx y incy a lda)
    1774                       (a)
    1775                       (lambda (i) (cond ((= i 2)  "M < 0")
    1776                                         ((= i 3)  "N < 0")
    1777                                         ((= i 6)  "LDA < max(1, M)")
    1778                                         ((= i 8)  "INCX = 0")
    1779                                         ((= i 11) "INCY < = 0")
    1780                                         (else (conc "error code " i)))))
    1781                              
    1782 (blas-level2-cz-wrapx (gerc order m n alpha x incx y incy a lda)
    1783                       (a)
    1784                       (lambda (i) (cond ((= i 2)  "M < 0")
    1785                                         ((= i 3)  "N < 0")
    1786                                         ((= i 6)  "LDA < max(1, M)")
    1787                                         ((= i 8)  "INCX = 0")
    1788                                         ((= i 11) "INCY < = 0")
    1789                                         (else (conc "error code " i)))))
    1790                              
    1791                              
    1792 (blas-level2-cz-wrapx (her order uplo n alpha x incx a lda)
    1793                       (a)
    1794                       (lambda (i) (cond ((= i 2)  "M < 0")
    1795                                         ((= i 3)  "N < 0")
    1796                                         ((= i 6)  "LDA < max(1, M)")
    1797                                         ((= i 8)  "INCX = 0")
    1798                                         ((= i 11) "INCY < = 0")
    1799                                         (else (conc "error code " i)))))
    1800                              
    1801 (blas-level2-cz-wrapx (hpr order uplo n alpha x incx ap)
    1802                       (ap)
    1803                       (lambda (i) (cond ((= i 2)  "M < 0")
    1804                                         ((= i 3)  "N < 0")
    1805                                         ((= i 6)  "LDA < max(1, M)")
    1806                                         ((= i 8)  "INCX = 0")
    1807                                         ((= i 11) "INCY < = 0")
    1808                                         (else (conc "error code " i)))))
    1809                              
    1810 (blas-level2-cz-wrapx (her2 order uplo n alpha x incx y incy a lda)
    1811                       (a)
    1812                       (lambda (i) (cond ((= i 2)  "M < 0")
    1813                                         ((= i 3)  "N < 0")
    1814                                         ((= i 6)  "LDA < max(1, M)")
    1815                                         ((= i 8)  "INCX = 0")
    1816                                         ((= i 11) "INCY < = 0")
    1817                                         (else (conc "error code " i)))))
    1818                              
    1819 (blas-level2-cz-wrapx (hpr2 order uplo n alpha x incx y incy ap)
    1820                       (ap)
    1821                       (lambda (i) (cond ((= i 2)  "M < 0")
    1822                                         ((= i 3)  "N < 0")
    1823                                         ((= i 6)  "LDA < max(1, M)")
    1824                                         ((= i 8)  "INCX = 0")
    1825                                         ((= i 11) "INCY < = 0")
    1826                                         (else (conc "error code " i)))))
    1827                              
    1828 (blas-level2-sd-wrapx (syr order uplo n alpha x incx a lda)
    1829                       (a)
    1830                       (lambda (i) (cond ((= i 2)  "M < 0")
    1831                                         ((= i 3)  "N < 0")
    1832                                         ((= i 6)  "LDA < max(1, M)")
    1833                                         ((= i 8)  "INCX = 0")
    1834                                         ((= i 11) "INCY < = 0")
    1835                                         (else (conc "error code " i)))))
    1836                              
    1837 (blas-level2-sd-wrapx (spr order uplo n alpha x incx ap)
    1838                       (ap)
    1839                       (lambda (i) (cond ((= i 2)  "M < 0")
    1840                                         ((= i 3)  "N < 0")
    1841                                         ((= i 6)  "LDA < max(1, M)")
    1842                                         ((= i 8)  "INCX = 0")
    1843                                         ((= i 11) "INCY < = 0")
    1844                                         (else (conc "error code " i)))))
    1845                              
    1846 (blas-level2-sd-wrapx (syr2 order uplo n alpha x incx y incy a lda)
    1847                       (a)
    1848                       (lambda (i) (cond ((= i 2)  "M < 0")
    1849                                         ((= i 3)  "N < 0")
    1850                                         ((= i 6)  "LDA < max(1, M)")
    1851                                         ((= i 8)  "INCX = 0")
    1852                                         ((= i 11) "INCY < = 0")
    1853                                         (else (conc "error code " i)))))
    1854                              
    1855 (blas-level2-sd-wrapx (spr2 order uplo n alpha x incx y incy ap)
    1856                       (ap)
    1857                       (lambda (i) (cond ((= i 2)  "M < 0")
    1858                                         ((= i 3)  "N < 0")
    1859                                         ((= i 6)  "LDA < max(1, M)")
    1860                                         ((= i 8)  "INCX = 0")
    1861                                         ((= i 11) "INCY < = 0")
    1862                                         (else (conc "error code " i)))))
    1863 
    1864 
    1865 
    1866 
    1867 (define-macro (blas-level1-wrap fn ret err vsize copy . make-return)
    1868   (let ((cfname (string->symbol (conc "c" (symbol->string (car fn)))))
    1869         (fname (string->symbol (conc (if vsize "" "unsafe-")
    1870                                      (symbol->string (car fn))
    1871                                      (if copy "" "!"))))
    1872         (args  (reverse (cdr fn))))
    1873     (let ((fsig  (let loop ((args args) (sig 'rest))
    1874                    (if (null? args) (cons fname sig)
    1875                        (let ((x (car args)))
    1876                          (let ((sig (case x
    1877                                       ((incx)     sig)
    1878                                       ((incy)     sig)
    1879                                       ((dotu)     sig)
    1880                                       ((dotc)     sig)
    1881                                       ((offx)     sig)
    1882                                       ((offy)     sig)
    1883                                       (else      (cons x sig)))))
    1884                            (loop (cdr args) sig))))))
    1885           (opts  (cond ((memq 'incy fn)  `((incx 1) (incy 1) (offx 0) (offy 0)))
    1886                        (else `((incx 1) (offx 0))))))
    1887       `(define ,fsig
    1888          (let-optionals rest ,opts
    1889           ,(if vsize
    1890                `(begin
    1891                   ,(if (memq 'y fn)
    1892                        `(let ((ysize (,vsize y))
    1893                               (ydim  (fx+ 1 (fx* (abs incy) (fx- (fx+ offy n) 1)))))
    1894                           (if (< ysize ydim)
    1895                               (blas:error ',fname (conc "vector Y is allocated " ysize " elements "
    1896                                                         "but given dimension is " ydim))))
    1897                        `(noop))
    1898                   ,(if (memq 'x fn)
    1899                        `(let ((xsize (,vsize x))
    1900                               (xdim  (fx+ 1 (fx* (abs incx) (fx- (fx+ offx n) 1)))))
    1901                           (if (< xsize xdim)
    1902                               (blas:error ',fname (conc "vector X is allocated " xsize " elements "
    1903                                                        "but given dimension is " xdim))))
    1904                        `(noop))
    1905                   ,(if (memq 'param fn)
    1906                        `(let ((psize (,vsize param))
    1907                               (pdim  5))
    1908                           (if (< psize pdim)
    1909                               (blas:error ',fname (conc "vector PARAM is allocated " psize " elements "
    1910                                                        "but dimension must be " pdim))))
    1911                        `(noop)))
    1912                  
    1913                `(noop))
    1914           (let ,(let loop ((fn fn) (bnds '()))
    1915                   (if (null? fn) bnds
    1916                       (let ((x (car fn)))
    1917                         (let ((bnds (cond ((or (eq? x 'dotc) (eq? x 'dotu))
    1918                                            (cons `(,x (,(car make-return))) bnds))
    1919                                           ((and copy (memq x ret))
    1920                                            (cons `(,x (,copy ,x)) bnds))
    1921                                           (else bnds))))
    1922                           (loop (cdr fn) bnds)))))
    1923             ,(cond
    1924               ((memq 'dotc fn)   `(begin (,cfname . ,(cdr fn))
    1925                                          (values dotc)))
    1926               ((memq 'dotu fn)   `(begin (,cfname . ,(cdr fn))
    1927                                          (values dotu)))
    1928               ((null? ret)       `(,cfname . ,(cdr fn)))
    1929               (else              `(begin (,cfname . ,(cdr fn))
    1930                                          (values . ,ret))))))))))
    1931 
    1932 
    1933 (define-macro (blas-level1-wrapx fn ret errs)
    1934   (if (null? ret)
    1935   `(begin
    1936      (blas-level1-wrap ,(cons (string->symbol (conc "blas:s" (symbol->string (car fn)))) (cdr fn))
    1937                        ,ret ,errs f32vector-length  blas:scopy)
    1938      (blas-level1-wrap ,(cons (string->symbol (conc "blas:d" (symbol->string (car fn)))) (cdr fn))
    1939                        ,ret ,errs f64vector-length  blas:dcopy)
    1940      (blas-level1-wrap ,(cons (string->symbol (conc "blas:c" (symbol->string (car fn)))) (cdr fn))
    1941                        ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) blas:ccopy)
    1942      (blas-level1-wrap ,(cons (string->symbol (conc "blas:z" (symbol->string (car fn)))) (cdr fn))
    1943                        ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) blas:zcopy))
    1944  
    1945   `(begin
    1946      (blas-level1-wrap ,(cons (string->symbol (conc "blas:s" (symbol->string (car fn)))) (cdr fn))
    1947                        ,ret ,errs #f #f)
    1948      (blas-level1-wrap ,(cons (string->symbol (conc "blas:d" (symbol->string (car fn)))) (cdr fn))
    1949                        ,ret ,errs #f #f)
    1950      (blas-level1-wrap ,(cons (string->symbol (conc "blas:c" (symbol->string (car fn)))) (cdr fn))
    1951                        ,ret ,errs #f #f)
    1952      (blas-level1-wrap ,(cons (string->symbol (conc "blas:z" (symbol->string (car fn)))) (cdr fn))
    1953                        ,ret ,errs #f #f)
    1954      
    1955      (blas-level1-wrap ,(cons (string->symbol (conc "blas:s" (symbol->string (car fn)))) (cdr fn))
    1956                        ,ret ,errs f32vector-length #f)
    1957      (blas-level1-wrap ,(cons (string->symbol (conc "blas:d" (symbol->string (car fn)))) (cdr fn))
    1958                        ,ret ,errs f64vector-length #f)
    1959      (blas-level1-wrap ,(cons (string->symbol (conc "blas:c" (symbol->string (car fn)))) (cdr fn))
    1960                        ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) #f)
    1961      (blas-level1-wrap ,(cons (string->symbol (conc "blas:z" (symbol->string (car fn)))) (cdr fn))
    1962                        ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) #f)
    1963      
    1964      (blas-level1-wrap ,(cons (string->symbol (conc "blas:s" (symbol->string (car fn)))) (cdr fn))
    1965                        ,ret ,errs f32vector-length  blas:scopy)
    1966      (blas-level1-wrap ,(cons (string->symbol (conc "blas:d" (symbol->string (car fn)))) (cdr fn))
    1967                        ,ret ,errs f64vector-length  blas:dcopy)
    1968      (blas-level1-wrap ,(cons (string->symbol (conc "blas:c" (symbol->string (car fn)))) (cdr fn))
    1969                        ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) blas:ccopy)
    1970      (blas-level1-wrap ,(cons (string->symbol (conc "blas:z" (symbol->string (car fn)))) (cdr fn))
    1971                        ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) blas:zcopy))))
    1972 
    1973 
    1974 (define-macro (blas-level1-sd-wrapx fn ret errs)
    1975   (if (null? ret)
    1976      
    1977   `(begin
    1978      (blas-level1-wrap ,(cons (string->symbol (conc "blas:s" (symbol->string (car fn)))) (cdr fn))
    1979                        ,ret ,errs f32vector-length  blas:scopy)
    1980      (blas-level1-wrap ,(cons (string->symbol (conc "blas:d" (symbol->string (car fn)))) (cdr fn))
    1981                        ,ret ,errs f64vector-length  blas:dcopy))
    1982 
    1983   `(begin
    1984      (blas-level1-wrap ,(cons (string->symbol (conc "blas:s" (symbol->string (car fn)))) (cdr fn))
    1985                        ,ret ,errs #f #f)
    1986      (blas-level1-wrap ,(cons (string->symbol (conc "blas:d" (symbol->string (car fn)))) (cdr fn))
    1987                        ,ret ,errs #f #f)
    1988 
    1989      (blas-level1-wrap ,(cons (string->symbol (conc "blas:s" (symbol->string (car fn)))) (cdr fn))
    1990                        ,ret ,errs f32vector-length #f)
    1991      (blas-level1-wrap ,(cons (string->symbol (conc "blas:d" (symbol->string (car fn)))) (cdr fn))
    1992                        ,ret ,errs f64vector-length #f)
    1993      
    1994      (blas-level1-wrap ,(cons (string->symbol (conc "blas:s" (symbol->string (car fn)))) (cdr fn))
    1995                        ,ret ,errs f32vector-length  blas:scopy)
    1996      (blas-level1-wrap ,(cons (string->symbol (conc "blas:d" (symbol->string (car fn)))) (cdr fn))
    1997                        ,ret ,errs f64vector-length  blas:dcopy))))
    1998 
    1999 
    2000 
    2001 (define-macro (blas-level1-cz-wrapx fn ret errs)
    2002   (if (null? ret)
    2003       `(begin
    2004          (blas-level1-wrap ,(cons (string->symbol (conc "blas:c" (symbol->string (car fn)))) (cdr fn))
    2005                            ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v)))
    2006                            blas:ccopy (lambda () (make-f32vector 2)))
    2007          (blas-level1-wrap ,(cons (string->symbol (conc "blas:z" (symbol->string (car fn)))) (cdr fn))
    2008                            ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v)))
    2009                            blas:zcopy (lambda () (make-f64vector 2))))
    2010 
    2011       `(begin
    2012          (blas-level1-wrap ,(cons (string->symbol (conc "blas:c" (symbol->string (car fn)))) (cdr fn))
    2013                            ,ret ,errs #f #f)
    2014          (blas-level1-wrap ,(cons (string->symbol (conc "blas:z" (symbol->string (car fn)))) (cdr fn))
    2015                            ,ret ,errs #f #f)
    2016          
    2017          (blas-level1-wrap ,(cons (string->symbol (conc "blas:c" (symbol->string (car fn)))) (cdr fn))
    2018                            ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) #f)
    2019          (blas-level1-wrap ,(cons (string->symbol (conc "blas:z" (symbol->string (car fn)))) (cdr fn))
    2020                            ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) #f)
    2021          
    2022          (blas-level1-wrap ,(cons (string->symbol (conc "blas:c" (symbol->string (car fn)))) (cdr fn))
    2023                            ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) blas:ccopy)
    2024          (blas-level1-wrap ,(cons (string->symbol (conc "blas:z" (symbol->string (car fn)))) (cdr fn))
    2025                            ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) blas:zcopy))))
    2026 
    2027 
    2028 (blas-level1-sd-wrapx (rot n x incx y incy c s)
    2029                       (x y)
    2030                       (lambda (i) (cond (conc "error code " i))))
    2031 
    2032 (blas-level1-sd-wrapx (rotm n x incx y incy param)
    2033                       (x y)
    2034                       (lambda (i) (cond (conc "error code " i))))
    2035 
    2036 (blas-level1-wrapx (swap n x incx y incy)
    2037                    (x y)
    2038                    (lambda (i) (cond (conc "error code " i))))
    2039 
    2040 (blas-level1-wrapx (scal n alpha x incx)
    2041                    (x)
    2042                    (lambda (i) (cond (conc "error code " i))))
    2043 
    2044 (blas-level1-wrapx (axpy n alpha x incx y incy)
    2045                    (y)
    2046                    (lambda (i) (cond (conc "error code " i))))
    2047 
    2048 (blas-level1-wrapx (iaxpy n alpha x incx offx y incy offy)
    2049                    (y)
    2050                    (lambda (i) (cond (conc "error code " i))))
    2051 
    2052 (blas-level1-sd-wrapx (dot n x incx y incy)
    2053                    ()
    2054                    (lambda (i) (cond (conc "error code " i))))
    2055 
    2056 (blas-level1-cz-wrapx (dotu n x incx y incy dotu)
    2057                       ()
    2058                       (lambda (i) (cond (conc "error code " i))))
    2059 
    2060 (blas-level1-cz-wrapx (dotc n x incx y incy dotc)
    2061                       ()
    2062                       (lambda (i) (cond (conc "error code " i))))
    2063 
    2064 (blas-level1-wrapx (nrm2 n x incx)
    2065                    ()
    2066                    (lambda (i) (cond (conc "error code " i))))
    2067 
    2068 (blas-level1-wrapx (asum n x incx)
    2069                    ()
    2070                    (lambda (i) (cond (conc "error code " i))))
    2071 
    2072 (blas-level1-wrapx (amax n x incx)
    2073                    ()
    2074                    (lambda (i) (cond (conc "error code " i))))
    2075 
    2076 
     2202  (blas-level1-sd-wrapx (rot n x incx y incy c s)
     2203                        (x y)
     2204                        (lambda (i) (cond (conc "error code " i))))
     2205 
     2206  (blas-level1-sd-wrapx (rotm n x incx y incy param)
     2207                        (x y)
     2208                        (lambda (i) (cond (conc "error code " i))))
     2209 
     2210  (blas-level1-wrapx (swap n x incx y incy)
     2211                     (x y)
     2212                     (lambda (i) (cond (conc "error code " i))))
     2213 
     2214  (blas-level1-wrapx (scal n alpha x incx)
     2215                     (x)
     2216                     (lambda (i) (cond (conc "error code " i))))
     2217 
     2218  (blas-level1-wrapx (axpy n alpha x incx y incy)
     2219                     (y)
     2220                     (lambda (i) (cond (conc "error code " i))))
     2221 
     2222  (blas-level1-wrapx (iaxpy n alpha x incx offx y incy offy)
     2223                     (y)
     2224                     (lambda (i) (cond (conc "error code " i))))
     2225 
     2226  (blas-level1-sd-wrapx (dot n x incx y incy)
     2227                        #f
     2228                        (lambda (i) (cond (conc "error code " i))))
     2229 
     2230  (blas-level1-cz-wrapx (dotu n x incx y incy dotu)
     2231                        #f
     2232                        (lambda (i) (cond (conc "error code " i))))
     2233 
     2234  (blas-level1-cz-wrapx (dotc n x incx y incy dotc)
     2235                        #f
     2236                        (lambda (i) (cond (conc "error code " i))))
     2237 
     2238  (blas-level1-wrapx (nrm2 n x incx)
     2239                     #f
     2240                     (lambda (i) (cond (conc "error code " i))))
     2241 
     2242  (blas-level1-wrapx (asum n x incx)
     2243                     #f
     2244                     (lambda (i) (cond (conc "error code " i))))
     2245 
     2246  (blas-level1-wrapx (amax n x incx)
     2247                     #f
     2248                     (lambda (i) (cond (conc "error code " i))))
     2249  )
     2250
     2251)
  • release/4/blas/trunk/blas.setup

    r6636 r14621  
    1 ;;;; blas.setup
     1;; -*- Hen -*-
    22
    33(define (dynld-name fn)         
    44  (make-pathname #f fn ##sys#load-dynamic-extension))   
    55
    6 (define (make-blas-test header ldflags)
    7   `((try-compile
    8       ,(string-append "#include " header "\n"
    9                       "int main() { cblas_ddot(0, NULL, 0, NULL, 0); return 0; }\n")
    10       ldflags: ,ldflags)
    11     ,ldflags) )
     6(define (blas-try-compile header ldflags)
     7  (and (try-compile
     8        (string-append "#include " header "\n"
     9                       "int main() { cblas_ddot(0, NULL, 0, NULL, 0); return 0; }\n")
     10        ldflags: ldflags)
     11       ldflags ))
    1212
    13 (define-macro (blas-test fst . rest)
    14   `(define ld-options
    15      (cond ,@(map (lambda (p) (make-blas-test (car p) (cdr p)))
    16                   (cons fst rest))
    17            (else (error "unable to figure out BLAS library")))) )
     13(define-syntax blas-test
     14  (syntax-rules ()
     15    ((_ (flags ...))
     16     (condition-case (blas-try-compile flags ...)
     17                     (t ()    #f)))))
    1818
    19 (blas-test
    20   ("<cblas.h>"         . "-lcblas -lm")
    21   ("<gsl/gsl_cblas.h>" . "-lgsl -lgslcblas -lm")
    22   ("<atlas/cblas.h>"   . "-lcblas -lm")
    23   ("<lapack/cblas.h>"  . "-lcblas -lm")
    24   ("<Accelerate/Accelerate.h>" . "-framework Accelerate"))
    25 
     19(define ld-options
     20  (or (blas-test  ("<cblas.h>" "-lblas -lm"))
     21      (blas-test  ("<cblas.h>" "-lcblas -lm"))
     22      (blas-test  ("<gsl/gsl_cblas.h>" "-lgsl -lgslcblas -lm"))
     23      (blas-test  ("<atlas/cblas.h>" "-lcblas -lm"))
     24      (blas-test  ("<lapack/cblas.h>" "-lcblas -lm"))
     25      (blas-test  ("<Accelerate/Accelerate.h>" "-framework Accelerate"))
     26      (error "unable to figure out location of BLAS library")))
    2627
    2728(run (csi -qbs blas-eggdoc.scm > blas.html))
    2829
    29 (compile -s -d0 -O2 blas.scm -emit-exports blas.exports -L "\"" ,ld-options "\"" -X easyffi)
     30(compile -O2 -d0 -s blas.scm -j blas -L "\"" ,ld-options "\"" -X easyffi)
     31(compile -O2 -d0 -s blas.import.scm)
    3032
    3133(install-extension
    3234 'blas
    33  `(,(dynld-name "blas") "blas.html" "blas.exports")
    34  '((version 2.5)
     35 `(,(dynld-name "blas") ,(dynld-name "blas.import") )
     36 '((version 2.6)
    3537   (documentation "blas.html")
    36    (exports "blas.exports") ) )
     38   ))
     39
  • release/4/blas/trunk/tests/run.scm

    r5749 r14621  
    11
    2 (require-extension srfi-1)
    3 (require-extension blas)
    4 (require-extension testbase)
    5 (require-extension testbase-output-compact)
     2
     3(require-extension srfi-1 srfi-4 blas test)
    64
    75(define (zeros m n)
     
    1311    (list->f64vector (list-tabulate size (lambda (i) 1.0)))))
    1412
     13(define order blas:RowMajor)
    1514
    16 (define-test blas1-test "BLAS Level 1 Test"
    17   (initial
    18    (define order blas:RowMajor)
     15(define asym  (f64vector 1 2 3 2 1 3 3 3 1))
     16(define vsym  (f64vector 9 10 11))
    1917
    20    (define asym  (f64vector 1 2 3 2 1 3 3 3 1))
    21    (define vsym  (f64vector 9 10 11))
    22    
    23    (define j (f64vector 440.0 1112.0 1784.0 2456.0))
    24    (define h (f64vector 110.0 278.0 446.0 614.0)) )
     18(define j (f64vector 440.0 1112.0 1784.0 2456.0))
     19(define h (f64vector 110.0 278.0 446.0 614.0))
    2520 
    26   (test/equal "daxpy"
    27               (blas:daxpy 4 4.0 h (zeros 4 1))
    28               (f64vector 440.0 1112.0 1784.0 2456.0))
    2921
    30   (test/equal "ddot"
    31               (blas:ddot 4 j h)
    32               2661184.0) )
     22(test-group "BLAS Level 1 Test"
     23  (test "daxpy"
     24        (f64vector 440.0 1112.0 1784.0 2456.0)
     25        (blas:daxpy 4 4.0 h (zeros 4 1)))
     26
     27  (test "ddot"
     28        2661184.0
     29        (blas:ddot 4 j h))
     30  )
    3331
    3432
    35 (define-test blas2-test "BLAS Level 2 Test"
    36   (initial
    37    (define order blas:RowMajor)
     33(define order blas:RowMajor)
    3834
    39    (define asym  (f64vector 1 2 3 2 1 3 3 3 1))
    40    (define vsym  (f64vector 9 10 11))
     35(define asym  (f64vector 1 2 3 2 1 3 3 3 1))
     36(define vsym  (f64vector 9 10 11))
    4137   
    42    (define j (f64vector 440.0 1112.0 1784.0 2456.0))
    43    (define g (f64vector 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16))
    44    (define h (f64vector 110.0 278.0 446.0 614.0))
    45    (define v (f64vector 9 10 11 12)) )
     38(define j (f64vector 440.0 1112.0 1784.0 2456.0))
     39(define g (f64vector 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16))
     40(define h (f64vector 110.0 278.0 446.0 614.0))
     41(define v (f64vector 9 10 11 12))
    4642
    47   (test/equal "dgemv"
    48               (blas:dgemv order blas:NoTrans 4 4 1 g v 0 (zeros 4 1))
    49               (f64vector 110.0 278.0 446.0 614.0))
     43(test-group "BLAS Level 2 Test"
    5044
    51   (test/equal "dsymv"
    52               (blas:dsymv order blas:Upper 3 1.0 asym vsym 0.0 (zeros 3 1))
    53               (f64vector 62.0 61.0 68.0))
     45  (test "dgemv"
     46        (f64vector 110.0 278.0 446.0 614.0)
     47        (blas:dgemv order blas:NoTrans 4 4 1 g v 0 (zeros 4 1))
     48        )
    5449
    55   (test/equal "dsyr"
    56               (blas:dsyr order blas:Upper 4 1.0 v (zeros 4 4))
    57               (f64vector 81 90 99 108 0 100 110 120 0 0 121 132 0 0 0 144))
     50  (test "dsymv"
     51        (f64vector 62.0 61.0 68.0)
     52        (blas:dsymv order blas:Upper 3 1.0 asym vsym 0.0 (zeros 3 1))
     53        )
    5854
    59   (test/equal "dger"
    60               (blas:dger order 4 4 1.0 j h (ones 4 4))
    61               (f64vector 48401.0 122321.0 196241.0 270161.0 122321.0
     55  (test "dsyr"
     56        (f64vector 81 90 99 108 0 100 110 120 0 0 121 132 0 0 0 144)
     57        (blas:dsyr order blas:Upper 4 1.0 v (zeros 4 4))
     58        )
     59
     60  (test "dger"
     61        (f64vector 48401.0 122321.0 196241.0 270161.0 122321.0
    6262                         309137.0 495953.0 682769.0 196241.0 495953.0 795665.0 1095377.0
    63                          270161.0 682769.0 1095377.0 1507985.0)) )
     63                         270161.0 682769.0 1095377.0 1507985.0)
     64        (blas:dger order 4 4 1.0 j h (ones 4 4))
     65        )
     66  )
     67
     68(define order blas:RowMajor)
     69
     70(define asym  (f64vector 1 2 3 2 1 3 3 3 1))
     71
     72(define a (f64vector 1 2 3 4 5 6 7 8))
     73(define b (f64vector 1 2 3 4 5 6 7 8 9 10 11 12))
     74(define c (f64vector 9 10 11 12 13 14 15 16))
     75(define d (f64vector 70.0 80.0 90.0 158.0 184.0 210.0))
     76
     77(test-group "BLAS Level 3 Test"
     78
     79   (test "dgemm"
     80         (f64vector 70.0 80.0 90.0 158.0 184.0 210.0)
     81         (blas:dgemm order blas:NoTrans blas:NoTrans 2 3 4 1.0 a b 0.0 (zeros 2 3))
     82         )
     83   
     84   (test "dgemm transpose"
     85         (f64vector 860.0 1088.0 1316.0 1544.0 1000.0 1264.0 1528.0 1792.0 1140.0 1440.0 1740.0 2040.0)
     86         (blas:dgemm order blas:Trans blas:NoTrans 3 4 2 1.0 d a 0.0 (zeros 3 4))
     87         )
     88
     89   (test "dsymm"
     90         (f64vector 38.0 44.0 50.0 56.0 34.0 40.0 46.0 52.0 27.0 34.0 41.0 48.0)
     91         (blas:dsymm order blas:Left blas:Upper 3 4 1.0 asym b 0.0 (zeros 3 4))
     92         )
     93
     94   (test "dsyrk"
     95         (f64vector 30.0 70.0 0.0 174.0)
     96         (blas:dsyrk order blas:Upper blas:NoTrans 2 4 1.0 a 0.0 (zeros 2 2))
     97         )
     98
     99   (test "dsyrk transpose"
     100         (f64vector 26.0 32.0 38.0 44.0 0.0 40.0 48.0 56.0 0.0 0.0 58.0 68.0 0.0 0.0 0.0 80.0)
     101         (blas:dsyrk order blas:Upper blas:Trans 4 2 1.0 a 0.0 (zeros 4 4))
     102         )
     103
     104   (test "dsyr2k"
     105         (f64vector 220.0 428.0 0.0 764.0)
     106         (blas:dsyr2k order blas:Upper blas:NoTrans 2 4 1.0 a c 0.0 (zeros 2 2))
     107         )
     108)
    64109
    65110
    66 (define-test blas3-test "BLAS Level 3 Test"
    67   (initial
    68    (define order blas:RowMajor)
    69 
    70    (define asym  (f64vector 1 2 3 2 1 3 3 3 1))
    71 
    72    (define a (f64vector 1 2 3 4 5 6 7 8))
    73    (define b (f64vector 1 2 3 4 5 6 7 8 9 10 11 12))
    74    (define c (f64vector 9 10 11 12 13 14 15 16))
    75    (define d (f64vector 70.0 80.0 90.0 158.0 184.0 210.0)) )
    76 
    77    (test/equal "dgemm"
    78                (blas:dgemm order blas:NoTrans blas:NoTrans 2 3 4 1.0 a b 0.0 (zeros 2 3))
    79                (f64vector 70.0 80.0 90.0 158.0 184.0 210.0))
    80    
    81    (test/equal "dgemm transpose"
    82                (blas:dgemm order blas:Trans blas:NoTrans 3 4 2 1.0 d a 0.0 (zeros 3 4))
    83                (f64vector 860.0 1088.0 1316.0 1544.0 1000.0 1264.0 1528.0 1792.0 1140.0 1440.0 1740.0 2040.0))
    84 
    85    (test/equal "dsymm"
    86                (blas:dsymm order blas:Left blas:Upper 3 4 1.0 asym b 0.0 (zeros 3 4))
    87                (f64vector 38.0 44.0 50.0 56.0 34.0 40.0 46.0 52.0 27.0 34.0 41.0 48.0))
    88 
    89    (test/equal "dsyrk"
    90                (blas:dsyrk order blas:Upper blas:NoTrans 2 4 1.0 a 0.0 (zeros 2 2))
    91                (f64vector 30.0 70.0 0.0 174.0))
    92 
    93    (test/equal "dsyrk transpose"
    94                (blas:dsyrk order blas:Upper blas:Trans 4 2 1.0 a 0.0 (zeros 4 4))
    95                (f64vector 26.0 32.0 38.0 44.0 0.0 40.0 48.0 56.0 0.0 0.0 58.0 68.0 0.0 0.0 0.0 80.0))
    96 
    97    (test/equal "dsyr2k"
    98                (blas:dsyr2k order blas:Upper blas:NoTrans 2 4 1.0 a c 0.0 (zeros 2 2))
    99                (f64vector 220.0 428.0 0.0 764.0)) )
    100 
    101 (test::styler-set! blas1-test test::output-style-compact)
    102 (test::styler-set! blas2-test test::output-style-compact)
    103 (test::styler-set! blas3-test test::output-style-compact)
    104 (run-test "BLAS Test")
    105111
    106112
Note: See TracChangeset for help on using the changeset viewer.