Commit 134132bc authored by Liam Healy's avatar Liam Healy

Clean up several compilation problems

Several bugs with small fixes, modifications to eliminate warnings:
- Bad names for argument variables in maref fixed.
- Add depenedencies in gsll.asd to avoid warnings.
- Histogram needs #'assign-pointer function which was previously
- #'scale is a generic function, change defun to defmethod in
- New #'variables-used-in-c-arguments replaces #'c-arguments in
  defmfun, now is a simplistic code walker but goes to arbitrary
  depth.  This will do for current uses of defmfun.
- Export and defgenerics for #'alloc, #'free which are used by
  histogram and random.  In gsl-objects.lisp for lack of a better
System now completely compiles from scratch with only one warning 
"Implicitly creating new generic function BIND-GENERATE-BINDINGS."
which is from metabang-bind.  No new testing.
parent 60551931
;; Get/set array or elements: cl-array, maref
;; Liam Healy 2008-08-27 22:43:10EDT maref.lisp
;; Time-stamp: <2008-08-28 21:51:18EDT maref.lisp>
;; Time-stamp: <2008-08-31 11:07:34EDT maref.lisp>
;; $Id: $
(in-package :gsl)
......@@ -39,7 +39,7 @@
(:method ((object array) &optional array-rank element-type)
;; For compatibility, work on CL arrays as well.
(declare (ignore array-rank element-type))
;;; Some functions in solve-minimize-fit return a pointer to a GSL
;;; vector with double-floats. #'cl-array will turn that into a
......@@ -55,8 +55,8 @@
(dim2 (cffi:foreign-slot-value pointer 'gsl-matrix-c 'size2))
(array (make-array* (list dim1 dim2) element-type)))
;; Copy over from the C side
(loop for i below size1
do (loop for j below size2 do
(loop for i below dim1
do (loop for j below dim2 do
(setf (aref array i j) (maref pointer i j))))
;; Vector
;; Definition of GSLL system
;; Liam Healy
;; Time-stamp: <2008-08-29 00:57:28EDT gsll.asd>
;; Time-stamp: <2008-08-31 10:05:43EDT gsll.asd>
;; $Id$
(asdf:defsystem "gsll"
......@@ -18,8 +18,9 @@
(:file "gsl-objects" :depends-on (init))
(:file "element-types" :depends-on (init))
(:file "number-conversion" :depends-on (init))
(:file "interface" :depends-on (init conditions element-types number-conversion))
(:file "defmfun" :depends-on (init element-types))
(:file "interface"
:depends-on (init conditions element-types number-conversion))
(:file "defmfun" :depends-on (init element-types interface))
(:file "callback" :depends-on (init))
(:file "lisp-unit")
......@@ -145,7 +146,7 @@
;; minimum and maximum values provided in vector.lisp
(:file "median-percentile")))
(:module histogram
:depends-on (init)
:depends-on (init linear-algebra)
((:file "histogram")
(:file "updating-accessing" :depends-on (histogram))
;; The histogram structure
;; Liam Healy, Mon Jan 1 2007 - 11:32
;; Time-stamp: <2008-08-23 19:08:15EDT histogram.lisp>
;; Time-stamp: <2008-08-31 11:03:07EDT histogram.lisp>
;; $Id$
(in-package :gsl)
......@@ -26,6 +26,16 @@
"A histogram, including bin boundaries and bin contents."))
(defun assign-pointer (object pointer)
"Check that a GSL data pointer is not null, then assign it to the object."
(format nil "for ~a."
(with-output-to-string (stream)
(print-data-object object nil stream))))
(setf (mpointer object) pointer))
(defmfun alloc-histo-1 (object)
(((number-of-bins object) sizet))
;; Histogram operations
;; Liam Healy, Mon Jan 1 2007 - 16:47
;; Time-stamp: <2008-08-17 09:34:52EDT operations.lisp>
;; Time-stamp: <2008-08-31 10:05:41EDT operations.lisp>
;; $Id$
(in-package :gsl)
......@@ -183,8 +183,7 @@
"Multiply the contents of the bins of histogram by the
constant scale, i.e. h'_1(i) = h_1(i) * scale.")
(export 'scale)
(defun scale (histogram scale)
(defmethod scale (scale (histogram histogram))
;; FDL
"Multiply the contents of the bins of histogram by the
constant scale, i.e. h'_1(i) = h_1(i) * scale."
;; Macro for defining GSL functions.
;; Liam Healy 2008-04-16 20:49:50EDT defmfun.lisp
;; Time-stamp: <2008-08-23 18:37:25EDT defmfun.lisp>
;; Time-stamp: <2008-08-31 10:46:03EDT defmfun.lisp>
;; $Id$
(in-package :gsl)
......@@ -483,18 +483,25 @@
(gensym (string (st-symbol sd)))
(st-type sd))))))
(defun c-arguments (c-arguments)
(defun stupid-code-walk-find-variables (sexp)
"This will work with the simplest s-expression forms only to find
variables used."
(labels ((scwfv (sexp)
(if (atom sexp)
(when (and (symbolp sexp)
(not (eql (symbol-package sexp)
(find-package :keyword))))
(list sexp))
(unless (member (first sexp) '(quote))
(mapcan #'scwfv (rest sexp))))))
(remove-duplicates (scwfv sexp))))
(defun variables-used-in-c-arguments (c-arguments)
"Find the arguments passed to the C function. This is a poor
quality code walker, but is sufficient for actual usage of defmfun."
(mapcan (lambda (s)
(let ((val (st-symbol s)))
(if (listp val)
;; walk only a top-level function call
(rest val)
(list val)))))
(mapcan (lambda (carg)
(stupid-code-walk-find-variables (st-symbol carg)))
(defun complete-definition
......@@ -514,8 +521,8 @@
(set-difference (arglist-plain-and-categories arglist nil)
(if mapdown
(apply 'union
(mapcar 'c-arguments c-arguments))
(c-arguments c-arguments))))
(mapcar 'variables-used-in-c-arguments c-arguments))
(variables-used-in-c-arguments c-arguments))))
,@(when documentation (list documentation))
,(funcall body-maker name arglist gsl-name c-arguments key-args))))
......@@ -532,7 +539,7 @@
(lambda (s)
(member s (arglist-plain-and-categories arglist nil)))
(c-arguments c-arguments)))
(variables-used-in-c-arguments c-arguments)))
;; Definition of GSL objects and ways to use them.
;; Liam Healy, Sun Dec 3 2006 - 10:21
;; Time-stamp: <2008-08-23 22:51:33EDT gsl-objects.lisp>
;; Time-stamp: <2008-08-31 11:35:19EDT gsl-objects.lisp>
;; $Id$
(in-package :gsl)
......@@ -122,3 +122,10 @@
(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.")
;;; Generic allocation and free used for histograms and random
(export '(alloc free))
(defgeneric alloc (object)
(:documentation "Allocate the GSL storage."))
(defgeneric free (object)
(:documentation "Free the GSL storage."))
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