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