From c01366d6cfe2a998c805e6a3e55785cee12c55c8 Mon Sep 17 00:00:00 2001
From: Liam Healy <lnp@healy.washington.dc.us>
Date: Mon, 29 Dec 2008 17:45:01 -0500
Subject: [PATCH] Better support for non-native implementations

Testing with Clozure reveals more details on the stack overflow
problem than what CLISP reveals.  This is fixed by using #'slot-value
instead of #'cl-array in  #'copy-c-to-cl and #'copy-cl-to-c.
Non-complex arrays were not handled correctly in
#'copy-array-from-pointer; fixed.  There is a dependency of
permutation and combination on the definition of #'data-class-name
through defmfun.  Test results:
CCL: TOTAL: 1143 assertions passed, 52 failed, 3 execution errors.
CLISP: TOTAL: 996 assertions passed, 149 failed, 11 execution errors.
SBCL: TOTAL: 1208 assertions passed, 0 failed, 0 execution errors.
(But only the second time it's run in SLIME.)
Variable *print-contents* to disable printing of marray contents in
print-object; this is helpful for debugging.
---
 data/foreign-array.lisp | 25 ++++++++++++++++---------
 gsll.asd                |  6 +++---
 init/mobject.lisp       | 13 +++++++------
 3 files changed, 26 insertions(+), 18 deletions(-)

diff --git a/data/foreign-array.lisp b/data/foreign-array.lisp
index 91285b1f..df72f914 100644
--- a/data/foreign-array.lisp
+++ b/data/foreign-array.lisp
@@ -1,6 +1,6 @@
 ;; Foreign arrays (usually in C)
 ;; Liam Healy 2008-12-28 10:44:22EST foreign-array.lisp
-;; Time-stamp: <2008-12-28 21:39:02EST foreign-array.lisp>
+;; Time-stamp: <2008-12-29 14:34:24EST foreign-array.lisp>
 ;; $Id: $
 
 (in-package :gsl)
@@ -63,10 +63,16 @@
 	    (* index-offset
 	       (cffi:foreign-type-size (cl-cffi (element-type object))))))))
 
+(defparameter *print-contents* t
+  "Print the contents of the foreign-array.")
+
 (defmethod print-object ((object foreign-array) stream)
   (print-unreadable-object (object stream :type t) 
-    #-native (copy-c-to-cl object)
-    (princ (cl-array object) stream)))
+    (if *print-contents*
+	(progn
+	  #-native (copy-c-to-cl object)
+	  (princ (cl-array object) stream))
+	(format stream "dimensions ~a" (dimensions object)))))
 
 (defun dim0 (object)
   "The first dimension of the object."
@@ -95,7 +101,7 @@
   "Copy the CL array to the C array."
   (when (c-invalid object)
     (copy-array-to-pointer
-     (cl-array object)
+     (slot-value object 'cl-array)
      (c-pointer object)
      (element-type object)
      0
@@ -108,7 +114,7 @@
   "Copy the C array to the CL array."
   (when (cl-invalid object)
     (copy-array-from-pointer
-     (cl-array object)
+     (slot-value object 'cl-array)
      (c-pointer object)
      (element-type object)
      0
@@ -144,7 +150,8 @@
        for array-index :from index-offset
        do
        (setf (row-major-aref array array-index)
-	     (complex 
-	      (cffi:mem-aref pointer cffi-type pointer-index)
-	      (cffi:mem-aref pointer cffi-type (1+ pointer-index)))))))
-
+	     (if (subtypep lisp-type 'complex)
+		 (complex 
+		  (cffi:mem-aref pointer cffi-type pointer-index)
+		  (cffi:mem-aref pointer cffi-type (1+ pointer-index)))
+		 (cffi:mem-aref pointer cffi-type pointer-index))))))
diff --git a/gsll.asd b/gsll.asd
index 3398ec8c..4dfd81f7 100644
--- a/gsll.asd
+++ b/gsll.asd
@@ -1,6 +1,6 @@
 ;; Definition of GSLL system 
 ;; Liam Healy
-;; Time-stamp: <2008-12-28 16:46:47EST gsll.asd>
+;; Time-stamp: <2008-12-29 13:35:30EST gsll.asd>
 ;; $Id$
 
 (asdf:defsystem "gsll"
@@ -40,8 +40,8 @@
 	     (:file "maref" :depends-on (marray vector matrix))
 	     (:file "both" :depends-on (marray vector matrix))
 	     (:file "array-tests" :depends-on (both))
-	     (:file "permutation" :depends-on (foreign-array))
-	     (:file "combination" :depends-on (foreign-array))))
+	     (:file "permutation" :depends-on (marray))
+	     (:file "combination" :depends-on (marray))))
    (:file "polynomial" :depends-on (init data))
    (:module special-functions
 	    :depends-on (init)
diff --git a/init/mobject.lisp b/init/mobject.lisp
index f87a3971..a38d0fab 100644
--- a/init/mobject.lisp
+++ b/init/mobject.lisp
@@ -1,6 +1,6 @@
 ;; Definition of GSL objects and ways to use them.
 ;; Liam Healy, Sun Dec  3 2006 - 10:21
-;; Time-stamp: <2008-12-28 20:45:50EST mobject.lisp>
+;; Time-stamp: <2008-12-29 17:37:25EST mobject.lisp>
 ;; $Id$
 
 ;;; GSL objects are represented in GSLL as and instance of a 'mobject.
@@ -136,9 +136,11 @@
   (:documentation "The name given to the GSL object."))
 
 ;;; Pointer type
-(defconstant +foreign-pointer-class+ (class-name (class-of (cffi:null-pointer)))
-  "The class in which foreign pointers fall.  This will be assumed to be a 
-   GSL vector or matrix.")
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defconstant +foreign-pointer-class+ (class-name (class-of (cffi:null-pointer)))
+    "The class in which foreign pointers fall.")
+  (defconstant +foreign-pointer-type+ (type-of (cffi:null-pointer))
+    "The type of foreign pointers."))
 
 ;;; Some functions in solve-minimize-fit return a pointer to a GSL
 ;;; vector with double-floats.  This function will return a contents
@@ -151,7 +153,6 @@
    "Create a contents list from the GSL object of type struct-type
     referenced by pointer."))
 
-;;; CLISP bug? doesn't know about +foreign-pointer-class+ defined above
-#-clisp
 (defmethod mpointer ((object #.+foreign-pointer-class+))
+  (check-type object #.+foreign-pointer-type+)
   object)
-- 
GitLab