Update of /project/cl-gsl/cvsroot/cl-gsl
In directory common-lisp.net:/tmp/cvs-serv30115
Modified Files:
permutation.lisp
Log Message:
Completed adding the wrappers.
Date: Wed May 4 04:48:37 2005
Author: edenny
Index: cl-gsl/permutation.lisp
diff -u cl-gsl/permutation.lisp:1.1 cl-gsl/permutation.lisp:1.2
--- cl-gsl/permutation.lisp:1.1 Sun May 1 00:41:10 2005
+++ cl-gsl/permutation.lisp Wed May 4 04:48:37 2005
@@ -21,7 +21,8 @@
(defclass gsl-permutation ()
((ptr :accessor ptr :initarg :ptr)
- (size :accessor size :initarg :size)))
+ (size :accessor size :initarg :size)
+ (element-type :accessor element-type :initform 'integer)))
;; ----------------------------------------------------------------------
@@ -85,8 +86,12 @@
((p gsl-permutation-ptr))
:int)
-(defmethod valid ((o gsl-permutation))
- (1/0->t/nil (gsl-permutation-valid (ptr o))))
+(defmethod isvalid ((o gsl-permutation))
+ ;; The C function gsl_permutation_valid does not return when the
+ ;; permutation is invalid - instead it calls GSL_ERROR.
+ ;; It only returns a value when the permutation is valid.
+ (ignore-errors
+ (= (gsl-permutation-valid (ptr o)) +success+)))
;; ----------------------------------------------------------------------
@@ -266,26 +271,38 @@
(i 0 (1+ i)))
((= i size))
(set-element p i (car x)))
- (unless (valid p)
+ (unless (isvalid p)
(error "intitial contents are not a valid permutation.")))
((vectorp initial-contents)
(do ((i 0 (1+ i)))
((= i size))
(set-element p i (aref initial-contents i)))
- (unless (valid p)
+ (unless (isvalid p)
(error "intitial contents are not a valid permutation.")))
(t
(error "initial-contents must be either a list or a vector."))))
(from-file
(read-from-file p from-file)
- (unless (valid p)
+ (unless (isvalid p)
(error "file contents are not a valid permutation.")))
(from-binary-file
(read-from-binary-file p from-binary-file)
- (unless (valid p)
- (error "file contents are not a valid permutation."))))
+ (unless (isvalid p)
+ (error "file contents are not a valid permutation.")))
+ (t
+ (permutation-init p)))
p))
+(defmacro with-permutation ((p size &key initial-contents from-file
+ from-binary-file)
+ &body body)
+ `(let ((,p (make-permutation ,size :initial-contents ,initial-contents
+ :from-file ,from-file
+ :from-binary-file ,from-binary-file)))
+ (unwind-protect
+ (progn ,@body)
+ (free ,p))))
+
;; ----------------------------------------------------------------------
(defun-foreign "gsl_permutation_memcpy"
@@ -330,16 +347,18 @@
(p gsl-permutation-ptr))
:int)
-(defmethod linear->canonical ((p gsl-permutation))
- (let* ((q (make-permutation (size p)))
- (status (gsl-permutation-linear-to-canonical (ptr q) (ptr p))))
- (values q status)))
-
-(defmacro with-permutation-linear->canonical ((q p) &body body)
- `(let ((,q (linear->canonical ,p)))
+(defmethod linear->canonical ((p-can gsl-permutation) (p-lin gsl-permutation))
+ (let ((status (gsl-permutation-linear-to-canonical (ptr p-can) (ptr p-lin))))
+ (values p-can status)))
+
+(defmacro with-permutation-linear->canonical ((p-can p-lin) &body body)
+ (let ((p (gensym)))
+ `(let* ((,p ,p-lin)
+ (,p-can (make-permutation (size ,p))))
+ (linear->canonical ,p-can ,p)
(unwind-protect
,@body
- (free ,q))))
+ (free ,p-can)))))
;; ----------------------------------------------------------------------
@@ -348,16 +367,18 @@
(q gsl-permutation-ptr))
:int)
-(defmethod canonical->linear ((q gsl-permutation))
- (let* ((p (make-permutation (size q)))
- (status (gsl-permutation-linear-to-canonical (ptr p) (ptr q))))
- (values p status)))
-
-(defmacro with-permutation-canonical->linear ((p q) &body body)
- `(let ((,p (linear->canonical ,q)))
- (unwind-protect
- ,@body
- (free ,p))))
+(defmethod canonical->linear ((p-lin gsl-permutation) (p-can gsl-permutation))
+ (let ((status (gsl-permutation-canonical-to-linear (ptr p-lin) (ptr p-can))))
+ (values p-lin status)))
+
+(defmacro with-permutation-canonical->linear ((p-lin p-can) &body body)
+ (let ((p (gensym)))
+ `(let* ((,p ,p-can)
+ (,p-lin (make-permutation (size ,p))))
+ (canonical->linear ,p-lin ,p)
+ (unwind-protect
+ ,@body
+ (free ,p-lin)))))
;; ----------------------------------------------------------------------
@@ -386,3 +407,10 @@
(defmethod canonical-cycles ((o gsl-permutation))
(gsl-permutation-linear-cycles (ptr o)))
+;; ----------------------------------------------------------------------
+
+(defmethod set-element ((p gsl-permutation) i &optional x dummy)
+ (assert (typep x 'integer))
+ (assert (and (typep i 'integer) (>= i 0) (< i (size p))))
+ (let ((data-ptr (uffi:get-slot-pointer (ptr p) '(* size-t) 'cl-gsl::data)))
+ (setf (uffi:deref-array data-ptr 'size-t i) x)))