matlisp-commit

[Akshay S. <ak...@us...>]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "matlisp".

The branch, matlisp-cffi has been updated
       via  ff263186ffc1a8443f5733cc975ba2e7c66d2206 (commit)
       via  f53e544eff8af4aa8fdd302a1adc98fed1b5aa35 (commit)
      from  9bfeec0a8b2e5604b2ce6b7ad6be62c3fd3f09c4 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit ff263186ffc1a8443f5733cc975ba2e7c66d2206
Author: Akshay Srinivasan <aks...@gm...>
Date:   Sat Mar 24 13:57:22 2012 +0530

    o Implemented support for callbacks.
    o Stated to using new protocol to append "~" to functions
      which return matrices which share the store.
    o Lots of tweaks to the FFI.

diff --git a/matlisp.asd b/matlisp.asd
index 2529cd7..2c8019c 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -147,8 +147,9 @@
 		     (:file "help")
 		     (:file "special")
 		     (:file "reader")
-		     ;;(:file "trans")
-		     ;;(:file "realimag")
+		     (:file "trans")
+		     (:file "realimag")
+		     (:file "submat")
 		     (:file "reshape")
 		     (:file "join")
 		     (:file "svd")
diff --git a/packages.lisp b/packages.lisp
index e4fe2da..94f67e0 100644
--- a/packages.lisp
+++ b/packages.lisp
@@ -160,22 +160,27 @@
 	   #:zip-eq
 	   #:cut-cons-chain!
 	   #:when-let
+	   #:if-let
 	   #:if-ret
 	   #:get-arg
 	   #:nconsc
 	   #:with-gensyms
 	   #:slot-values
-	   #:mlet*))
+	   #:mlet*
+	   #:recursive-append
+	   ;;
+	   #:foreign-vector #:make-foreign-vector #:foreign-vector-p
+	   #:fv-ref #:fv-pointer #:fv-size #:fv-type))
 
 (defpackage :fortran-ffi-accessors
+  (:nicknames :ffi)
   #+:cmu (:use :common-lisp :c-call :cffi :utilities)
   #+:sbcl (:use :common-lisp :sb-alien :sb-c :cffi :utilities)
   #+:allegro (:use :common-lisp :cffi :utilities)
   #+(not (or sbcl cmu allegro)) (:use :common-lisp :cffi :utilities)
   (:export
    ;; interface functions
-   #:def-fortran-routine
-   #:incf-sap
+   #:def-fortran-routine   
    #:with-vector-data-addresses
    )
   (:documentation "Fortran foreign function interface"))
@@ -315,14 +320,22 @@
 	   #:store #:store-size	   
 	   ;;Generic functions on standard-matrix
 	   #:fill-matrix
-	   #:ctranspose! #:ctranspose #:transpose #:transpose!
 	   #:row-or-col-vector-p #:row-vector-p #:col-vector-p
-	   #:row #:col #:diag #:sub-matrix
+	   ;;Submatrix ops
+	   #:row~ #:row
+	   #:col~ #:col
+	   #:diag~ #:diag
+	   #:sub-matrix~ #:sub-matrix
+	   ;;Transpose
+	   #:transpose~ #:transpose! #:transpose
+	   #:ctranspose! #:ctranspose	   
 	   ;;Real-double-matrix
 	   #:real-matrix #:real-matrix-element-type #:real-matrix-store-type
 	   ;;Complex-double-matrix
 	   #:complex-matrix #:complex-matrix-element-type #:complex-matrix-store-type #:complex-coerce #:complex-double-float
-	   #:mrealpart #:mimagpart
+	   ;;Real and imaginary parts
+	   #:mrealpart~ #:mrealpart #:real
+	   #:mimagpart~ #:mimagpart #:imag
 	   ;;
 	   "CONVERT-TO-LISP-ARRAY"
    "DOT"
@@ -399,7 +412,6 @@
    "POTRF!"
    "POTRS!"
    "RAND"
-   "REAL"
    "RESHAPE!"
    "RESHAPE"
    "SAVE-MATLISP"
