From 94651b3d87d7e76735139f0838261bf927759845 Mon Sep 17 00:00:00 2001 From: liam <liam@a3d8a0fb-c1db-0310-ace7-a616afeb9e30> Date: Fri, 21 Apr 2006 13:41:25 +0000 Subject: [PATCH] Bind named vector dimension in defun-gsl expansion so that e.g. (defun-gsl polynomial-solve-ws ((coefficients (:double n)) (workspace poly-complex-workspace)) "gsl_poly_complex_solve" :return ((gsl-complex (1- n)))) expands to (DEFUNX-MAP POLYNOMIAL-SOLVE-WS "gsl_poly_complex_solve" (COEFFICIENTS WORKSPACE) (LET ((N (FIRST (STORAGE-SIZE COEFFICIENTS)))) (WITH-FOREIGN-OBJECTS ((#:RET4113 'GSL-COMPLEX (1- N))) ... ))) This currently works only for a vector; no accomodation is made for matrices. git-svn-id: svn+ssh://pop/opt/space/mathematics/gsl/trunk@3043 a3d8a0fb-c1db-0310-ace7-a616afeb9e30 --- interface.lisp | 140 ++++++++++++++++++++++++++---------------------- polynomial.lisp | 3 +- 2 files changed, 78 insertions(+), 65 deletions(-) diff --git a/interface.lisp b/interface.lisp index 79777d10..d89c0dbb 100644 --- a/interface.lisp +++ b/interface.lisp @@ -3,7 +3,7 @@ ; description: Macros to interface GSL functions. ; date: Mon Mar 6 2006 - 22:35 ; author: Liam M. Healy -; modified: Wed Apr 19 2006 - 17:06 +; modified: Fri Apr 21 2006 - 09:26 ;******************************************************** (in-package :gsl) @@ -197,7 +197,7 @@ and a scaling exponent e10, such that the value is val*10^e10." (defun wrap-form (form wrappers) (if wrappers (wrap-form - `(,@(first wrappers) ,form) + (if (first wrappers) `(,@(first wrappers) ,form) form) (rest wrappers)) form)) @@ -216,25 +216,33 @@ and a scaling exponent e10, such that the value is val*10^e10." "Convert the argument declarations to a list of declarations appropriate for foreign-funcall. If mode is T, a mode argument will be added to the end, if it is an integer, it will be put at that position." - (flet ((splicearg (spec) - ;; No accomodation for matrices (two indices) yet - (if (rst-arrayp spec) - (values - (if (rst-pointer-last-p spec) - `(:size (first (storage-size ,(rst-symbol spec))) - :pointer (gsl-array ,(rst-symbol spec))) - `(:pointer (gsl-array ,(rst-symbol spec)) - :size (first (storage-size ,(rst-symbol spec)))))) - (values - `(,(rst-type spec) - ,(wrap-arg spec)))))) - (mapcan #'splicearg - (if mode - (let ((mode (if (integerp mode) mode (length arguments)))) - (append (subseq arguments 0 mode) - '((mode sf-mode)) - (subseq arguments mode))) - arguments)))) + (let (sizes) ; save the dimension arg if not '* + (flet ((splicearg (spec) + ;; No accomodation for matrices (two indices) yet + (if (rst-arrayp spec) + (let* ((value `(first (storage-size ,(rst-symbol spec)))) + (use-form + (if (eq (rst-dim spec) '*) + value + (progn + (push `(,(rst-dim spec) ,value) sizes) + (rst-dim spec))))) + (if (rst-pointer-last-p spec) + `(:size ,use-form + :pointer (gsl-array ,(rst-symbol spec))) + `(:pointer (gsl-array ,(rst-symbol spec)) + :size ,use-form))) + `(,(rst-type spec) + ,(wrap-arg spec))))) + (values + (mapcan #'splicearg + (if mode + (let ((mode (if (integerp mode) mode (length arguments)))) + (append (subseq arguments 0 mode) + '((mode sf-mode)) + (subseq arguments mode))) + arguments)) + sizes)))) ;;;;**************************************************************************** ;;;; Checking results @@ -300,46 +308,50 @@ and a scaling exponent e10, such that the value is val*10^e10." (return-symb-type (unless (or (eq c-return-value :return) return-input) (return-symbol-type return)))) - `(,@(if (eq cl-name :lambda) - '(lambda) - `(,(if method 'defmethod-map 'defunx-map) ,cl-name ,gsl-name)) - ,(if mode - `(,@clargs &optional (mode :double-prec)) - `(,@clargs)) - ,@(when documentation (list documentation)) - ,(wrap-form ; with-foreign-object - `(let ((creturn - (cffi:foreign-funcall - ,gsl-name - ,@(splice-arguments arguments mode) - ,@(mapcan (lambda (r) `(:pointer ,(rst-symbol r))) - return-symb-type) - ,(case c-return-value - (:return (first return)) - (:void :void) - (t :int))))) - ,@(case c-return-value - (:void '((declare (ignore creturn)))) - (:error-code - (if method - `((check-gsl-status creturn `(,',cl-name))) ; need args - `((check-gsl-status creturn `(,',cl-name ,,@clargs)))))) - ,@(check-null-pointers check-null-pointers) - ,@after - (values - ,@return-input - ,@(case c-return-value - (:number-of-answers - (mapcan - (lambda (decl seq) - `((when (> creturn ,seq) ,@(pick-result decl)))) - return-symb-type - (loop for i below (length return) collect i))) - (:success-failure - '((success-failure creturn))) - (:return (list (wrap-arg `(creturn ,@return)))) - (t - (mapcan #'pick-result return-symb-type))))) - (when return-symb-type - `((cffi:with-foreign-objects - ,(mapcar #'wfo-declare return-symb-type)))))))) + (multiple-value-bind (cargs dimbind) + (splice-arguments arguments mode) + `(,@(if (eq cl-name :lambda) + '(lambda) + `(,(if method 'defmethod-map 'defunx-map) ,cl-name ,gsl-name)) + ,(if mode + `(,@clargs &optional (mode :double-prec)) + `(,@clargs)) + ,@(when documentation (list documentation)) + ,(wrap-form ; with-foreign-object + `(let ((creturn + (cffi:foreign-funcall + ,gsl-name + ,@cargs + ,@(mapcan (lambda (r) `(:pointer ,(rst-symbol r))) + return-symb-type) + ,(case c-return-value + (:return (first return)) + (:void :void) + (t :int))))) + ,@(case c-return-value + (:void '((declare (ignore creturn)))) + (:error-code + (if method + `((check-gsl-status creturn `(,',cl-name))) ; need args + `((check-gsl-status creturn `(,',cl-name ,,@clargs)))))) + ,@(check-null-pointers check-null-pointers) + ,@after + (values + ,@return-input + ,@(case c-return-value + (:number-of-answers + (mapcan + (lambda (decl seq) + `((when (> creturn ,seq) ,@(pick-result decl)))) + return-symb-type + (loop for i below (length return) collect i))) + (:success-failure + '((success-failure creturn))) + (:return (list (wrap-arg `(creturn ,@return)))) + (t + (mapcan #'pick-result return-symb-type))))) + (list + (when return-symb-type + `(cffi:with-foreign-objects + ,(mapcar #'wfo-declare return-symb-type))) + (when dimbind `(let ,dimbind)))))))) diff --git a/polynomial.lisp b/polynomial.lisp index 1db16a15..986b4786 100644 --- a/polynomial.lisp +++ b/polynomial.lisp @@ -3,7 +3,7 @@ ; description: Polynomials ; date: Tue Mar 21 2006 - 18:33 ; author: Liam M. Healy -; modified: Thu Apr 20 2006 - 18:16 +; modified: Fri Apr 21 2006 - 09:20 ;******************************************************** ;;; $Id: $ @@ -11,6 +11,7 @@ ;;; To do: ;;; Divided difference needs to be checked. +;;; polynomial-solve-ws awaits complex vectors ;;;;**************************************************************************** ;;;; Polynomial Evaluation -- GitLab