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