Commit ce261d71 authored by Liam Healy's avatar Liam Healy
Browse files

Move symbol-type and number-conversion to grid

Move number-conversion.lisp from init/ to grid/ and symbol-type
portion of init/interface.lisp to grid/symbol-type.lisp.
All tests pass
TOTAL: 1627 assertions passed, 6 failed, 0 execution errors.
parent 2317ccf0
;; Conversion of numbers C->CL
;; Liam Healy, Sun May 28 2006 - 22:04
;; Time-stamp: <2009-12-07 22:30:23EST number-conversion.lisp>
;; Time-stamp: <2009-12-20 23:12:25EST number-conversion.lisp>
;; $Id$
(in-package :gsl)
(in-package :c-array)
(export '(complex-to-cl))
;;;;****************************************************************************
;;;; Built-in numerical types
;;;;****************************************************************************
(export '(dcref scref))
(export '(dcref))
(defmacro dcref (double &optional (index 0))
"Reference C double(s)."
`(cffi:mem-aref ,double :double ,index))
(defmacro scref (size &optional (index 0))
"Reference C size(s)."
`(cffi:mem-aref ,size 'sizet ,index))
;;;;****************************************************************************
;;;; Complex numbers
;;;;****************************************************************************
;;; GSL complex struct is defined in init/complex-types.lisp.
(defun complex-to-cl
(gsl-complex &optional (index 0) (complex-type 'c-array:complex-double-c))
(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 'c-array::dat)))
complex-type 'dat)))
(complex (dcref carr 0)
(dcref carr 1))))
;;;;****************************************************************************
;;;; Conversion form
;;;;****************************************************************************
(defun cl-convert-form (decl)
"Generate a form that calls the appropriate converter from C/GSL to CL."
(case (st-actual-type decl)
(sf-result
`((val ,(st-symbol decl))
(err ,(st-symbol decl))))
(sf-result-e10
`((val ,(st-symbol decl) 'sf-result-e10)
(e10 ,(st-symbol decl))
(err ,(st-symbol decl) 'sf-result-e10)))
(c-array:complex-double-c
`((complex-to-cl ,(st-symbol decl) 0 'c-array:complex-double-c)))
(c-array:complex-float-c
`((complex-to-cl ,(st-symbol decl) 0 'c-array:complex-float-c)))
(t `((cffi:mem-aref ,(st-symbol decl) ',(st-actual-type decl))))))
;; 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))
;; Definition of GSLL system
;; Liam Healy
;; Time-stamp: <2009-12-07 22:58:36EST gsll.asd>
;; Time-stamp: <2009-12-20 22:50:14EST gsll.asd>
(when (asdf:find-system :fsbv nil)
(pushnew :fsbv *features*))
......@@ -21,7 +21,10 @@
((:file "pkgdcl")
(:file "types" :depends-on ("pkgdcl"))
(:file "complex-types" :depends-on ("pkgdcl" "types"))
(:file "element-types" :depends-on ("pkgdcl"))))
(:file "element-types" :depends-on ("pkgdcl"))
(:file "symbol-type" :depends-on ("pkgdcl"))
(:file "number-conversion"
:depends-on ("pkgdcl" "complex-types" "symbol-type"))))
(:module init
:depends-on (grid)
:components
......@@ -30,20 +33,19 @@
(:file "utility")
(:file "forms")
(:file "conditions" :depends-on ("init" "libgsl"))
(:file "number-conversion" :depends-on ("init" "libgsl"))
(:file "callback-compile-defs" :depends-on ("init"))
(:file "mobject" :depends-on ("init" "callback-compile-defs"))
(:file "callback-included" :depends-on ("mobject"))
(:file "callback"
:depends-on
("init" "utility" "forms" "number-conversion"
("init" "utility" "forms"
"callback-included"))
(:file "types" :depends-on ("init" "libgsl"))
(cffi-grovel:grovel-file "callback-struct"
:depends-on ("types" "libgsl"))
(:file "funcallable" :depends-on ("utility"))
(:file "interface"
:depends-on ("init" "conditions" "number-conversion"))
:depends-on ("init" "conditions"))
(:file "defmfun" :depends-on ("init" "forms" "interface"))
(:file "defmfun-array"
:depends-on ("defmfun" "callback-included"))
......@@ -63,7 +65,7 @@
#+fsbv
(:file "complex")))
(:module data
:depends-on (init)
:depends-on (init grid)
:components
((:file "foreign-friendly")
(:file "foreign-array" :depends-on ("foreign-friendly"))
......
;; Expand the body of a defmfun
;; Liam Healy 2009-04-13 22:07:13EDT body-expand.lisp
;; Time-stamp: <2009-11-18 09:56:18EST body-expand.lisp>
;; Time-stamp: <2009-12-20 23:13:49EST body-expand.lisp>
(in-package :gsl)
(defun creturn-st (c-return)
"The symbol-type of the return from the C function."
(make-st
(c-array:make-st
(if (listp c-return)
(st-symbol c-return)
(c-array:st-symbol c-return)
(make-symbol "CRETURN"))
(if (member c-return *special-c-return*)
:int
(if (listp c-return) (st-type c-return) c-return))))
(if (listp c-return) (c-array:st-type c-return) c-return))))
#+fsbv
(defun variables-passed-by-value (c-arguments-st)
......@@ -20,11 +20,11 @@
variable in the C argument list."
(loop for sd in c-arguments-st
collect
(when (fsbv:defined-type-p (st-type sd))
(list (st-symbol sd)
(make-st
(make-symbol (string (st-symbol sd)))
(st-type sd))))))
(when (fsbv:defined-type-p (c-array:st-type sd))
(list (c-array:st-symbol sd)
(c-array:make-st
(make-symbol (string (c-array:st-symbol sd)))
(c-array:st-type sd))))))
;;; This function should never be called even when FSBV is absent,
;;; because the potential callers should all have #-fsbv
......@@ -44,7 +44,7 @@
(fsbv:defcfun-args-from-ff-args ff-args)
(let ((gsl-name-symbol (make-symbol gsl-name))
(symbargs
(mapcar (lambda (st) (make-st (gensym "ARG") (st-type st)))
(mapcar (lambda (st) (c-array:make-st (gensym "ARG") (c-array:st-type st)))
args)))
(values
`(fsbv:defcfun (,gsl-name-symbol gsl-name) ,return-type
......@@ -66,6 +66,22 @@
`(no-fsbv-error no-fsbv-error ,@args)
`(cffi:foreign-funcall ,gsl-name ,@args)))
(defun cl-convert-form (decl)
"Generate a form that calls the appropriate converter from C/GSL to CL."
(case (c-array:st-actual-type decl)
(sf-result
`((val ,(c-array:st-symbol decl))
(err ,(c-array:st-symbol decl))))
(sf-result-e10
`((val ,(c-array:st-symbol decl) 'sf-result-e10)
(e10 ,(c-array:st-symbol decl))
(err ,(c-array:st-symbol decl) 'sf-result-e10)))
(c-array:complex-double-c
`((c-array:complex-to-cl ,(c-array:st-symbol decl) 0 'c-array:complex-double-c)))
(c-array:complex-float-c
`((c-array:complex-to-cl ,(c-array:st-symbol decl) 0 'c-array:complex-float-c)))
(t `((cffi:mem-aref ,(c-array:st-symbol decl) ',(c-array:st-actual-type decl))))))
(defun body-expand (name arglist gsl-name c-arguments key-args)
"Expand the body (computational part) of the defmfun."
(with-defmfun-key-args key-args
......@@ -73,7 +89,7 @@
(allocated-return ; Allocated and then returned from CL function
(mapcar
(lambda (s)
(or (find s c-arguments :key #'st-symbol)
(or (find s c-arguments :key #'c-array:st-symbol)
;; Catch programming errors, usually typos
(error "Could not find ~a among the arguments" s)))
(remove-if
......@@ -86,19 +102,19 @@
#-fsbv nil)
(clret (or ; better as a symbol macro
(substitute
(st-symbol creturn-st) :c-return
(c-array:st-symbol creturn-st) :c-return
(mapcar (lambda (sym)
(let ((it (find sym allocated-return :key 'st-symbol)))
(let ((it (find sym allocated-return :key 'c-array:st-symbol)))
(if it
(first (cl-convert-form it))
sym)))
return))
(mappend
#'cl-convert-form
(callback-remove-arg allocated-return cbinfo 'st-symbol))
(callback-remove-arg allocated-return cbinfo 'c-array:st-symbol))
outputs
(unless (eq c-return :void)
(list (st-symbol creturn-st))))))
(list (c-array:st-symbol creturn-st))))))
(wrap-letlike
allocated-return
(mapcar (lambda (d) (wfo-declare d cbinfo))
......@@ -111,36 +127,36 @@
(when callback-object (callback-set-dynamic callback-object arglist)))
,@(callback-set-slots
cbinfo callback-dynamic-variables callback-dynamic)
(let ((,(st-symbol creturn-st)
(let ((,(c-array:st-symbol creturn-st)
,(ffexpand (some 'identity pbv)
gsl-name
(append
(mappend
(lambda (arg)
(list (cond
((member (st-symbol arg) allocated-return) :pointer)
(t (st-type arg)))
(st-symbol arg)))
(mapcar 'st-pointer-generic-pointer c-arguments))
(list (st-type creturn-st))))))
((member (c-array:st-symbol arg) allocated-return) :pointer)
(t (c-array:st-type arg)))
(c-array:st-symbol arg)))
(mapcar 'c-array:st-pointer-generic-pointer c-arguments))
(list (c-array:st-type creturn-st))))))
,@(case c-return
(:void `((declare (ignore ,(st-symbol creturn-st)))))
(:void `((declare (ignore ,(c-array:st-symbol creturn-st)))))
(:error-code ; fill in arguments
`((check-gsl-status ,(st-symbol creturn-st)
`((check-gsl-status ,(c-array:st-symbol creturn-st)
',(or (defgeneric-method-p name) name)))))
#-native
,@(when outputs
(mapcar
(lambda (x) `(setf (cl-invalid ,x) t (c-invalid ,x) nil))
outputs))
,@(when (eq (st-type creturn-st) :pointer)
,@(when (eq (c-array:st-type creturn-st) :pointer)
`((check-null-pointer
,(st-symbol creturn-st)
,(c-array:st-symbol creturn-st)
,@'('memory-allocation-failure "No memory allocated."))))
,@after
(values
,@(defmfun-return
c-return (st-symbol creturn-st) clret
c-return (c-array:st-symbol creturn-st) clret
allocated-return
return return-supplied-p
enumeration outputs))))))))
......
;; Foreign callback functions.
;; Liam Healy
;; Time-stamp: <2009-05-04 21:44:08EDT callback.lisp>
;; Time-stamp: <2009-12-20 22:34:34EST callback.lisp>
;; $Id$
(in-package :gsl)
......@@ -221,4 +221,4 @@
;; CL specials to do the same job.
(declare ,@(when (member :slug args) `((ignore ,slug)))
(special ,dynamic-variable))
(funcall ,dynamic-variable ,@(mapcar 'st-symbol (remove :slug args))))))
(funcall ,dynamic-variable ,@(mapcar 'c-array:st-symbol (remove :slug args))))))
;; Helpers for defining GSL functions on arrays
;; Liam Healy 2009-01-07 22:01:16EST defmfun-array.lisp
;; Time-stamp: <2009-12-07 22:55:39EST defmfun-array.lisp>
;; Time-stamp: <2009-12-20 22:35:57EST defmfun-array.lisp>
;; $Id: $
(in-package :gsl)
......@@ -159,7 +159,7 @@
(if (and (listp arg) (numberp (second arg)))
(let ((actual-type
(c-array:cffi-cl
(st-type (find (first arg) carg-actual :key 'st-symbol)))))
(c-array:st-type (find (first arg) carg-actual :key 'c-array:st-symbol)))))
(list (first arg) ; Optional arg default numerical value
(if actual-type
;; coerce to the right type
......
;; Helpers that define a single GSL function interface
;; Liam Healy 2009-01-07 22:02:20EST defmfun-single.lisp
;; Time-stamp: <2009-11-01 14:20:53EST defmfun-single.lisp>
;; Time-stamp: <2009-12-20 22:34:33EST defmfun-single.lisp>
;; $Id: $
(in-package :gsl)
......@@ -29,7 +29,7 @@
quality code walker, but is sufficient for actual usage of defmfun."
(remove-duplicates
(mappend (lambda (carg)
(stupid-code-walk-find-variables (st-symbol carg)))
(stupid-code-walk-find-variables (c-array:st-symbol carg)))
c-arguments)
:from-end t))
......
;; Macros to interface GSL functions, including definitions necessary for defmfun.
;; Liam Healy
;; Time-stamp: <2009-12-06 19:52:33EST interface.lisp>
;; Time-stamp: <2009-12-20 23:03:02EST interface.lisp>
(in-package :gsl)
......@@ -22,50 +22,19 @@
(gethash (string-downcase string) *gsl-symbol-equivalence*))
;;;;****************************************************************************
;;;; Symbol-type declaration
;;;; Declare foreign objects
;;;;****************************************************************************
;;; 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))
(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))
(defmacro scref (size &optional (index 0))
"Reference C size(s)."
`(cffi:mem-aref ,size 'sizet ,index))
(defun wfo-declare (d cbinfo)
`(,(st-symbol d)
,@(if (eq (st-symbol d)
`(,(c-array:st-symbol d)
,@(if (eq (c-array:st-symbol d)
(parse-callback-static cbinfo 'foreign-argument))
`(',(parse-callback-static cbinfo 'callback-fnstruct))
`(',(st-actual-type d)))))
`(',(c-array:st-actual-type d)))))
;;;;****************************************************************************
;;;; Checking results from GSL functions
......@@ -102,10 +71,10 @@
(defun cl-argument-types (cl-arguments c-arguments-types)
"Create CL argument and types from the C arguments."
(loop for sd in c-arguments-types
for cl-type = (c-array:cffi-cl (st-type sd))
for cl-type = (c-array:cffi-cl (c-array:st-type sd))
append
(when (and cl-type (member (st-symbol sd) (cl-symbols cl-arguments)))
(list (list (st-symbol sd) cl-type)))))
(when (and cl-type (member (c-array:st-symbol sd) (cl-symbols cl-arguments)))
(list (list (c-array:st-symbol sd) cl-type)))))
(defun declaration-form (cl-argument-types &optional ignores specials)
(cons 'declare
......
;; Linear least squares, or linear regression
;; Liam Healy <2008-01-21 12:41:46EST linear-least-squares.lisp>
;; Time-stamp: <2009-05-24 22:56:00EDT linear-least-squares.lisp>
;; Time-stamp: <2009-12-20 23:03:01EST linear-least-squares.lisp>
;; $Id$
(in-package :gsl)
......@@ -187,7 +187,7 @@
:inputs (model weight observations)
:outputs (parameters covariance)
:switch (weight)
:return (parameters covariance (dcref chisq))
:return (parameters covariance (c-array:dcref chisq))
:export nil
:index linear-mfit
:documentation ; FDL
......@@ -232,7 +232,7 @@
:inputs (model weight observations)
:outputs (parameters covariance)
:switch (weight)
:return ((dcref chisq) (scref rank))
:return ((c-array:dcref chisq) (scref rank))
:export nil
:index linear-mfit
:documentation ; FDL
......
;; Multivariate minimization.
;; Liam Healy <Tue Jan 8 2008 - 21:28>
;; Time-stamp: <2009-06-09 23:02:27EDT minimization-multi.lisp>
;; Time-stamp: <2009-12-20 22:19:22EST minimization-multi.lisp>
;; $Id$
(in-package :gsl)
......@@ -407,7 +407,7 @@
(defun paraboloid-and-derivative
(arguments-gv-pointer value-pointer derivative-gv-pointer)
(prog1
(setf (dcref value-pointer)
(setf (c-array:dcref value-pointer)
(paraboloid-vector arguments-gv-pointer))
(paraboloid-derivative
arguments-gv-pointer derivative-gv-pointer)))
......
;; Coulumb functions
;; Liam Healy, Sat Mar 18 2006 - 23:23
;; Time-stamp: <2009-04-26 22:57:18EDT coulomb.lisp>
;; Time-stamp: <2009-12-20 23:16:02EST coulomb.lisp>
;; $Id$
(in-package :gsl)
......@@ -38,7 +38,7 @@
(exp-F (:pointer :double)) (exp-G (:pointer :double)))
:return
((val F) (val Fp) (val G) (val Gp)
(dcref exp-F) (dcref exp-G)
(c-array:dcref exp-F) (c-array:dcref exp-G)
(err F) (err Fp) (err G) (err Gp))
:documentation ; FDL
"The Coulomb wave functions F_L(\eta,x),
......@@ -57,7 +57,7 @@
((L-min :double) ((1- (dim0 fc-array)) :int) (eta :double) (x :double)
((c-pointer fc-array) :pointer) (F-exponent (:pointer :double)))
:outputs (fc-array)
:return (fc-array (dcref F-exponent))
:return (fc-array (c-array:dcref F-exponent))
:documentation ; FDL
"The Coulomb wave function F_L(\eta,x) for
L = Lmin ... Lmin + kmax, storing the results in fc-array.
......@@ -74,7 +74,7 @@
((c-pointer fc-array) :pointer) ((c-pointer gc-array) :pointer)
(F-exponent (:pointer :double)) (G-exponent (:pointer :double)))
:outputs (fc-array gc-array)
:return (fc-array gc-array (dcref F-exponent) (dcref G-exponent))
:return (fc-array gc-array (c-array:dcref F-exponent) (c-array:dcref G-exponent))
:documentation ; FDL
"The functions F_L(\eta,x),
G_L(\eta,x) for L = Lmin ... Lmin + kmax storing the
......@@ -99,7 +99,7 @@
:outputs (fc-array fcp-array gc-array gcp-array)
:return
(fc-array fcp-array gc-array gcp-array
(dcref F-exponent) (dcref G-exponent))
(c-array:dcref F-exponent) (c-array:dcref G-exponent))
:documentation ; FDL
"The functions F_L(\eta,x),
G_L(\eta,x) and their derivatives F'_L(\eta,x),
......@@ -115,7 +115,7 @@
((L-min :double) ((1- (dim0 fc-array)) :int) (eta :double) (x :double)
((c-pointer fc-array) :pointer) (F-exponent (:pointer :double)))
:outputs (fc-array)
:return (fc-array (dcref F-exponent))
:return (fc-array (c-array:dcref F-exponent))
:documentation ; FDL
"The Coulomb wave function divided by the argument
F_L(\eta, x)/x for L = Lmin ... Lmin + kmax, storing the
......
;; Gamma functions
;; Liam Healy, Thu Apr 27 2006 - 22:06
;; Time-stamp: <2009-04-26 22:59:46EDT gamma.lisp>
;; Time-stamp: <2009-12-20 22:19:20EST gamma.lisp>
;; $Id$
(in-package :gsl)
......@@ -37,7 +37,7 @@
(defmfun log-gamma-sign (x)
"gsl_sf_lngamma_sgn_e"
((x :double) (ret sf-result) (sign (:pointer :double)))
:return ((val ret) (dcref sign) (err ret))
:return ((val ret) (c-array:dcref sign) (err ret))
:documentation ; FDL
"Compute the sign of the gamma function and the logarithm of
its magnitude, subject to x not being a negative integer. The
......@@ -136,7 +136,7 @@
The computed parameters are result =
log(|(a)_x|) and sgn = sgn((a)_x) where (a)_x :=
Gamma(a + x)/Gamma(a), subject to a, a+x not being negative integers."
:return ((val ret) (dcref sign) (err ret)))
:return ((val ret) (c-array:dcref sign) (err ret)))
(defmfun relative-pochammer (a x)
"gsl_sf_pochrel_e" ((a :double) (x :double) (ret sf-result))
......
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