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