src/numerics/cffiglue.lsp

   1 ;;  -*- mode: lisp -*-
   2
   3 ;;; cffiglue -- Interface to C library.  Based on the range of CL FFI
   4 ;;;             "glues" by Luke Tierney.
   5 ;;;
   6 ;;; Copyright (c) 1991, by Luke Tierney.
   7 ;;; Copyright (c) 2007, by Carlos Ungil.
   8 ;;; Copyright (c) 2007-2008, by AJ Rossini <blindglobe@gmail.com>.
   9 ;;; Permission is granted for unrestricted use.
  10
  11 (in-package :lisp-stat-ffi-int)
  12
  13 ;; are there any error message components that need to be exported?
  14 ;; More importantly, should we factor them out into a logging package?
  15
  16 ;; This package initially loads the liblispstat library for access.
  17
  18 (cffi:load-foreign-library
  19  (concatenate 'string
  20               (namestring lisp-stat-config::*lispstat-home-dir*)
  21               "lib/liblispstat"
  22               #+darwin ".dylib"
  23               #-darwin ".so"))
  24
  25 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  26 ;;;
  27 ;;;                     Callback Support Functions
  28 ;;;
  29 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  30
  31 (cffi:defcfun ("ccl_store_integer" ccl-store-integer)
  32     :void (x :int))
  33 (cffi:defcfun ("ccl_store_double" ccl-store-double)
  34     :void (x :double))
  35 (cffi:defcfun ("ccl_store_ptr" ccl-store-ptr)
  36     :void (x :pointer))
  37
  38 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  39 ;;;
  40 ;;;                 XLISP Internal Error Message Emulation
  41 ;;;
  42 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  43
  44 (defvar *buf* (make-string 1000))
  45
  46 (defun set-buf-char (i c) (setf (elt *buf* i) (code-char c)))
  47
  48 (defun get-buf (&optional (n (position (code-char 0) *buf*)))
  49   (subseq *buf* 0 n))
  50
  51 (cffi:defcfun ("register_set_buf_char" register-set-buf-char)
  52     :void (p :pointer))
  53 (cffi:defcallback ccl-set-buf-char :void ((n :int) (c :int))
  54   (set-buf-char n c))
  55 (register-set-buf-char (cffi:callback ccl-set-buf-char))
  56
  57 (cffi:defcfun ("register_print_buffer" register-print-buffer)
  58     :void (p :pointer))
  59 (cffi:defcallback ccl-print-buffer :void ((n :int) (type :int))
  60   (case type
  61     (0 (princ (get-buf n)))
  62     (1 (error (get-buf n))))
  63   n)
  64 (register-print-buffer (cffi:callback ccl-print-buffer))
  65
  66 (cffi:defcfun ("stdputstr" stdputstr)
  67     :void (string :string))
  68 (cffi:defcfun ("xlfail" xlfail)
  69     :void (string :string))