;; Scheme interface to BLAS (module blas (RowMajor ColMajor NoTrans Trans ConjTrans Left Right Upper Lower Unit NonUnit sicopy dicopy cicopy zicopy scopy dcopy ccopy zcopy unsafe-sgemm! unsafe-dgemm! unsafe-cgemm! unsafe-zgemm! sgemm! dgemm! cgemm! zgemm! sgemm dgemm cgemm zgemm unsafe-ssymm! unsafe-dsymm! unsafe-csymm! unsafe-zsymm! ssymm! dsymm! csymm! zsymm! ssymm dsymm csymm zsymm unsafe-chemm! unsafe-zhemm! chemm! zhemm! chemm zhemm unsafe-ssyrk! unsafe-dsyrk! unsafe-csyrk! unsafe-zsyrk! ssyrk! dsyrk! csyrk! zsyrk! ssyrk dsyrk csyrk zsyrk unsafe-cherk! unsafe-zherk! cherk! zherk! cherk zherk unsafe-ssyr2k! unsafe-dsyr2k! unsafe-csyr2k! unsafe-zsyr2k! ssyr2k! dsyr2k! csyr2k! zsyr2k! ssyr2k dsyr2k csyr2k zsyr2k unsafe-cher2k! unsafe-zher2k! cher2k! zher2k! cher2k zher2k unsafe-strmm! unsafe-dtrmm! unsafe-ctrmm! unsafe-ztrmm! strmm! dtrmm! ctrmm! ztrmm! strmm dtrmm ctrmm ztrmm unsafe-strsm! unsafe-dtrsm! unsafe-ctrsm! unsafe-ztrsm! strsm! dtrsm! ctrsm! ztrsm! strsm dtrsm ctrsm ztrsm unsafe-sgemv! unsafe-dgemv! unsafe-cgemv! unsafe-zgemv! sgemv! dgemv! cgemv! zgemv! sgemv dgemv cgemv zgemv unsafe-chemv! unsafe-zhemv! chemv! zhemv! chemv zhemv unsafe-chbmv! unsafe-zhbmv! chbmv! zhbmv! chbmv zhbmv unsafe-chpmv! unsafe-zhpmv! chpmv! zhpmv! chpmv zhpmv unsafe-ssymv! unsafe-dsymv! ssymv! dsymv! ssymv dsymv unsafe-ssbmv! unsafe-dsbmv! ssbmv! dsbmv! ssbmv dsbmv unsafe-sspmv! unsafe-dspmv! sspmv! dspmv! sspmv dspmv unsafe-strmv! unsafe-dtrmv! unsafe-ctrmv! unsafe-ztrmv! strmv! dtrmv! ctrmv! ztrmv! strmv dtrmv ctrmv ztrmv unsafe-stbmv! unsafe-dtbmv! unsafe-ctbmv! unsafe-ztbmv! stbmv! dtbmv! ctbmv! ztbmv! stbmv dtbmv ctbmv ztbmv unsafe-stpmv! unsafe-dtpmv! unsafe-ctpmv! unsafe-ztpmv! stpmv! dtpmv! ctpmv! ztpmv! stpmv dtpmv ctpmv ztpmv unsafe-strsv! unsafe-dtrsv! unsafe-ctrsv! unsafe-ztrsv! strsv! dtrsv! ctrsv! ztrsv! strsv dtrsv ctrsv ztrsv unsafe-stbsv! unsafe-dtbsv! unsafe-ctbsv! unsafe-ztbsv! stbsv! dtbsv! ctbsv! ztbsv! stbsv dtbsv ctbsv ztbsv unsafe-stpsv! unsafe-dtpsv! unsafe-ctpsv! unsafe-ztpsv! stpsv! dtpsv! ctpsv! ztpsv! stpsv dtpsv ctpsv ztpsv unsafe-sger! unsafe-dger! sger! dger! sger dger unsafe-siger! unsafe-diger! siger! diger! siger diger unsafe-cgeru! unsafe-zgeru! cgeru! zgeru! cgeru zgeru unsafe-cgerc! unsafe-zgerc! cgerc! zgerc! cgerc zgerc unsafe-cher! unsafe-zher! cher! zher! cher zher unsafe-chpr! unsafe-zhpr! chpr! zhpr! chpr zhpr unsafe-cher2! unsafe-zher2! cher2! zher2! cher2 zher2 unsafe-chpr2! unsafe-zhpr2! chpr2! zhpr2! chpr2 zhpr2 unsafe-ssyr! unsafe-dsyr! ssyr! dsyr! ssyr dsyr unsafe-sspr! unsafe-dspr! sspr! dspr! sspr dspr unsafe-ssyr2! unsafe-dsyr2! ssyr2! dsyr2! ssyr2 dsyr2 unsafe-sspr2! unsafe-dspr2! sspr2! dspr2! sspr2 dspr2 unsafe-srot! unsafe-drot! srot! drot! srot drot unsafe-srotm! unsafe-drotm! srotm! drotm! srotm drotm unsafe-sswap! unsafe-dswap! unsafe-cswap! unsafe-zswap! sswap! dswap! cswap! zswap! sswap dswap cswap zswap unsafe-sscal! unsafe-dscal! unsafe-cscal! unsafe-zscal! sscal! dscal! cscal! zscal! sscal dscal cscal zscal unsafe-saxpy! unsafe-daxpy! unsafe-caxpy! unsafe-zaxpy! saxpy! daxpy! caxpy! zaxpy! saxpy daxpy caxpy zaxpy unsafe-siaxpy! unsafe-diaxpy! unsafe-ciaxpy! unsafe-ziaxpy! siaxpy! diaxpy! ciaxpy! ziaxpy! siaxpy diaxpy ciaxpy ziaxpy sdot ddot cdotu zdotu cdotc zdotc snrm2 dnrm2 cnrm2 znrm2 sasum dasum casum zasum samax damax camax zamax ) (import scheme (chicken base) (chicken foreign) (chicken fixnum) (chicken string) srfi-4 bind) (import-for-syntax (srfi 1) (chicken string)) (bind* #<0, calculate size needed for offsetY + elements with incY (fx+ offsetY (fx+ (fx* (abs incY) (fx- n 1)) 1)))))) ;; Skip bounds checking entirely for n = 0 (no-op case) (if (fx> n 0) ;; Only do bounds checking when we actually copy elements (,%cond ;; Check offsetX ((fx< offsetX 0) (error ',name (conc "offset of vector X (" offsetX ") is negative"))) ((fx>= offsetX xlen) (error ',name (conc "offset of vector X (" offsetX ") is greater than or equal to its length: " xlen))) ;; Check offsetY ((fx< offsetY 0) (error ',name (conc "offset of vector Y (" offsetY ") is negative"))) ((and y (fx>= offsetY ylen)) (error ',name (conc "offset of vector Y (" offsetY ") is greater than or equal to its length: " ylen))) ;; Check that source access pattern stays within bounds ((fx>= (fx+ offsetX (fx* (abs incX) (fx- n 1))) xlen) (error ',name (conc "source access beyond vector X bounds: last element at position " (fx+ offsetX (fx* (abs incX) (fx- n 1))) " >= " xlen))) ;; Check that destination access pattern stays within bounds ((and y (fx>= (fx+ offsetY (fx* (abs incY) (fx- n 1))) ylen)) (error ',name (conc "destination access beyond vector Y bounds: last element at position " (fx+ offsetY (fx* (abs incY) (fx- n 1))) " >= " ylen))))) (,%let ((y (,%or y (,make-vector ylen)))) (,copy n x incX offsetX y incY offsetY) y))))) ) ) (icopy-wrapper sicopy c_sicopy f32vector-length make-f32vector) (icopy-wrapper dicopy c_dicopy f64vector-length make-f64vector) (icopy-wrapper cicopy c_cicopy (lambda (x) (fx/ (f32vector-length x) 2)) (lambda (n) (make-f32vector (fx* 2 n)))) (icopy-wrapper zicopy c_zicopy (lambda (x) (fx/ (f64vector-length x) 2)) (lambda (n) (make-f64vector (fx* 2 n)))) (bind* #<symbol (conc "cblas_" (symbol->string (car fn))))) (fname (string->symbol (conc (if vsize "" "unsafe-") (symbol->string (car fn)) (if copy "" "!")))) (%define (r 'define)) (%begin (r 'begin)) (%let (r 'let)) (%cond (r 'cond)) (%or (r 'or)) (%if (r 'if)) (ka (r 'ka)) (kb (r 'kb)) (kc (r 'kc)) (asize (r 'asize)) (bsize (r 'bsize)) (csize (r 'csize)) (args (reverse (cdr fn))) ;; Build required arguments (required-args (let loop ((args args) (req '())) (if (null? args) req (let ((x (car args))) (case x ((lda ldb ldc) (loop (cdr args) req)) (else (loop (cdr args) (cons x req)))))))) ;; Build keyword defaults (keyword-defaults (append (if (memq 'lda fn) `((lda ,(cond ((memq 'side fn) `(,%if (= side Left) m n)) ((memq 'transA fn) `(,%if (= transA NoTrans) k ,(if (memq 'm fn) 'm 'n))) ((memq 'trans fn) `(,%if (= trans NoTrans) k n)) (else (cond ((memq 'm fn) 'm) (else 'n)))))) '()) (if (memq 'ldb fn) `((ldb ,(cond ((memq 'transB fn) `(,%if (= transB NoTrans) n k)) ((memq 'trans fn) `(,%if (= trans NoTrans) k n)) (else 'n)))) '()) (if (memq 'ldc fn) '((ldc n)) '())))) `(,%define (,fname ,@required-args #!key ,@(map (lambda (kw-default) (if (list? (cadr kw-default)) `(,(car kw-default) #f) `(,(car kw-default) ,(cadr kw-default)))) keyword-defaults)) ;; Handle computed keyword defaults (,%let ,(filter-map (lambda (kw-default) (if (list? (cadr kw-default)) `(,(car kw-default) (or ,(car kw-default) ,(cadr kw-default))) #f)) keyword-defaults) ,(if vsize `(,%begin (,%let ((,asize (,vsize a)) (,ka ,(cond ((memq 'side fn) `(,%if (= side Left) m n)) ((memq 'transA fn) `(,%if (= transA NoTrans) ,(if (memq 'm fn) 'm 'n) k)) ((memq 'trans fn) `(,%if (= trans NoTrans) ,(if (memq 'm fn) 'm 'n) k)) (else (if (memq 'm fn) 'm 'n))))) (,%if (< ,asize (fx* lda ,ka)) (error ',fname (conc "matrix A is allocated " ,asize " elements " "but given dimensions are " ,ka " by " lda)))) ,(if (memq 'b fn) `(,%let ((,bsize (,vsize b)) (,kb ,(cond ((memq 'transB fn) `(,%if (= transB NoTrans) k n)) ((memq 'trans fn) `(,%if (= trans NoTrans) n k)) (else 'm)))) (,%if (< ,bsize (fx* ldb ,kb)) (error ',fname (conc "matrix B is allocated " ,bsize " elements " "but given dimensions are " ,kb " by " ldb)))) `(begin)) ,(if (memq 'c fn) `(let ((,csize (,vsize c)) (,kc ,(if (memq 'm fn) 'm 'n))) (if (< ,csize (fx* ldc ,kc)) (error ',fname (conc "matrix C is allocated " ,csize " elements " "but given dimensions are " ,kc " by " ldc)))) `(begin))) `(begin)) (,%let ,(let loop ((fn fn) (bnds '())) (if (null? fn) bnds (let ((x (car fn))) (let ((bnds (case x (else (if (and copy ret (memq x ret)) (cons `(,x (,copy ,x)) bnds) bnds))))) (loop (cdr fn) bnds))))) (,%begin (,cfname . ,(cdr fn)) (values . ,ret)))))))) ) (define-syntax blas-level3-wrapx (er-macro-transformer (lambda (x r c) (let* ((fn (cadr x)) (ret (caddr x)) (errs (cadddr x))) `(begin ;; Unsafe versions (no bounds checking) (blas-level3-wrap ,(cons (string->symbol (conc "s" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs #f #f) (blas-level3-wrap ,(cons (string->symbol (conc "d" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs #f #f) (blas-level3-wrap ,(cons (string->symbol (conc "c" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs #f #f) (blas-level3-wrap ,(cons (string->symbol (conc "z" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs #f #f) ;; Safe versions with bounds checking (no copy) (blas-level3-wrap ,(cons (string->symbol (conc "s" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs f32vector-length #f) (blas-level3-wrap ,(cons (string->symbol (conc "d" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs f64vector-length #f) (blas-level3-wrap ,(cons (string->symbol (conc "c" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs (lambda (v) (fx/ (f32vector-length v) 2)) #f) (blas-level3-wrap ,(cons (string->symbol (conc "z" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs (lambda (v) (fx/ (f64vector-length v) 2)) #f) ;; Safe versions with bounds checking and copying (blas-level3-wrap ,(cons (string->symbol (conc "s" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs f32vector-length scopy) (blas-level3-wrap ,(cons (string->symbol (conc "d" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs f64vector-length dcopy) (blas-level3-wrap ,(cons (string->symbol (conc "c" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs (lambda (v) (fx/ (f32vector-length v) 2)) ccopy) (blas-level3-wrap ,(cons (string->symbol (conc "z" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs (lambda (v) (fx/ (f64vector-length v) 2)) zcopy)))) ) ) (define-syntax blas-level3-cz-wrapx (er-macro-transformer (lambda (x r c) (let* ((fn (cadr x)) (ret (caddr x)) (errs (cadddr x))) `(begin ;; Unsafe versions (blas-level3-wrap ,(cons (string->symbol (conc "c" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs #f #f) (blas-level3-wrap ,(cons (string->symbol (conc "z" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs #f #f) ;; Safe versions (no copy) (blas-level3-wrap ,(cons (string->symbol (conc "c" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs (lambda (v) (fx/ (f32vector-length v) 2)) #f) (blas-level3-wrap ,(cons (string->symbol (conc "z" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs (lambda (v) (fx/ (f64vector-length v) 2)) #f) ;; Safe versions with copying (blas-level3-wrap ,(cons (string->symbol (conc "c" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs (lambda (v) (fx/ (f32vector-length v) 2)) ccopy) (blas-level3-wrap ,(cons (string->symbol (conc "z" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs (lambda (v) (fx/ (f64vector-length v) 2)) zcopy)))) ) ) (blas-level3-wrapx (gemm order transA transB m n k alpha a lda b ldb beta c ldc) (c) (lambda (i) (cond ((= i 3) "M < 0") ((= i 4) "N < 0") ((= i 5) "K < 0") ((= i 8) "LDA < max(1, M or K)") ((= i 10) "LDB < max(1, N or K)") ((= i 13) "LDC < max(1, M)") (else (conc "error code " i))))) (blas-level3-wrapx (symm order side uplo m n alpha a lda b ldb beta c ldc) (c) (lambda (i) (cond ((= i 3) "M < 0") ((= i 4) "N < 0") ((= i 5) "K < 0") ((= i 8) "LDA < max(1, M or K)") ((= i 10) "LDB < max(1, N or K)") ((= i 13) "LDC < max(1, M)") (else (conc "error code " i))))) (blas-level3-cz-wrapx (hemm order side uplo m n alpha a lda b ldb beta c ldc) (c) (lambda (i) (cond ((= i 3) "M < 0") ((= i 4) "N < 0") ((= i 5) "K < 0") ((= i 8) "LDA < max(1, M or K)") ((= i 10) "LDB < max(1, N or K)") ((= i 13) "LDC < max(1, M)") (else (conc "error code " i))))) (blas-level3-wrapx (syrk order uplo trans n k alpha a lda beta c ldc) (c) (lambda (i) (cond ((= i 3) "M < 0") ((= i 4) "N < 0") ((= i 5) "K < 0") ((= i 8) "LDA < max(1, M or K)") ((= i 10) "LDB < max(1, N or K)") ((= i 13) "LDC < max(1, M)") (else (conc "error code " i))))) (blas-level3-cz-wrapx (herk order uplo trans n k alpha a lda beta c ldc) (c) (lambda (i) (cond ((= i 3) "M < 0") ((= i 4) "N < 0") ((= i 5) "K < 0") ((= i 8) "LDA < max(1, M or K)") ((= i 10) "LDB < max(1, N or K)") ((= i 13) "LDC < max(1, M)") (else (conc "error code " i))))) (blas-level3-wrapx (syr2k order uplo trans n k alpha a lda b ldb beta c ldc) (c) (lambda (i) (cond ((= i 3) "M < 0") ((= i 4) "N < 0") ((= i 5) "K < 0") ((= i 8) "LDA < max(1, M or K)") ((= i 10) "LDB < max(1, N or K)") ((= i 13) "LDC < max(1, M)") (else (conc "error code " i))))) (blas-level3-cz-wrapx (her2k order uplo trans n k alpha a lda b ldb beta c ldc) (c) (lambda (i) (cond ((= i 3) "M < 0") ((= i 4) "N < 0") ((= i 5) "K < 0") ((= i 8) "LDA < max(1, M or K)") ((= i 10) "LDB < max(1, N or K)") ((= i 13) "LDC < max(1, M)") (else (conc "error code " i))))) (blas-level3-wrapx (trmm order side uplo transA diag m n alpha a lda b ldb) (b) (lambda (i) (cond ((= i 3) "M < 0") ((= i 4) "N < 0") ((= i 5) "K < 0") ((= i 8) "LDA < max(1, M or K)") ((= i 10) "LDB < max(1, N or K)") ((= i 13) "LDC < max(1, M)") (else (conc "error code " i))))) (blas-level3-wrapx (trsm order side uplo transA diag m n alpha a lda b ldb) (b) (lambda (i) (cond ((= i 3) "M < 0") ((= i 4) "N < 0") ((= i 5) "K < 0") ((= i 8) "LDA < max(1, M or K)") ((= i 10) "LDB < max(1, N or K)") ((= i 13) "LDC < max(1, M)") (else (conc "error code " i))))) (define-syntax blas-level2-wrap (er-macro-transformer (lambda (x r c) (let* ((fn (cadr x)) (ret (caddr x)) (err (cadddr x)) (vsize (car (cddddr x))) (copy (cadr (cddddr x))) (cfname (string->symbol (conc "cblas_" (symbol->string (car fn))))) (fname (string->symbol (conc (if vsize "" "unsafe-") (symbol->string (car fn)) (if copy "" "!")))) (%define (r 'define)) (%begin (r 'begin)) (%let (r 'let)) (%cond (r 'cond)) (%or (r 'or)) (%if (r 'if)) (ka (r 'ka)) (asize (r 'asize)) (apsize (r 'apsize)) (apdim (r 'apdim)) (xsize (r 'xsize)) (ysize (r 'ysize)) (xdim (r 'xdim)) (ydim (r 'ydim)) (args (reverse (cdr fn))) ;; Build required arguments (required-args (let loop ((args args) (req '())) (if (null? args) req (let ((x (car args))) (case x ((lda incx incy offx offy) (loop (cdr args) req)) (else (loop (cdr args) (cons x req)))))))) ;; Build keyword defaults (keyword-defaults (append (if (memq 'lda fn) `((lda ,(cond ((memq 'k fn) `(fx+ 1 k)) (else 'n)))) '()) (if (memq 'incy fn) '((incx 1) (incy 1) (offx 0) (offy 0)) '((incx 1) (offx 0)))))) `(,%define (,fname ,@required-args #!key ,@(map (lambda (kw-default) (if (list? (cadr kw-default)) ;; Handle computed defaults `(,(car kw-default) #f) `(,(car kw-default) ,(cadr kw-default)))) keyword-defaults)) ;; Handle computed keyword defaults (,%let ,(filter-map (lambda (kw-default) (if (list? (cadr kw-default)) `(,(car kw-default) (or ,(car kw-default) ,(cadr kw-default))) #f)) keyword-defaults) ,(if vsize `(,%begin ,(if (memq 'a fn) `(,%let ((,asize (,vsize a)) (,ka ,(if (memq 'm fn) 'm 'n))) (,%if (< ,asize (fx* lda ,ka)) (error ',fname (conc "matrix A is allocated " ,asize " elements " "but given dimensions are " ,ka " by " lda)))) `(begin)) ,(if (memq 'ap fn) `(,%let ((,apsize (,vsize ap)) (,apdim (fx/ (fx* n (fx+ n 1)) 2))) (,%if (< ,apsize ,apdim) (error ',fname (conc "vector Ap is allocated " ,apsize " elements " "but given dimension is " ,apdim)))) `(begin)) ;,(if (memq 'y fn) ; `(,%let ((,ysize (,vsize y)) ; (,ydim ,(if (and (memq 'm fn) (memq 'trans fn)) ; `(,%if (= trans NoTrans) ; (fx+ 1 (fx+ offy (fx* (abs incy) (fx- m 1)))) ; (fx+ 1 (fx+ offy (fx* (abs incy) (fx- n 1))))) ; `(fx+ 1 (fx+ offy (fx* (abs incy) (fx- n 1))))))) ; (,%if (< ,ysize ,ydim) ; (error ',fname (conc "vector Y is allocated " ,ysize " elements " ; "but required dimension is " ,ydim)))) ; `(begin)) ,(if (memq 'x fn) `(,%let ((,xsize (,vsize x)) (,xdim ,(if (and (memq 'm fn) (memq 'trans fn)) `(,%if (= trans NoTrans) (fx+ 1 (fx+ offx (fx* (abs incx) (fx- n 1)))) (fx+ 1 (fx+ offx (fx* (abs incx) (fx- m 1))))) `(fx+ 1 (fx+ offx (fx* (abs incx) (fx- n 1))))))) (,%if (< ,xsize ,xdim) (error ',fname (conc "vector X is allocated " ,xsize " elements " "but required dimension is " ,xdim)))) `(begin))) `(begin)) (let ,(let loop ((fn fn) (bnds '())) (if (null? fn) bnds (let ((x (car fn))) (let ((bnds (case x (else (if (and copy ret (memq x ret)) (cons `(,x (,copy ,x)) bnds) bnds))))) (loop (cdr fn) bnds))))) (begin (,cfname . ,(cdr fn)) (values . ,ret)))))))) ) (define-syntax blas-level2-wrapx (er-macro-transformer (lambda (x r c) (let* ((fn (cadr x)) (ret (caddr x)) (errs (cadddr x))) `(begin ;; Unsafe versions (no bounds checking) (blas-level2-wrap ,(cons (string->symbol (conc "s" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs #f #f) (blas-level2-wrap ,(cons (string->symbol (conc "d" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs #f #f) (blas-level2-wrap ,(cons (string->symbol (conc "c" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs #f #f) (blas-level2-wrap ,(cons (string->symbol (conc "z" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs #f #f) ;; Safe versions with bounds checking (no copy) (blas-level2-wrap ,(cons (string->symbol (conc "s" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs f32vector-length #f) (blas-level2-wrap ,(cons (string->symbol (conc "d" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs f64vector-length #f) (blas-level2-wrap ,(cons (string->symbol (conc "c" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs (lambda (v) (fx/ (f32vector-length v) 2)) #f) (blas-level2-wrap ,(cons (string->symbol (conc "z" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs (lambda (v) (fx/ (f64vector-length v) 2)) #f) ;; Safe versions with bounds checking and copying (blas-level2-wrap ,(cons (string->symbol (conc "s" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs f32vector-length scopy) (blas-level2-wrap ,(cons (string->symbol (conc "d" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs f64vector-length dcopy) (blas-level2-wrap ,(cons (string->symbol (conc "c" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs (lambda (v) (fx/ (f32vector-length v) 2)) ccopy) (blas-level2-wrap ,(cons (string->symbol (conc "z" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs (lambda (v) (fx/ (f64vector-length v) 2)) zcopy)))) )) (define-syntax blas-level2-sd-wrapx (er-macro-transformer (lambda (x r c) (let* ((fn (cadr x)) (ret (caddr x)) (errs (cadddr x))) `(begin ;; Unsafe versions (blas-level2-wrap ,(cons (string->symbol (conc "s" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs #f #f) (blas-level2-wrap ,(cons (string->symbol (conc "d" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs #f #f) ;; Safe versions (no copy) (blas-level2-wrap ,(cons (string->symbol (conc "s" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs f32vector-length #f) (blas-level2-wrap ,(cons (string->symbol (conc "d" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs f64vector-length #f) ;; Safe versions with copying (blas-level2-wrap ,(cons (string->symbol (conc "s" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs f32vector-length scopy) (blas-level2-wrap ,(cons (string->symbol (conc "d" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs f64vector-length dcopy)))) )) (define-syntax blas-level2-cz-wrapx (er-macro-transformer (lambda (x r c) (let* ((fn (cadr x)) (ret (caddr x)) (errs (cadddr x))) `(begin ;; Unsafe versions (blas-level2-wrap ,(cons (string->symbol (conc "c" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs #f #f) (blas-level2-wrap ,(cons (string->symbol (conc "z" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs #f #f) ;; Safe versions (no copy) (blas-level2-wrap ,(cons (string->symbol (conc "c" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs (lambda (v) (fx/ (f32vector-length v) 2)) #f) (blas-level2-wrap ,(cons (string->symbol (conc "z" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs (lambda (v) (fx/ (f64vector-length v) 2)) #f) ;; Safe versions with copying (blas-level2-wrap ,(cons (string->symbol (conc "c" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs (lambda (v) (fx/ (f32vector-length v) 2)) ccopy) (blas-level2-wrap ,(cons (string->symbol (conc "z" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs (lambda (v) (fx/ (f64vector-length v) 2)) zcopy)))) )) (blas-level2-wrapx (gemv order trans m n alpha a lda x incx beta y incy) (y) (lambda (i) (cond ((= i 2) "M < 0") ((= i 3) "N < 0") ((= i 6) "LDA < max(1, M)") ((= i 8) "INCX = 0") ((= i 11) "INCY < = 0") (else (conc "error code " i))))) (blas-level2-cz-wrapx (hemv order uplo n alpha a lda x incx beta y incy) (y) (lambda (i) (cond ((= i 2) "M < 0") ((= i 3) "N < 0") ((= i 6) "LDA < max(1, M)") ((= i 8) "INCX = 0") ((= i 11) "INCY < = 0") (else (conc "error code " i))))) (blas-level2-cz-wrapx (hbmv order uplo n k alpha a lda x incx beta y incy) (y) (lambda (i) (cond ((= i 2) "M < 0") ((= i 3) "N < 0") ((= i 6) "LDA < max(1, M)") ((= i 8) "INCX = 0") ((= i 11) "INCY < = 0") (else (conc "error code " i))))) (blas-level2-cz-wrapx (hpmv order uplo n alpha ap x incx beta y incy) (y) (lambda (i) (cond ((= i 2) "M < 0") ((= i 3) "N < 0") ((= i 6) "LDA < max(1, M)") ((= i 8) "INCX = 0") ((= i 11) "INCY < = 0") (else (conc "error code " i))))) (blas-level2-sd-wrapx (symv order uplo n alpha a lda x incx beta y incy) (y) (lambda (i) (cond ((= i 2) "M < 0") ((= i 3) "N < 0") ((= i 6) "LDA < max(1, M)") ((= i 8) "INCX = 0") ((= i 11) "INCY < = 0") (else (conc "error code " i))))) (blas-level2-sd-wrapx (sbmv order uplo n k alpha a lda x incx beta y incy) (y) (lambda (i) (cond ((= i 2) "M < 0") ((= i 3) "N < 0") ((= i 6) "LDA < max(1, M)") ((= i 8) "INCX = 0") ((= i 11) "INCY < = 0") (else (conc "error code " i))))) (blas-level2-sd-wrapx (spmv order uplo n alpha ap x incx beta y incy) (y) (lambda (i) (cond ((= i 2) "M < 0") ((= i 3) "N < 0") ((= i 6) "LDA < max(1, M)") ((= i 8) "INCX = 0") ((= i 11) "INCY < = 0") (else (conc "error code " i))))) (blas-level2-wrapx (trmv order uplo trans diag n a lda x incx) (x) (lambda (i) (cond ((= i 2) "M < 0") ((= i 3) "N < 0") ((= i 6) "LDA < max(1, M)") ((= i 8) "INCX = 0") ((= i 11) "INCY < = 0") (else (conc "error code " i))))) (blas-level2-wrapx (tbmv order uplo trans diag n k a lda x incx) (x) (lambda (i) (cond ((= i 2) "M < 0") ((= i 3) "N < 0") ((= i 6) "LDA < max(1, M)") ((= i 8) "INCX = 0") ((= i 11) "INCY < = 0") (else (conc "error code " i))))) (blas-level2-wrapx (tpmv order uplo trans diag n ap x incx) (x) (lambda (i) (cond ((= i 2) "M < 0") ((= i 3) "N < 0") ((= i 6) "LDA < max(1, M)") ((= i 8) "INCX = 0") ((= i 11) "INCY < = 0") (else (conc "error code " i))))) (blas-level2-wrapx (trsv order uplo trans diag n a lda x incx) (x) (lambda (i) (cond ((= i 2) "M < 0") ((= i 3) "N < 0") ((= i 6) "LDA < max(1, M)") ((= i 8) "INCX = 0") ((= i 11) "INCY < = 0") (else (conc "error code " i))))) (blas-level2-wrapx (tbsv order uplo trans diag n k a lda x incx) (x) (lambda (i) (cond ((= i 2) "M < 0") ((= i 3) "N < 0") ((= i 6) "LDA < max(1, M)") ((= i 8) "INCX = 0") ((= i 11) "INCY < = 0") (else (conc "error code " i))))) (blas-level2-wrapx (tpsv order uplo trans diag n ap x incx) (x) (lambda (i) (cond ((= i 2) "M < 0") ((= i 3) "N < 0") ((= i 6) "LDA < max(1, M)") ((= i 8) "INCX = 0") ((= i 11) "INCY < = 0") (else (conc "error code " i))))) (blas-level2-sd-wrapx (ger order m n alpha x incx y incy a lda) (a) (lambda (i) (cond ((= i 2) "M < 0") ((= i 3) "N < 0") ((= i 6) "LDA < max(1, M)") ((= i 8) "INCX = 0") ((= i 11) "INCY < = 0") (else (conc "error code " i))))) (blas-level2-cz-wrapx (geru order m n alpha x incx y incy a lda) (a) (lambda (i) (cond ((= i 2) "M < 0") ((= i 3) "N < 0") ((= i 6) "LDA < max(1, M)") ((= i 8) "INCX = 0") ((= i 11) "INCY < = 0") (else (conc "error code " i))))) (blas-level2-cz-wrapx (gerc order m n alpha x incx y incy a lda) (a) (lambda (i) (cond ((= i 2) "M < 0") ((= i 3) "N < 0") ((= i 6) "LDA < max(1, M)") ((= i 8) "INCX = 0") ((= i 11) "INCY < = 0") (else (conc "error code " i))))) (blas-level2-cz-wrapx (her order uplo n alpha x incx a lda) (a) (lambda (i) (cond ((= i 2) "M < 0") ((= i 3) "N < 0") ((= i 6) "LDA < max(1, M)") ((= i 8) "INCX = 0") ((= i 11) "INCY < = 0") (else (conc "error code " i))))) (blas-level2-cz-wrapx (hpr order uplo n alpha x incx ap) (ap) (lambda (i) (cond ((= i 2) "M < 0") ((= i 3) "N < 0") ((= i 6) "LDA < max(1, M)") ((= i 8) "INCX = 0") ((= i 11) "INCY < = 0") (else (conc "error code " i))))) (blas-level2-cz-wrapx (her2 order uplo n alpha x incx y incy a lda) (a) (lambda (i) (cond ((= i 2) "M < 0") ((= i 3) "N < 0") ((= i 6) "LDA < max(1, M)") ((= i 8) "INCX = 0") ((= i 11) "INCY < = 0") (else (conc "error code " i))))) (blas-level2-cz-wrapx (hpr2 order uplo n alpha x incx y incy ap) (ap) (lambda (i) (cond ((= i 2) "M < 0") ((= i 3) "N < 0") ((= i 6) "LDA < max(1, M)") ((= i 8) "INCX = 0") ((= i 11) "INCY < = 0") (else (conc "error code " i))))) (blas-level2-sd-wrapx (syr order uplo n alpha x incx a lda) (a) (lambda (i) (cond ((= i 2) "M < 0") ((= i 3) "N < 0") ((= i 6) "LDA < max(1, M)") ((= i 8) "INCX = 0") ((= i 11) "INCY < = 0") (else (conc "error code " i))))) (blas-level2-sd-wrapx (spr order uplo n alpha x incx ap) (ap) (lambda (i) (cond ((= i 2) "M < 0") ((= i 3) "N < 0") ((= i 6) "LDA < max(1, M)") ((= i 8) "INCX = 0") ((= i 11) "INCY < = 0") (else (conc "error code " i))))) (blas-level2-sd-wrapx (syr2 order uplo n alpha x incx y incy a lda) (a) (lambda (i) (cond ((= i 2) "M < 0") ((= i 3) "N < 0") ((= i 6) "LDA < max(1, M)") ((= i 8) "INCX = 0") ((= i 11) "INCY < = 0") (else (conc "error code " i))))) (blas-level2-sd-wrapx (ger order m n alpha x incx y incy a lda) (a) (lambda (i) (cond ((= i 2) "M < 0") ((= i 3) "N < 0") ((= i 6) "LDA < max(1, M)") ((= i 8) "INCX = 0") ((= i 11) "INCY < = 0") (else (conc "error code " i))))) (blas-level2-sd-wrapx (iger order m n alpha x incx offx y incy offy a lda) (a) (lambda (i) (cond ((= i 2) "M < 0") ((= i 3) "N < 0") ((= i 6) "LDA < max(1, M)") ((= i 8) "INCX = 0") ((= i 11) "INCY < = 0") (else (conc "error code " i))))) (blas-level2-cz-wrapx (geru order m n alpha x incx y incy a lda) (a) (lambda (i) (cond ((= i 2) "M < 0") ((= i 3) "N < 0") ((= i 6) "LDA < max(1, M)") ((= i 8) "INCX = 0") ((= i 11) "INCY < = 0") (else (conc "error code " i))))) (blas-level2-cz-wrapx (gerc order m n alpha x incx y incy a lda) (a) (lambda (i) (cond ((= i 2) "M < 0") ((= i 3) "N < 0") ((= i 6) "LDA < max(1, M)") ((= i 8) "INCX = 0") ((= i 11) "INCY < = 0") (else (conc "error code " i))))) (blas-level2-cz-wrapx (her order uplo n alpha x incx a lda) (a) (lambda (i) (cond ((= i 2) "M < 0") ((= i 3) "N < 0") ((= i 6) "LDA < max(1, M)") ((= i 8) "INCX = 0") ((= i 11) "INCY < = 0") (else (conc "error code " i))))) (blas-level2-cz-wrapx (hpr order uplo n alpha x incx ap) (ap) (lambda (i) (cond ((= i 2) "M < 0") ((= i 3) "N < 0") ((= i 6) "LDA < max(1, M)") ((= i 8) "INCX = 0") ((= i 11) "INCY < = 0") (else (conc "error code " i))))) (blas-level2-cz-wrapx (her2 order uplo n alpha x incx y incy a lda) (a) (lambda (i) (cond ((= i 2) "M < 0") ((= i 3) "N < 0") ((= i 6) "LDA < max(1, M)") ((= i 8) "INCX = 0") ((= i 11) "INCY < = 0") (else (conc "error code " i))))) (blas-level2-cz-wrapx (hpr2 order uplo n alpha x incx y incy ap) (ap) (lambda (i) (cond ((= i 2) "M < 0") ((= i 3) "N < 0") ((= i 6) "LDA < max(1, M)") ((= i 8) "INCX = 0") ((= i 11) "INCY < = 0") (else (conc "error code " i))))) (blas-level2-sd-wrapx (syr order uplo n alpha x incx a lda) (a) (lambda (i) (cond ((= i 2) "M < 0") ((= i 3) "N < 0") ((= i 6) "LDA < max(1, M)") ((= i 8) "INCX = 0") ((= i 11) "INCY < = 0") (else (conc "error code " i))))) (blas-level2-sd-wrapx (spr order uplo n alpha x incx ap) (ap) (lambda (i) (cond ((= i 2) "M < 0") ((= i 3) "N < 0") ((= i 6) "LDA < max(1, M)") ((= i 8) "INCX = 0") ((= i 11) "INCY < = 0") (else (conc "error code " i))))) (blas-level2-sd-wrapx (syr2 order uplo n alpha x incx y incy a lda) (a) (lambda (i) (cond ((= i 2) "M < 0") ((= i 3) "N < 0") ((= i 6) "LDA < max(1, M)") ((= i 8) "INCX = 0") ((= i 11) "INCY < = 0") (else (conc "error code " i))))) (blas-level2-sd-wrapx (spr2 order uplo n alpha x incx y incy ap) (ap) (lambda (i) (cond ((= i 2) "M < 0") ((= i 3) "N < 0") ((= i 6) "LDA < max(1, M)") ((= i 8) "INCX = 0") ((= i 11) "INCY < = 0") (else (conc "error code " i))))) (define-syntax blas-level1-wrap (er-macro-transformer (lambda (x r c) (let* ((fn (cadr x)) (ret (caddr x)) (err (cadddr x)) (vsize (car (cddddr x))) (copy (cadr (cddddr x))) (make-return (cddr (cddddr x))) (cfname (string->symbol (conc "cblas_" (symbol->string (car fn))))) (fname (string->symbol (conc (if vsize "" "unsafe-") (symbol->string (car fn)) (if copy "" "!")))) (%define (r 'define)) (%begin (r 'begin)) (%let (r 'let)) (%cond (r 'cond)) (%or (r 'or)) (%if (r 'if)) (%lambda (r 'lambda)) (asize (r 'asize)) (apsize (r 'apsize)) (apdim (r 'apdim)) (xsize (r 'xsize)) (ysize (r 'ysize)) (xdim (r 'xdim)) (ydim (r 'ydim)) (psize (r 'psize)) (pdim (r 'pdim)) (args (reverse (cdr fn))) ;; Build required arguments (non-optional ones) (required-args (let loop ((args args) (req '())) (if (null? args) req (let ((x (car args))) (case x ((incx incy dotu dotc offx offy) (loop (cdr args) req)) (else (loop (cdr args) (cons x req)))))))) ;; Build keyword argument defaults (keyword-defaults (cond ((memq 'incy fn) '((incx 1) (incy 1) (offx 0) (offy 0))) (else '((incx 1) (offx 0)))))) `(,%define (,fname ,@required-args #!key ,@(map (lambda (kw-default) `(,(car kw-default) ,(cadr kw-default))) keyword-defaults)) ,(if vsize `(,%begin ,(if (memq 'y fn) `(,%let ((,ysize (,vsize y)) (,ydim (fx+ 1 (fx+ offy (fx* (abs incy) (fx- n 1)))))) (,%if (< ,ysize ,ydim) (error ',fname (conc "vector Y is allocated " ,ysize " elements " "but required dimension is " ,ydim)))) `(begin)) ,(if (memq 'x fn) `(,%let ((,xsize (,vsize x)) (,xdim (fx+ 1 (fx+ offx (fx* (abs incx) (fx- n 1)))))) (,%if (< ,xsize ,xdim) (error ',fname (conc "vector X is allocated " ,xsize " elements " "but required dimension is " ,xdim)))) `(begin)) ,(if (memq 'param fn) `(,%let ((,psize (,vsize param)) (,pdim 5)) (,%if (< ,psize ,pdim) (error ',fname (conc "vector PARAM is allocated " ,psize " elements " "but dimension must be " ,pdim)))) `(begin))) `(begin)) (let ,(let loop ((fn fn) (bnds '())) (if (null? fn) bnds (let ((x (car fn))) (let ((bnds (cond ((or (eq? x 'dotc) (eq? x 'dotu)) (cons `(,x (,(car make-return))) bnds)) ((and copy ret (memq x ret)) (cons `(,x (,copy ,x)) bnds)) (else bnds)))) (loop (cdr fn) bnds))))) ,(cond ((memq 'dotc fn) `(begin (,cfname . ,(cdr fn)) (values dotc))) ((memq 'dotu fn) `(begin (,cfname . ,(cdr fn)) (values dotu))) ((not ret) `(,cfname . ,(cdr fn))) (else `(begin (,cfname . ,(cdr fn)) (values . ,ret))))))))) ) (define-syntax blas-level1-wrapx (er-macro-transformer (lambda (x r c) (let* ((fn (cadr x)) (ret (caddr x)) (errs (cadddr x))) (if (not ret) ;; For procedures that don't return vectors (like dot products) `(begin (blas-level1-wrap ,(cons (string->symbol (conc "s" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs f32vector-length scopy) (blas-level1-wrap ,(cons (string->symbol (conc "d" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs f64vector-length dcopy) (blas-level1-wrap ,(cons (string->symbol (conc "c" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs (lambda (v) (fx/ (f32vector-length v) 2)) ccopy) (blas-level1-wrap ,(cons (string->symbol (conc "z" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs (lambda (v) (fx/ (f64vector-length v) 2)) zcopy)) ;; For procedures that return vectors `(begin ;; Unsafe versions (no bounds checking) (blas-level1-wrap ,(cons (string->symbol (conc "s" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs #f #f) (blas-level1-wrap ,(cons (string->symbol (conc "d" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs #f #f) (blas-level1-wrap ,(cons (string->symbol (conc "c" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs #f #f) (blas-level1-wrap ,(cons (string->symbol (conc "z" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs #f #f) ;; Safe versions with bounds checking (no copy) (blas-level1-wrap ,(cons (string->symbol (conc "s" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs f32vector-length #f) (blas-level1-wrap ,(cons (string->symbol (conc "d" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs f64vector-length #f) (blas-level1-wrap ,(cons (string->symbol (conc "c" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs (lambda (v) (fx/ (f32vector-length v) 2)) #f) (blas-level1-wrap ,(cons (string->symbol (conc "z" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs (lambda (v) (fx/ (f64vector-length v) 2)) #f) ;; Safe versions with bounds checking and copying (blas-level1-wrap ,(cons (string->symbol (conc "s" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs f32vector-length scopy) (blas-level1-wrap ,(cons (string->symbol (conc "d" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs f64vector-length dcopy) (blas-level1-wrap ,(cons (string->symbol (conc "c" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs (lambda (v) (fx/ (f32vector-length v) 2)) ccopy) (blas-level1-wrap ,(cons (string->symbol (conc "z" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs (lambda (v) (fx/ (f64vector-length v) 2)) zcopy)))) )) ) (define-syntax blas-level1-sd-wrapx (er-macro-transformer (lambda (x r c) (let* ((fn (cadr x)) (ret (caddr x)) (errs (cadddr x))) (if (not ret) ;; For procedures that don't return vectors `(begin (blas-level1-wrap ,(cons (string->symbol (conc "s" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs f32vector-length scopy) (blas-level1-wrap ,(cons (string->symbol (conc "d" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs f64vector-length dcopy)) ;; For procedures that return vectors `(begin ;; Unsafe versions (blas-level1-wrap ,(cons (string->symbol (conc "s" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs #f #f) (blas-level1-wrap ,(cons (string->symbol (conc "d" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs #f #f) ;; Safe versions (no copy) (blas-level1-wrap ,(cons (string->symbol (conc "s" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs f32vector-length #f) (blas-level1-wrap ,(cons (string->symbol (conc "d" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs f64vector-length #f) ;; Safe versions with copying (blas-level1-wrap ,(cons (string->symbol (conc "s" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs f32vector-length scopy) (blas-level1-wrap ,(cons (string->symbol (conc "d" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs f64vector-length dcopy)))) )) ) (define-syntax blas-level1-cz-wrapx (er-macro-transformer (lambda (x r c) (let* ((fn (cadr x)) (ret (caddr x)) (errs (cadddr x))) (if (not ret) ;; For procedures that don't return vectors `(begin (blas-level1-wrap ,(cons (string->symbol (conc "c" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs (lambda (v) (fx/ (f32vector-length v) 2)) ccopy (lambda () (make-f32vector 2))) (blas-level1-wrap ,(cons (string->symbol (conc "z" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs (lambda (v) (fx/ (f64vector-length v) 2)) zcopy (lambda () (make-f64vector 2)))) ;; For procedures that return vectors `(begin ;; Unsafe versions (blas-level1-wrap ,(cons (string->symbol (conc "c" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs #f #f) (blas-level1-wrap ,(cons (string->symbol (conc "z" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs #f #f) ;; Safe versions (no copy) (blas-level1-wrap ,(cons (string->symbol (conc "c" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs (lambda (v) (fx/ (f32vector-length v) 2)) #f) (blas-level1-wrap ,(cons (string->symbol (conc "z" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs (lambda (v) (fx/ (f64vector-length v) 2)) #f) ;; Safe versions with copying (blas-level1-wrap ,(cons (string->symbol (conc "c" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs (lambda (v) (fx/ (f32vector-length v) 2)) ccopy) (blas-level1-wrap ,(cons (string->symbol (conc "z" (symbol->string (car fn)))) (cdr fn)) ,ret ,errs (lambda (v) (fx/ (f64vector-length v) 2)) zcopy)))) )) ) (blas-level1-sd-wrapx (rot n x incx y incy c s) (x y) (lambda (i) (cond (conc "error code " i)))) (blas-level1-sd-wrapx (rotm n x incx y incy param) (x y) (lambda (i) (cond (conc "error code " i)))) (blas-level1-wrapx (swap n x incx y incy) (x y) (lambda (i) (cond (conc "error code " i)))) (blas-level1-wrapx (scal n alpha x incx) (x) (lambda (i) (cond (conc "error code " i)))) (blas-level1-wrapx (axpy n alpha x incx y incy) (y) (lambda (i) (cond (conc "error code " i)))) (blas-level1-wrapx (iaxpy n alpha x incx offx y incy offy) (y) (lambda (i) (cond (conc "error code " i)))) (blas-level1-sd-wrapx (dot n x incx y incy) #f (lambda (i) (cond (conc "error code " i)))) (blas-level1-cz-wrapx (dotu n x incx y incy dotu) #f (lambda (i) (cond (conc "error code " i)))) (blas-level1-cz-wrapx (dotc n x incx y incy dotc) #f (lambda (i) (cond (conc "error code " i)))) (blas-level1-wrapx (nrm2 n x incx) #f (lambda (i) (cond (conc "error code " i)))) (blas-level1-wrapx (asum n x incx) #f (lambda (i) (cond (conc "error code " i)))) (blas-level1-wrapx (amax n x incx) #f (lambda (i) (cond (conc "error code " i)))) )