but not really...
[CommonLispStat.git] / cffiglue.lsp
blobaebadeee7c35f974d2e82dddcb5ca41a8cb0278e
1 ;; -*- mode: lisp -*-
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.
11 (in-package :cl-user)
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 ))
19 ;; are there any error message components that need to be exported?
20 ;; More importantly, should we factor them out into a logging package?
22 ;; This package initially loads the liblispstat library for access.
24 (in-package :lisp-stat-ffi-int)
26 (cffi:load-foreign-library
27 (concatenate 'string
28 (namestring cl-user::*lispstat-home-dir*)
29 "lib/liblispstat"
30 #+darwin ".dylib"
31 #-darwin ".so"))
33 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
34 ;;;
35 ;;; Callback Support Functions
36 ;;;
37 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
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))
46 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
47 ;;;
48 ;;; XLISP Internal Error Message Emulation
49 ;;;
50 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
52 (defvar *buf* (make-string 1000))
54 (defun set-buf-char (i c) (setf (elt *buf* i) (code-char c)))
56 (defun get-buf (&optional (n (position (code-char 0) *buf*)))
57 (subseq *buf* 0 n))
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))
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))))
72 (register-print-buffer (cffi:callback ccl-print-buffer))
74 (cffi:defcfun ("stdputstr" stdputstr)
75 :void (string :string))
76 (cffi:defcfun ("xlfail" xlfail)
77 :void (string :string))