1 files changed, 108 insertions, 0 deletions
diff --git a/prescheme-nim-local/openblas.scm b/prescheme-nim-local/openblas.scm
new file mode 100644
index 0000000..c171906
--- /dev/null
+++ b/prescheme-nim-local/openblas.scm
@@ -0,0 +1,108 @@
+;; openblas+gsl example (WIP)
+
+(define %vec-a (vector-unfold (lambda (i)
+                                (* i i))
+                              5))
+
+;; take vec-a's length at compile-time
+(define %len-a (vector-length %vec-a))
+
+
+(define foox
+  (external "computefoox" (=> (integer integer) integer)
+            (lambda (x y)
+              (display (+ x y)))))
+
+(define (handle-error message)
+  (define out (current-error-port))
+  (error message))
+
+(define-wrapper-type gsl-vector)
+
+(define (gsl-create-vector size) ; gsl_vector_alloc (3);
+  ((external "gsl_vector_alloc" (=> (integer) gsl-vector))
+   size))
+
+(define (gsl-destroy-vector vector)
+  ((external "gsl_vector_free" (=> (gsl-vector) unit ) )
+   vector))
+
+(define (with-vector vector proc)
+  (if (null-pointer? vector)
+      (handle-error "Could not create vector")
+      (let ((result (proc vector)))
+        (gsl-destroy-vector vector)
+        result)))
+
+;; void gsl_vector_set(gsl_vector *v, const size_t i, double x)
+(define (gsl-vector-set! v i x)
+  ((external "gsl_vector_set" (=> (gsl-vector integer float) unit ) )
+   v i x))
+
+;; double gsl_vector_get(const gsl_vector *v, const size_t i)
+(define (gsl-vector-get v i)
+  ((external "gsl_vector_get" (=> (gsl-vector integer) float ) )
+   v i))
+
+;; gcvt (float value, int ndigits, char * buf);
+(define (gcvt v ndigits buf)
+  ((external "gcvt" (=> (float integer (^ char)) unit ) )
+   v ndigits buf))
+
+
+;;(define-c-generator make-string #t
+;;  (lambda (call port indent)
+;;    ; calloc is used as a hack to get a zero at the end
+;;    (format port "(char *)calloc( 1, 1 + ")
+;;    (c-value (call-arg call 0) port)
+;;    (format port ")")))
+
+(define (main)
+  (define out (current-output-port))
+
+  (write-string "Prescheme vector: print vec-a with vector-for-each:\n" out)
+  ; (make-pointer gsl-vector)
+
+  (vector-for-each (lambda (i val)
+                     (write-string " vec-a[" out)
+                     (write-integer i out)
+                     (write-string "] = " out)
+                     (write-integer val out)
+                     (write-string ", " out)
+                     )
+                   %vec-a %len-a)
+  (newline out)
+  (write-string "OpenBLAS: print vec-a with vector-for-each:\n" out)
+  (with-vector
+   (gsl-create-vector 5)
+   (lambda (one-vec)
+     ;; (gsl-vector-for-each (lambda (i val)
+     ;;                    gsl-set-vector(one-vec,i,val);
+     ;;                    )
+     ;;                 one-vec)
+     (let ((x 1.1))
+       (gsl-vector-set! one-vec 0 (fl* x 0.0))
+       (gsl-vector-set! one-vec 1 (fl* x x))
+       (gsl-vector-set! one-vec 2 (fl* x 2.1))
+       (gsl-vector-set! one-vec 3 4.0)
+       (gsl-vector-set! one-vec 4 5.0)
+       ;; (gsl-vector-set one-vec 5 6.0)
+       )
+     (vector-for-each (lambda (i val)
+                        (write-string " vec-b[" out)
+                        (write-integer i out)
+                        (write-string "] = " out)
+                        ;; (write-number (gsl-vector-get one-vec i) out)
+                        (let ((target (make-string 20)))
+                          ;; (write-integer (gsl-vector-get one-vec i) out)
+                          ;; (gcvt (gsl-vector-get one-vec i) target)
+                          (gcvt (gsl-vector-get one-vec i) 4 target)
+                          (write-string target out)
+                          )
+                        (write-string ", " out)
+                        )
+                      %vec-a %len-a)
+     ))
+  (newline out)
+  0
+)