src/rclg-foreigns.lisp

   1 ;;; RCLG: R-CommonLisp Gateway
   2
   3 ;;; Copyright (c) 2005--2007, <rif@mit.edu>
   4 ;;;                           AJ Rossini <blindglobe@gmail.com>
   5 ;;; All rights reserved.
   6 ;;;
   7 ;;; Redistribution and use in source and binary forms, with or without
   8 ;;; modification, are permitted provided that the following conditions are
   9 ;;; met:
  10 ;;;
  11 ;;;     * Redistributions of source code must retain the above copyright
  12 ;;;       notice, this list of conditions and the following disclaimer.
  13 ;;;     * Redistributions in binary form must reproduce the above
  14 ;;;       copyright notice, this list of conditions and the following disclaimer
  15 ;;;       in the documentation and/or other materials provided with the
  16 ;;;       distribution.
  17 ;;;     * The names of the contributors may not be used to endorse or
  18 ;;;       promote products derived from this software without specific
  19 ;;;       prior written permission.
  20 ;;;
  21 ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  22 ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  23 ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
  24 ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
  25 ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
  26 ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
  27 ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
  28 ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
  29 ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
  30 ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
  31 ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  32
  33
  34 ;;; Author:      rif@mit.edu
  35 ;;; Maintainers: rif@mit.edu,
  36 ;;;              AJ Rossini <blindglobe@gmail.com>
  37
  38 ;;; Intent: This code provides access to libR functions and variables,
  39 ;;; wrapping them using CFFI.   Many of these should be exported to
  40 ;;; other packages, but no exported over to a naive user (only to
  41 ;;; developers and resulting code).
  42
  43 (defpackage :rclg-foreigns
  44   (:use :common-lisp :cffi :rclg-load :rclg-types)
  45   (:export :%set-tag :%rf-length :%set-vector-elt :%vector-elt
  46            :%rf-elt :%rf-coerce-vector :%rf-alloc-vector
  47            :%rf-protect :%rf-unprotect :%rf-unprotect-ptr
  48            :%rf-init-embedded-r :%rf-initialize-r
  49            :%setup-r-main-loop
  50            :%rf-find-var :%rf-find-fun
  51            :%rf-install :%r-try-eval
  52            :%rf-get-attrib :%rf-set-attrib
  53            :%LOGICAL :%INT :%REAL :%COMPLEX
  54            :%rf-mkchar :%set-string-elt
  55            :%string-elt :%r-char :%r-check-activity :%r-run-handlers
  56            :*r-names-symbol* :*r-dims-symbol* :*r-global-env*
  57            :*r-unbound-value* :*r-nil-value* :*r-input-handlers*
  58            :*r-interactive*))
  59
  60 (in-package :rclg-foreigns)
  61
  62 ;; we can't do anything else until the R libraries are loaded.
  63
  64
  65 (eval-when (:load-toplevel)
  66   (progn
  67     (load-r-libraries)
  68     (unless *rclg-loaded*
  69       (error "rclg-load has not loaded the R libraries."))))
  70
  71 ;;; R library foreigns
  72
  73 (defcfun ("SET_TAG" %set-tag) :void
  74   (robj sexp)
  75   (tag sexp))
  76
  77 (defcfun ("Rf_length" %rf-length) :int
  78   (x sexp))
  79
  80 (defcfun ("SET_VECTOR_ELT" %set-vector-elt) sexp
  81   (x sexp)
  82   (i :int)
  83   (v sexp))
  84
  85 (defcfun ("VECTOR_ELT" %vector-elt) sexp
  86   (s sexp)
  87   (i :int))
  88
  89 (defcfun ("Rf_elt" %rf-elt) sexp
  90   (s sexp)
  91   (i :int))
  92
  93
  94 (defcfun ("Rf_coerceVector" %rf-coerce-vector) sexp
  95   (s sexp)
  96   (type sexptype))
  97
  98
  99 (defcfun ("Rf_allocVector" %rf-alloc-vector) sexp
 100   (s sexptype)
 101   (n :int))
 102
 103 ;; FIXME:AJR: def-function doesn't take a docstring!
 104 ;; The following "'Protects' the item (presumably by telling the
 105 ;; garbage collector it's in use, although I (rif) haven't looked at
 106 ;; the internals.  Returns the same pointer you give it.)"
 107 (defcfun ("Rf_protect" %rf-protect) sexp
 108   (s sexp))
 109
 110 (defcfun ("Rf_unprotect" %rf-unprotect) :void
 111   (n :int))
 112
 113 (defcfun ("Rf_unprotect_ptr" %rf-unprotect-ptr) :void
 114   (s sexp))
 115
 116 ;; Initialization/Finalization mgmt
 117
 118 (defcfun ("Rf_initEmbeddedR" %rf-init-embedded-r) :int
 119   (argc :int)
 120   (argv :pointer))
 121
 122 (defcfun ("Rf_endEmbeddedR" %rf-end-embedded-r) :void
 123   (fatal :int))
 124
 125 (defcfun ("Rf_initialize_R" %rf-initialize-r) :int
 126   (argc :int)
 127   (argv :pointer))
 128
 129 (defcfun ("setup_Rmainloop" %setup-r-main-loop) :void)
 130
 131 (defcfun ("Rf_findVar" %rf-find-var) sexp
 132   (installed sexp)
 133   (environment sexp))
 134
 135 (defcfun ("Rf_findFun" %rf-find-fun) sexp
 136   (installed sexp)
 137   (environment sexp))
 138
 139 (defcfun ("Rf_install" %rf-install) sexp
 140   (ident r-string))
 141
 142 (defcfun ("R_tryEval" %r-try-eval) sexp
 143   (e sexp)
 144   (env sexp)
 145   (error-occurred r-string))
 146
 147 (defcfun ("Rf_getAttrib" %rf-get-attrib) sexp
 148   (robj sexp)
 149   (attrib sexp))
 150
 151 (defcfun ("Rf_setAttrib" %rf-set-attrib) sexp
 152   (robj sexp)
 153   (attrib sexp)
 154   (val sexp))
 155
 156 (defcfun ("LOGICAL" %LOGICAL) :pointer (e sexp))
 157 (defcfun ("INTEGER" %INT) :pointer (e sexp))
 158 (defcfun ("REAL" %REAL) :pointer (e sexp))
 159
 160 (defcfun ("Rf_mkChar" %rf-mkchar) sexp
 161   (s r-string))
 162
 163 (defcfun ("SET_STRING_ELT" %set-string-elt) :void
 164   (robj sexp)
 165   (i :int)
 166   (string sexp))
 167
 168 (defcfun ("STRING_ELT" %string-elt) sexp
 169   (s sexp)
 170   (i :int))
 171
 172 (defcfun ("R_CHAR" %r-char) r-string
 173   (s sexp))
 174
 175 (defcfun ("R_checkActivity" %r-check-activity) :pointer
 176   (usec :int)
 177   (ignore-stdin :int))
 178
 179 (defcfun ("R_runHandlers" %r-run-handlers) :void
 180   (i :pointer)
 181   (f :pointer))
 182
 183 (defcfun ("COMPLEX" %COMPLEX) :pointer
 184   (e sexp))
 185
 186 ;; libR foreign (global?) variables.
 187
 188 (eval-when (:compile-toplevel :load-toplevel)
 189   (defmacro def-r-var (r-name cl-name)
 190     `(defcvar (,r-name ,cl-name :read-only t) sexp)))
 191
 192 (def-r-var "R_NamesSymbol" *r-names-symbol*)
 193 (def-r-var "R_DimSymbol" *r-dims-symbol*)
 194 (def-r-var "R_GlobalEnv" *r-global-env*)
 195 (def-r-var "R_UnboundValue" *r-unbound-value*)
 196 (def-r-var "R_NilValue" *r-nil-value*)
 197 (def-r-var "R_InputHandlers" *r-input-handlers*)
 198
 199 (defcvar ( "R_Interactive" *r-interactive* :read-only nil) :int)
 200
 201 ;;; data to R conversion functions -- found in ../c/rclg-helpers.c
 202 ;; will only work if shared libraries are loaded.
 203
 204 #+nil
 205 (defcfun ("doubleFloatVecToR" %double-float-vec-to-R) :void
 206   (d :pointer)
 207   (i :int)
 208   (s sexp))
 209
 210
 211
 212 #+nil
 213 (defun %double-float-vec-to-R (lisp-float-vector length sexp)
 214   (dotimes (i length)
 215       (let* ((tmp (%rf-alloc-vector %REALSXP length))
 216              (tmpptr (%REAL tmp))
 217              (tmpval (aref lisp-float-vector i))
 218         (setf tmpptr tmp-float)
 219         (%set-vector-elt lisp-double-vector i tmp)
 220         (setf i (+ i 1))))))
 221
 222
 223 #|
 224 void doubleFloatVecToR(double *d, int length, SEXP v) {
 225   int i;
 226
 227   for (i = 0; i < length; i++) {
 228     SEXP tmp = Rf_allocVector(REALSXP, 1);
 229     double *tmpptr = REAL(tmp);
 230     *tmpptr = d[i];
 231     SET_VECTOR_ELT(v, i, tmp);
 232   }
 233 }
 234
 235 |#
 236
 237
 238
 239 #+nil
 240 (defcfun ("intVecToR" %integer-vec-to-R) :void
 241   (d :pointer)
 242   (i :int)
 243   (s sexp)
 244   (div :int))
 245
 246 #|
 247 /* We use the divisor to handle the fact that CMUCL fixnums are *4. */
 248 /* May not work in other CLs. */
 249 void intVecToR(int *d, int length, SEXP v, int divisor) {
 250   int i;
 251
 252   for (i = 0; i < length; i++) {
 253     SEXP tmp = Rf_allocVector(INTSXP, 1);
 254     int *tmpptr = INTEGER(tmp);
 255     *tmpptr = d[i]/divisor;
 256     SET_VECTOR_ELT(v, i, tmp);
 257   }
 258 }
 259 |#