From c75e91d2ccc85d04fa7bbe71521e74fb54e097ba Mon Sep 17 00:00:00 2001 From: Liam Healy <liam@thinkpad.local> Date: Wed, 23 Dec 2009 23:13:21 -0500 Subject: [PATCH] Remove grid to the gsd/c-array repository The grid subdirectory is now the c-array system within the GSD repository, as it has no GSL-dependent definitions and is potentially useful on its own for other C libraries. There is a bare minimum mention of GSD in the documentation, which needs to be enhanced as it is required for GSLL to compile/load. --- data/marray.lisp | 7 +- documentation/index.html | 4 +- grid/complex-types.lisp | 53 ----------- grid/copy.lisp | 40 -------- grid/element-reference.lisp | 55 ----------- grid/element-types.lisp | 49 ---------- grid/foreign-array.lisp | 184 ------------------------------------ grid/foreign-friendly.lisp | 141 --------------------------- grid/methods.lisp | 19 ---- grid/number-conversion.lisp | 36 ------- grid/pkgdcl.lisp | 12 --- grid/symbol-type.lisp | 46 --------- grid/types.lisp | 141 --------------------------- gsll.asd | 25 +---- init/defmfun-array.lisp | 4 +- init/types.lisp | 3 +- 16 files changed, 16 insertions(+), 803 deletions(-) delete mode 100644 grid/complex-types.lisp delete mode 100644 grid/copy.lisp delete mode 100644 grid/element-reference.lisp delete mode 100644 grid/element-types.lisp delete mode 100644 grid/foreign-array.lisp delete mode 100644 grid/foreign-friendly.lisp delete mode 100644 grid/methods.lisp delete mode 100644 grid/number-conversion.lisp delete mode 100644 grid/pkgdcl.lisp delete mode 100644 grid/symbol-type.lisp delete mode 100644 grid/types.lisp diff --git a/data/marray.lisp b/data/marray.lisp index 21553c26..03832d6a 100644 --- a/data/marray.lisp +++ b/data/marray.lisp @@ -1,6 +1,6 @@ ;; A "marray" is an array in both GSL and CL ;; Liam Healy 2008-04-06 21:23:41EDT -;; Time-stamp: <2009-12-22 23:17:22EST marray.lisp> +;; Time-stamp: <2009-12-23 23:03:10EST marray.lisp> (in-package :gsl) @@ -88,8 +88,9 @@ ;; e.g. (data-class-name 'vector '(unsigned-byte 8)) ;; -> VECTOR-UNSIGNED-BYTE-8 (if (member category '(vector matrix)) - (intern (format nil "~a-~a" category (c-array:cl-single element-type)) - :gsl) + (intern + (format nil "~a-~a" category (c-array:cl-single element-type :gsl)) + :gsl) category)) (defun data-defclass (category superclass) diff --git a/documentation/index.html b/documentation/index.html index 469399e4..1cf2ed05 100644 --- a/documentation/index.html +++ b/documentation/index.html @@ -117,6 +117,8 @@ combination for which the following are supported:</p> <li><a href="http://common-lisp.net/project/cl-utilities/">cl-utilities</a> </li> <li><a href="http://www.cliki.net/asdf">ASDF</a></li> +<li><a>GSD</a>, the <i>Grid Structured Data</i>; in particular, + the <code>c-array</code> system</li> <li><a href="http://repo.or.cz/w/lisp-unit.git">lisp-unit</a>, <i>(Optional)</i> necessary to run <code>gsll-tests</code> </li> @@ -450,7 +452,7 @@ and arrays used internally or for function return. <!-- Created: Feb 25 2005 --> <!-- hhmts start --> <small> -Time-stamp: <2009-12-07 22:51:15EST index.html> +Time-stamp: <2009-12-23 23:10:30EST index.html> </small> <!-- hhmts end --> </div> diff --git a/grid/complex-types.lisp b/grid/complex-types.lisp deleted file mode 100644 index 12a548cf..00000000 --- a/grid/complex-types.lisp +++ /dev/null @@ -1,53 +0,0 @@ -;; Complex number types -;; Liam Healy 2009-01-13 21:24:05EST complex-types.lisp -;; Time-stamp: <2009-12-06 22:05:59EST complex-types.lisp> - -(in-package :c-array) - -(export '(complex-double-c complex-float-c component-float-type component-type)) - -;;;;**************************************************************************** -;;;; Complex types -;;;;**************************************************************************** - -#+fsbv -(fsbv:defcstruct - (complex-float-c :constructor complex :deconstructor (realpart imagpart)) - (dat :float :count 2)) - -#-fsbv -(cffi:defcstruct complex-float-c (dat :float :count 2)) - -#+fsbv -(fsbv:defcstruct - (complex-double-c :constructor complex :deconstructor (realpart imagpart)) - (dat :double :count 2)) - -#-fsbv -(cffi:defcstruct complex-double-c (dat :double :count 2)) - -#+long-double -(cffi:defcstruct complex-long-double-c - (dat :long-double :count 2)) - -(defun clean-type (type) - ;; SBCL at least will specify limits on the type, e.g. - ;; (type-of #C(1.0 2.0)) - ;; (COMPLEX (DOUBLE-FLOAT 1.0 2.0)) - ;; This cleans that up to make - ;; (clean-type (type-of #C(1.0 2.0))) - ;; (COMPLEX DOUBLE-FLOAT) - (if (and (subtypep type 'complex) (listp (second type))) - (list (first type) (first (second type))) - type)) - -(defun component-float-type (eltype) - "The type of the component of this type (complex)." - (if (subtypep eltype 'complex) - ;; complex: use the component type - (second eltype) - eltype)) - -(defun component-type (eltype) - (cl-cffi (component-float-type eltype))) - diff --git a/grid/copy.lisp b/grid/copy.lisp deleted file mode 100644 index bc2f1019..00000000 --- a/grid/copy.lisp +++ /dev/null @@ -1,40 +0,0 @@ -;; Copy objects -;; Liam Healy 2009-12-21 10:16:04EST copy.lisp -;; Time-stamp: <2009-12-21 10:46:41EST copy.lisp> -;; $Id: $ - -(in-package :c-array) - -(export - '(copy clone copy-to-destination copy-making-destination array-mismatch)) - -(defun copy (object &optional destination) - "Create a duplicate object." - (if destination - (copy-to-destination object destination) - (copy-making-destination object))) - -;;; Could be part of copy when the second argument is optional? -(defgeneric clone (object) - (:documentation "Create a duplicate object.")) - -(defgeneric copy-making-destination (object) - (:documentation "Create new duplicate object.")) - -(defgeneric copy-to-destination (object destination) - ;; This copies values into an existing object. Methods are defined - ;; for non-array GSL objects that have _memcpy functions defined. - ;; Defined for - ;; random-number-generator, quasi-random-number-generator, - ;; histogram, histogram2d, permutation, combination. - (:documentation "Copy contents into existing object.")) - -(define-condition array-mismatch (error) - () - (:report - (lambda (condition stream) - (declare (ignore condition)) - (format stream "Arrays must be of equal size for copying."))) - (:documentation - "An error indicating that the two arrays do not have - the same dimensions.")) diff --git a/grid/element-reference.lisp b/grid/element-reference.lisp deleted file mode 100644 index 6b953134..00000000 --- a/grid/element-reference.lisp +++ /dev/null @@ -1,55 +0,0 @@ -;; Get/set array or elements: cl-array, maref -;; Liam Healy 2009-12-21 09:40:27EST element-reference.lisp -;; Time-stamp: <2009-12-21 15:55:44EST element-reference.lisp> - -(in-package :c-array) - -(export '(cl-array)) - -;;; These functions handle the details of converting between the C -;;; representation of arrays and Common Lisp arrays. The function -;;; #'maref can be treated like #'aref for reading and setting -;;; elements, except that it is limited to two indices (vectors or -;;; matrices only) and requires a final argument with the element -;;; type when taking a C pointer as the first argument (only needed -;;; in the case of solve-minimize-fit for callbacks and some return -;;; values). - -;;; Both these functions take one of the following class arguments for -;;; the array: -;;; - a foreign-array -;;; - a Common Lisp array - -;;;;**************************************************************************** -;;;; Get the entire array: cl-array -;;;;**************************************************************************** - -(defgeneric cl-array (object &optional array-rank element-type) - (:documentation - "The array as a CL native array. The object may be a foreign-array object, - or an ordinary CL array of one or two dimensions. Optional - arguments array-rank and element-type are used only for - pointers.") - (:method ((object foreign-array) &optional array-rank element-type) - (declare (ignore array-rank element-type)) - #-native (copy-c-to-cl object) - (slot-value object 'grid:data)) - (:method ((object array) &optional array-rank element-type) - ;; For compatibility, work on CL arrays as well. - (declare (ignore array-rank element-type)) - object)) - -;;;;**************************************************************************** -;;;; Get or set elements of the array: gref, (setf gref) -;;;;**************************************************************************** - -(defmethod grid:gref ((object foreign-array) &rest indices) - #-native (copy-c-to-cl object) - (apply 'aref (grid:grid-data object) indices)) - -;;; Alternative to complete copy is to mark which elements have -;;; changed and just copy them. Is it worth it? - -(defmethod (setf grid:gref) (value (object foreign-array) &rest indices) - (apply '(setf aref) value (grid:grid-data object) indices) - #-native (setf (c-invalid object) t)) diff --git a/grid/element-types.lisp b/grid/element-types.lisp deleted file mode 100644 index 49a19159..00000000 --- a/grid/element-types.lisp +++ /dev/null @@ -1,49 +0,0 @@ -;; Mapping of element type names -;; Liam Healy 2008-04-13 11:22:46EDT element-types.lisp -;; Time-stamp: <2009-12-07 22:51:13EST element-types.lisp> -;; $Id$ - -(in-package :c-array) - -(export '(*array-element-types* *array-element-types-no-complex* - *float-complex-types* *float-types* *complex-types* - *double-types* element-types)) -;;;;**************************************************************************** -;;;; Common element type groups for generic functions -;;;;**************************************************************************** - -(defparameter *array-element-types* - (remove-duplicates (all-types *cstd-cl-type-mapping* t) :test 'equal) - "All the array element types supported.") - -(defparameter *array-element-types-no-complex* - (remove-if (lambda (tp) (subtypep tp 'complex)) *array-element-types*) - "All the array element types supported except for complex types.") - -(defparameter *float-complex-types* - (remove-if (lambda (tp) (subtypep tp 'integer)) *array-element-types*) - "All the float or complex array element types supported.") - -(defparameter *float-types* - (remove-if-not (lambda (tp) (subtypep tp 'float)) *array-element-types*) - "All the float array element types.") - -(defparameter *complex-types* - (remove-if-not (lambda (tp) (subtypep tp 'complex)) *array-element-types*) - "All the supported complex array element types.") - -(defparameter *double-types* - (list 'double-float '(complex double-float)) - "All the supported double float element types.") - -(defun element-types (element-types) - "All the element types available of a given category." - (case element-types - ((nil t) *array-element-types*) - (:no-complex *array-element-types-no-complex*) - (:float *float-types*) - (:complex *complex-types*) - (:float-complex *float-complex-types*) - (:doubles *double-types*) - (t element-types))) - diff --git a/grid/foreign-array.lisp b/grid/foreign-array.lisp deleted file mode 100644 index 75bebb27..00000000 --- a/grid/foreign-array.lisp +++ /dev/null @@ -1,184 +0,0 @@ -;; Foreign (C or C-compatible) arrays -;; Liam Healy 2008-12-28 10:44:22EST foreign-array.lisp -;; Time-stamp: <2009-12-21 22:27:03EST foreign-array.lisp> - -(in-package :c-array) - -;;;;**************************************************************************** -;;;; Object and methods -;;;;**************************************************************************** - -(export '(foreign-array dimensions total-size element-type element-size - *print-contents*)) - -#-native -(defgeneric (setf cl-invalid) (value object) ; do nothing - (:method (value (object t)) value)) - -#-native -(defgeneric (setf c-invalid) (value object) ; do nothing - (:method (value (object t)) value)) - -(defclass foreign-array (grid:grid) - (#-native - (c-pointer :accessor c-pointer :documentation "A pointer to the C array.") - (dimensions :reader dimensions) - (total-size :reader total-size) - (element-type :initarg :element-type :reader element-type) - (original-array :reader original-array) - (offset :reader offset) - #-native - (cl-invalid - :initform t :accessor cl-invalid - :documentation - "An indication of whether the Lisp object (slot 'data) agrees with the - C data. If NIL, they agree. If T, they disagree in an unspecified - way. If a list of index sets, those indices disagree and the remainder - are correct.") - #-native - (c-invalid - :initform t :accessor c-invalid - :documentation - "An indication of whether the C data agrees with the - Lisp object (slot 'data). If NIL, they agree. If T, - they disagree in an unspecified - way. If a list of index sets, those indices disagree and the remainder - are correct.")) - (:documentation - "A superclass for arrays represented in C and CL.")) - -(defun foreign-array-specification (object dimensions) - "Create the grid specification for the object, with a possibly - different set of dimensions." - (let ((class - (or - (find-if (lambda (cl) (typep object cl)) - grid:*grid-data-superclasses*) - (class-name (class-of object))))) - (list (cons class dimensions) (element-type object)))) - -;;; Allowable keys: :dimensions, :initial-contents, :initial-element. -(defmethod initialize-instance :after - ((object foreign-array) &rest initargs - &key dimensions initial-contents initial-element) - (declare (ignore dimensions #+native initial-contents #+native initial-element)) - (with-slots (grid:rank grid:affi grid:specification grid:data - dimensions original-array offset total-size) - object - (unless (and (slot-boundp object 'grid:data) grid:data) - (setf grid:data (apply #'make-ffa (element-type object) initargs))) - (setf dimensions (array-dimensions grid:data) - total-size (array-total-size grid:data) - grid:rank (length dimensions) - grid:specification - (foreign-array-specification object dimensions) - grid:affi (ignore-errors (affi:make-affi dimensions))) - #-native - (let ((cptr (cffi:foreign-alloc - (cl-cffi (element-type object)) - :count (total-size object)))) - (setf (c-pointer object) cptr) - (tg:finalize object (lambda () (cffi:foreign-free cptr)))) - #-native - (setf (cl-invalid object) (not (or initial-contents initial-element))) - (multiple-value-bind (oa index-offset) - (find-original-array grid:data) - (setf original-array oa - offset - (* 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) - (if *print-contents* - (progn - #-native (copy-c-to-cl object) - (princ (grid:grid-data object) stream)) - (format stream "dimensions ~a" (dimensions object))))) - -(export '(dim0 dim1)) - -(defun dim0 (object) - "The first dimension of the object." - (first (dimensions object))) - -(defun dim1 (object) - "The first dimension of the object." - (second (dimensions object))) - -(defun element-size (object) - "The size of each element as stored in C." - (cffi:foreign-type-size (cl-cffi (element-type object)))) - -;;;;**************************************************************************** -;;;; Syncronize C and CL -;;;;**************************************************************************** - -;;; For implementations with separate C and CL storage (non-native), -;;; the two arrays must match when one side has updated and the other -;;; side wishes to refer to the values. For native implementations, -;;; these don't do anything because they will always match. - -;;; Called in defmfun expansion right before GSL function is entered. -#-native -(defun copy-cl-to-c (object) - "Copy the CL array to the C array." - (when (and (typep object 'mobject) (c-invalid object)) - (copy-array-to-pointer - (slot-value object 'grid:data) - (c-pointer object) - (element-type object) - 0 - (total-size object)) - (setf (c-invalid object) nil))) - -;;; Called right before gref -#-native -(defun copy-c-to-cl (object) - "Copy the C array to the CL array." - (when (and (typep object 'mobject) (cl-invalid object)) - (copy-array-from-pointer - (slot-value object 'grid:data) - (c-pointer object) - (element-type object) - 0 - (total-size object)) - (setf (cl-invalid object) nil))) - -#-native -(defun copy-array-to-pointer (array pointer lisp-type index-offset length) - "Copy length elements from array (starting at index-offset) of type - lisp-type to the memory area that starts at pointer, coercing the - elements if necessary." - (let ((cffi-type (component-type lisp-type))) - (loop :repeat length - for array-index :from index-offset - for pointer-index :from 0 :by (if (subtypep lisp-type 'complex) 2 1) - do - (if (subtypep lisp-type 'complex) - (setf (cffi:mem-aref pointer cffi-type pointer-index) - (realpart (row-major-aref array array-index)) - (cffi:mem-aref pointer cffi-type (1+ pointer-index)) - (imagpart (row-major-aref array array-index))) - (setf (cffi:mem-aref pointer cffi-type pointer-index) - (row-major-aref array array-index)))))) - -#-native -(defun copy-array-from-pointer (array pointer lisp-type index-offset length) - "Copy length elements from array (starting at index-offset) of type - lisp-type from the memory area that starts at pointer, coercing the - elements if necessary." - (let ((cffi-type (component-type lisp-type))) - (loop :repeat length - for pointer-index :from 0 :by (if (subtypep lisp-type 'complex) 2 1) - for array-index :from index-offset - do - (setf (row-major-aref array array-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/grid/foreign-friendly.lisp b/grid/foreign-friendly.lisp deleted file mode 100644 index 34d82159..00000000 --- a/grid/foreign-friendly.lisp +++ /dev/null @@ -1,141 +0,0 @@ -;; Use the foreign-friendly arrays package. -;; Liam Healy 2008-03-22 15:40:08EDT -;; Time-stamp: <2009-12-21 08:34:21EST foreign-friendly.lisp> - -;;; Foreign-friendly arrays (original implementation by Tamas Papp) -;;; http://www.princeton.edu/~tpapp/software.html -;;; The replacements here don't do coercions or checks -;;; on type as they are unnecessary, and handle complex types. - -(in-package :c-array) - -(export '(make-ffa native-pointer-protect c-pointer)) - -;;;;**************************************************************************** -;;;; Make arrays for possible foreign use -;;;;**************************************************************************** - -(defun make-ffa - (element-type - &key dimensions (initial-element nil initial-element-p) - (initial-contents nil initial-contents-p) - &allow-other-keys) - "Make an array of one or two dimensions for possible use in foreign code. - Syntax is similar to make-array, but note that element-type - is mandatory and limited to certain types." - (assert (member element-type *array-element-types* :test 'equal) - (element-type) - "Specified element-type must be one of *array-element-types*.") - (let* ((initial-matrix (listp (first initial-contents))) - (complex-initial-real - (and initial-contents-p - (subtypep element-type 'complex) - (typep - (if initial-matrix - (caar initial-contents) - (first initial-contents)) - 'real)))) - (unless dimensions - (if initial-contents-p - (setf dimensions - (if initial-matrix - ;; matrix - (list (length initial-contents) - (ceiling (length (first initial-contents)) - (if complex-initial-real 2 1))) - ;; vector - (ceiling (length initial-contents) - (if complex-initial-real 2 1)))) - (error "dimensions must be specified if contents are not"))) - (when (and initial-matrix initial-contents-p) - ;; flatten matrix spec - (setf initial-contents (apply #'append initial-contents))) - (when complex-initial-real - (setf initial-contents (list-complex-from-real initial-contents))) - (apply 'make-ffa-1d - dimensions element-type - (append - (when initial-contents-p - (list :initial-contents initial-contents)) - (when initial-element-p - (list :initial-element initial-element)))))) - -(defun list-complex-from-real (list) - "Collect a list of complex numbers from real components." - (assert (evenp (length list)) (list) - "Cannot collect reals into complex from an odd number of reals.") - (loop for (re im) on list by #'cddr collect (complex re im))) - -(defun make-ffa-1d (dimensions element-type &key - (initial-element 0 initial-element-p) - (initial-contents nil initial-contents-p)) - "Make an array that is either one-dimensional or displaced to a - one-dimensional array. Array is filled with initial-element or - initial-contents, coerced to the given type." - ;; element-type is a type spec in CL form - (assert (or (atom dimensions) (and (listp dimensions) (car dimensions)))) - (let* ((dimensions (if (atom dimensions) (list dimensions) dimensions)) - (length (reduce #'* dimensions)) - (array (cond - ((and initial-element-p initial-contents-p) - (error "you can't supply both initial-element and ~ - initial-contents")) - ;; initial element given - (initial-element-p - (make-array length :element-type element-type - :initial-element (coerce initial-element - element-type))) - ;; contents given, copy or coerce - (initial-contents - (when (listp (first initial-contents)) - ;; flatten list for matrices - (setf initial-contents (apply 'append initial-contents))) - (assert (= (length initial-contents) length)) - (if (typep initial-contents (list 'vector element-type)) - (copy-seq initial-contents) - (map (list 'vector element-type) - (lambda (x) (coerce x element-type)) initial-contents))) - ;; neither - (t (make-array length :element-type element-type))))) - (if (cdr dimensions) - (make-array dimensions :element-type element-type - :displaced-to array) - array))) - -;;;;**************************************************************************** -;;;; Protect native pointers -;;;;**************************************************************************** - -;;; To be called by a defmfun expander -#+(and native sbcl) -(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." - ;; http://www.sbcl.org/manual/Calling-Lisp-From-C.html - `(sb-sys:with-pinned-objects - ,(mapcar (lambda (s) `(original-array ,s)) array-symbols) - ,body)) - -#+(and native sbcl) -(defun c-pointer (marray) - "The pointer to the C array." - (cffi:inc-pointer - (sb-sys:vector-sap (original-array marray)) (offset marray))) - -;;;;**************************************************************************** -;;;; Pointer management -;;;;**************************************************************************** - -(defun find-original-array (array) - "Find the original parent of a displaced array, return this and the -sum of displaced index offsets." - (let ((sum-of-offsets 0)) - (tagbody - check-displacement - (multiple-value-bind (displaced-to displaced-index-offset) - (array-displacement array) - (when displaced-to - (setf array displaced-to) - (incf sum-of-offsets displaced-index-offset) - (go check-displacement)))) - (values array sum-of-offsets))) diff --git a/grid/methods.lisp b/grid/methods.lisp deleted file mode 100644 index 8a5e0a2f..00000000 --- a/grid/methods.lisp +++ /dev/null @@ -1,19 +0,0 @@ -;; Methods for grid functions -;; Liam Healy 2009-12-21 11:19:00EST methods.lisp -;; Time-stamp: <2009-12-21 21:56:38EST methods.lisp> - -(in-package :c-array) - -(defmethod grid:grid-rank ((object foreign-array)) - (length (dimensions object))) - -(defmethod grid:grid-dimensions ((object foreign-array)) - (dimensions object)) - -(defmethod grid:make-grid-data - ((type (eql 'foreign-array)) dimensions rest-spec - &key (initial-element nil initial-element-p)) - (make-instance 'foreign-array - :dimensions dimensions - :element-type rest-spec - :initial-element initial-element)) diff --git a/grid/number-conversion.lisp b/grid/number-conversion.lisp deleted file mode 100644 index 35dd0fa4..00000000 --- a/grid/number-conversion.lisp +++ /dev/null @@ -1,36 +0,0 @@ -;; Conversion of numbers C->CL -;; Liam Healy, Sun May 28 2006 - 22:04 -;; Time-stamp: <2009-12-20 23:12:25EST number-conversion.lisp> -;; $Id$ - -(in-package :c-array) - -(export '(complex-to-cl)) - -;;;;**************************************************************************** -;;;; Built-in numerical types -;;;;**************************************************************************** - -(export '(dcref)) - -(defmacro dcref (double &optional (index 0)) - "Reference C double(s)." - `(cffi:mem-aref ,double :double ,index)) - -;;;;**************************************************************************** -;;;; Complex numbers -;;;;**************************************************************************** - -;;; GSL complex struct is defined in init/complex-types.lisp. -(defun complex-to-cl - (gsl-complex &optional (index 0) (complex-type 'complex-double-c)) - "Make a CL complex number from the GSL pointer to a complex struct or - an array of complex structs and an index into the array." - (let ((carr (cffi:foreign-slot-value - (cffi:inc-pointer - gsl-complex - (* index (cffi:foreign-type-size complex-type))) - complex-type 'dat))) - (complex (dcref carr 0) - (dcref carr 1)))) - diff --git a/grid/pkgdcl.lisp b/grid/pkgdcl.lisp deleted file mode 100644 index 36a6110f..00000000 --- a/grid/pkgdcl.lisp +++ /dev/null @@ -1,12 +0,0 @@ -;; Declaration of package -;; Liam Healy 2009-12-06 19:41:09EST pkgdcl.lisp -;; Time-stamp: <2009-12-21 08:56:53EST pkgdcl.lisp> - -(in-package :cl-user) - -(defpackage c-array - (:use :common-lisp :cffi)) - -#+sbcl -(eval-when (:compile-toplevel :load-toplevel :execute) - (pushnew :native *features*)) diff --git a/grid/symbol-type.lisp b/grid/symbol-type.lisp deleted file mode 100644 index 55bccc21..00000000 --- a/grid/symbol-type.lisp +++ /dev/null @@ -1,46 +0,0 @@ -;; Symbol-type declaration -;; Liam Healy 2009-12-20 22:27:54EST symbol-type.lisp -;; Time-stamp: <2009-12-20 22:41:13EST symbol-type.lisp> - -;;; An "st" or symbol-type is a list (symbol type) where -;;; type could be (element-type array-dim). These are examples of lists -;;; of sts: - ;; ((#:RET3500 SF-RESULT)) - ;; ((#:RET3501 (:DOUBLE (- NMAX NMIN)))) - ;; ((#:RET3502 (:DOUBLE (1+ KMAX))) (#:RET3503 (:DOUBLE (1+ KMAX))) - ;; (#:RET3504 (:DOUBLE (1+ KMAX))) (#:RET3505 (:DOUBLE (1+ KMAX))) - ;; (#:RET3506 :DOUBLE) (#:RET3507 :DOUBLE)) - -(in-package :c-array) - -(export - '(make-st st-symbol st-type st-pointerp st-actual-type - st-pointer-generic-pointer)) - -(defun make-st (symbol type) - (list symbol type)) - -(defun st-symbol (decl) - (first decl)) - -(defun st-type (decl) - (second decl)) - -(defun st-pointerp (decl) - "If this st represents a pointer, return the type of the object." - (if - (eq (st-type decl) :pointer) - t ; return T for type if unknown type - (if (and (listp (st-type decl)) - (eq (first (st-type decl)) :pointer)) - (second (st-type decl))))) - -(defun st-actual-type (decl) - (or (st-pointerp decl) (st-type decl))) - -(defun st-pointer-generic-pointer (decl) - (if (st-pointerp decl) - (make-st (st-symbol decl) :pointer) - decl)) - - diff --git a/grid/types.lisp b/grid/types.lisp deleted file mode 100644 index 899d61bc..00000000 --- a/grid/types.lisp +++ /dev/null @@ -1,141 +0,0 @@ -;; Number types used by GSL functions, and specification conversion -;; Liam Healy 2008-12-31 21:06:34EST types.lisp -;; Time-stamp: <2009-12-07 22:26:05EST types.lisp> -;; $Id: $ - -(in-package :c-array) - -(export '(*cstd-integer-types* - *cstd-cl-type-mapping* floating-point-association all-types - lookup-type cl-single cl-cffi cffi-cl number-class)) - -;;;;**************************************************************************** -;;;; Type specification conversion -;;;;**************************************************************************** - -;; cffi-features:no-long-long doesn't work for me, but ought to be checked? - -;;; The different element type forms: -;;; C standard full, or "CFFI" :unsigned-char -;;; GSL splice name "uchar" -;;; C explicit :uint8 (not used here) -;;; CL '(unsigned-byte 8) -;;; Single 'unsigned-byte-8 - -;;; Functions to perform conversions -;;; CL -> single in function #'cl-single -;;; CL -> CFFI (Cstd) in function #'cl-cffi -;;; CFFI (Cstd) -> CL in function #'cffi-cl - -;;; Sources of equivalence -;;; Cstd -> CL in alist *cstd-cl-type-mapping* - -;;; :long-double may be pushed onto *features* if -;;; the implementation supports long doubles in CFFI. - -;;;;**************************************************************************** -;;;; Basic definition -;;;;**************************************************************************** - -;;; Preliminary definitions. These are not used directly outside this -;;; file; they exist to define the two variables -;;; *cstd-cl-type-mapping* and *cstd-gsl-mapping* which are used by -;;; the conversion functions. - -(defparameter *cstd-integer-types* - '(:char :unsigned-char - :short :unsigned-short - :int :unsigned-int - :long :unsigned-long - #+int64 - :long-long - #+int64 - :unsigned-long-long) - ;; http://common-lisp.net/project/cffi/manual/html_node/Built_002dIn-Types.html - "List of integer types supported by CFFI, from the CFFI docs.") - -(defparameter *fp-type-mapping* - '((:float . single-float) (:double . double-float) - ;; For those implementations that support a separate long-double - ;; type assume this mapping: - #+long-double (:long-double . long-float) - (complex-float-c . (complex single-float)) - (complex-double-c . (complex double-float)) - ;; For those implementations that support a separate long-double - ;; type assume this mapping: - #+long-double - (complex-long-double-c . (complex long-float))) - ;; Ordered by: real shortest to longest, then complex shortest to longest. - "List of floating point types supported by CFFI from the CFFI docs - plus corresponding complex types.") - -;;; Mapping alists used by conversion functions. - -;;; Used by #'cl-gsl -(defparameter *cstd-cl-type-mapping* - (append - *fp-type-mapping* - (mapcar - (lambda (type) - (cons - type - (list - (if (string-equal type "uns" :end1 3) - 'unsigned-byte - 'signed-byte) - (* 8 (cffi:foreign-type-size type))))) - *cstd-integer-types*)) - ;; Be careful when reverse associating, as there may be several C - ;; types that map to a single CL type. - "An alist of the C standard types as keywords, and the CL type - The exception is complex types, which don't have a definition - in the C standard; in that case, the C type is the GSL struct - definition.") - -(defmacro floating-point-association (splice-list) - `(mapcar - #'cons - (mapcar #'first *fp-type-mapping*) - (subseq ,splice-list 0 (length *fp-type-mapping*)))) - -;;;;**************************************************************************** -;;;; Conversions -;;;;**************************************************************************** - -(defun all-types (alist &optional right-side) - "A list of all types defined by symbol or definition." - (mapcar (if right-side #'rest #'first) alist)) - -(defun lookup-type (symbol alist &optional reverse) - "Lookup the symbol defined in the alist." - (or - (if reverse - (first (rassoc symbol alist :test #'equal)) - (rest (assoc symbol alist))) - ;;(error "Did not find ~a in ~a" symbol (mapcar #'first alist)) - )) - -;;; (cl-single '(unsigned-byte 8)) -;;; UNSIGNED-BYTE-8 -(defun cl-single (cl-type) - "The element type name as a single symbol." - (intern (if (atom cl-type) - (princ-to-string cl-type) - (format nil "~{~a~^-~}" cl-type)) - :gsl)) - -(defun cl-cffi (cl-type) - "The CFFI element type from the CL type." - (lookup-type (clean-type cl-type) *cstd-cl-type-mapping* t)) - -(defun cffi-cl (cffi-type) - "The CL type from the CFFI element type." - (unless (eq cffi-type :pointer) - (lookup-type cffi-type *cstd-cl-type-mapping*))) - -;;; For future use -(defparameter *cl-numeric-classes* '(ratio integer rational float real complex number)) -(defun number-class (type) - "Find the class corresponding to the numeric type." - (find-if (lambda (class) (subtypep type class)) *cl-numeric-classes*)) - diff --git a/gsll.asd b/gsll.asd index d340eeec..816fbf41 100644 --- a/gsll.asd +++ b/gsll.asd @@ -1,6 +1,6 @@ ;; Definition of GSLL system ;; Liam Healy -;; Time-stamp: <2009-12-21 14:16:54EST gsll.asd> +;; Time-stamp: <2009-12-23 22:47:56EST gsll.asd> (when (asdf:find-system :fsbv nil) (pushnew :fsbv *features*)) @@ -14,24 +14,9 @@ :version "0" :author "Liam M. Healy" :licence "LLGPL v3, FDL" - :depends-on (grid cffi cffi-grovel trivial-garbage cl-utilities #+fsbv fsbv) + :depends-on (c-array grid cffi cffi-grovel trivial-garbage cl-utilities #+fsbv fsbv) :components - ((:module grid ; temporary - :components - ((:file "pkgdcl") - (:file "types" :depends-on ("pkgdcl")) - (:file "complex-types" :depends-on ("pkgdcl" "types")) - (:file "element-types" :depends-on ("pkgdcl")) - (:file "symbol-type" :depends-on ("pkgdcl")) - (:file "number-conversion" - :depends-on ("pkgdcl" "complex-types" "symbol-type")) - (:file "foreign-friendly" :depends-on ("pkgdcl")) - (:file "foreign-array" :depends-on ("pkgdcl" "foreign-friendly")) - (:file "methods" :depends-on ("pkgdcl")) - (:file "element-reference" :depends-on ("pkgdcl")) - (:file "copy" :depends-on ("pkgdcl")))) - (:module init - :depends-on (grid) + ((:module init :components ((:file "init") (cffi-grovel:grovel-file "libgsl" :pathname #+unix "libgsl-unix") @@ -70,7 +55,7 @@ #+fsbv (:file "complex"))) (:module data - :depends-on (init grid) + :depends-on (init) :components ((cffi-grovel:grovel-file "array-structs") (:file "marray" :depends-on ("array-structs")) @@ -82,7 +67,7 @@ (:file "array-tests" :depends-on ("both")) (:file "permutation" :depends-on ("marray" "array-structs")) (:file "combination" :depends-on ("marray" "array-structs")))) - (:file "polynomial" :depends-on (grid init data)) + (:file "polynomial" :depends-on (init data)) (:module special-functions :depends-on (init) :components diff --git a/init/defmfun-array.lisp b/init/defmfun-array.lisp index 88719713..3089282a 100644 --- a/init/defmfun-array.lisp +++ b/init/defmfun-array.lisp @@ -1,6 +1,6 @@ ;; Helpers for defining GSL functions on arrays ;; Liam Healy 2009-01-07 22:01:16EST defmfun-array.lisp -;; Time-stamp: <2009-12-20 22:35:57EST defmfun-array.lisp> +;; Time-stamp: <2009-12-23 23:03:19EST defmfun-array.lisp> ;; $Id: $ (in-package :gsl) @@ -115,7 +115,7 @@ (if (listp base-name) (if (symbolp (first base-name)) ;; An explicit listing of types with function names - (getf base-name (c-array:cl-single type)) + (getf base-name (c-array:cl-single type :gsl)) (let ((blas (search "blas" (first base-name) :test 'string-equal))) (apply #'concatenate 'string (substitute diff --git a/init/types.lisp b/init/types.lisp index 044be978..560f55b5 100644 --- a/init/types.lisp +++ b/init/types.lisp @@ -1,6 +1,6 @@ ;; Number types used by GSL functions, and specification conversion ;; Liam Healy 2008-12-31 21:06:34EST types.lisp -;; Time-stamp: <2009-12-07 22:53:34EST types.lisp> +;; Time-stamp: <2009-12-23 23:00:53EST types.lisp> ;; $Id: $ (in-package :gsl) @@ -93,6 +93,7 @@ ;;;; Conversions ;;;;**************************************************************************** +;;; GSL splice name "uchar" ;;; (cl-gsl '(unsigned-byte 8)) ;;; "uchar" (defun cl-gsl (cl-type &optional prepend-underscore blas) -- GitLab