diff --git a/data/combination.lisp b/data/combination.lisp index 33cb2aac412c9a723554f06decbdbffc76dabed8..a95a66c7feedfd59636fc5cd8d1dd2b7a0fb98db 100644 --- a/data/combination.lisp +++ b/data/combination.lisp @@ -1,6 +1,6 @@ ;; Combinations ;; Liam Healy, Sun Mar 26 2006 - 11:51 -;; Time-stamp: <2008-10-25 19:05:36EDT combination.lisp> +;; Time-stamp: <2008-11-29 15:09:07EST combination.lisp> ;; $Id$ (in-package :gsl) @@ -39,15 +39,14 @@ 'combination :cl-array (make-array* k *sizet-type*) :mpointer nil ; this will be set by :before method below. - :c-pointer nil ; this will be set by defmfun + #-native :c-pointer #-native nil ; this will be set by defmfun :dimensions (copy-list nk) + ;; The total-size of a combination is k, because that is the length + ;; of the vector that represents it. :total-size k))) -(defmethod mpointer :before ((object combination)) - "Make a GSL struct if there isn't one already." +(defmethod alloc-gsl-struct ((object combination)) (unless (slot-value object 'mpointer) - ;; Cribbed from alloc-gsl-struct - (unless (c-pointer object) (error "No C array.")) ; safety while developing (let ((blockptr (cffi:foreign-alloc 'gsl-combination-c))) (setf (block-pointer object) blockptr @@ -58,11 +57,10 @@ (cffi:foreign-slot-value blockptr 'gsl-combination-c 'k) (elt (dimensions object) 1) (mpointer object) - (block-pointer object))) - nil)) - -;;; The total-size of a combination is k, because that is the length -;;; of the vector that represents it. + (block-pointer object)) + (tg:finalize + object + (lambda () (cffi:foreign-free blockptr)))))) ;;;;**************************************************************************** ;;;; Setting values diff --git a/data/data.lisp b/data/data.lisp index b2e5ab0ff9d9232629ebeb0c37a375028d3da807..4bc3f1d02e4b82036fb56724a6b9dcdec8dfa6bc 100644 --- a/data/data.lisp +++ b/data/data.lisp @@ -1,7 +1,7 @@ ;; "Data" is bulk arrayed data, like vectors, matrices, permutations, ;; combinations, or histograms. ;; Liam Healy 2008-04-06 21:23:41EDT -;; Time-stamp: <2008-11-27 22:58:31EST data.lisp> +;; Time-stamp: <2008-11-29 15:08:23EST data.lisp> ;; $Id$ (in-package :gsl) @@ -314,25 +314,25 @@ (size sizet) (data :pointer)) -(defun alloc-gsl-struct (object) - "Allocate the GSL structure." - ;; Need to check that all allocations succeeded. - ;; This should only be called from #'mpointer - ;; thus it will be created only when first needed. - (unless (block-pointer object) - (let ((blockptr (cffi:foreign-alloc 'gsl-block-c))) - (setf (block-pointer object) - blockptr - (cffi:foreign-slot-value blockptr 'gsl-block-c 'size) - (total-size object)) - (setf - (cffi:foreign-slot-value (block-pointer object) 'gsl-block-c 'data) - (c-pointer object)) - (let ((array-struct (alloc-from-block object))) - (tg:finalize - object - (lambda () - (unless (eq blockptr array-struct) - (cffi:foreign-free blockptr)) - (cffi:foreign-free array-struct))) - (setf (mpointer object) array-struct))))) +(defgeneric alloc-gsl-struct (object) + (:documentation "Allocate the GSL structure.") + (:method ((object gsl-data)) + ;; Need to check that all allocations succeeded. + (unless (block-pointer object) + (let ((blockptr (cffi:foreign-alloc 'gsl-block-c))) + (setf (block-pointer object) + blockptr + (cffi:foreign-slot-value blockptr 'gsl-block-c 'size) + (total-size object) + (cffi:foreign-slot-value (block-pointer object) 'gsl-block-c 'data) + (c-pointer object)) + (let ((array-struct (alloc-from-block object))) + (tg:finalize + object + (lambda () + (unless (eq blockptr array-struct) + (cffi:foreign-free blockptr)) + (cffi:foreign-free array-struct))) + (setf (mpointer object) array-struct)))))) + +;;; For #-native, do the whole thing using _alloc, _free functions. diff --git a/data/foreign-friendly.lisp b/data/foreign-friendly.lisp index 9febaea8fbfc2772ce16c635417e2edde043c5a3..47708326f2f996c63e3621745bfdcebe32a8cecc 100644 --- a/data/foreign-friendly.lisp +++ b/data/foreign-friendly.lisp @@ -1,6 +1,6 @@ ;; Use the foreign-friendly arrays package. ;; Liam Healy 2008-03-22 15:40:08EDT -;; Time-stamp: <2008-11-27 22:59:29EST foreign-friendly.lisp> +;; Time-stamp: <2008-11-29 11:16:03EST foreign-friendly.lisp> ;; $Id$ ;;; Foreign-friendly arrays (original implementation by Tamas Papp) @@ -78,15 +78,13 @@ ;;; To be called by a defmfun expander #+sbcl -(defun native-pointer (array-symbols body) +(defun native-pointer-protect (array-symbols body) "Wrap the body with a form that obtains the native pointer and protects it during execution of the body." - (if array-symbols - ;; http://www.sbcl.org/manual/Calling-Lisp-From-C.html - `(sb-sys:with-pinned-objects - ,(mapcar (lambda (s) `(original-array ,s)) array-symbols) - ,body) - body)) + ;; http://www.sbcl.org/manual/Calling-Lisp-From-C.html + `(sb-sys:with-pinned-objects + ,(mapcar (lambda (s) `(original-array ,s)) array-symbols) + ,body)) #+sbcl (defun c-pointer (gsl-data) diff --git a/data/vector.lisp b/data/vector.lisp index 21c4b659175e8f8f01710ece91f19837ea42b054..b968fee54dd14063bee3b5ee79902e6a7890a9e1 100644 --- a/data/vector.lisp +++ b/data/vector.lisp @@ -1,6 +1,6 @@ ;; Vectors ;; Liam Healy 2008-04-13 09:39:02EDT vector.lisp -;; Time-stamp: <2008-11-15 13:35:01EST vector.lisp> +;; Time-stamp: <2008-11-29 14:19:54EST vector.lisp> ;; $Id$ (in-package :gsl) @@ -53,7 +53,7 @@ (defmfun vector-reverse ((vec vector)) ("gsl_" :category :type "_reverse") - (((mpointer vec) gsl-vector-c)) + (((mpointer vec) :pointer)) :definition :generic :inputs (vec) :outputs (vec) diff --git a/gsll.asd b/gsll.asd index 8b0bea7a6c9f53442090574ac2a312a7de550513..11a224ed246e91473a94bf466e351ce3e6d9d79e 100644 --- a/gsll.asd +++ b/gsll.asd @@ -1,6 +1,6 @@ ;; Definition of GSLL system ;; Liam Healy -;; Time-stamp: <2008-11-23 14:08:05EST gsll.asd> +;; Time-stamp: <2008-11-29 11:18:52EST gsll.asd> ;; $Id$ (asdf:defsystem "gsll" @@ -23,12 +23,10 @@ (:file "defmfun" :depends-on (init element-types interface)) (:file "callback" :depends-on (init)) (:file "generate-examples" :depends-on (init)))) - #+(or) (:module floating-point :depends-on (init) :components ((:file "ieee-modes"))) - #+(or) (:file "mathematical" :depends-on (init)) ;; complex numbers not necessary? Just make a struct. (:module data diff --git a/init/defmfun.lisp b/init/defmfun.lisp index 61aaccd04938caa92f91fefbbc93c106b4471e28..6bae89818cc8c45a88985f014047511492288a4f 100644 --- a/init/defmfun.lisp +++ b/init/defmfun.lisp @@ -1,6 +1,6 @@ ;; Macro for defining GSL functions. ;; Liam Healy 2008-04-16 20:49:50EDT defmfun.lisp -;; Time-stamp: <2008-11-23 14:09:12EST defmfun.lisp> +;; Time-stamp: <2008-11-29 14:20:17EST defmfun.lisp> ;; $Id$ (in-package :gsl) @@ -145,7 +145,7 @@ 'gsl-zerop '((v vector)) '("gsl_vector" :type "_isnull") - '(((pointer v) gsl-vector-c)) + '(((pointer v) :pointer)) '(:c-return :boolean :definition :generic :documentation ; FDL @@ -181,7 +181,7 @@ 'gsl-zerop '((v vector)) '("gsl_vector" :type "_isnull") - '(((pointer v) gsl-vector-c)) + '(((pointer v) :pointer)) '(:c-return :boolean :definition :methods :documentation ; FDL @@ -507,6 +507,14 @@ (stupid-code-walk-find-variables (st-symbol carg))) c-arguments))) +(defun native-pointer (array-symbols body) + "Wrap the body with a form that obtains the native pointer + and protects it during execution of the body." + (if array-symbols + ;; http://www.sbcl.org/manual/Calling-Lisp-From-C.html + (native-pointer-protect array-symbols body) + body)) + (defun complete-definition (definition name arglist gsl-name c-arguments key-args &optional