diff --git a/src/axpy.lisp b/src/axpy.lisp
index 662cfd6..0891c60 100644
--- a/src/axpy.lisp
+++ b/src/axpy.lisp
@@ -134,11 +134,11 @@ don't know how to coerce COMPLEX to REAL"))
 (generate-typed-axpy!-func complex-double-axpy!-typed complex-double-float complex-matrix-store-type complex-matrix blas:zaxpy)
 
 (defmethod axpy! ((alpha cl:real) (x real-matrix) (y complex-matrix))
-  (real-double-axpy!-typed (coerce alpha 'double-float) x (mrealpart y)))
+  (real-double-axpy!-typed (coerce alpha 'double-float) x (mrealpart~ y)))
 
 (defmethod axpy! ((alpha complex) (x real-matrix) (y complex-matrix))
-  (real-double-axpy!-typed (coerce (realpart alpha) 'double-float) x (mrealpart y))
-  (real-double-axpy!-typed (coerce (imagpart alpha) 'double-float) x (mimagpart y)))
+  (real-double-axpy!-typed (coerce (realpart alpha) 'double-float) x (mrealpart~ y))
+  (real-double-axpy!-typed (coerce (imagpart alpha) 'double-float) x (mimagpart~ y)))
 
 (defmethod axpy! ((alpha number) (x complex-matrix) (y complex-matrix))
   (complex-double-axpy!-typed (complex-coerce alpha) x y))
diff --git a/src/complex-matrix.lisp b/src/complex-matrix.lisp
index 3ad8280..928d43f 100644
--- a/src/complex-matrix.lisp
+++ b/src/complex-matrix.lisp
@@ -69,75 +69,6 @@
 	  (aref store (+ 1 (* 2 idx))) (imagpart coerced-value))))
 
 ;;
-(defmethod transpose ((matrix complex-matrix))
-  (mlet* (((hd nr nc rs cs st) (slot-values matrix '(head number-of-rows number-of-cols row-stride col-stride store))
-	   :type (fixnum fixnum fixnum fixnum fixnum (complex-matrix-store-type *))))
-	 (make-instance 'sub-complex-matrix
-			:nrows nc :ncols nr
-			:store st
-			:head hd
-			:row-stride cs :col-stride rs
-			:parent matrix)))
-
-;;
-(defmethod sub-matrix ((matrix complex-matrix) (origin list) (dim list))
-  (destructuring-bind (o-i o-j) origin
-    (destructuring-bind (nr-s nc-s) dim
-      (mlet* (((hd nr nc rs cs st) (slot-values matrix '(head number-of-rows number-of-cols row-stride col-stride store))
-	       :type (fixnum fixnum fixnum fixnum fixnum (complex-matrix-store-type *))))
-    (unless (and (< -1 o-i (+ o-j nr-s) nr) (< -1 o-j (+ o-j nc-s) nc))
-      (error "Bad index and/or size.
-Cannot create a sub-matrix of size (~a ~a) starting at (~a ~a)" nr-s nc-s o-i o-j))
-    (make-instance 'sub-complex-matrix
-		   :nrows nr-s :ncols nc-s
-		   :store st
-		   :head (store-indexing o-i o-j hd rs cs)
-		   :row-stride rs :col-stride cs)))))
-
-;;
-(defmethod row ((matrix complex-matrix) (i fixnum))
-  (mlet* (((hd nr nc rs cs st) (slot-values matrix '(head number-of-rows number-of-cols row-stride col-stride store))
-	   :type (fixnum fixnum fixnum fixnum fixnum (complex-matrix-store-type *))))
-	 (unless (< -1 i nr)
-	   (error "Index ~a is outside the valid range for the given matrix." i))
-	 (make-instance 'sub-complex-matrix
-			:nrows 1 :ncols nc
-			:store st
-			:head (store-indexing i 0 hd rs cs)
-			:row-stride rs :col-stride cs)))
-
-;;
-(defmethod col ((matrix complex-matrix) (j fixnum))
-  (mlet* (((hd nr nc rs cs st) (slot-values matrix '(head number-of-rows number-of-cols row-stride col-stride store))
-	   :type (fixnum fixnum fixnum fixnum fixnum (complex-matrix-store-type *))))
-	 (unless (< -1 j nc)
-	   (error "Index ~a is outside the valid range for the given matrix." j))
-	 (make-instance 'sub-complex-matrix
-			:nrows nr :ncols 1
-			:store st
-			:head (store-indexing 0 j hd rs cs)
-			:row-stride rs :col-stride cs)))
-
-;;
-(defmethod diag ((matrix complex-matrix) &optional (d 0))
-  (declare (type fixnum d))
-  (mlet* (((hd nr nc rs cs st) (slot-values matrix '(head number-of-rows number-of-cols row-stride col-stride store))
-	   :type (fixnum fixnum fixnum fixnum fixnum (complex-matrix-store-type *)))
-	  ((f-i f-j) (if (< d 0)
-			 (values (- d) 0)
-			 (values 0 d))
-	   :type (fixnum fixnum)))
-	 (unless (and (< -1 f-i nr) (< -1 f-j nc))
-	   (error "Index ~a is outside the valid range for the given matrix." d))
-	 (let ((d-s (min (- nr f-i) (- nc f-j))))
-	   (declare (type fixnum d-s))
-	   (make-instance 'sub-complex-matrix
-			  :nrows 1 :ncols d-s
-			  :store st
-			  :head (store-indexing f-i f-j hd rs cs)
-			  :row-stride 1 :col-stride (+ rs cs)))))
-
-;;
 (declaim (inline allocate-complex-store))
 (defun allocate-complex-store (size)
   (make-array (* 2 size) :element-type 'complex-matrix-element-type
@@ -357,31 +288,3 @@ Cannot create a sub-matrix of size (~a ~a) starting at (~a ~a)" nr-s nc-s o-i o-
 	 (make-complex-matrix-dim n m)))
       (t
        (error "require 1 or 2 arguments to make a matrix")))))
-
-;;
-
-(defun mrealpart (mat)
-  (typecase mat
-    (real-matrix mat)
-    (complex-matrix (make-instance 'sub-real-matrix
-				   :parent mat :store (store mat)
-				   :nrows (nrows mat) :ncols (ncols mat)
-				   :row-stride (* 2 (row-stride mat)) :col-stride (* 2 (col-stride mat))
-				   :head (* 2 (head mat))))
-    (number (cl:realpart mat))))
-
-(defun mimagpart (mat)
-  (typecase mat
-    (real-matrix nil)
-    (complex-matrix (make-instance 'sub-real-matrix
-				   :parent mat :store (store mat)
-				   :nrows (nrows mat) :ncols (ncols mat)
-				   :row-stride (* 2 (row-stride mat)) :col-stride (* 2 (col-stride mat))
-				   :head (+ 1 (* 2 (head mat)))))
-    (number (cl:imagpart mat))))
-
-(defun mconjugate! (mat)
-  (typecase mat
-    (real-matrix mat)
-    (complex-matrix (scal! -1d0 (mimagpart mat))))
-  mat)
\ No newline at end of file
diff --git a/src/copy.lisp b/src/copy.lisp
index 344999a..aa3cbda 100644
--- a/src/copy.lisp
+++ b/src/copy.lisp
@@ -219,8 +219,8 @@ don't know how to coerce a COMPLEX to a REAL"))
   (complex-double-copy!-typed x y))
 
 (defmethod copy! ((x real-matrix) (y complex-matrix))
-  (real-double-copy!-typed x (mrealpart y))
-  (scal! 0d0 (mimagpart y))
+  (real-double-copy!-typed x (mrealpart~ y))
+  (scal! 0d0 (mimagpart~ y))
   y)
 
 (defmethod copy! ((x number) (y complex-matrix))
diff --git a/src/dlsode.lisp b/src/dlsode.lisp
index 3883519..a284d50 100644
--- a/src/dlsode.lisp
+++ b/src/dlsode.lisp
@@ -1,15 +1,7 @@
-(in-package "MATLISP")
-#+nil
-(progn
-(asdf:oos 'asdf:load-op :cffi)
-
-(load "f77-mangling.lisp")
-(load "cffi-helpers.lisp")
-(load "ffi-cffi.lisp")
-)
+(in-package #:matlisp)
 
 (cffi:define-foreign-library libodepack
-  (:unix #.(translate-logical-pathname
+  #+nil(:unix #.(translate-logical-pathname
 	    (merge-pathnames "matlisp:lib;libodepack"
 			     *shared-library-pathname-extension*)))
   (t (:default "libodepack")))
@@ -17,13 +9,23 @@
 (cffi:use-foreign-library libodepack)
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+#+nil(def-fortran-routine testde :void
+  (field (:callback :void
+		    (c-neq :integer :input)
+		    (c-t :double-float :input)
+		    (c-y (* :double-float :size c-neq) :input)
+		    (c-ydot (* :double-float :size c-neq) :output)))
+  (neq :integer :input)
+  (y (* :double-float) :input-output))
+
+
 (def-fortran-routine dlsode :void
   "DLSODE in ODEPACK"
   (field (:callback :void
 		    (c-neq :integer :input)
 		    (c-t :double-float :input)
-		    (c-y (* :double-float) :input)
-		    (c-ydot (* :double-float) :output)))
+		    (c-y (* :double-float :size c-neq) :input)
+		    (c-ydot (* :double-float :size c-neq) :output)))
   (neq :integer :input)
   (y (* :double-float) :input-output)
   (ts :double-float :input-output)
@@ -41,31 +43,15 @@
   (jacobian (:callback :void
 		       (c-neq :integer :input)
 		       (c-t :double-float :input)
-		       (c-y (* :double-float) :input)
+		       (c-y (* :double-float :size c-neq) :input)
 		       (c-upper-bandwidth :integer :input)
 		       (c-lower-bandwidth :integer :input)
-		       (c-pd (* :double-float) :output)
+		       (c-pd (* :double-float :size (* c-neq c-neq)) :output)
 		       (c-nrowpd :integer :input)))
   (mf :integer :input))
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (defun lsode-evolve (field y t-array report)
-  ;; Use gensym ? Will have to use a macrolet.
-  (cffi:defcallback *evolve-callback* :void ((c-neq :pointer :int)
-					     (c-tc :pointer :double)
-					     (c-y :pointer :double)
-					     (c-ydot :pointer :double))
-    (let* ((neq (cffi:mem-aref c-neq :int))
-	   (y (make-array neq :element-type 'double-float :initial-element 0d0))
-	   (ts (cffi:mem-aref c-tc :double)))
-      ;; Copy things to simple-arrays
-      (loop for i from 0 below neq
-	 do (setf (aref y i) (cffi:mem-aref c-y :double i)))     
-      ;; Assume form of field
-      (let ((ydot (funcall field ts y)))
-      ;; Copy ydot back
-	(loop for i from 0 below neq
-	   do (setf (cffi:mem-aref c-ydot :double i) (aref ydot i))))))
   ;;
   (let* ((neq (length y))
 	 (lrw (+ 22 (* 9 neq) (* neq neq) 5))
@@ -86,21 +72,22 @@
        do (progn
 	    (setq tout (aref t-array i))
 	    (multiple-value-bind (y-out ts-out istate-out rwork-out iwork-out)
-		(dlsode (cffi:callback *evolve-callback*) neq y ts tout itol rtol atol itask istate iopt rwork lrw iwork liw (cffi:null-pointer) mf)
+		(dlsode field neq y ts tout itol rtol atol itask istate iopt rwork lrw iwork liw (cffi:null-pointer) mf)
 	      (setq ts ts-out)
 	      (setq istate istate-out))
 	    (funcall report ts y)))))
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(defun pend-field (ts y)
-  (make-array 2 :element-type 'double-float :initial-contents `(,(aref y 1) ,(- (sin (aref y 0))))))
+(defun pend-field (neq time y ydot)
+	(setf (fv-ref ydot 0) (fv-ref y 1)
+	      (fv-ref ydot 1) (- (sin (fv-ref y 0)))))
 
 (defun pend-report (ts y)
   (format t "~A ~A ~A ~%" ts (aref y 0) (aref y 1)))
 
 (defvar y (make-array 2 :element-type 'double-float :initial-contents `(,(/ pi 2) 0d0)))
 
-(lsode-evolve #'pend-field y #(0d0 1d0) #'pend-report)
+;; (lsode-evolve #'pend-field y #(0d0 1d0 2d0) #'pend-report)
 ;; Should return
 ;; 1.0d0 1.074911802207049d0 -0.975509986605856d0
 ;; 2.0d0 -0.20563950412081608d0 -1.3992359518735706d0
diff --git a/src/dot.lisp b/src/dot.lisp
index badff89..5a5d896 100644
--- a/src/dot.lisp
+++ b/src/dot.lisp
@@ -139,7 +139,7 @@
     (let ((realpart (ddot nxm store-x 1 store-y 2))
 	  (imagpart (with-vector-data-addresses ((addr-x store-x)
 						 (addr-y store-y))
-			  (incf-sap :double-float addr-y)
+			  (incf-sap addr-y :double-float)
 			  (ddot nxm addr-x 1 addr-y 2))))
 
       (declare (type complex-matrix-element-type realpart imagpart))
@@ -192,7 +192,7 @@
     (let ((realpart (ddot nxm store-x 2 store-y 1))
 	  (imagpart (with-vector-data-addresses ((addr-x store-x)
 						  (addr-y store-y))
-			  (incf-sap :double-float addr-x)
+			  (incf-sap addr-x :double-float)
 			  (ddot nxm addr-x 2 addr-y 1))))
 
       (declare (type complex-matrix-element-type realpart imagpart))
diff --git a/src/ffi-cffi-interpreter-specific.lisp b/src/ffi-cffi-interpreter-specific.lisp
index 75afa9a..eda8343 100644
--- a/src/ffi-cffi-interpreter-specific.lisp
+++ b/src/ffi-cffi-interpreter-specific.lisp
@@ -82,14 +82,16 @@ Returns
 
 #+(or sbcl cmu ccl)
 (defmacro with-vector-data-addresses (vlist &body body)
-  "WITH-VECTOR-DATA-ADDRESSES (var-list &body body)
+"
+  WITH-VECTOR-DATA-ADDRESSES (var-list &body body)
 
- Execute the body with the variables in VAR-LIST appropriately bound.
- VAR-LIST should be a list of pairs.  The first element is the address
- of the desired object; the second element is the variable whose address
- we want.
+  Execute the body with the variables in VAR-LIST appropriately bound.
+  VAR-LIST should be a list of pairs.  The first element is the address
+  of the desired object; the second element is the variable whose address
+  we want.
 
- Garbage collection is also disabled while executing the body."
+  Garbage collection is also disabled while executing the body.
+"
   ;; We wrap everything inside a WITHOUT-GCING form to inhibit garbage
   ;; collection to avoid complications that may arise during a
   ;; collection while in a fortran call.
@@ -103,13 +105,7 @@ Returns
        (let (,@(mapcar #'(lambda (lst)
 			   (destructuring-bind (addr-var var &key inc-type inc) lst
 			     `(,addr-var ,@(if inc
-					       `((cffi:inc-pointer (vector-data-address ,var)
-								   ,@(case inc-type
-									   (:double-float  `((* ,inc 8)))
-									   (:single-float `((* ,inc 4)))
-									   (:complex-double-float  `((* ,inc 16)))
-									   (:complex-single-float  `((* ,inc 8)))
-									   (t `(,inc)))))
+					       `((inc-sap (vector-data-address ,var) ,inc-type ,inc))
 					       `((vector-data-address ,var))))))
 		       vlist))
 	 ,@body))))
diff --git a/src/ffi-cffi.lisp b/src/ffi-cffi.lisp
index b1d8bcc..5146374 100644
--- a/src/ffi-cffi.lisp
+++ b/src/ffi-cffi.lisp
@@ -11,97 +11,102 @@
 
 (in-package "FORTRAN-FFI-ACCESSORS")
 
-#+(or)
 (defconstant +ffi-types+ '(:single-float :double-float
 			   :complex-single-float :complex-double-float
 			   :integer :long
 			   :string
 			   :callback))
 
-
 (defconstant +ffi-styles+ '(:input :input-value :workspace
 			    ;;
 			    :input-output :output :workspace-output))
 
+  
 ;; Create objects on the heap and run some stuff.
-(defmacro with-foreign-objects-heap-ed (declarations &rest body)
-    "
-Allocate \"objects\" on the heap and run the \"body\" of code.
+(defmacro with-foreign-objects-heaped (declarations &rest body)
+"
+  Allocate \"objects\" on the heap and run the \"body\" of code.
 
-with-foreign-objects-heap-ed (declarations) &rest body
-binding := {(var type &optional count &key (initial-contents nil))}*
+  with-foreign-objects-heap-ed (declarations) &rest body
+  binding := {(var type &optional count &key (initial-contents nil))}*
 
-Example:
->> (with-foreign-objects-heap-ed ((x :int :count 10 :initial-element 2))
-     (+ (cffi:mem-aref x :int 2) 1))
-3
+  Example:
+  >> (with-foreign-objects-heaped ((x :int :count 10 :initial-element 2))
+       (+ (cffi:mem-aref x :int 2) 1))
+  3
 >>
-  "
-  (let ((ret (gensym)))
-    ;; Allocate objects from the heap
-    `(let* (,@(mapcar (lambda (decl) (list (car decl) `(cffi:foreign-alloc ,@(cdr decl))))
-		      declarations)
-	    ;; Store result temporarily
-	    (,ret (progn ,@body)))
-       ;;Free C objects
-       ,@(mapcar (lambda (decl) `(cffi:foreign-free ,(car decl)))
-		 declarations)
-       ,ret)))
+"
+;; Allocate objects from the heap
+  (recursive-append
+   (when declarations
+     `(let (,@(mapcar (lambda (decl) (let ((var (car decl)))
+					 (check-type var symbol)
+					 `(,var (cffi:foreign-alloc ,@(cdr decl)))))
+			declarations))))
+    ;; Store result and then free foreign-objects
+   (when declarations
+       `(multiple-value-prog1))
+   `((progn
+       ,@body)
+     ;;Free C objects
+     ,@(mapcar (lambda (decl) `(cffi:foreign-free ,(car decl)))
+	       declarations))))
 
 ;; Create objects on the stack and run the "body" of code.
-(defmacro with-foreign-objects-stack-ed (declarations &rest body)
-  "
-Allocate \"objects\" on the stack and run the \"body\" of code.
-
-with-foreign-objects-stack-ed (declarations) &rest body
-binding := {(var type &optional count &key (initial-contents nil))}*
-
-Example:
->> (with-foreign-objects-stack-ed ((x :int :count 10 :initial-element 2))
-     (+ (cffi:mem-aref x :int 2) 1))
-3
->>
-  "
-  (if (null declarations)
-      `(progn ,@body)
-      (let ((wfo-decl nil)
-	    (wfo-body nil)
-	    (wfo-before nil))
-	(loop for decl in declarations
-	   do (destructuring-bind (var type &key (count 1) initial-element initial-contents) decl
-		  ;;Make sure the var and type are symbols;;
-		(check-type var symbol)
-		(check-type type symbol)
-		(when (and initial-element initial-contents)
-		  (error "Cannot apply both :initial-element and :initial-contents at the same time."))
-		;;
-		(if (eq count 1)
-		    (progn
-		      ;; Count defaults to one in with-foreign-objects
-		      (nconsc wfo-decl `((,var ,type)))
-		      (if (or initial-element initial-contents)
-			  (nconsc wfo-body `((setf (cffi:mem-aref ,var ,type 0) ,@(cond
-										   (initial-element `(,initial-element))
-										   (initial-contents `((car ,initial-contents)))))))))
-		      ;;
-		      (let ((decl-count (gensym))
-			    (decl-init (gensym))
-			    (loop-var (gensym)))
-			;;
-			(nconsc wfo-before `((,decl-count ,count)))
-			(nconsc wfo-before `((,decl-init ,(or initial-element initial-contents))))
-			;;
-			(nconsc wfo-decl `((,var ,type ,decl-count)))
-			(if (or initial-element initial-contents)
-			    (nconsc wfo-body `((loop for ,loop-var from 0 below ,decl-count
-						  do (setf (cffi:mem-aref ,var ,type ,loop-var) ,@(cond
-												   (initial-element `(,decl-init))
-
-												   (initial-contents `((elt ,decl-init ,loop-var)))))))))))))
-	`(let (,@wfo-before)
-	   (cffi:with-foreign-objects (,@wfo-decl)
-	     ,@wfo-body
-	     ,@body)))))
+(defmacro with-foreign-objects-stacked (declarations &rest body)
+"
+  Allocate \"objects\" on the stack and run the \"body\" of code.
+
+  with-foreign-objects-stacked (declarations) &rest body
+  binding := {(var type &optional count &key (initial-contents nil))}*
+
+  Example:
+  >> (with-foreign-objects-stacked ((x :int :count 10 :initial-element 2))
+       (+ (cffi:mem-aref x :int 2) 1))
+  3
+  >>
+"
+  (let ((wfo-decl nil)
+	(wfo-body nil)
+	(wfo-before nil))
+    (dolist (decl declarations)
+      (destructuring-bind (var type &key (count 1) initial-element initial-contents) decl
+	;;Make sure the var and type are symbols;;
+	(check-type var symbol)
+	(check-type type symbol)
+	(when (and initial-element initial-contents)
+	  (error "Cannot apply both :initial-element and :initial-contents at the same time."))
+	;;
+	(if (eq count 1)
+	    (progn
+	      ;; Count defaults to one in with-foreign-objects
+	      (nconsc wfo-decl `((,var ,type)))
+	      (if (or initial-element initial-contents)
+		  (nconsc wfo-body `((setf (cffi:mem-aref ,var ,type 0) ,@(cond
+									   (initial-element `(,initial-element))
+									   (initial-contents `((elt ,initial-contents 0)))))))))
+	    ;;
+	    (let ((decl-count (gensym))
+		  (decl-init (gensym))
+		  (loop-var (gensym)))
+	      ;;
+	      (nconsc wfo-before `((,decl-count ,count)))
+	      (nconsc wfo-before `((,decl-init ,(or initial-element initial-contents))))
+	      ;;
+	      (nconsc wfo-decl `((,var ,type ,decl-count)))
+	      (if (or initial-element initial-contents)
+		  (nconsc wfo-body `((dotimes (,loop-var ,decl-count)
+				       (setf (cffi:mem-aref ,var ,type ,loop-var) ,@(cond
+										     (initial-element `(,decl-init))
+										     (initial-contents `((elt ,decl-init ,loop-var)))))))))))))
+	(recursive-append
+	 (when wfo-before
+	   `(let (,@wfo-before)))
+	 (if wfo-decl
+	     `(cffi:with-foreign-objects (,@wfo-decl))
+	     `(progn))
+	 `(,@wfo-body
+	   ,@body))))
 
 ;; Get the equivalent CFFI type.
 ;; If the type is an array, get the type of the array element type.
@@ -201,8 +206,7 @@ Example:
 			     (:string
 			      ;; String lengths are appended to the function arguments,
 			      ;; passed by value.
-			      (pushnew `(,(scat "LEN-" name) ,@(->cffi-type :integer))
-				       aux-pars)
+			      (nconsc aux-pars `((,(scat "LEN-" name) ,@(->cffi-type :integer))))
 			      `(,name ,@(->cffi-type :string)))
 			     (t
 			      `(,name ,@(get-read-in-type type style))))))
@@ -214,14 +218,14 @@ Example:
 ;; Call defcfun to define the foreign function.
 ;; Also creates a nice lisp helper function.
 (defmacro def-fortran-routine (func-name return-type &rest body)
-  (multiple-value-bind (name fortran-name) (if (listp func-name)
-					       (values (cadr func-name) (car func-name))
-					       (values func-name (make-fortran-name func-name)))
+  (multiple-value-bind (fortran-name name) (if (listp func-name)
+					       (values (car func-name) (cadr func-name))
+					       (values (make-fortran-name func-name) func-name))
     (let* ((lisp-name  (make-fortran-ffi-name `,name))
 	   (hack-return-type `,return-type)
 	   (hack-body `(,@body))
 	   (hidden-var-name nil))
-
+      ;;
       (multiple-value-bind (doc pars)
 	  (parse-doc-&-parameters `(,@body))
 	(when (member hack-return-type '(:complex-single-float :complex-double-float))
@@ -236,7 +240,7 @@ Example:
 			    (,hidden-var-name ,hack-return-type :output)
 			    ,@pars))
 	  (setq hack-return-type :void)))
-
+      
       `(eval-when (load eval compile)
 	 (progn
 	   ;; Removing 'inlines' It seems that CMUCL has a problem with
@@ -257,6 +261,7 @@ Example:
 	  (return-vars nil)
 	  (array-vars nil)
 	  (ref-vars nil)
+	  (callback-code nil)
 	  ;;
 	  (defun-args nil)
 	  (defun-keyword-args nil)
@@ -265,133 +270,230 @@ Example:
 	  ;;
 	  (ffi-args nil)
 	  (aux-ffi-args nil))
-      (loop for decl in pars
-	 do (destructuring-bind (var type &optional style) decl
-	      (let ((ffi-var nil)
-		    (aux-var nil))
-		(cond
-		  ;; Callbacks are tricky because the data inside
-		  ;; pointer arrays will need to be copied without
-		  ;; implicit knowledge of the size of the array.
-		  ;; This is usually taken care of by special data
-		  ;; structure - ala GSL - or by passing additional
-		  ;; arguments to the callback to apprise it of the
-		  ;; bounds on the arrays.
-		  ;; TODO: Add support for declaring array dimensions
-		  ;; in the callback declaration.
-		  ((callback-type-p type)
-		   (setq ffi-var var))
-		  ;; Can't really enforce "style" when given an array.
-		  ;; Complex numbers do not latch onto this case, they
-		  ;; are passed by value.
-		  ((array-p type)
-		   (setq ffi-var (scat "ADDR-" var))
-		   (nconsc array-vars `((,ffi-var ,var)))
-		   ;;
-		   (when-let (arg (get-arg :inc type))
-		     (nconsc defun-keyword-args
-			     `((,arg 0)))
-		     (nconc (car (last array-vars)) `(:inc-type ,(cadr type) :inc ,arg))))
-		  ;; Strings
-		  ((string-p type)
-		   (setq ffi-var var)
-		   (setq aux-var (scat "LEN-" var))
-		   (nconsc aux-args `((,aux-var (length (the string ,var))))))
-		  ;; Pass-by-value variables
-		  ((eq style :input-value)
-		   (setq ffi-var var))
-		  ;; Pass-by-reference variables
-		  (t
-		   (cond
-		     ;; Makes more sense to copy complex numbers into
-		     ;; arrays, rather than twiddling around with lisp
-		     ;; memory internals.
-		     ((member type '(:complex-single-float :complex-double-float))
-		      (setq ffi-var (scat "ADDR-REAL-CAST-" var))
-		      (nconsc ref-vars
-			      `((,ffi-var ,(second (->cffi-type type)) :count 2 :initial-contents (list (realpart ,var) (imagpart ,var))))))
-		     (t
-		      (setq ffi-var (scat "REF-" var))
-		      (nconsc ref-vars
-			      `((,ffi-var ,@(->cffi-type type) :initial-element ,var)))))))
-		;; Output variables
-		(when (and (output-p style) (not (eq type :string)))
-		  (nconsc return-vars
-			  `((,ffi-var ,var ,type))))
-		;; Arguments for the lisp wrapper
-		(when (not (eq var hidden-var-name))
-		  (nconsc defun-args
-			  `(,var)))
-		;; Arguments for the FFI function
-		(nconsc ffi-args
-			`(,ffi-var))
-		;; Auxillary arguments for FFI
-		(when (not (null aux-var))
-		  (nconsc aux-ffi-args
-			  `(,aux-var))))))
-      ;;Return the function definition
+      (dolist (decl pars)
+	(destructuring-bind (var type &optional style) decl
+	  (let ((ffi-var nil)
+		(aux-var nil))
+	    (cond
+	      ;; Callbacks are tricky.
+	      ((callback-type-p type)
+	       (let* ((callback-name (gensym (symbol-name var)))
+		      (c-callback-code (def-fortran-callback var callback-name (second type) (cddr type))))
+		 (nconsc callback-code c-callback-code)
+		 (setq ffi-var `(cffi:callback ,callback-name))))
+	      ;; Can't really enforce "style" when given an array.
+	      ;; Complex numbers do not latch onto this case, they
+	      ;; are passed by value.
+	      ((array-p type)
+	       (setq ffi-var (scat "ADDR-" var))
+	       (nconsc array-vars `((,ffi-var ,var)))
+	       ;;
+	       (when-let (arg (get-arg :inc type))
+		 (nconsc defun-keyword-args
+			 `((,arg 0)))
+		 (nconc (car (last array-vars)) `(:inc-type ,(cadr type) :inc ,arg))))
+	      ;; Strings
+	      ((string-p type)
+	       (setq ffi-var var)
+	       (setq aux-var (scat "LEN-" var))
+	       (nconsc aux-args `((,aux-var (length (the string ,var))))))
+	      ;; Pass-by-value variables
+	      ((eq style :input-value)
+	       (setq ffi-var var))
+	      ;; Pass-by-reference variables
+	      (t
+	       (cond
+		 ;; Makes more sense to copy complex numbers into
+		 ;; arrays, rather than twiddling around with lisp
+		 ;; memory internals.
+		 ((member type '(:complex-single-float :complex-double-float))
+		  (setq ffi-var (scat "ADDR-REAL-CAST-" var))
+		  (nconsc ref-vars
+			  `((,ffi-var ,(second (->cffi-type type)) :count 2 :initial-contents (list (realpart ,var) (imagpart ,var))))))
+		 (t
+		  (setq ffi-var (scat "REF-" var))
+		  (nconsc ref-vars
+			  `((,ffi-var ,@(->cffi-type type) :initial-element ,var)))))))
+	    ;; Output variables
+	    (when (and (output-p style) (not (eq type :string)))
+	      (nconsc return-vars
+		      `((,ffi-var ,var ,type))))
+	    ;; Arguments for the lisp wrapper
+	    (unless (eq var hidden-var-name)
+	      (nconsc defun-args
+		      `(,var)))
+	    ;; Arguments for the FFI function
+	    (nconsc ffi-args
+		    `(,ffi-var))
+	    ;; Auxillary arguments for FFI
+	    (unless (null aux-var)
+	      (nconsc aux-ffi-args
+		      `(,aux-var))))))
+      ;;Complex returns through hidden variable.
+      (unless (null hidden-var-name)
+	(nconsc aux-args `((,hidden-var-name ,(ecase (second (first pars))
+						     (:complex-single-float #c(0e0 0e0))
+						     (:complex-double-float #c(0d0 0d0)))))))
+      ;;Keyword argument list
       (unless (null defun-keyword-args)
-	(setq defun-keyword-args (append '(&key) defun-keyword-args)))
+	(setq defun-keyword-args (cons '&key defun-keyword-args)))
+      ;;Return the function definition
+      (let ((retvar (gensym)))
+	`(
+	  ,(recursive-append
+	    `(defun ,name ,(append defun-args defun-keyword-args)
+	       ,@doc)
+	    ;;
+	    (unless (null aux-args)
+	      `(let (,@aux-args)))
+	    ;;Don't use with-foreign.. if ref-vars is nil
+	    (unless (null ref-vars)
+	      `(with-foreign-objects-stacked (,@ref-vars)))
+	    ;;Don't use with-vector-dat.. if array-vars is nil
+	    (unless (null array-vars)
+	      `(with-vector-data-addresses (,@array-vars)))
+	    ;;Declare callbacks
+	    callback-code
+	    ;;Call the foreign-function
+	    `(let ((,retvar (,ffi-fn ,@ffi-args ,@aux-ffi-args)))
+	       ;;Ignore return if type is :void
+	       ,@(when (eq return-type :void)
+		       `((declare (ignore ,retvar))))
+	       ;; Copy values in reference pointers back to local
+	       ;; variables.  Lisp has local scope; its safe to
+	       ;; modify variables in parameter lists.
+	       ,@(mapcar #'(lambda (decl)
+			     (destructuring-bind (ffi-var var type) decl
+			       (if (member type '(:complex-single-float :complex-double-float))
+				   `(setq ,var (complex (cffi:mem-aref ,ffi-var ,(second (->cffi-type type)...
 
[truncated message content]