lisp/gtk-ffi.el

   1 ;;; gtk-ffi.el --- Foreign function interface for the GTK object system
   2
   3 ;; Copyright (C) 2000 Free Software Foundation
   4
   5 ;; Maintainer: William Perry <wmperry@gnu.org>
   6 ;; Keywords: extensions, dumped
   7
   8 ;; This file is part of XEmacs.
   9
  10 ;; XEmacs is free software; you can redistribute it and/or modify it
  11 ;; under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; XEmacs is distributed in the hope that it will be useful, but
  16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  22 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  23 ;; 02111-1307, USA.
  24
  25 ;;; Synched up with: Not in FSF
  26
  27 ;;; Commentary:
  28
  29 ;; This file is dumped with XEmacs.
  30
  31 (defvar gtk-type-aliases '((GtkType . guint)
  32                            (GdkAtom . gulong)
  33                            (GdkBitmap . GdkWindow)
  34                            (time_t    . guint)
  35                            (none      . void)
  36                            (GdkDrawable . GdkWindow)
  37                            (GdkBitmap . GdkWindow)
  38                            (GdkPixmap . GdkWindow))
  39   "An assoc list of aliases for commonly used GTK types that are not
  40 really part of the object system.")
  41
  42 (defvar gtk-ffi-debug nil
  43   "If non-nil, all functions defined wiht `gtk-import-function' will be checked
  44 for missing marshallers.")
  45
  46 (defun gtk-ffi-check-function (func)
  47   ;; We don't call gtk-main or gtk-main-quit because it thoroughly
  48   ;; hoses us (locks up xemacs handling events, but no lisp).
  49   (if (not (memq func '(gtk-main gtk-main-quit)))
  50       (condition-case err
  51           (funcall func)
  52         (error
  53          (case (car err)
  54            (wrong-number-of-arguments nil)
  55            (error
  56             (if (string= "Could not locate marshaller function" (nth 1 err))
  57                 (progn
  58                   (set-buffer (get-buffer-create "needed marshallers"))
  59                   (display-buffer (current-buffer))
  60                   (goto-char (point-max))
  61                   (insert
  62                    (format "%S\n"
  63                            (split-string
  64                             (substring (nth 2 err) (length "emacs_gtk_marshal_")) "_+")))))))))))
  65
  66 (defmacro gtk-import-function (retval name &rest args)
  67   (if (symbolp name)
  68       (setq name (symbol-name name)))
  69   (let ((lisp-name (intern (replace-in-string name "_" "-")))
  70         (doc-string nil))
  71     (setq retval (or (cdr-safe (assoc retval gtk-type-aliases)) retval)
  72           doc-string (concat "The lisp version of " name ".\n"
  73                              (if args
  74                                  (concat "Prototype: " (prin1-to-string args)))))
  75
  76     ;; Drop off any naming of arguments, etc.
  77     (if (and args (consp (car args)))
  78         (setq args (mapcar 'car args)))
  79
  80     ;; Get rid of any type aliases.
  81     (setq args (mapcar (lambda (x)
  82                          (or (cdr-safe (assoc x gtk-type-aliases)) x)) args))
  83
  84     `(progn
  85        (defun ,lisp-name (&rest args)
  86          ,doc-string
  87          (if (not (get (quote ,lisp-name) 'gtk-ffi nil))
  88              (put (quote ,lisp-name) 'gtk-ffi
  89                   (gtk-import-function-internal (quote ,retval) ,name
  90                                                 (quote ,args))))
  91          (gtk-call-function (get (quote ,lisp-name) 'gtk-ffi 'ignore) args))
  92        (and gtk-ffi-debug (gtk-ffi-check-function (quote ,lisp-name))))))
  93
  94 (defmacro gtk-import-variable (type name)
  95   (if (symbolp name) (setq name (symbol-name name)))
  96   (let ((lisp-name (intern (replace-in-string name "_" "-")))
  97         (doc-string nil))
  98     (setq type (or (cdr-safe (assoc type gtk-type-aliases)) type)
  99           doc-string (concat "Retrieve the variable " name " (type: " (symbol-name type) ").\n"))
 100     `(defun ,lisp-name ()
 101        ,doc-string
 102        (gtk-import-variable-internal (quote ,type) ,name))))
 103
 104 (provide 'gtk-ffi)