rcl/funcall.lisp

   1 ;; Copyright (c) 2006-2007 Carlos Ungil
   2
   3 ;; Permission is hereby granted, free of charge, to any person obtaining
   4 ;; a copy of this software and associated documentation files (the
   5 ;; "Software"), to deal in the Software without restriction, including
   6 ;; without limitation the rights to use, copy, modify, merge, publish,
   7 ;; distribute, sublicense, and/or sell copies of the Software, and to
   8 ;; permit persons to whom the Software is furnished to do so, subject to
   9 ;; the following conditions:
  10
  11 ;; The above copyright notice and this permission notice shall be
  12 ;; included in all copies or substantial portions of the Software.
  13
  14 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  15 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  16 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  17 ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
  18 ;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
  19 ;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
  20 ;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  21
  22 (in-package :rcl)
  23
  24 (defun r-variable (name)
  25   "Find the variable in the R image"
  26   (make-instance 'r-pointer
  27                  :pointer (rf-findvar (rf-install name) *r-globalenv*)))
  28
  29 (defun r-function (name)
  30   "Find the function in the R image"
  31   (when (member (r-type-decode
  32                  (first (sxpinfo-decode
  33                          (sxpinfo-bitfield
  34                           (sexp-sxpinfo
  35                            (rf-findvar (rf-install name) *r-globalenv*))))))
  36                 '(:promise :builtin-non-special-forms))
  37     (let ((result (rf-findfun (rf-install name) *r-globalenv*)))
  38       (when result (make-instance 'r-pointer :pointer result)))))
  39
  40 (defun r-funcall (function &rest args)
  41   "Call the function in the R image"
  42   (unless *r-session*
  43     (error "You have to execute (r-init) first"))
  44   (cffi:with-foreign-object (error-occurred :int)
  45     (let ((command (new-language-construct (1+ (count-if-not #'keywordp args))))
  46           (r-function (r-function function)))
  47       (unless r-function (error "~A is not a valid function" function))
  48       (let ((list (sexp-union command)) cdr)
  49         (setf (listsxp-car list) (pointer r-function))
  50         (loop while args
  51            do   (let ((arg (pop args)))
  52                   (setf cdr (listsxp-cdr list))
  53                   (setf list (sexp-union cdr))
  54                   ;; named argument passed as two successive arguments :name value
  55                   (when (keywordp arg)
  56                     (setf (listsxp-tag list)
  57                           (rf-install (string-downcase
  58                                        (substitute #\_ #\- (symbol-name arg))))
  59                           arg (pop args)))
  60                   ;; named argument passed as cons (:name . value)
  61                   (when (and (consp arg) (keywordp (car arg)))
  62                     (setf (listsxp-tag list)
  63                           (rf-install (string-downcase
  64                                        (substitute #\_ #\- (symbol-name (car arg)))))
  65                           arg (cdr arg)))
  66                   (setf (listsxp-car list) (r-obj-from-lisp arg)))))
  67       (let ((result (r-tryeval command *r-globalenv* error-occurred)))
  68         (if (zerop (cffi:mem-aref error-occurred :int))
  69             (make-instance 'r-pointer :pointer result)
  70             (error "error calling ~A" function))))))
  71