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)))