Commit 59f80be4 authored by Liam Healy's avatar Liam Healy

Combinations are garbage-collected; restore floating-point and mathematical

Redefine #'alloc-gsl-struct as a generic function and define a method
specifically for combinations.  Define #'native-pointer in
defmfun.lisp with a new function #'native-pointer-protect made from
its body left in data.lisp, so that now floating-point and
mathematical can be compiled and loaded as defined in the asd file.
Use :pointer for foreign argument types instead of gsl-vector-c.
parent 9b1ed35d
;; 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
......
;; "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.
;; 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)
......
;; 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)
......
;; 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
......
;; 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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment