update.
[chise/xemacs-chise.git] / 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)