From 59f80be46fd5377598d1a5d21da2e6cf7ae640c0 Mon Sep 17 00:00:00 2001
From: Liam Healy <liam@thinkpad.local>
Date: Sat, 29 Nov 2008 15:20:58 -0500
Subject: [PATCH] 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.
---
 data/combination.lisp      | 20 ++++++++---------
 data/data.lisp             | 46 +++++++++++++++++++-------------------
 data/foreign-friendly.lisp | 14 +++++-------
 data/vector.lisp           |  4 ++--
 gsll.asd                   |  4 +---
 init/defmfun.lisp          | 14 +++++++++---
 6 files changed, 52 insertions(+), 50 deletions(-)

diff --git a/data/combination.lisp b/data/combination.lisp
index 33cb2aac..a95a66c7 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 b2e5ab0f..4bc3f1d0 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 9febaea8..47708326 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 21c4b659..b968fee5 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 8b0bea7a..11a224ed 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 61aaccd0..6bae8981 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
-- 
GitLab