Mercurial > hg > xemacs-beta
annotate src/ui-gtk.c @ 5353:38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
lisp/ChangeLog addition:
2011-02-07 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el:
* bytecomp.el (byte-compile-initial-macro-environment):
Shadow `block', `return-from' here, we implement them differently
when byte-compiling.
* bytecomp.el (byte-compile-active-blocks): New.
* bytecomp.el (byte-compile-block-1): New.
* bytecomp.el (byte-compile-return-from-1): New.
* bytecomp.el (return-from-1): New.
* bytecomp.el (block-1): New.
These are two aliases that exist to have their own associated
byte-compile functions, which functions implement `block' and
`return-from'.
* cl-extra.el (cl-macroexpand-all):
Fix a bug here when macros in the environment have been compiled.
* cl-macs.el (block):
* cl-macs.el (return):
* cl-macs.el (return-from):
Be more careful about lexical scope in these macros.
* cl.el:
* cl.el ('cl-block-wrapper): Removed.
* cl.el ('cl-block-throw): Removed.
These aren't needed in code generated by this XEmacs. They
shouldn't be needed in code generated by XEmacs 21.4, but if it
turns out the packages do need them, we can put them back.
2011-01-30 Mike Sperber <mike@xemacs.org>
* font-lock.el (font-lock-fontify-pending-extents): Don't fail if
`font-lock-mode' is unset, which can happen in the middle of
`revert-buffer'.
2011-01-23 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (delete):
* cl-macs.el (delq):
* cl-macs.el (remove):
* cl-macs.el (remq):
Don't use the compiler macro if these functions were given the
wrong number of arguments, as happens in lisp-tests.el.
* cl-seq.el (remove, remq): Removed.
I added these to subr.el, and forgot to remove them from here.
2011-01-22 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el (byte-compile-setq, byte-compile-set):
Remove kludge allowing keywords' values to be set, all the code
that does that is gone.
* cl-compat.el (elt-satisfies-test-p):
* faces.el (set-face-parent):
* faces.el (face-doc-string):
* gtk-font-menu.el:
* gtk-font-menu.el (gtk-reset-device-font-menus):
* msw-font-menu.el:
* msw-font-menu.el (mswindows-reset-device-font-menus):
* package-get.el (package-get-installedp):
* select.el (select-convert-from-image-data):
* sound.el:
* sound.el (load-sound-file):
* x-font-menu.el (x-reset-device-font-menus-core):
Don't quote keywords, they're self-quoting, and the
win from backward-compatibility is sufficiently small now that the
style problem overrides it.
2011-01-22 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (block, return-from): Require that NAME be a symbol
in these macros, as always documented in the #'block docstring and
as required by Common Lisp.
* descr-text.el (unidata-initialize-unihan-database):
Correct the use of non-symbols in #'block and #'return-from in
this function.
2011-01-15 Aidan Kehoe <kehoea@parhasard.net>
* cl-extra.el (concatenate): Accept more complicated TYPEs in this
function, handing the sequences over to #'coerce if we don't
understand them here.
* cl-macs.el (inline): Don't proclaim #'concatenate as inline, its
compiler macro is more useful than doing that.
2011-01-11 Aidan Kehoe <kehoea@parhasard.net>
* subr.el (delete, delq, remove, remq): Move #'remove, #'remq
here, they don't belong in cl-seq.el; move #'delete, #'delq here
from fns.c, implement them in terms of #'delete*, allowing support
for sequences generally.
* update-elc.el (do-autoload-commands): Use #'delete*, not #'delq
here, now the latter's no longer dumped.
* cl-macs.el (delete, delq): Add compiler macros transforming
#'delete and #'delq to #'delete* calls.
2011-01-10 Aidan Kehoe <kehoea@parhasard.net>
* dialog.el (make-dialog-box): Correct a misplaced parenthesis
here, thank you Mats Lidell in 87zkr9gqrh.fsf@mail.contactor.se !
2011-01-02 Aidan Kehoe <kehoea@parhasard.net>
* dialog.el (make-dialog-box):
* list-mode.el (display-completion-list):
These functions used to use cl-parsing-keywords; change them to
use defun* instead, fixing the build. (Not sure what led to me
not including this change in d1b17a33450b!)
2011-01-02 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (define-star-compiler-macros):
Make sure the form has ITEM and LIST specified before attempting
to change to calls with explicit tests; necessary for some tests
in lisp-tests.el to compile correctly.
(stable-union, stable-intersection): Add compiler macros for these
functions, in the same way we do for most of the other functions
in cl-seq.el.
2011-01-01 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (dolist, dotimes, do-symbols, macrolet)
(symbol-macrolet):
Define these macros with defmacro* instead of parsing the argument
list by hand, for the sake of style and readability; use backquote
where appropriate, instead of calling #'list and and friends, for
the same reason.
2010-12-30 Aidan Kehoe <kehoea@parhasard.net>
* x-misc.el (device-x-display):
Provide this function, documented in the Lispref for years, but
not existing previously. Thank you Julian Bradfield, thank you
Jeff Mincy.
2010-12-30 Aidan Kehoe <kehoea@parhasard.net>
* cl-seq.el:
Move the heavy lifting from this file to C. Dump the
cl-parsing-keywords macro, but don't use defun* for the functions
we define that do take keywords, dynamic scope lossage makes that
not practical.
* subr.el (sort, fillarray): Move these aliases here.
(map-plist): #'nsublis is now built-in, but at this point #'eql
isn't necessarily available as a test; use #'eq.
* obsolete.el (cl-delete-duplicates): Make this available for old
compiler macros and old code.
(memql): Document that this is equivalent to #'member*, and worse.
* cl.el (adjoin, subst): Removed. These are in C.
2010-12-30 Aidan Kehoe <kehoea@parhasard.net>
* simple.el (assoc-ignore-case): Remove a duplicate definition of
this function (it's already in subr.el).
* iso8859-1.el (char-width):
On non-Mule, make this function equivalent to that produced by
(constantly 1), but preserve its docstring.
* subr.el (subst-char-in-string): Define this in terms of
#'substitute, #'nsubstitute.
(string-width): Define this using #'reduce and #'char-width.
(char-width): Give this a simpler definition, it makes far more
sense to check for mule at load time and redefine, as we do in
iso8859-1.el.
(store-substring): Implement this in terms of #'replace, now
#'replace is cheap.
2010-12-30 Aidan Kehoe <kehoea@parhasard.net>
* update-elc.el (lisp-files-needed-for-byte-compilation)
(lisp-files-needing-early-byte-compilation):
cl-macs belongs in the former, not the latter, it is as
fundamental as bytecomp.el.
2010-12-30 Aidan Kehoe <kehoea@parhasard.net>
* cl.el:
Provde the Common Lisp program-error, type-error as error
symbols. This doesn't nearly go far enough for anyone using the
Common Lisp errors.
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (delete-duplicates):
If the form has an incorrect number of arguments, don't attempt a
compiler macroexpansion.
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (cl-safe-expr-p):
Forms that start with the symbol lambda are also safe.
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (= < > <= >=):
For these functions' compiler macros, the optimisation is safe
even if the first and the last arguments have side effects, since
they're only used the once.
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (inline-side-effect-free-compiler-macros):
Unroll a loop here at macro-expansion time, so these compiler
macros are compiled. Use #'eql instead of #'eq in a couple of
places for better style.
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* cl-extra.el (notany, notevery): Avoid some dynamic scope
stupidity with local variable names in these functions, when they
weren't prefixed with cl-; go into some more detail in the doc
strings.
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* byte-optimize.el (side-effect-free-fns): #'remove, #'remq are
free of side-effects.
(side-effect-and-error-free-fns):
Drop dot, dot-marker from the list.
2010-11-17 Aidan Kehoe <kehoea@parhasard.net>
* cl-extra.el (coerce):
In the argument list, name the first argument OBJECT, not X; the
former name was always used in the doc string and is clearer.
Handle vector type specifications which include the length of the
target sequence, error if there's a mismatch.
* cl-macs.el (cl-make-type-test): Handle type specifications
starting with the symbol 'eql.
2010-11-14 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (eql): Don't remove the byte-compile property of this
symbol. That was necessary to override a bug in bytecomp.el where
#'eql was confused with #'eq, which bug we no longer have.
If neither expression is constant, don't attempt to handle the
expression in this compiler macro, leave it to byte-compile-eql,
which produces better code anyway.
* bytecomp.el (eq): #'eql is not the function associated with the
byte-eq byte code.
(byte-compile-eql): Add an explicit compile method for this
function, for cases where the cl-macs compiler macro hasn't
reduced it to #'eq or #'equal.
2010-10-25 Aidan Kehoe <kehoea@parhasard.net>
Add compiler macros and compilation sanity-checking for various
functions that take keywords.
* byte-optimize.el (side-effect-free-fns): #'symbol-value is
side-effect free and not error free.
* bytecomp.el (byte-compile-normal-call): Check keyword argument
lists for sanity; store information about the positions where
keyword arguments start using the new byte-compile-keyword-start
property.
* cl-macs.el (cl-const-expr-val): Take a new optional argument,
cl-not-constant, defaulting to nil, in this function; return it if
the expression is not constant.
(cl-non-fixnum-number-p): Make this into a separate function, we
want to pass it to #'every.
(eql): Use it.
(define-star-compiler-macros): Use the same code to generate the
member*, assoc* and rassoc* compiler macros; special-case some
code in #'add-to-list in subr.el.
(remove, remq): Add compiler macros for these two functions, in
preparation for #'remove being in C.
(define-foo-if-compiler-macros): Transform (remove-if-not ...) calls to
(remove ... :if-not) at compile time, which will be a real win
once the latter is in C.
(define-substitute-if-compiler-macros)
(define-subst-if-compiler-macros): Similarly for these functions.
(delete-duplicates): Change this compiler macro to use
#'plists-equal; if we don't have information about the type of
SEQUENCE at compile time, don't bother attempting to inline the
call, the function will be in C soon enough.
(equalp): Remove an old commented-out compiler macro for this, if
we want to see it it's in version control.
(subst-char-in-string): Transform this to a call to nsubstitute or
nsubstitute, if that is appropriate.
* cl.el (ldiff): Don't call setf here, this makes for a load-time
dependency problem in cl-macs.el
2010-06-14 Stephen J. Turnbull <stephen@xemacs.org>
* term/vt100.el:
Refer to XEmacs, not GNU Emacs, in permissions.
* term/bg-mouse.el:
* term/sup-mouse.el:
Put copyright notice in canonical "Copyright DATE AUTHOR" form.
Refer to XEmacs, not GNU Emacs, in permissions.
* site-load.el:
Add permission boilerplate.
* mule/canna-leim.el:
* alist.el:
Refer to XEmacs, not APEL/this program, in permissions.
* mule/canna-leim.el:
Remove my copyright, I've assigned it to the FSF.
2010-06-14 Stephen J. Turnbull <stephen@xemacs.org>
* gtk.el:
* gtk-widget-accessors.el:
* gtk-package.el:
* gtk-marshal.el:
* gtk-compose.el:
* gnome.el:
Add copyright notice based on internal evidence.
2010-06-14 Stephen J. Turnbull <stephen@xemacs.org>
* easymenu.el: Add reference to COPYING to permission notice.
* gutter.el:
* gutter-items.el:
* menubar-items.el:
Fix typo "Xmacs" in permissions notice.
2010-06-14 Stephen J. Turnbull <stephen@xemacs.org>
* auto-save.el:
* font.el:
* fontconfig.el:
* mule/kinsoku.el:
Add "part of XEmacs" text to permission notice.
2010-10-14 Aidan Kehoe <kehoea@parhasard.net>
* byte-optimize.el (side-effect-free-fns):
* cl-macs.el (remf, getf):
* cl-extra.el (tailp, cl-set-getf, cl-do-remf):
* cl.el (ldiff, endp):
Tighten up Common Lisp compatibility for #'ldiff, #'endp, #'tailp;
add circularity checking for the first two.
#'cl-set-getf and #'cl-do-remf were Lisp implementations of
#'plist-put and #'plist-remprop; change the names to aliases,
changes the macros that use them to using #'plist-put and
#'plist-remprop directly.
2010-10-12 Aidan Kehoe <kehoea@parhasard.net>
* abbrev.el (fundamental-mode-abbrev-table, global-abbrev-table):
Create both these abbrev tables using the usual
#'define-abbrev-table calls, rather than attempting to
special-case them.
* cl-extra.el: Force cl-macs to be loaded here, if cl-extra.el is
being loaded interpreted. Previously other, later files would
redundantly call (load "cl-macs") when interpreted, it's more
reasonable to do it here, once.
* cmdloop.el (read-quoted-char-radix): Use defcustom here, we
don't have any dump-order dependencies that would prevent that.
* custom.el (eval-when-compile): Don't load cl-macs when
interpreted or when byte-compiling, rely on cl-extra.el in the
former case and the appropriate entry in bytecomp-load-hook in the
latter. Get rid of custom-declare-variable-list, we have no
dump-time dependencies that would require it.
* faces.el (eval-when-compile): Don't load cl-macs when
interpreted or when byte-compiling.
* packages.el: Remove some inaccurate comments.
* post-gc.el (cleanup-simple-finalizers): Use #'delete-if-not
here, now the order of preloaded-file-list has been changed to
make it available.
* subr.el (custom-declare-variable-list): Remove. No need for it.
Also remove a stub define-abbrev-table from this file, given the
current order of preloaded-file-list there's no need for it.
2010-10-10 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el (byte-compile-constp) Forms quoted with FUNCTION are
also constant.
(byte-compile-initial-macro-environment): In #'the, if FORM is
constant and does not match TYPE, warn at byte-compile time.
2010-10-10 Aidan Kehoe <kehoea@parhasard.net>
* backquote.el (bq-vector-contents, bq-list*): Remove; the former
is equivalent to (append VECTOR nil), the latter to (list* ...).
(bq-process-2): Use (append VECTOR nil) instead of using
#'bq-vector-contents to convert to a list.
(bq-process-1): Now we use list* instead of bq-list
* subr.el (list*): Moved from cl.el, since it is now required to
be available the first time a backquoted form is encountered.
* cl.el (list*): Move to subr.el.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* test-harness.el (Check-Message):
Add an omitted comma here, thank you the buildbot.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* hash-table.el (hash-table-key-list, hash-table-value-list)
(hash-table-key-value-alist, hash-table-key-value-plist):
Remove some useless #'nreverse calls in these files; our hash
tables have no order, it's not helpful to pretend they do.
* behavior.el (read-behavior):
Do the same in this file, in some code evidently copied from
hash-table.el.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* info.el (Info-insert-dir):
* format.el (format-deannotate-region):
* files.el (cd, save-buffers-kill-emacs):
Use #'some, #'every and related functions for applying boolean
operations to lists, instead of rolling our own ones that cons and
don't short-circuit.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el (byte-compile-initial-macro-environment):
* cl-macs.el (the):
Rephrase the docstring, make its implementation when compiling
files a little nicer.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* descr-text.el (unidata-initialize-unicodedata-database)
(unidata-initialize-unihan-database, describe-char-unicode-data)
(describe-char-unicode-data):
Wrap calls to the database functions with (with-fboundp ...),
avoiding byte compile warnings on builds without support for the
database functions.
(describe-char): (reduce #'max ...), not (apply #'max ...), no
need to cons needlessly.
(describe-char): Remove a redundant lambda wrapping
#'extent-properties.
(describe-char-unicode-data): Call #'nsubst when replacing "" with
nil in the result of #'split-string, instead of consing inside
mapcar.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* x-faces.el (x-available-font-sizes):
* specifier.el (let-specifier):
* package-ui.el (pui-add-required-packages):
* msw-faces.el (mswindows-available-font-sizes):
* modeline.el (modeline-minor-mode-menu):
* minibuf.el (minibuf-directory-files):
Replace the O2N (delq nil (mapcar (lambda (W) (and X Y)) Z)) with
the ON (mapcan (lambda (W) (and X (list Y))) Z) in these files.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (= < > <= >=):
When these functions are handed more than two arguments, and those
arguments have no side effects, transform to a series of two
argument calls, avoiding funcall in the byte-compiled code.
* mule/mule-cmds.el (finish-set-language-environment):
Take advantage of this change in a function called 256 times at
startup.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el (byte-compile-function-form, byte-compile-quote)
(byte-compile-quote-form):
Warn at compile time, and error at runtime, if a (quote ...) or a
(function ...) form attempts to quote more than one object.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* byte-optimize.el (byte-optimize-apply): Transform (apply 'nconc
(mapcar ...)) to (mapcan ...); warn about use of the first idiom.
* update-elc.el (do-autoload-commands):
* packages.el (packages-find-package-library-path):
* frame.el (frame-list):
* extents.el (extent-descendants):
* etags.el (buffer-tag-table-files):
* dumped-lisp.el (preloaded-file-list):
* device.el (device-list):
* bytecomp-runtime.el (proclaim-inline, proclaim-notinline)
Use #'mapcan, not (apply #'nconc (mapcar ...) in all these files.
* bytecomp-runtime.el (eval-when-compile, eval-and-compile):
In passing, mention that these macros also evaluate the body when
interpreted.
tests/ChangeLog addition:
2011-02-07 Aidan Kehoe <kehoea@parhasard.net>
* automated/lisp-tests.el:
Test lexical scope for `block', `return-from'; add a
Known-Bug-Expect-Failure for a contorted example that fails when
byte-compiled.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Mon, 07 Feb 2011 12:01:24 +0000 |
| parents | ba07c880114a |
| children | 2aa9cd456ae7 |
| rev | line source |
|---|---|
| 462 | 1 /* ui-gtk.c |
| 2 ** | |
| 3 ** Description: Creating 'real' UIs from lisp. | |
| 4 ** | |
| 5 ** Created by: William M. Perry <wmperry@gnu.org> | |
| 6 ** Copyright (c) 2000 William M. Perry <wmperry@gnu.org> | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
7 ** Copyright (C) 2010 Ben Wing. |
| 462 | 8 ** |
|
4709
db7068430402
Add explicit GPL v2 or later notices to Bill Perry's code, where such notices
Jerry James <james@xemacs.org>
parents:
3017
diff
changeset
|
9 ** This file is part of XEmacs. |
|
db7068430402
Add explicit GPL v2 or later notices to Bill Perry's code, where such notices
Jerry James <james@xemacs.org>
parents:
3017
diff
changeset
|
10 ** |
|
db7068430402
Add explicit GPL v2 or later notices to Bill Perry's code, where such notices
Jerry James <james@xemacs.org>
parents:
3017
diff
changeset
|
11 ** XEmacs is free software; you can redistribute it and/or modify it |
|
db7068430402
Add explicit GPL v2 or later notices to Bill Perry's code, where such notices
Jerry James <james@xemacs.org>
parents:
3017
diff
changeset
|
12 ** under the terms of the GNU General Public License as published by the |
|
db7068430402
Add explicit GPL v2 or later notices to Bill Perry's code, where such notices
Jerry James <james@xemacs.org>
parents:
3017
diff
changeset
|
13 ** Free Software Foundation; either version 2, or (at your option) any |
|
db7068430402
Add explicit GPL v2 or later notices to Bill Perry's code, where such notices
Jerry James <james@xemacs.org>
parents:
3017
diff
changeset
|
14 ** later version. |
|
db7068430402
Add explicit GPL v2 or later notices to Bill Perry's code, where such notices
Jerry James <james@xemacs.org>
parents:
3017
diff
changeset
|
15 ** |
|
db7068430402
Add explicit GPL v2 or later notices to Bill Perry's code, where such notices
Jerry James <james@xemacs.org>
parents:
3017
diff
changeset
|
16 ** XEmacs is distributed in the hope that it will be useful, but WITHOUT |
|
db7068430402
Add explicit GPL v2 or later notices to Bill Perry's code, where such notices
Jerry James <james@xemacs.org>
parents:
3017
diff
changeset
|
17 ** ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
|
db7068430402
Add explicit GPL v2 or later notices to Bill Perry's code, where such notices
Jerry James <james@xemacs.org>
parents:
3017
diff
changeset
|
18 ** FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
|
db7068430402
Add explicit GPL v2 or later notices to Bill Perry's code, where such notices
Jerry James <james@xemacs.org>
parents:
3017
diff
changeset
|
19 ** for more details. |
|
db7068430402
Add explicit GPL v2 or later notices to Bill Perry's code, where such notices
Jerry James <james@xemacs.org>
parents:
3017
diff
changeset
|
20 ** |
|
db7068430402
Add explicit GPL v2 or later notices to Bill Perry's code, where such notices
Jerry James <james@xemacs.org>
parents:
3017
diff
changeset
|
21 ** You should have received a copy of the GNU General Public License |
|
db7068430402
Add explicit GPL v2 or later notices to Bill Perry's code, where such notices
Jerry James <james@xemacs.org>
parents:
3017
diff
changeset
|
22 ** along with XEmacs; see the file COPYING. If not, write to |
|
db7068430402
Add explicit GPL v2 or later notices to Bill Perry's code, where such notices
Jerry James <james@xemacs.org>
parents:
3017
diff
changeset
|
23 ** the Free Software Foundation, Inc., 51 Franklin Street - Fifth Floor, |
|
5231
ba07c880114a
Fix up FSF's Franklin Street address in many files.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
5191
diff
changeset
|
24 ** Boston, MA 02110-1301, USA. */ |
| 462 | 25 |
| 26 #include <config.h> | |
| 27 #include "lisp.h" | |
| 1346 | 28 |
| 462 | 29 #include "buffer.h" |
| 30 #include "device.h" | |
| 31 #include "elhash.h" | |
| 1346 | 32 #include "events.h" |
| 33 #include "faces.h" | |
|
4908
b3ce27ca7647
various fixes related to gtk, redisplay-xlike-inc.c
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
34 #include "hash.h" |
|
b3ce27ca7647
various fixes related to gtk, redisplay-xlike-inc.c
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
35 #include "sysdll.h" |
|
b3ce27ca7647
various fixes related to gtk, redisplay-xlike-inc.c
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
36 #include "window.h" |
|
b3ce27ca7647
various fixes related to gtk, redisplay-xlike-inc.c
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
37 |
|
b3ce27ca7647
various fixes related to gtk, redisplay-xlike-inc.c
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
38 #include "console-gtk-impl.h" |
| 1346 | 39 #include "glyphs-gtk.h" |
|
5176
8b2f75cecb89
rename objects* (.c, .h and .el files) to fontcolor*
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
40 #include "fontcolor-gtk.h" |
| 1346 | 41 #include "ui-gtk.h" |
| 462 | 42 |
| 43 /* XEmacs specific GTK types */ | |
| 44 #include "gtk-glue.c" | |
| 45 | |
| 2054 | 46 /* Is the fundamental type of 't' the xemacs defined fundamental type 'type'? */ |
| 47 #define IS_XEMACS_GTK_FUNDAMENTAL_TYPE(t,type) (((GtkType) GTK_FUNDAMENTAL_TYPE(t)) == (type)) | |
| 48 | |
| 462 | 49 Lisp_Object Qemacs_ffip; |
| 50 Lisp_Object Qemacs_gtk_objectp; | |
| 51 Lisp_Object Qemacs_gtk_boxedp; | |
| 52 Lisp_Object Qvoid; | |
| 53 Lisp_Object Venumeration_info; | |
| 54 | |
| 55 static GHashTable *dll_cache; | |
| 56 | |
| 57 Lisp_Object gtk_type_to_lisp (GtkArg *arg); | |
| 58 int lisp_to_gtk_type (Lisp_Object obj, GtkArg *arg); | |
| 1883 | 59 int lisp_to_gtk_ret_type (Lisp_Object obj, GtkArg *arg); |
| 778 | 60 #if 0 |
| 462 | 61 void describe_gtk_arg (GtkArg *arg); |
| 778 | 62 #endif |
| 462 | 63 guint symbol_to_enum (Lisp_Object obj, GtkType t); |
| 64 static guint lisp_to_flag (Lisp_Object obj, GtkType t); | |
| 65 static Lisp_Object flags_to_list (guint value, GtkType t); | |
| 66 static Lisp_Object enum_to_symbol (guint value, GtkType t); | |
| 67 | |
| 68 #define NIL_OR_VOID_P(x) (NILP (x) || EQ (x, Qvoid)) | |
| 69 | |
| 70 static void | |
| 71 initialize_dll_cache (void) | |
| 72 { | |
| 73 if (!dll_cache) | |
| 74 { | |
| 2054 | 75 static char text[] = "---XEmacs Internal Handle---"; |
| 76 | |
| 462 | 77 dll_cache = g_hash_table_new (g_str_hash, g_str_equal); |
| 78 | |
| 2054 | 79 g_hash_table_insert (dll_cache, text, dll_open (Qnil)); |
| 462 | 80 } |
| 81 } | |
| 82 | |
| 83 DEFUN ("dll-load", Fdll_load, 1, 1, 0, /* | |
| 84 Load a shared library DLL into XEmacs. No initialization routines are required. | |
| 85 This is for loading dependency DLLs into XEmacs. | |
| 86 */ | |
| 87 (dll)) | |
| 88 { | |
| 89 dll_handle h; | |
| 90 | |
| 91 CHECK_STRING (dll); | |
| 92 | |
| 93 initialize_dll_cache (); | |
| 94 | |
| 95 /* If the dll name has a directory component in it, then we should | |
| 96 expand it. */ | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
97 if (!NILP (Fstring_match (build_ascstring ("/"), dll, Qnil, Qnil))) |
| 462 | 98 dll = Fexpand_file_name (dll, Qnil); |
| 99 | |
| 100 /* Check if we have already opened it first */ | |
| 101 h = g_hash_table_lookup (dll_cache, XSTRING_DATA (dll)); | |
| 102 | |
| 103 if (!h) | |
| 104 { | |
| 1811 | 105 h = dll_open (dll); |
| 462 | 106 |
| 107 if (h) | |
| 108 { | |
| 2054 | 109 g_hash_table_insert (dll_cache, qxestrdup (XSTRING_DATA (dll)), h); |
| 462 | 110 } |
| 111 else | |
| 112 { | |
| 2054 | 113 signal_error (Qfile_error, "dll_open error", dll_error()); |
| 462 | 114 } |
| 115 } | |
| 116 return (h ? Qt : Qnil); | |
| 117 } | |
| 118 | |
| 119 | |
| 120 /* Gtk object importing */ | |
| 121 EXFUN (Fgtk_import_type, 1); | |
| 122 | |
| 123 static struct hash_table *internal_type_hash; | |
| 124 | |
| 125 static int | |
| 126 type_already_imported_p (GtkType t) | |
| 127 { | |
| 128 void *retval = NULL; | |
| 129 | |
| 130 /* These are cases that we don't need to import */ | |
| 131 switch (GTK_FUNDAMENTAL_TYPE (t)) | |
| 132 { | |
| 133 case GTK_TYPE_CHAR: | |
| 134 case GTK_TYPE_UCHAR: | |
| 135 case GTK_TYPE_BOOL: | |
| 136 case GTK_TYPE_INT: | |
| 137 case GTK_TYPE_UINT: | |
| 138 case GTK_TYPE_LONG: | |
| 139 case GTK_TYPE_ULONG: | |
| 140 case GTK_TYPE_FLOAT: | |
| 141 case GTK_TYPE_DOUBLE: | |
| 142 case GTK_TYPE_STRING: | |
| 143 case GTK_TYPE_BOXED: | |
| 144 case GTK_TYPE_POINTER: | |
| 145 case GTK_TYPE_SIGNAL: | |
| 146 case GTK_TYPE_ARGS: | |
| 147 case GTK_TYPE_CALLBACK: | |
| 148 case GTK_TYPE_C_CALLBACK: | |
| 149 case GTK_TYPE_FOREIGN: | |
| 150 return (1); | |
| 151 } | |
| 152 | |
| 153 if (!internal_type_hash) | |
| 154 { | |
| 2515 | 155 internal_type_hash = make_hash_table (163); |
| 462 | 156 return (0); |
| 157 } | |
| 158 | |
| 159 if (gethash ((void *)t, internal_type_hash, (const void **)&retval)) | |
| 160 { | |
| 161 return (1); | |
| 162 } | |
| 163 return (0); | |
| 164 } | |
| 165 | |
| 166 static void | |
| 167 mark_type_as_imported (GtkType t) | |
| 168 { | |
| 169 if (type_already_imported_p (t)) | |
| 170 return; | |
| 171 | |
| 172 puthash ((void *) t, (void *) 1, internal_type_hash); | |
| 173 } | |
| 174 | |
| 175 static void import_gtk_type (GtkType t); | |
| 176 | |
| 177 static void | |
| 178 import_gtk_object_internal (GtkType the_type) | |
| 179 { | |
| 180 GtkType original_type = the_type; | |
| 181 int first_time = 1; | |
| 182 | |
| 183 do | |
| 184 { | |
| 185 GtkArg *args; | |
| 186 guint32 *flags; | |
| 187 guint n_args; | |
| 188 guint i; | |
| 189 #if 0 | |
| 190 GtkObjectClass *klass; | |
| 191 GtkSignalQuery *query; | |
| 192 guint32 *signals; | |
| 193 guint n_signals; | |
| 194 #endif | |
| 195 | |
| 196 /* Register the type before we do anything else with it... */ | |
| 197 if (!first_time) | |
| 198 { | |
| 199 if (!type_already_imported_p (the_type)) | |
| 200 { | |
| 201 import_gtk_type (the_type); | |
| 202 } | |
| 203 } | |
| 204 else | |
| 205 { | |
| 206 /* We need to mark the object type as imported here or we | |
| 207 run the risk of SERIOUS recursion when we do automatic | |
| 208 argument type importing. mark_type_as_imported() is | |
| 209 smart enough to be a noop if we attempt to register | |
| 210 things twice. */ | |
| 211 first_time = 0; | |
| 212 mark_type_as_imported (the_type); | |
| 213 } | |
| 214 | |
| 215 args = gtk_object_query_args(the_type,&flags,&n_args); | |
| 216 | |
| 217 /* First get the arguments the object can accept */ | |
| 218 for (i = 0; i < n_args; i++) | |
| 219 { | |
| 220 if ((args[i].type != original_type) && !type_already_imported_p (args[i].type)) | |
| 221 { | |
| 222 import_gtk_type (args[i].type); | |
| 223 } | |
| 224 } | |
| 225 | |
| 226 g_free(args); | |
| 227 g_free(flags); | |
| 228 | |
| 229 #if 0 | |
| 230 /* Now lets publish the signals */ | |
| 231 klass = (GtkObjectClass *) gtk_type_class (the_type); | |
| 232 signals = klass->signals; | |
| 233 n_signals = klass->nsignals; | |
| 234 | |
| 235 for (i = 0; i < n_signals; i++) | |
| 236 { | |
| 237 query = gtk_signal_query (signals[i]); | |
| 238 /* What do we want to do here? */ | |
| 239 g_free (query); | |
| 240 } | |
| 241 #endif | |
| 242 | |
| 243 the_type = gtk_type_parent(the_type); | |
| 244 } while (the_type != GTK_TYPE_INVALID); | |
| 245 } | |
| 246 | |
| 247 static void | |
| 248 import_gtk_enumeration_internal (GtkType the_type) | |
| 249 { | |
| 250 GtkEnumValue *vals = gtk_type_enum_get_values (the_type); | |
| 251 Lisp_Object assoc = Qnil; | |
| 252 | |
| 253 if (NILP (Venumeration_info)) | |
| 254 { | |
| 255 Venumeration_info = call2 (intern ("make-hashtable"), make_int (100), Qequal); | |
| 256 } | |
| 257 | |
| 258 while (vals && vals->value_name) | |
| 259 { | |
| 260 assoc = Fcons (Fcons (intern (vals->value_nick), make_int (vals->value)), assoc); | |
| 261 assoc = Fcons (Fcons (intern (vals->value_name), make_int (vals->value)), assoc); | |
| 262 vals++; | |
| 263 } | |
| 264 | |
| 265 assoc = Fnreverse (assoc); | |
| 266 | |
| 267 Fputhash (make_int (the_type), assoc, Venumeration_info); | |
| 268 } | |
| 269 | |
| 270 static void | |
| 271 import_gtk_type (GtkType t) | |
| 272 { | |
| 273 if (type_already_imported_p (t)) | |
| 274 { | |
| 275 return; | |
| 276 } | |
| 277 | |
| 278 switch (GTK_FUNDAMENTAL_TYPE (t)) | |
| 279 { | |
| 280 case GTK_TYPE_ENUM: | |
| 281 case GTK_TYPE_FLAGS: | |
| 282 import_gtk_enumeration_internal (t); | |
| 283 break; | |
| 284 case GTK_TYPE_OBJECT: | |
| 285 import_gtk_object_internal (t); | |
| 286 break; | |
| 287 default: | |
| 288 break; | |
| 289 } | |
| 290 | |
| 291 mark_type_as_imported (t); | |
| 292 } | |
| 293 | |
| 294 | |
| 295 /* Foreign function calls */ | |
| 296 static emacs_ffi_data * | |
| 297 allocate_ffi_data (void) | |
| 298 { | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
299 Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (emacs_ffi); |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
300 emacs_ffi_data *data = XFFI (obj); |
| 462 | 301 |
| 302 data->return_type = GTK_TYPE_NONE; | |
| 303 data->n_args = 0; | |
| 304 data->function_name = Qnil; | |
| 305 data->function_ptr = 0; | |
| 306 data->marshal = 0; | |
| 307 | |
| 308 return (data); | |
| 309 } | |
| 310 | |
| 1204 | 311 static const struct memory_description ffi_data_description [] = { |
| 312 { XD_LISP_OBJECT, offsetof (emacs_ffi_data, function_name) }, | |
| 934 | 313 { XD_END } |
| 314 }; | |
| 315 | |
| 462 | 316 static Lisp_Object |
| 317 mark_ffi_data (Lisp_Object obj) | |
| 318 { | |
| 319 emacs_ffi_data *data = (emacs_ffi_data *) XFFI (obj); | |
| 320 | |
| 321 mark_object (data->function_name); | |
| 322 return (Qnil); | |
| 323 } | |
| 324 | |
| 325 static void | |
| 2286 | 326 ffi_object_printer (Lisp_Object obj, Lisp_Object printcharfun, |
| 327 int UNUSED (escapeflag)) | |
| 462 | 328 { |
| 329 if (print_readably) | |
|
5142
f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents:
5127
diff
changeset
|
330 printing_unreadable_lisp_object (obj, 0); |
| 462 | 331 |
| 800 | 332 write_fmt_string_lisp (printcharfun, "#<ffi %S", 1, XFFI (obj)->function_name); |
| 462 | 333 if (XFFI (obj)->n_args) |
| 800 | 334 write_fmt_string (printcharfun, " %d arguments", XFFI (obj)->n_args); |
| 335 write_fmt_string (printcharfun, " %p>", (void *)XFFI (obj)->function_ptr); | |
| 462 | 336 } |
| 337 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
338 DEFINE_NODUMP_LISP_OBJECT ("ffi", emacs_ffi, |
|
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
339 mark_ffi_data, ffi_object_printer, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
340 0, 0, 0, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
341 ffi_data_description, emacs_ffi_data); |
| 462 | 342 |
| 2054 | 343 #if defined (__cplusplus) |
| 344 #define MANY_ARGS ... | |
| 345 #else | |
| 346 #define MANY_ARGS | |
| 347 #endif | |
| 348 | |
| 349 typedef void (*pfv)(); | |
| 350 typedef GtkObject * (*__OBJECT_fn) (MANY_ARGS); | |
| 351 typedef gint (*__INT_fn) (MANY_ARGS); | |
| 352 typedef void (*__NONE_fn) (MANY_ARGS); | |
| 353 typedef gchar * (*__STRING_fn) (MANY_ARGS); | |
| 354 typedef gboolean (*__BOOL_fn) (MANY_ARGS); | |
| 355 typedef gfloat (*__FLOAT_fn) (MANY_ARGS); | |
| 356 typedef void * (*__POINTER_fn) (MANY_ARGS); | |
| 357 typedef GList * (*__LIST_fn) (MANY_ARGS); | |
| 462 | 358 |
| 359 /* An auto-generated file of marshalling functions. */ | |
| 360 #include "emacs-marshals.c" | |
| 2054 | 361 #undef MANY_ARGS |
| 462 | 362 |
| 363 #define CONVERT_SINGLE_TYPE(var,nam,tp) case GTK_TYPE_##nam: GTK_VALUE_##nam (var) = * (tp *) v; break; | |
| 364 #define CONVERT_RETVAL(a,freep) \ | |
| 365 do { \ | |
| 366 void *v = GTK_VALUE_POINTER(a); \ | |
| 367 switch (GTK_FUNDAMENTAL_TYPE (a.type)) \ | |
| 1726 | 368 { \ |
| 462 | 369 CONVERT_SINGLE_TYPE(a,CHAR,gchar); \ |
| 370 CONVERT_SINGLE_TYPE(a,UCHAR,guchar); \ | |
| 371 CONVERT_SINGLE_TYPE(a,BOOL,gboolean); \ | |
| 372 CONVERT_SINGLE_TYPE(a,INT,gint); \ | |
| 373 CONVERT_SINGLE_TYPE(a,UINT,guint); \ | |
| 374 CONVERT_SINGLE_TYPE(a,LONG,glong); \ | |
| 375 CONVERT_SINGLE_TYPE(a,ULONG,gulong); \ | |
| 376 CONVERT_SINGLE_TYPE(a,FLOAT,gfloat); \ | |
| 377 CONVERT_SINGLE_TYPE(a,DOUBLE,gdouble); \ | |
| 378 CONVERT_SINGLE_TYPE(a,STRING,gchar *); \ | |
| 379 CONVERT_SINGLE_TYPE(a,ENUM,gint); \ | |
| 380 CONVERT_SINGLE_TYPE(a,FLAGS,guint); \ | |
| 381 CONVERT_SINGLE_TYPE(a,BOXED,void *); \ | |
| 382 CONVERT_SINGLE_TYPE(a,POINTER,void *); \ | |
| 383 CONVERT_SINGLE_TYPE(a,OBJECT,GtkObject *); \ | |
| 1726 | 384 default: \ |
| 385 GTK_VALUE_POINTER (a) = * (void **) v; \ | |
| 462 | 386 break; \ |
| 1726 | 387 } \ |
|
4976
16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
388 if (freep) xfree (v); \ |
| 462 | 389 } while (0) |
| 390 | |
| 778 | 391 static gpointer __allocate_object_storage (GtkType t) |
| 462 | 392 { |
| 393 size_t s = 0; | |
| 394 void *rval = NULL; | |
| 395 | |
| 396 switch (GTK_FUNDAMENTAL_TYPE (t)) | |
| 397 { | |
| 398 /* flag types */ | |
| 399 case GTK_TYPE_CHAR: | |
| 400 s = (sizeof (gchar)); | |
| 401 break; | |
| 402 case GTK_TYPE_UCHAR: | |
| 403 s = (sizeof (guchar)); | |
| 404 break; | |
| 405 case GTK_TYPE_BOOL: | |
| 406 s = (sizeof (gboolean)); | |
| 407 break; | |
| 408 case GTK_TYPE_INT: | |
| 409 s = (sizeof (gint)); | |
| 410 break; | |
| 411 case GTK_TYPE_UINT: | |
| 412 s = (sizeof (guint)); | |
| 413 break; | |
| 414 case GTK_TYPE_LONG: | |
| 415 s = (sizeof (glong)); | |
| 416 break; | |
| 417 case GTK_TYPE_ULONG: | |
| 418 s = (sizeof (gulong)); | |
| 419 break; | |
| 420 case GTK_TYPE_FLOAT: | |
| 421 s = (sizeof (gfloat)); | |
| 422 break; | |
| 423 case GTK_TYPE_DOUBLE: | |
| 424 s = (sizeof (gdouble)); | |
| 425 break; | |
| 426 case GTK_TYPE_STRING: | |
| 427 s = (sizeof (gchar *)); | |
| 428 break; | |
| 429 case GTK_TYPE_ENUM: | |
| 430 case GTK_TYPE_FLAGS: | |
| 431 s = (sizeof (guint)); | |
| 432 break; | |
| 433 case GTK_TYPE_BOXED: | |
| 434 case GTK_TYPE_POINTER: | |
| 435 s = (sizeof (void *)); | |
| 436 break; | |
| 437 | |
| 438 /* base type of the object system */ | |
| 439 case GTK_TYPE_OBJECT: | |
| 440 s = (sizeof (GtkObject *)); | |
| 441 break; | |
| 442 | |
| 443 default: | |
| 2054 | 444 if (IS_XEMACS_GTK_FUNDAMENTAL_TYPE(t, GTK_TYPE_LISTOF)) |
| 462 | 445 { |
| 446 s = (sizeof (void *)); | |
| 447 } | |
| 448 rval = NULL; | |
| 449 break; | |
| 450 } | |
| 451 | |
| 452 if (s) | |
| 453 { | |
| 454 rval = xmalloc (s); | |
| 455 memset (rval, '\0', s); | |
| 456 } | |
| 457 | |
| 458 return (rval); | |
| 459 } | |
| 460 | |
| 778 | 461 static Lisp_Object type_to_marshaller_type (GtkType t) |
| 462 | 462 { |
| 463 switch (GTK_FUNDAMENTAL_TYPE (t)) | |
| 464 { | |
| 465 case GTK_TYPE_NONE: | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
466 return (build_ascstring ("NONE")); |
| 462 | 467 /* flag types */ |
| 468 case GTK_TYPE_CHAR: | |
| 469 case GTK_TYPE_UCHAR: | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
470 return (build_ascstring ("CHAR")); |
| 462 | 471 case GTK_TYPE_BOOL: |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
472 return (build_ascstring ("BOOL")); |
| 462 | 473 case GTK_TYPE_ENUM: |
| 474 case GTK_TYPE_FLAGS: | |
| 475 case GTK_TYPE_INT: | |
| 476 case GTK_TYPE_UINT: | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
477 return (build_ascstring ("INT")); |
| 462 | 478 case GTK_TYPE_LONG: |
| 479 case GTK_TYPE_ULONG: | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
480 return (build_ascstring ("LONG")); |
| 462 | 481 case GTK_TYPE_FLOAT: |
| 482 case GTK_TYPE_DOUBLE: | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
483 return (build_ascstring ("FLOAT")); |
| 462 | 484 case GTK_TYPE_STRING: |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
485 return (build_ascstring ("STRING")); |
| 462 | 486 case GTK_TYPE_BOXED: |
| 487 case GTK_TYPE_POINTER: | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
488 return (build_ascstring ("POINTER")); |
| 462 | 489 case GTK_TYPE_OBJECT: |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
490 return (build_ascstring ("OBJECT")); |
| 462 | 491 case GTK_TYPE_CALLBACK: |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
492 return (build_ascstring ("CALLBACK")); |
| 462 | 493 default: |
| 494 /* I can't put this in the main switch statement because it is a | |
| 495 new fundamental type that is not fixed at compile time. | |
| 496 *sigh* | |
| 497 */ | |
| 2054 | 498 if (IS_XEMACS_GTK_FUNDAMENTAL_TYPE(t, GTK_TYPE_ARRAY)) |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
499 return (build_ascstring ("ARRAY")); |
| 462 | 500 |
| 2054 | 501 if (IS_XEMACS_GTK_FUNDAMENTAL_TYPE(t, GTK_TYPE_LISTOF)) |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
502 return (build_ascstring ("LIST")); |
| 462 | 503 return (Qnil); |
| 504 } | |
| 505 } | |
| 506 | |
| 507 struct __dll_mapper_closure { | |
| 2054 | 508 void * (*func) (dll_handle, const CIbyte *); |
| 509 Ibyte *obj_name; | |
| 462 | 510 void **storage; |
| 511 }; | |
| 512 | |
| 2286 | 513 static void __dll_mapper (gpointer UNUSED (key), gpointer value, |
| 514 gpointer user_data) | |
| 462 | 515 { |
| 516 struct __dll_mapper_closure *closure = (struct __dll_mapper_closure *) user_data; | |
| 517 | |
| 518 if (*(closure->storage) == NULL) | |
| 519 { | |
| 520 /* Need to see if it is in this one */ | |
| 2054 | 521 *(closure->storage) = closure->func ((dll_handle) value, (CIbyte*) closure->obj_name); |
| 462 | 522 } |
| 523 } | |
| 524 | |
| 525 DEFUN ("gtk-import-variable-internal", Fgtk_import_variable_internal, 2, 2, 0, /* | |
| 526 Import a variable into the XEmacs namespace. | |
| 527 */ | |
| 528 (type, name)) | |
| 529 { | |
| 530 void *var = NULL; | |
| 531 GtkArg arg; | |
| 532 | |
| 533 if (SYMBOLP (type)) type = Fsymbol_name (type); | |
| 534 | |
| 535 CHECK_STRING (type); | |
| 536 CHECK_STRING (name); | |
| 537 | |
| 538 initialize_dll_cache (); | |
| 539 xemacs_init_gtk_classes (); | |
| 540 | |
| 541 arg.type = gtk_type_from_name ((char *) XSTRING_DATA (type)); | |
| 542 | |
| 543 if (arg.type == GTK_TYPE_INVALID) | |
| 544 { | |
| 563 | 545 sferror ("Unknown type", type); |
| 462 | 546 } |
| 547 | |
| 548 /* Need to look thru the already-loaded dlls */ | |
| 549 { | |
| 550 struct __dll_mapper_closure closure; | |
| 551 | |
| 552 closure.func = dll_variable; | |
| 553 closure.obj_name = XSTRING_DATA (name); | |
| 554 closure.storage = &var; | |
| 555 | |
| 556 g_hash_table_foreach (dll_cache, __dll_mapper, &closure); | |
| 557 } | |
| 558 | |
| 559 if (!var) | |
| 560 { | |
| 563 | 561 gui_error ("Could not locate variable", name); |
| 462 | 562 } |
| 563 | |
| 564 GTK_VALUE_POINTER(arg) = var; | |
| 565 CONVERT_RETVAL (arg, 0); | |
| 566 return (gtk_type_to_lisp (&arg)); | |
| 567 } | |
| 568 | |
| 569 DEFUN ("gtk-import-function-internal", Fgtk_import_function_internal, 2, 3, 0, /* | |
| 570 Import a function into the XEmacs namespace. | |
| 571 */ | |
| 572 (rettype, name, args)) | |
| 573 { | |
| 574 Lisp_Object rval = Qnil; | |
| 575 Lisp_Object marshaller = Qnil; | |
| 576 emacs_ffi_data *data = NULL; | |
| 577 gint n_args = 0; | |
| 578 #if 0 | |
| 579 dll_handle h = NULL; | |
| 580 #endif | |
| 581 ffi_marshalling_function marshaller_func = NULL; | |
| 582 ffi_actual_function name_func = NULL; | |
| 583 | |
| 584 CHECK_SYMBOL (rettype); | |
| 585 CHECK_STRING (name); | |
| 586 CHECK_LIST (args); | |
| 587 | |
| 588 initialize_dll_cache (); | |
| 589 xemacs_init_gtk_classes (); | |
| 590 | |
| 591 /* Need to look thru the already-loaded dlls */ | |
| 592 { | |
| 593 struct __dll_mapper_closure closure; | |
| 594 | |
| 595 closure.func = dll_function; | |
| 596 closure.obj_name = XSTRING_DATA (name); | |
| 597 closure.storage = (void **) &name_func; | |
| 598 | |
| 599 g_hash_table_foreach (dll_cache, __dll_mapper, &closure); | |
| 600 } | |
| 601 | |
| 602 if (!name_func) | |
| 603 { | |
| 563 | 604 gui_error ("Could not locate function", name); |
| 462 | 605 } |
| 606 | |
| 607 data = allocate_ffi_data (); | |
| 608 | |
| 609 if (NILP (rettype)) | |
| 610 { | |
| 611 rettype = Qvoid; | |
| 612 } | |
| 613 | |
| 614 if (!NILP (args)) | |
| 615 { | |
| 616 Lisp_Object value = args; | |
| 617 Lisp_Object type = Qnil; | |
| 618 | |
| 2367 | 619 EXTERNAL_LIST_LOOP_2 (elt, value) |
| 462 | 620 { |
| 621 GtkType the_type; | |
| 622 Lisp_Object marshaller_type = Qnil; | |
| 623 | |
| 2367 | 624 CHECK_SYMBOL (elt); |
| 462 | 625 |
| 2367 | 626 type = Fsymbol_name (elt); |
| 462 | 627 |
| 628 the_type = gtk_type_from_name ((char *) XSTRING_DATA (type)); | |
| 629 | |
| 630 if (the_type == GTK_TYPE_INVALID) | |
| 631 { | |
| 563 | 632 invalid_argument ("Unknown argument type", type); |
| 462 | 633 } |
| 634 | |
| 635 /* All things must be reduced to their basest form... */ | |
| 636 import_gtk_type (the_type); | |
| 637 data->args[n_args] = the_type; /* GTK_FUNDAMENTAL_TYPE (the_type); */ | |
| 638 | |
| 639 /* Now lets build up another chunk of our marshaller function name */ | |
| 640 marshaller_type = type_to_marshaller_type (data->args[n_args]); | |
| 641 | |
| 642 if (NILP (marshaller_type)) | |
| 643 { | |
| 563 | 644 invalid_argument ("Do not know how to marshal", type); |
| 462 | 645 } |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
646 marshaller = concat3 (marshaller, build_ascstring ("_"), marshaller_type); |
| 462 | 647 n_args++; |
| 648 } | |
| 649 } | |
| 650 else | |
| 651 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
652 marshaller = concat3 (marshaller, build_ascstring ("_"), type_to_marshaller_type (GTK_TYPE_NONE)); |
| 462 | 653 } |
| 654 | |
| 655 rettype = Fsymbol_name (rettype); | |
| 656 data->return_type = gtk_type_from_name ((char *) XSTRING_DATA (rettype)); | |
| 657 | |
| 658 if (data->return_type == GTK_TYPE_INVALID) | |
| 659 { | |
| 563 | 660 invalid_argument ("Unknown return type", rettype); |
| 462 | 661 } |
| 662 | |
| 663 import_gtk_type (data->return_type); | |
| 664 | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
665 marshaller = concat3 (type_to_marshaller_type (data->return_type), build_ascstring ("_"), marshaller); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
666 marshaller = concat2 (build_ascstring ("emacs_gtk_marshal_"), marshaller); |
| 462 | 667 |
| 668 marshaller_func = (ffi_marshalling_function) find_marshaller ((char *) XSTRING_DATA (marshaller)); | |
| 669 | |
| 670 if (!marshaller_func) | |
| 671 { | |
| 563 | 672 gui_error ("Could not locate marshaller function", marshaller); |
| 462 | 673 } |
| 674 | |
| 675 data->n_args = n_args; | |
| 676 data->function_name = name; | |
| 2054 | 677 data->function_ptr = (dll_func) name_func; |
| 462 | 678 data->marshal = marshaller_func; |
| 679 | |
| 797 | 680 rval = wrap_emacs_ffi (data); |
| 462 | 681 return (rval); |
| 682 } | |
| 683 | |
| 684 DEFUN ("gtk-call-function", Fgtk_call_function, 1, 2, 0, /* | |
| 685 Call an external function. | |
| 686 */ | |
| 687 (func, args)) | |
| 688 { | |
| 689 GtkArg the_args[MAX_GTK_ARGS]; | |
| 690 gint n_args = 0; | |
| 691 Lisp_Object retval = Qnil; | |
| 692 | |
| 693 CHECK_FFI (func); | |
| 694 CHECK_LIST (args); | |
| 695 | |
| 696 n_args = XINT (Flength (args)); | |
| 697 | |
| 698 #ifdef XEMACS_IS_SMARTER_THAN_THE_PROGRAMMER | |
| 699 /* #### I think this is too dangerous to enable by default. | |
| 700 ** #### Genuine program bugs would probably be allowed to | |
| 701 ** #### slip by, and not be very easy to find. | |
| 702 ** #### Bill Perry July 9, 2000 | |
| 703 */ | |
| 704 if (n_args != XFFI(func)->n_args) | |
| 705 { | |
| 706 Lisp_Object for_append[3]; | |
| 707 | |
| 708 /* Signal an error if they pass in too many arguments */ | |
| 709 if (n_args > XFFI(func)->n_args) | |
| 710 { | |
| 711 return Fsignal (Qwrong_number_of_arguments, | |
| 712 list2 (func, make_int (n_args))); | |
| 713 } | |
| 714 | |
| 715 /* If they did not provide enough arguments, be nice and assume | |
| 716 ** they wanted `nil' in there. | |
| 717 */ | |
| 718 for_append[0] = args; | |
| 719 for_append[1] = Fmake_list (make_int (XFFI(func)->n_args - n_args), Qnil); | |
| 720 | |
| 721 args = Fappend (2, for_append); | |
| 722 } | |
| 723 #else | |
| 724 if (n_args != XFFI(func)->n_args) | |
| 725 { | |
| 726 /* Signal an error if they do not pass in the correct # of arguments */ | |
| 727 return Fsignal (Qwrong_number_of_arguments, | |
| 728 list2 (func, make_int (n_args))); | |
| 729 } | |
| 730 #endif | |
| 731 | |
| 732 if (!NILP (args)) | |
| 733 { | |
| 734 Lisp_Object value = args; | |
| 735 | |
| 736 CHECK_LIST (args); | |
| 737 n_args = 0; | |
| 738 | |
| 739 /* First we convert all of the arguments from Lisp to GtkArgs */ | |
| 2367 | 740 { |
| 741 EXTERNAL_LIST_LOOP_2 (elt, value) | |
| 742 { | |
| 743 the_args[n_args].type = XFFI (func)->args[n_args]; | |
| 462 | 744 |
| 2367 | 745 if (lisp_to_gtk_type (elt, &the_args[n_args])) |
| 746 { | |
| 747 /* There was some sort of an error */ | |
| 748 gui_error ("Error converting arguments", args); | |
| 749 } | |
| 750 n_args++; | |
| 751 } | |
| 752 } | |
| 462 | 753 } |
| 754 | |
| 755 /* Now we need to tack on space for a return value, if they have | |
| 756 asked for one */ | |
| 757 if (XFFI (func)->return_type != GTK_TYPE_NONE) | |
| 758 { | |
| 759 the_args[n_args].type = XFFI (func)->return_type; | |
| 760 GTK_VALUE_POINTER (the_args[n_args]) = __allocate_object_storage (the_args[n_args].type); | |
| 761 n_args++; | |
| 762 } | |
| 763 | |
| 764 XFFI (func)->marshal ((ffi_actual_function) (XFFI (func)->function_ptr), the_args); | |
| 765 | |
| 766 if (XFFI (func)->return_type != GTK_TYPE_NONE) | |
| 767 { | |
| 768 CONVERT_RETVAL (the_args[n_args - 1], 1); | |
| 769 retval = gtk_type_to_lisp (&the_args[n_args - 1]); | |
| 770 } | |
| 771 | |
| 772 /* Need to free any array or list pointers */ | |
| 773 { | |
| 774 int i; | |
| 775 for (i = 0; i < n_args; i++) | |
| 776 { | |
| 2054 | 777 if (IS_XEMACS_GTK_FUNDAMENTAL_TYPE(the_args[i].type, GTK_TYPE_ARRAY)) |
| 462 | 778 { |
| 779 g_free (GTK_VALUE_POINTER (the_args[i])); | |
| 780 } | |
| 2054 | 781 else if (IS_XEMACS_GTK_FUNDAMENTAL_TYPE(the_args[i].type, GTK_TYPE_LISTOF)) |
| 462 | 782 { |
| 783 /* g_list_free (GTK_VALUE_POINTER (the_args[i])); */ | |
| 784 } | |
| 785 } | |
| 786 } | |
| 787 | |
| 788 return (retval); | |
| 789 } | |
| 790 | |
| 791 | |
| 792 | |
| 793 /* GtkObject wrapping for Lisp */ | |
| 794 static void | |
| 2286 | 795 emacs_gtk_object_printer (Lisp_Object obj, Lisp_Object printcharfun, |
| 796 int UNUSED (escapeflag)) | |
| 462 | 797 { |
| 798 if (print_readably) | |
|
5142
f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents:
5127
diff
changeset
|
799 printing_unreadable_lisp_object (obj, 0); |
| 462 | 800 |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
801 write_ascstring (printcharfun, "#<GtkObject ("); |
| 462 | 802 if (XGTK_OBJECT (obj)->alive_p) |
|
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
803 write_cistring (printcharfun, gtk_type_name (GTK_OBJECT_TYPE (XGTK_OBJECT (obj)->object))); |
| 462 | 804 else |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
805 write_ascstring (printcharfun, "dead"); |
| 800 | 806 write_fmt_string (printcharfun, ") %p>", (void *) XGTK_OBJECT (obj)->object); |
| 462 | 807 } |
| 808 | |
| 809 static Lisp_Object | |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
810 emacs_gtk_object_getprop (Lisp_Object obj, Lisp_Object prop) |
| 462 | 811 { |
| 812 Lisp_Object rval = Qnil; | |
| 813 Lisp_Object prop_name = Qnil; | |
| 814 GtkArgInfo *info = NULL; | |
| 815 char *err; | |
| 816 GtkArg args[2]; | |
| 817 | |
| 818 CHECK_SYMBOL (prop); /* Shouldn't need to ever do this, but I'm paranoid */ | |
| 819 | |
| 820 prop_name = Fsymbol_name (prop); | |
| 821 | |
| 822 args[0].name = (char *) XSTRING_DATA (prop_name); | |
| 823 | |
| 824 err = gtk_object_arg_get_info (GTK_OBJECT_TYPE (XGTK_OBJECT (obj)->object), | |
| 825 args[0].name, | |
| 826 &info); | |
| 827 | |
| 828 if (err) | |
| 829 { | |
| 830 /* Not a magic symbol, fall back to just looking in our real plist */ | |
| 831 g_free (err); | |
| 832 | |
| 833 return (Fplist_get (XGTK_OBJECT (obj)->plist, prop, Qunbound)); | |
| 834 } | |
| 835 | |
| 836 if (!(info->arg_flags & GTK_ARG_READABLE)) | |
| 837 { | |
| 563 | 838 invalid_operation ("Attempt to get write-only property", prop); |
| 462 | 839 } |
| 840 | |
| 841 gtk_object_getv (XGTK_OBJECT (obj)->object, 1, args); | |
| 842 | |
| 843 if (args[0].type == GTK_TYPE_INVALID) | |
| 844 { | |
| 845 /* If we can't get the attribute, then let the code in Fget know | |
| 846 so it can use the default value supplied by the caller */ | |
| 847 return (Qunbound); | |
| 848 } | |
| 849 | |
| 850 rval = gtk_type_to_lisp (&args[0]); | |
| 851 | |
| 852 /* Free up any memory. According to the documentation and Havoc's | |
| 853 book, if the fundamental type of the returned value is | |
| 854 GTK_TYPE_STRING, GTK_TYPE_BOXED, or GTK_TYPE_ARGS, you are | |
| 855 responsible for freeing it. */ | |
| 856 switch (GTK_FUNDAMENTAL_TYPE (args[0].type)) | |
| 857 { | |
| 858 case GTK_TYPE_STRING: | |
| 859 g_free (GTK_VALUE_STRING (args[0])); | |
| 860 break; | |
| 861 case GTK_TYPE_BOXED: | |
| 862 g_free (GTK_VALUE_BOXED (args[0])); | |
| 863 break; | |
| 864 case GTK_TYPE_ARGS: | |
| 865 g_free (GTK_VALUE_ARGS (args[0]).args); | |
| 866 default: | |
| 867 break; | |
| 868 } | |
| 869 | |
| 870 return (rval); | |
| 871 } | |
| 872 | |
| 873 static int | |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
874 emacs_gtk_object_putprop (Lisp_Object obj, Lisp_Object prop, Lisp_Object value) |
| 462 | 875 { |
| 876 GtkArgInfo *info = NULL; | |
| 877 Lisp_Object prop_name = Qnil; | |
| 878 GtkArg args[2]; | |
| 879 char *err = NULL; | |
| 880 | |
| 881 prop_name = Fsymbol_name (prop); | |
| 882 | |
| 883 args[0].name = (char *) XSTRING_DATA (prop_name); | |
| 884 | |
| 885 err = gtk_object_arg_get_info (GTK_OBJECT_TYPE (XGTK_OBJECT (obj)->object), | |
| 886 args[0].name, | |
| 887 &info); | |
| 888 | |
| 889 if (err) | |
| 890 { | |
| 891 /* Not a magic symbol, fall back to just storing in our real plist */ | |
| 892 g_free (err); | |
| 893 | |
| 894 XGTK_OBJECT (obj)->plist = Fplist_put (XGTK_OBJECT (obj)->plist, prop, value); | |
| 895 return (1); | |
| 896 } | |
| 897 | |
| 898 args[0].type = info->type; | |
| 899 | |
| 900 if (lisp_to_gtk_type (value, &args[0])) | |
| 901 { | |
| 563 | 902 gui_error ("Error converting to GtkType", value); |
| 462 | 903 } |
| 904 | |
| 905 if (!(info->arg_flags & GTK_ARG_WRITABLE)) | |
| 906 { | |
| 563 | 907 invalid_operation ("Attempt to set read-only argument", prop); |
| 462 | 908 } |
| 909 | |
| 910 gtk_object_setv (XGTK_OBJECT (obj)->object, 1, args); | |
| 911 | |
| 912 return (1); | |
| 913 } | |
| 914 | |
| 1204 | 915 static const struct memory_description gtk_object_data_description [] = { |
| 916 { XD_LISP_OBJECT, offsetof (emacs_gtk_object_data, plist) }, | |
| 934 | 917 { XD_END } |
| 918 }; | |
| 919 | |
| 462 | 920 static Lisp_Object |
| 921 mark_gtk_object_data (Lisp_Object obj) | |
| 922 { | |
| 923 return (XGTK_OBJECT (obj)->plist); | |
| 924 } | |
| 925 | |
| 926 static void | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
927 emacs_gtk_object_finalizer (Lisp_Object obj) |
| 462 | 928 { |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
929 emacs_gtk_object_data *data = XEMACS_GTK_OBJECT_DATA (obj); |
| 462 | 930 |
| 931 if (data->alive_p) | |
|
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
932 gtk_object_unref (data->object); |
| 462 | 933 } |
| 934 | |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
935 DEFINE_NODUMP_LISP_OBJECT ("GtkObject", emacs_gtk_object, |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
936 mark_gtk_object_data, |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
937 emacs_gtk_object_printer, |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
938 emacs_gtk_object_finalizer, |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
939 0, /* equality */ |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
940 0, /* hash */ |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
941 gtk_object_data_description, |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
942 emacs_gtk_object_data); |
| 462 | 943 |
| 944 static emacs_gtk_object_data * | |
| 945 allocate_emacs_gtk_object_data (void) | |
| 946 { | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
947 Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (emacs_gtk_object); |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
948 emacs_gtk_object_data *data = XGTK_OBJECT (obj); |
| 462 | 949 |
| 950 data->object = NULL; | |
| 951 data->alive_p = FALSE; | |
| 952 data->plist = Qnil; | |
| 953 | |
| 954 return (data); | |
| 955 } | |
| 956 | |
| 957 /* We need to keep track of when the object is destroyed so that we | |
| 958 can mark it as dead, otherwise even our print routine (which calls | |
| 959 GTK_OBJECT_TYPE) will crap out and die. This is also used in the | |
| 960 lisp_to_gtk_type() routine to defend against passing dead objects | |
| 961 to GTK routines. */ | |
| 962 static void | |
| 2286 | 963 __notice_object_destruction (GtkObject *UNUSED (obj), gpointer user_data) |
| 462 | 964 { |
| 965 ungcpro_popup_callbacks ((GUI_ID) user_data); | |
| 966 } | |
| 967 | |
| 968 Lisp_Object build_gtk_object (GtkObject *obj) | |
| 969 { | |
| 970 Lisp_Object retval = Qnil; | |
| 971 emacs_gtk_object_data *data = NULL; | |
| 972 GUI_ID id = 0; | |
| 973 | |
| 2168 | 974 id = (GUI_ID) gtk_object_get_data (obj, GTK_DATA_GUI_IDENTIFIER); |
| 462 | 975 |
| 976 if (id) | |
| 977 { | |
| 978 retval = get_gcpro_popup_callbacks (id); | |
| 979 } | |
| 980 | |
| 981 if (NILP (retval)) | |
| 982 { | |
| 983 data = allocate_emacs_gtk_object_data (); | |
| 984 | |
| 985 data->object = obj; | |
| 986 data->alive_p = TRUE; | |
| 797 | 987 retval = wrap_emacs_gtk_object (data); |
| 462 | 988 |
| 989 id = new_gui_id (); | |
| 2168 | 990 gtk_object_set_data (obj, GTK_DATA_GUI_IDENTIFIER, (gpointer) id); |
| 462 | 991 gcpro_popup_callbacks (id, retval); |
| 992 gtk_object_ref (obj); | |
| 993 gtk_signal_connect (obj, "destroy", GTK_SIGNAL_FUNC (__notice_object_destruction), (gpointer)id); | |
| 994 } | |
| 995 | |
| 996 return (retval); | |
| 997 } | |
| 998 | |
| 999 static void | |
| 1000 __internal_callback_destroy (gpointer data) | |
| 1001 { | |
| 1002 Lisp_Object lisp_data; | |
| 1003 | |
| 5013 | 1004 lisp_data = GET_LISP_FROM_VOID (data); |
| 462 | 1005 |
| 1006 ungcpro_popup_callbacks (XINT (XCAR (lisp_data))); | |
| 1007 } | |
| 1008 | |
| 1009 static void | |
| 1010 __internal_callback_marshal (GtkObject *obj, gpointer data, guint n_args, GtkArg *args) | |
| 1011 { | |
| 1012 Lisp_Object arg_list = Qnil; | |
| 1013 Lisp_Object callback_fn = Qnil; | |
| 1014 Lisp_Object callback_data = Qnil; | |
| 1015 Lisp_Object newargs[3]; | |
| 1016 Lisp_Object rval = Qnil; | |
| 1017 struct gcpro gcpro1; | |
| 1018 int i; | |
| 1019 | |
| 5013 | 1020 callback_fn = GET_LISP_FROM_VOID (data); |
| 462 | 1021 |
| 1022 /* Nuke the GUI_ID off the front */ | |
| 1023 callback_fn = XCDR (callback_fn); | |
| 1024 | |
| 1025 callback_data = XCAR (callback_fn); | |
| 1026 callback_fn = XCDR (callback_fn); | |
| 1027 | |
| 1028 /* The callback data goes at the very end of the argument list */ | |
| 1029 arg_list = Fcons (callback_data, Qnil); | |
| 1030 | |
| 1031 /* Build up the argument list, lisp style */ | |
| 1032 for (i = n_args - 1; i >= 0; i--) | |
| 1033 { | |
| 1034 arg_list = Fcons (gtk_type_to_lisp (&args[i]), arg_list); | |
| 1035 } | |
| 1036 | |
| 1037 /* We always pass the widget as the first parameter at the very least */ | |
| 1038 arg_list = Fcons (build_gtk_object (obj), arg_list); | |
| 1039 | |
| 1040 GCPRO1 ((arg_list)); | |
| 1041 | |
| 1042 newargs[0] = callback_fn; | |
| 1043 newargs[1] = arg_list; | |
| 1044 | |
| 1045 rval = Fapply (2, newargs); | |
| 1046 signal_fake_event (); | |
| 1047 | |
| 1048 if (args[n_args].type != GTK_TYPE_NONE) | |
| 1883 | 1049 lisp_to_gtk_ret_type (rval, &args[n_args]); |
| 462 | 1050 |
| 1051 UNGCPRO; | |
| 1052 } | |
| 1053 | |
| 1054 DEFUN ("gtk-signal-connect", Fgtk_signal_connect, 3, 6, 0, /* | |
| 1055 */ | |
| 1056 (obj, name, func, cb_data, object_signal, after_p)) | |
| 1057 { | |
| 1058 int c_after; | |
| 1059 int c_object_signal; | |
| 1060 GUI_ID id = 0; | |
| 1061 | |
| 1062 CHECK_GTK_OBJECT (obj); | |
| 1063 | |
| 1064 if (SYMBOLP (name)) | |
| 1065 name = Fsymbol_name (name); | |
| 1066 | |
| 1067 CHECK_STRING (name); | |
| 1068 | |
| 1069 if (NILP (object_signal)) | |
| 1070 c_object_signal = 0; | |
| 1071 else | |
| 1072 c_object_signal = 1; | |
| 1073 | |
| 1074 if (NILP (after_p)) | |
| 1075 c_after = 0; | |
| 1076 else | |
| 1077 c_after = 1; | |
| 1078 | |
| 1079 id = new_gui_id (); | |
| 1080 func = Fcons (cb_data, func); | |
| 1081 func = Fcons (make_int (id), func); | |
| 1082 | |
| 1083 gcpro_popup_callbacks (id, func); | |
| 1084 | |
| 1085 gtk_signal_connect_full (XGTK_OBJECT (obj)->object, (char *) XSTRING_DATA (name), | |
| 5013 | 1086 NULL, __internal_callback_marshal, STORE_LISP_IN_VOID (func), |
| 462 | 1087 __internal_callback_destroy, c_object_signal, c_after); |
| 1088 return (Qt); | |
| 1089 } | |
| 1090 | |
| 1091 | |
| 1092 /* GTK_TYPE_BOXED wrapper for Emacs lisp */ | |
| 1204 | 1093 static const struct memory_description emacs_gtk_boxed_description [] = { |
| 960 | 1094 { XD_END } |
| 1095 }; | |
| 1096 | |
| 462 | 1097 static void |
| 2286 | 1098 emacs_gtk_boxed_printer (Lisp_Object obj, Lisp_Object printcharfun, |
| 1099 int UNUSED (escapeflag)) | |
| 462 | 1100 { |
| 1101 if (print_readably) | |
|
5142
f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents:
5127
diff
changeset
|
1102 printing_unreadable_lisp_object (obj, 0); |
| 462 | 1103 |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
1104 write_ascstring (printcharfun, "#<GtkBoxed ("); |
|
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
1105 write_cistring (printcharfun, gtk_type_name (XGTK_BOXED (obj)->object_type)); |
| 800 | 1106 write_fmt_string (printcharfun, ") %p>", (void *) XGTK_BOXED (obj)->object); |
| 462 | 1107 } |
| 1108 | |
| 1109 static int | |
| 2286 | 1110 emacs_gtk_boxed_equality (Lisp_Object o1, Lisp_Object o2, int UNUSED (depth)) |
| 462 | 1111 { |
| 1112 emacs_gtk_boxed_data *data1 = XGTK_BOXED(o1); | |
| 1113 emacs_gtk_boxed_data *data2 = XGTK_BOXED(o2); | |
| 1114 | |
| 1115 return ((data1->object == data2->object) && | |
| 1116 (data1->object_type == data2->object_type)); | |
| 1117 } | |
| 1118 | |
| 2515 | 1119 static Hashcode |
|
5191
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5178
diff
changeset
|
1120 emacs_gtk_boxed_hash (Lisp_Object obj, int UNUSED (depth), |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5178
diff
changeset
|
1121 Boolint UNUSED (equalp)) |
| 462 | 1122 { |
| 1123 emacs_gtk_boxed_data *data = XGTK_BOXED(obj); | |
| 2515 | 1124 return (HASH2 ((Hashcode) data->object, data->object_type)); |
| 462 | 1125 } |
| 1126 | |
|
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
1127 DEFINE_NODUMP_LISP_OBJECT ("GtkBoxed", emacs_gtk_boxed, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
1128 0, /* marker function */ |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
1129 emacs_gtk_boxed_printer, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
1130 0, /* nuker */ |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
1131 emacs_gtk_boxed_equality, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
1132 emacs_gtk_boxed_hash, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
1133 emacs_gtk_boxed_description, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
1134 emacs_gtk_boxed_data); |
| 462 | 1135 /* Currently defined GTK_TYPE_BOXED structures are: |
| 1136 | |
| 1137 GtkAccelGroup - | |
| 1138 GtkSelectionData - | |
| 1139 GtkStyle - | |
| 1140 GtkCTreeNode - | |
| 1141 GdkColormap - | |
| 1142 GdkVisual - | |
| 1143 GdkFont - | |
| 1144 GdkWindow - | |
| 1145 GdkDragContext - | |
| 1146 GdkEvent - | |
| 1147 GdkColor - | |
| 1148 */ | |
| 1149 static emacs_gtk_boxed_data * | |
| 1150 allocate_emacs_gtk_boxed_data (void) | |
| 1151 { | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
1152 Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (emacs_gtk_boxed); |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
1153 emacs_gtk_boxed_data *data = XGTK_BOXED (obj); |
| 462 | 1154 |
| 1155 data->object = NULL; | |
| 1156 data->object_type = GTK_TYPE_INVALID; | |
| 1157 | |
| 1158 return (data); | |
| 1159 } | |
| 1160 | |
| 1161 Lisp_Object build_gtk_boxed (void *obj, GtkType t) | |
| 1162 { | |
| 1163 Lisp_Object retval = Qnil; | |
| 1164 emacs_gtk_boxed_data *data = NULL; | |
| 1165 | |
| 1166 if (GTK_FUNDAMENTAL_TYPE (t) != GTK_TYPE_BOXED) | |
| 2500 | 1167 ABORT(); |
| 462 | 1168 |
| 1169 data = allocate_emacs_gtk_boxed_data (); | |
| 1170 data->object = obj; | |
| 1171 data->object_type = t; | |
| 1172 | |
| 797 | 1173 retval = wrap_emacs_gtk_boxed (data); |
| 462 | 1174 |
| 1175 return (retval); | |
| 1176 } | |
| 1177 | |
| 1178 | |
| 1179 /* The automatically generated structure access routines */ | |
| 1180 #include "emacs-widget-accessors.c" | |
| 1181 | |
| 1182 /* The hand generated funky functions that we can't just import using the FFI */ | |
| 1183 #include "ui-byhand.c" | |
| 1184 | |
| 1185 /* The glade support */ | |
| 1186 #include "glade.c" | |
| 1187 | |
| 1188 | |
| 1189 /* Type manipulation */ | |
| 1190 DEFUN ("gtk-fundamental-type", Fgtk_fundamental_type, 1, 1, 0, /* | |
| 1191 Load a shared library DLL into XEmacs. No initialization routines are required. | |
| 1192 This is for loading dependency DLLs into XEmacs. | |
| 1193 */ | |
| 1194 (type)) | |
| 1195 { | |
| 1196 GtkType t; | |
| 1197 | |
| 1198 if (SYMBOLP (type)) | |
| 1199 type = Fsymbol_name (type); | |
| 1200 | |
| 1201 CHECK_STRING (type); | |
| 1202 | |
| 1203 t = gtk_type_from_name ((char *) XSTRING_DATA (type)); | |
| 1204 | |
| 1205 if (t == GTK_TYPE_INVALID) | |
| 1206 { | |
| 563 | 1207 invalid_argument ("Not a GTK type", type); |
| 462 | 1208 } |
| 1209 return (make_int (GTK_FUNDAMENTAL_TYPE (t))); | |
| 1210 } | |
| 1211 | |
| 1212 DEFUN ("gtk-object-type", Fgtk_object_type, 1, 1, 0, /* | |
| 1213 Return the GtkType of OBJECT. | |
| 1214 */ | |
| 1215 (object)) | |
| 1216 { | |
| 1217 CHECK_GTK_OBJECT (object); | |
| 1218 return (make_int (GTK_OBJECT_TYPE (XGTK_OBJECT (object)->object))); | |
| 1219 } | |
| 1220 | |
| 1221 DEFUN ("gtk-describe-type", Fgtk_describe_type, 1, 1, 0, /* | |
| 1222 Returns a cons of two lists describing the Gtk object TYPE. | |
| 1223 The car is a list of all the signals that it will emit. | |
| 1224 The cdr is a list of all the magic properties it has. | |
| 1225 */ | |
| 1226 (type)) | |
| 1227 { | |
| 1228 Lisp_Object rval, signals, props; | |
| 1229 GtkType t; | |
| 1230 | |
| 1231 props = signals = rval = Qnil; | |
| 1232 | |
| 1233 if (SYMBOLP (type)) | |
| 1234 { | |
| 1235 type = Fsymbol_name (type); | |
| 1236 } | |
| 1237 | |
| 1238 if (STRINGP (type)) | |
| 1239 { | |
| 2054 | 1240 t = gtk_type_from_name ((gchar*) XSTRING_DATA (type)); |
| 462 | 1241 if (t == GTK_TYPE_INVALID) |
| 1242 { | |
| 563 | 1243 invalid_argument ("Not a GTK type", type); |
| 462 | 1244 } |
| 1245 } | |
| 1246 else | |
| 1247 { | |
| 1248 CHECK_INT (type); | |
| 1249 t = XINT (type); | |
| 1250 } | |
| 1251 | |
| 1252 if (GTK_FUNDAMENTAL_TYPE (t) != GTK_TYPE_OBJECT) | |
| 1253 { | |
| 563 | 1254 invalid_argument ("Not a GtkObject", type); |
| 462 | 1255 } |
| 1256 | |
| 1257 /* Need to do stupid shit like this to get the args | |
| 1258 ** registered... damn GTK and its lazy loading | |
| 1259 */ | |
| 1260 { | |
| 1261 GtkArg args[3]; | |
| 1262 GtkObject *obj = gtk_object_newv (t, 0, args); | |
| 1263 | |
| 1264 gtk_object_destroy(obj); | |
| 1265 } | |
| 1266 | |
| 1267 do | |
| 1268 { | |
| 1269 guint i; | |
| 1270 | |
| 1271 /* Do the magic arguments first */ | |
| 1272 { | |
| 1273 GtkArg *args; | |
| 1274 guint32 *flags; | |
| 1275 guint n_args; | |
| 1276 | |
| 1277 args = gtk_object_query_args(t,&flags,&n_args); | |
| 1278 | |
| 1279 for (i = 0; i < n_args; i++) | |
| 1280 { | |
| 1281 props = Fcons (Fcons (intern (gtk_type_name(args[i].type)), | |
| 1282 intern (args[i].name)), props); | |
| 1283 } | |
| 1284 | |
| 1285 g_free (args); | |
| 1286 g_free (flags); | |
| 1287 } | |
| 1288 | |
| 1289 /* Now the signals */ | |
| 1290 { | |
| 1291 GtkObjectClass *klass; | |
| 1292 GtkSignalQuery *query; | |
| 1293 guint32 *gtk_signals; | |
| 1294 guint n_signals; | |
| 1295 | |
| 1296 klass = (GtkObjectClass *) gtk_type_class (t); | |
| 1297 gtk_signals = klass->signals; | |
| 1298 n_signals = klass->nsignals; | |
| 1299 | |
| 1300 for (i = 0; i < n_signals; i++) | |
| 1301 { | |
| 1302 Lisp_Object params = Qnil; | |
| 1303 | |
| 1304 query = gtk_signal_query (gtk_signals[i]); | |
| 1305 | |
| 1306 if (query) | |
| 1307 { | |
| 1308 if (query->nparams) | |
| 1309 { | |
| 1310 int j; | |
| 1311 | |
| 1312 for (j = query->nparams - 1; j >= 0; j--) | |
| 1313 { | |
| 1314 params = Fcons (intern (gtk_type_name (query->params[j])), params); | |
| 1315 } | |
| 1316 } | |
| 1317 | |
| 1318 signals = Fcons (Fcons (intern (gtk_type_name (query->return_val)), | |
| 1319 Fcons (intern (query->signal_name), | |
| 1320 params)), | |
| 1321 signals); | |
| 1322 | |
| 1323 g_free (query); | |
| 1324 } | |
| 1325 } | |
| 1326 } | |
| 1327 t = gtk_type_parent(t); | |
| 1328 } while (t != GTK_TYPE_INVALID); | |
| 1329 | |
| 1330 rval = Fcons (signals, props); | |
| 1331 | |
| 1332 return (rval); | |
| 1333 } | |
| 1334 | |
| 1335 | |
| 1336 void | |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
1337 ui_gtk_objects_create (void) |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
1338 { |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
1339 OBJECT_HAS_METHOD (emacs_gtk_object, getprop); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
1340 OBJECT_HAS_METHOD (emacs_gtk_object, putprop); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
1341 /* #### No remprop or plist methods */ |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
1342 } |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
1343 |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
1344 void |
| 462 | 1345 syms_of_ui_gtk (void) |
| 1346 { | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
1347 INIT_LISP_OBJECT (emacs_ffi); |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
1348 INIT_LISP_OBJECT (emacs_gtk_object); |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
1349 INIT_LISP_OBJECT (emacs_gtk_boxed); |
| 563 | 1350 DEFSYMBOL_MULTIWORD_PREDICATE (Qemacs_ffip); |
| 1351 DEFSYMBOL_MULTIWORD_PREDICATE (Qemacs_gtk_objectp); | |
| 1352 DEFSYMBOL_MULTIWORD_PREDICATE (Qemacs_gtk_boxedp); | |
| 1353 DEFSYMBOL (Qvoid); | |
| 462 | 1354 DEFSUBR (Fdll_load); |
| 1355 DEFSUBR (Fgtk_import_function_internal); | |
| 1356 DEFSUBR (Fgtk_import_variable_internal); | |
| 1357 DEFSUBR (Fgtk_signal_connect); | |
| 1358 DEFSUBR (Fgtk_call_function); | |
| 1359 DEFSUBR (Fgtk_fundamental_type); | |
| 1360 DEFSUBR (Fgtk_object_type); | |
| 1361 DEFSUBR (Fgtk_describe_type); | |
| 1362 syms_of_widget_accessors (); | |
| 1363 syms_of_ui_byhand (); | |
| 1364 syms_of_glade (); | |
| 1365 } | |
| 1366 | |
| 1367 void | |
| 1368 vars_of_ui_gtk (void) | |
| 1369 { | |
| 1370 Fprovide (intern ("gtk-ui")); | |
| 1371 DEFVAR_LISP ("gtk-enumeration-info", &Venumeration_info /* | |
| 1372 A hashtable holding type information about GTK enumerations and flags. | |
| 1373 Do NOT modify unless you really understand ui-gtk.c. | |
| 1374 */); | |
| 1375 | |
| 1376 Venumeration_info = Qnil; | |
| 1377 vars_of_glade (); | |
| 1378 } | |
| 1379 | |
| 1380 | |
| 1381 /* Various utility functions */ | |
| 778 | 1382 #if 0 |
| 462 | 1383 void describe_gtk_arg (GtkArg *arg) |
| 1384 { | |
| 1385 GtkArg a = *arg; | |
| 1386 | |
| 1387 switch (GTK_FUNDAMENTAL_TYPE (a.type)) | |
| 1388 { | |
| 1389 /* flag types */ | |
| 1390 case GTK_TYPE_CHAR: | |
| 1391 stderr_out ("char: %c\n", GTK_VALUE_CHAR (a)); | |
| 1392 break; | |
| 1393 case GTK_TYPE_UCHAR: | |
| 1394 stderr_out ("uchar: %c\n", GTK_VALUE_CHAR (a)); | |
| 1395 break; | |
| 1396 case GTK_TYPE_BOOL: | |
| 1397 stderr_out ("uchar: %s\n", GTK_VALUE_BOOL (a) ? "true" : "false"); | |
| 1398 break; | |
| 1399 case GTK_TYPE_INT: | |
| 1400 stderr_out ("int: %d\n", GTK_VALUE_INT (a)); | |
| 1401 break; | |
| 1402 case GTK_TYPE_UINT: | |
| 1403 stderr_out ("uint: %du\n", GTK_VALUE_UINT (a)); | |
| 1404 break; | |
| 1405 case GTK_TYPE_LONG: | |
| 1406 stderr_out ("long: %ld\n", GTK_VALUE_LONG (a)); | |
| 1407 break; | |
| 1408 case GTK_TYPE_ULONG: | |
| 1409 stderr_out ("ulong: %lu\n", GTK_VALUE_ULONG (a)); | |
| 1410 break; | |
| 1411 case GTK_TYPE_FLOAT: | |
| 1412 stderr_out ("float: %g\n", GTK_VALUE_FLOAT (a)); | |
| 1413 break; | |
| 1414 case GTK_TYPE_DOUBLE: | |
| 1415 stderr_out ("double: %f\n", GTK_VALUE_DOUBLE (a)); | |
| 1416 break; | |
| 1417 case GTK_TYPE_STRING: | |
| 1418 stderr_out ("string: %s\n", GTK_VALUE_STRING (a)); | |
| 1419 break; | |
| 1420 case GTK_TYPE_ENUM: | |
| 1421 case GTK_TYPE_FLAGS: | |
| 1422 stderr_out ("%s: ", (a.type == GTK_TYPE_ENUM) ? "enum" : "flag"); | |
| 1423 { | |
| 1424 GtkEnumValue *vals = gtk_type_enum_get_values (a.type); | |
| 1425 | |
| 1426 while (vals && vals->value_name && (vals->value != GTK_VALUE_ENUM(a))) vals++; | |
| 1427 | |
| 1428 stderr_out ("%s\n", vals ? vals->value_name : "!!! UNKNOWN ENUM VALUE !!!"); | |
| 1429 } | |
| 1430 break; | |
| 1431 case GTK_TYPE_BOXED: | |
| 1432 stderr_out ("boxed: %p\n", GTK_VALUE_BOXED (a)); | |
| 1433 break; | |
| 1434 case GTK_TYPE_POINTER: | |
| 1435 stderr_out ("pointer: %p\n", GTK_VALUE_BOXED (a)); | |
| 1436 break; | |
| 1437 | |
| 1438 /* structured types */ | |
| 1439 case GTK_TYPE_SIGNAL: | |
| 1440 case GTK_TYPE_ARGS: /* This we can do as a list of values */ | |
| 2500 | 1441 ABORT(); |
| 462 | 1442 case GTK_TYPE_CALLBACK: |
| 1443 stderr_out ("callback fn: ...\n"); | |
| 1444 break; | |
| 1445 case GTK_TYPE_C_CALLBACK: | |
| 1446 case GTK_TYPE_FOREIGN: | |
| 2500 | 1447 ABORT(); |
| 462 | 1448 |
| 1449 /* base type of the object system */ | |
| 1450 case GTK_TYPE_OBJECT: | |
| 1451 if (GTK_VALUE_OBJECT (a)) | |
| 1452 stderr_out ("object: %s\n", gtk_type_name (GTK_OBJECT_TYPE (GTK_VALUE_OBJECT (a)))); | |
| 1453 else | |
| 1454 stderr_out ("object: NULL\n"); | |
| 1455 break; | |
| 1456 | |
| 1457 default: | |
| 2500 | 1458 ABORT(); |
| 462 | 1459 } |
| 1460 } | |
| 778 | 1461 #endif |
| 462 | 1462 |
| 1463 Lisp_Object gtk_type_to_lisp (GtkArg *arg) | |
| 1464 { | |
| 1465 switch (GTK_FUNDAMENTAL_TYPE (arg->type)) | |
| 1466 { | |
| 1467 case GTK_TYPE_NONE: | |
| 1468 return (Qnil); | |
| 1469 case GTK_TYPE_CHAR: | |
| 1470 return (make_char (GTK_VALUE_CHAR (*arg))); | |
| 1471 case GTK_TYPE_UCHAR: | |
| 1472 return (make_char (GTK_VALUE_UCHAR (*arg))); | |
| 1473 case GTK_TYPE_BOOL: | |
| 1474 return (GTK_VALUE_BOOL (*arg) ? Qt : Qnil); | |
| 1475 case GTK_TYPE_INT: | |
| 1476 return (make_int (GTK_VALUE_INT (*arg))); | |
| 1477 case GTK_TYPE_UINT: | |
| 1478 return (make_int (GTK_VALUE_INT (*arg))); | |
| 1479 case GTK_TYPE_LONG: /* I think these are wrong! */ | |
| 1480 return (make_int (GTK_VALUE_INT (*arg))); | |
| 1481 case GTK_TYPE_ULONG: /* I think these are wrong! */ | |
| 1482 return (make_int (GTK_VALUE_INT (*arg))); | |
| 1483 case GTK_TYPE_FLOAT: | |
| 1484 return (make_float (GTK_VALUE_FLOAT (*arg))); | |
| 1485 case GTK_TYPE_DOUBLE: | |
| 1486 return (make_float (GTK_VALUE_DOUBLE (*arg))); | |
| 1487 case GTK_TYPE_STRING: | |
|
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
1488 return (build_cistring (GTK_VALUE_STRING (*arg))); |
| 462 | 1489 case GTK_TYPE_FLAGS: |
| 1490 return (flags_to_list (GTK_VALUE_FLAGS (*arg), arg->type)); | |
| 1491 case GTK_TYPE_ENUM: | |
| 1492 return (enum_to_symbol (GTK_VALUE_ENUM (*arg), arg->type)); | |
| 1493 case GTK_TYPE_BOXED: | |
| 1494 if (arg->type == GTK_TYPE_GDK_EVENT) | |
| 1495 { | |
| 1496 return (gdk_event_to_emacs_event((GdkEvent *) GTK_VALUE_BOXED (*arg))); | |
| 1497 } | |
| 1498 | |
| 1499 if (GTK_VALUE_BOXED (*arg)) | |
| 1500 return (build_gtk_boxed (GTK_VALUE_BOXED (*arg), arg->type)); | |
| 1501 else | |
| 1502 return (Qnil); | |
| 1503 case GTK_TYPE_POINTER: | |
| 1504 if (GTK_VALUE_POINTER (*arg)) | |
| 1505 { | |
| 1506 Lisp_Object rval; | |
| 1507 | |
| 5013 | 1508 rval = GET_LISP_FROM_VOID (GTK_VALUE_POINTER (*arg)); |
| 462 | 1509 return (rval); |
| 1510 } | |
| 1511 else | |
| 1512 return (Qnil); | |
| 1513 case GTK_TYPE_OBJECT: | |
| 1514 if (GTK_VALUE_OBJECT (*arg)) | |
| 1515 return (build_gtk_object (GTK_VALUE_OBJECT (*arg))); | |
| 1516 else | |
| 1517 return (Qnil); | |
| 1518 | |
| 1519 case GTK_TYPE_CALLBACK: | |
| 1520 { | |
| 1521 Lisp_Object rval; | |
| 1522 | |
| 5013 | 1523 rval = GET_LISP_FROM_VOID (GTK_VALUE_CALLBACK (*arg).data); |
| 462 | 1524 |
| 1525 return (rval); | |
| 1526 } | |
| 1527 | |
| 1528 default: | |
| 2054 | 1529 if (IS_XEMACS_GTK_FUNDAMENTAL_TYPE(arg->type, GTK_TYPE_LISTOF)) |
| 462 | 1530 { |
| 1531 if (!GTK_VALUE_POINTER (*arg)) | |
| 1532 return (Qnil); | |
| 1533 else | |
| 1534 { | |
| 1535 return (xemacs_gtklist_to_list (arg)); | |
| 1536 } | |
| 1537 } | |
| 1538 stderr_out ("Do not know how to convert `%s' to lisp!\n", gtk_type_name (arg->type)); | |
| 2500 | 1539 ABORT (); |
| 462 | 1540 } |
| 1541 /* This is chuck reminding GCC to... SHUT UP! */ | |
| 1542 return (Qnil); | |
| 1543 } | |
| 1544 | |
| 1545 int lisp_to_gtk_type (Lisp_Object obj, GtkArg *arg) | |
| 1546 { | |
| 1547 switch (GTK_FUNDAMENTAL_TYPE (arg->type)) | |
| 1548 { | |
| 1549 /* flag types */ | |
| 1550 case GTK_TYPE_NONE: | |
| 1551 return (0); | |
| 1552 case GTK_TYPE_CHAR: | |
| 1553 { | |
| 867 | 1554 Ichar c; |
| 462 | 1555 |
| 1556 CHECK_CHAR_COERCE_INT (obj); | |
| 1557 c = XCHAR (obj); | |
| 1558 GTK_VALUE_CHAR (*arg) = c; | |
| 1559 } | |
| 1560 break; | |
| 1561 case GTK_TYPE_UCHAR: | |
| 1562 { | |
| 867 | 1563 Ichar c; |
| 462 | 1564 |
| 1565 CHECK_CHAR_COERCE_INT (obj); | |
| 1566 c = XCHAR (obj); | |
| 1567 GTK_VALUE_CHAR (*arg) = c; | |
| 1568 } | |
| 1569 break; | |
| 1570 case GTK_TYPE_BOOL: | |
| 1571 GTK_VALUE_BOOL (*arg) = NILP (obj) ? FALSE : TRUE; | |
| 1572 break; | |
| 1573 case GTK_TYPE_INT: | |
| 1574 case GTK_TYPE_UINT: | |
| 1575 if (NILP (obj) || EQ (Qt, obj)) | |
| 1576 { | |
| 1577 /* For we are a kind mistress and allow sending t/nil for | |
| 1578 1/0 to stupid GTK functions that say they take guint or | |
| 1579 gint in the header files, but actually treat it like a | |
| 1580 bool. *sigh* | |
| 1581 */ | |
| 1582 GTK_VALUE_INT(*arg) = NILP (obj) ? 0 : 1; | |
| 1583 } | |
| 1584 else | |
| 1585 { | |
| 1586 CHECK_INT (obj); | |
| 1587 GTK_VALUE_INT(*arg) = XINT (obj); | |
| 1588 } | |
| 1589 break; | |
| 1590 case GTK_TYPE_LONG: | |
| 1591 case GTK_TYPE_ULONG: | |
| 2500 | 1592 ABORT(); |
| 462 | 1593 case GTK_TYPE_FLOAT: |
| 1594 CHECK_INT_OR_FLOAT (obj); | |
| 1595 GTK_VALUE_FLOAT(*arg) = extract_float (obj); | |
| 1596 break; | |
| 1597 case GTK_TYPE_DOUBLE: | |
| 1598 CHECK_INT_OR_FLOAT (obj); | |
| 1599 GTK_VALUE_DOUBLE(*arg) = extract_float (obj); | |
| 1600 break; | |
| 1601 case GTK_TYPE_STRING: | |
| 1602 if (NILP (obj)) | |
| 1603 GTK_VALUE_STRING (*arg) = NULL; | |
| 1604 else | |
| 1605 { | |
| 1606 CHECK_STRING (obj); | |
| 1607 GTK_VALUE_STRING (*arg) = (char *) XSTRING_DATA (obj); | |
| 1608 } | |
| 1609 break; | |
| 1610 case GTK_TYPE_ENUM: | |
| 1611 case GTK_TYPE_FLAGS: | |
| 1612 /* Convert a lisp symbol to a GTK enum */ | |
| 1613 GTK_VALUE_ENUM(*arg) = lisp_to_flag (obj, arg->type); | |
| 1614 break; | |
| 1615 case GTK_TYPE_BOXED: | |
| 1616 if (NILP (obj)) | |
| 1617 { | |
| 1618 GTK_VALUE_BOXED(*arg) = NULL; | |
| 1619 } | |
| 1620 else if (GTK_BOXEDP (obj)) | |
| 1621 { | |
| 1622 GTK_VALUE_BOXED(*arg) = XGTK_BOXED (obj)->object; | |
| 1623 } | |
| 1624 else if (arg->type == GTK_TYPE_STYLE) | |
| 1625 { | |
| 1626 obj = Ffind_face (obj); | |
| 1627 CHECK_FACE (obj); | |
| 1628 GTK_VALUE_BOXED(*arg) = face_to_style (obj); | |
| 1629 } | |
| 1630 else if (arg->type == GTK_TYPE_GDK_GC) | |
| 1631 { | |
| 1632 obj = Ffind_face (obj); | |
| 1633 CHECK_FACE (obj); | |
| 1634 GTK_VALUE_BOXED(*arg) = face_to_gc (obj); | |
| 1635 } | |
| 1636 else if (arg->type == GTK_TYPE_GDK_WINDOW) | |
| 1637 { | |
| 1638 if (GLYPHP (obj)) | |
| 1639 { | |
| 1640 Lisp_Object window = Fselected_window (Qnil); | |
| 793 | 1641 Lisp_Object instance = |
| 1642 glyph_image_instance (obj, window, ERROR_ME_DEBUG_WARN, 1); | |
| 462 | 1643 struct Lisp_Image_Instance *p = XIMAGE_INSTANCE (instance); |
| 1644 | |
| 1645 switch (XIMAGE_INSTANCE_TYPE (instance)) | |
| 1646 { | |
| 1647 case IMAGE_TEXT: | |
| 1648 case IMAGE_POINTER: | |
| 1649 case IMAGE_SUBWINDOW: | |
| 1650 case IMAGE_NOTHING: | |
| 1651 GTK_VALUE_BOXED(*arg) = NULL; | |
| 1652 break; | |
| 1653 | |
| 1654 case IMAGE_MONO_PIXMAP: | |
| 1655 case IMAGE_COLOR_PIXMAP: | |
| 1656 GTK_VALUE_BOXED(*arg) = IMAGE_INSTANCE_GTK_PIXMAP (p); | |
| 1657 break; | |
| 1658 } | |
| 1659 } | |
| 1660 else if (GTK_OBJECTP (obj) && GTK_IS_WIDGET (XGTK_OBJECT (obj)->object)) | |
| 1661 { | |
| 1662 GTK_VALUE_BOXED(*arg) = GTK_WIDGET (XGTK_OBJECT (obj))->window; | |
| 1663 } | |
| 1664 else | |
| 1665 { | |
| 563 | 1666 invalid_argument ("Don't know how to convert object to GDK_WINDOW", obj); |
| 462 | 1667 } |
| 1668 break; | |
| 1669 } | |
| 1670 else if (arg->type == GTK_TYPE_GDK_COLOR) | |
| 1671 { | |
| 1672 if (COLOR_SPECIFIERP (obj)) | |
| 1673 { | |
| 1674 /* If it is a specifier, we just convert it to an | |
| 1675 instance, and let the ifs below handle it. | |
| 1676 */ | |
| 1677 obj = Fspecifier_instance (obj, Qnil, Qnil, Qnil); | |
| 1678 } | |
| 1679 | |
| 1680 if (COLOR_INSTANCEP (obj)) | |
| 1681 { | |
| 1682 /* Easiest one */ | |
| 1683 GTK_VALUE_BOXED(*arg) = COLOR_INSTANCE_GTK_COLOR (XCOLOR_INSTANCE (obj)); | |
| 1684 } | |
| 1685 else if (STRINGP (obj)) | |
| 1686 { | |
| 563 | 1687 invalid_argument ("Please use a color specifier or instance, not a string", obj); |
| 462 | 1688 } |
| 1689 else | |
| 1690 { | |
| 563 | 1691 invalid_argument ("Don't know how to convert to GdkColor", obj); |
| 462 | 1692 } |
| 1693 } | |
| 1694 else if (arg->type == GTK_TYPE_GDK_FONT) | |
| 1695 { | |
| 1696 if (SYMBOLP (obj)) | |
| 1697 { | |
| 1698 /* If it is a symbol, we treat that as a face name */ | |
| 1699 obj = Ffind_face (obj); | |
| 1700 } | |
| 1701 | |
| 1702 if (FACEP (obj)) | |
| 1703 { | |
| 1704 /* If it is a face, we just grab the font specifier, and | |
| 1705 cascade down until we finally reach a FONT_INSTANCE | |
| 1706 */ | |
| 1707 obj = Fget (obj, Qfont, Qnil); | |
| 1708 } | |
| 1709 | |
| 1710 if (FONT_SPECIFIERP (obj)) | |
| 1711 { | |
| 1712 /* If it is a specifier, we just convert it to an | |
| 1713 instance, and let the ifs below handle it | |
| 1714 */ | |
| 1715 obj = Fspecifier_instance (obj, Qnil, Qnil, Qnil); | |
| 1716 } | |
| 1717 | |
| 1718 if (FONT_INSTANCEP (obj)) | |
| 1719 { | |
| 1720 /* Easiest one */ | |
| 1721 GTK_VALUE_BOXED(*arg) = FONT_INSTANCE_GTK_FONT (XFONT_INSTANCE (obj)); | |
| 1722 } | |
| 1723 else if (STRINGP (obj)) | |
| 1724 { | |
| 563 | 1725 invalid_argument ("Please use a font specifier or instance, not a string", obj); |
| 462 | 1726 } |
| 1727 else | |
| 1728 { | |
| 563 | 1729 invalid_argument ("Don't know how to convert to GdkColor", obj); |
| 462 | 1730 } |
| 1731 } | |
| 1732 else | |
| 1733 { | |
| 1734 /* Unknown type to convert to boxed */ | |
| 1735 stderr_out ("Don't know how to convert to boxed!\n"); | |
| 1736 GTK_VALUE_BOXED(*arg) = NULL; | |
| 1737 } | |
| 1738 break; | |
| 1739 | |
| 1740 case GTK_TYPE_POINTER: | |
| 1741 if (NILP (obj)) | |
| 1742 GTK_VALUE_POINTER(*arg) = NULL; | |
| 1743 else | |
| 5013 | 1744 GTK_VALUE_POINTER(*arg) = STORE_LISP_IN_VOID (obj); |
| 462 | 1745 break; |
| 1746 | |
| 1747 /* structured types */ | |
| 1748 case GTK_TYPE_SIGNAL: | |
| 1749 case GTK_TYPE_ARGS: /* This we can do as a list of values */ | |
| 1750 case GTK_TYPE_C_CALLBACK: | |
| 1751 case GTK_TYPE_FOREIGN: | |
| 1752 stderr_out ("Do not know how to convert `%s' from lisp!\n", gtk_type_name (arg->type)); | |
| 1753 return (-1); | |
| 1754 | |
| 1755 #if 0 | |
| 1756 /* #### BILL! */ | |
| 1757 /* This is not used, and does not work with union type */ | |
| 1758 case GTK_TYPE_CALLBACK: | |
| 1759 { | |
| 1760 GUI_ID id; | |
| 1761 | |
| 1762 id = new_gui_id (); | |
| 1763 obj = Fcons (Qnil, obj); /* Empty data */ | |
| 1764 obj = Fcons (make_int (id), obj); | |
| 1765 | |
| 1766 gcpro_popup_callbacks (id, obj); | |
| 1767 | |
| 1768 GTK_VALUE_CALLBACK(*arg).marshal = __internal_callback_marshal; | |
| 1769 GTK_VALUE_CALLBACK(*arg).data = (gpointer) obj; | |
| 1770 GTK_VALUE_CALLBACK(*arg).notify = __internal_callback_destroy; | |
| 1771 } | |
| 1772 break; | |
| 1773 #endif | |
| 1774 | |
| 1775 /* base type of the object system */ | |
| 1776 case GTK_TYPE_OBJECT: | |
| 1777 if (NILP (obj)) | |
| 1778 GTK_VALUE_OBJECT (*arg) = NULL; | |
| 1779 else | |
| 1780 { | |
| 1781 CHECK_GTK_OBJECT (obj); | |
| 1782 if (XGTK_OBJECT (obj)->alive_p) | |
| 1783 GTK_VALUE_OBJECT (*arg) = XGTK_OBJECT (obj)->object; | |
| 1784 else | |
| 563 | 1785 invalid_argument ("Attempting to pass dead object to GTK function", obj); |
| 462 | 1786 } |
| 1787 break; | |
| 1788 | |
| 1789 default: | |
| 2054 | 1790 if (IS_XEMACS_GTK_FUNDAMENTAL_TYPE(arg->type, GTK_TYPE_ARRAY)) |
| 462 | 1791 { |
| 1792 if (NILP (obj)) | |
| 1793 GTK_VALUE_POINTER(*arg) = NULL; | |
| 1794 else | |
| 1795 { | |
| 1796 xemacs_list_to_array (obj, arg); | |
| 1797 } | |
| 1798 } | |
| 2054 | 1799 else if (IS_XEMACS_GTK_FUNDAMENTAL_TYPE(arg->type, GTK_TYPE_LISTOF)) |
| 462 | 1800 { |
| 1801 if (NILP (obj)) | |
| 1802 GTK_VALUE_POINTER(*arg) = NULL; | |
| 1803 else | |
| 1804 { | |
| 1805 xemacs_list_to_gtklist (obj, arg); | |
| 1806 } | |
| 1807 } | |
| 1808 else | |
| 1809 { | |
| 1810 stderr_out ("Do not know how to convert `%s' from lisp!\n", gtk_type_name (arg->type)); | |
| 2500 | 1811 ABORT(); |
| 462 | 1812 } |
| 1813 break; | |
| 1814 } | |
| 1815 | |
| 1816 return (0); | |
| 1817 } | |
| 1818 | |
| 1883 | 1819 /* Convert lisp types to GTK return types. This is identical to |
| 1820 lisp_to_gtk_type() except that the macro used to set the value is | |
| 1821 different. | |
| 1822 | |
| 1823 ### There should be some way of combining these two functions. | |
| 1824 */ | |
| 1825 int lisp_to_gtk_ret_type (Lisp_Object obj, GtkArg *arg) | |
| 1826 { | |
| 1827 switch (GTK_FUNDAMENTAL_TYPE (arg->type)) | |
| 1828 { | |
| 1829 /* flag types */ | |
| 1830 case GTK_TYPE_NONE: | |
| 1831 return (0); | |
| 1832 case GTK_TYPE_CHAR: | |
| 1833 { | |
| 1834 Ichar c; | |
| 1835 | |
| 1836 CHECK_CHAR_COERCE_INT (obj); | |
| 1837 c = XCHAR (obj); | |
| 1838 *(GTK_RETLOC_CHAR (*arg)) = c; | |
| 1839 } | |
| 1840 break; | |
| 1841 case GTK_TYPE_UCHAR: | |
| 1842 { | |
| 1843 Ichar c; | |
| 1844 | |
| 1845 CHECK_CHAR_COERCE_INT (obj); | |
| 1846 c = XCHAR (obj); | |
| 1847 *(GTK_RETLOC_CHAR (*arg)) = c; | |
| 1848 } | |
| 1849 break; | |
| 1850 case GTK_TYPE_BOOL: | |
| 1851 *(GTK_RETLOC_BOOL (*arg)) = NILP (obj) ? FALSE : TRUE; | |
| 1852 break; | |
| 1853 case GTK_TYPE_INT: | |
| 1854 case GTK_TYPE_UINT: | |
| 1855 if (NILP (obj) || EQ (Qt, obj)) | |
| 1856 { | |
| 1857 /* For we are a kind mistress and allow sending t/nil for | |
| 1858 1/0 to stupid GTK functions that say they take guint or | |
| 1859 gint in the header files, but actually treat it like a | |
| 1860 bool. *sigh* | |
| 1861 */ | |
| 1862 *(GTK_RETLOC_INT(*arg)) = NILP (obj) ? 0 : 1; | |
| 1863 } | |
| 1864 else | |
| 1865 { | |
| 1866 CHECK_INT (obj); | |
| 1867 *(GTK_RETLOC_INT(*arg)) = XINT (obj); | |
| 1868 } | |
| 1869 break; | |
| 1870 case GTK_TYPE_LONG: | |
| 1871 case GTK_TYPE_ULONG: | |
| 2500 | 1872 ABORT(); |
| 1883 | 1873 case GTK_TYPE_FLOAT: |
| 1874 CHECK_INT_OR_FLOAT (obj); | |
| 1875 *(GTK_RETLOC_FLOAT(*arg)) = extract_float (obj); | |
| 1876 break; | |
| 1877 case GTK_TYPE_DOUBLE: | |
| 1878 CHECK_INT_OR_FLOAT (obj); | |
| 1879 *(GTK_RETLOC_DOUBLE(*arg)) = extract_float (obj); | |
| 1880 break; | |
| 1881 case GTK_TYPE_STRING: | |
| 1882 if (NILP (obj)) | |
| 1883 *(GTK_RETLOC_STRING (*arg)) = NULL; | |
| 1884 else | |
| 1885 { | |
| 1886 CHECK_STRING (obj); | |
| 1887 *(GTK_RETLOC_STRING (*arg)) = (char *) XSTRING_DATA (obj); | |
| 1888 } | |
| 1889 break; | |
| 1890 case GTK_TYPE_ENUM: | |
| 1891 case GTK_TYPE_FLAGS: | |
| 1892 /* Convert a lisp symbol to a GTK enum */ | |
| 1893 *(GTK_RETLOC_ENUM(*arg)) = lisp_to_flag (obj, arg->type); | |
| 1894 break; | |
| 1895 case GTK_TYPE_BOXED: | |
| 1896 if (NILP (obj)) | |
| 1897 { | |
| 1898 *(GTK_RETLOC_BOXED(*arg)) = NULL; | |
| 1899 } | |
| 1900 else if (GTK_BOXEDP (obj)) | |
| 1901 { | |
| 1902 *(GTK_RETLOC_BOXED(*arg)) = XGTK_BOXED (obj)->object; | |
| 1903 } | |
| 1904 else if (arg->type == GTK_TYPE_STYLE) | |
| 1905 { | |
| 1906 obj = Ffind_face (obj); | |
| 1907 CHECK_FACE (obj); | |
| 1908 *(GTK_RETLOC_BOXED(*arg)) = face_to_style (obj); | |
| 1909 } | |
| 1910 else if (arg->type == GTK_TYPE_GDK_GC) | |
| 1911 { | |
| 1912 obj = Ffind_face (obj); | |
| 1913 CHECK_FACE (obj); | |
| 1914 *(GTK_RETLOC_BOXED(*arg)) = face_to_gc (obj); | |
| 1915 } | |
| 1916 else if (arg->type == GTK_TYPE_GDK_WINDOW) | |
| 1917 { | |
| 1918 if (GLYPHP (obj)) | |
| 1919 { | |
| 1920 Lisp_Object window = Fselected_window (Qnil); | |
| 1921 Lisp_Object instance = | |
| 1922 glyph_image_instance (obj, window, ERROR_ME_DEBUG_WARN, 1); | |
| 1923 struct Lisp_Image_Instance *p = XIMAGE_INSTANCE (instance); | |
| 1924 | |
| 1925 switch (XIMAGE_INSTANCE_TYPE (instance)) | |
| 1926 { | |
| 1927 case IMAGE_TEXT: | |
| 1928 case IMAGE_POINTER: | |
| 1929 case IMAGE_SUBWINDOW: | |
| 1930 case IMAGE_NOTHING: | |
| 1931 *(GTK_RETLOC_BOXED(*arg)) = NULL; | |
| 1932 break; | |
| 1933 | |
| 1934 case IMAGE_MONO_PIXMAP: | |
| 1935 case IMAGE_COLOR_PIXMAP: | |
| 1936 *(GTK_RETLOC_BOXED(*arg)) = IMAGE_INSTANCE_GTK_PIXMAP (p); | |
| 1937 break; | |
| 1938 } | |
| 1939 } | |
| 1940 else if (GTK_OBJECTP (obj) && GTK_IS_WIDGET (XGTK_OBJECT (obj)->object)) | |
| 1941 { | |
| 1942 *(GTK_RETLOC_BOXED(*arg)) = GTK_WIDGET (XGTK_OBJECT (obj))->window; | |
| 1943 } | |
| 1944 else | |
| 1945 { | |
| 1946 invalid_argument ("Don't know how to convert object to GDK_WINDOW", obj); | |
| 1947 } | |
| 1948 break; | |
| 1949 } | |
| 1950 else if (arg->type == GTK_TYPE_GDK_COLOR) | |
| 1951 { | |
| 1952 if (COLOR_SPECIFIERP (obj)) | |
| 1953 { | |
| 1954 /* If it is a specifier, we just convert it to an | |
| 1955 instance, and let the ifs below handle it. | |
| 1956 */ | |
| 1957 obj = Fspecifier_instance (obj, Qnil, Qnil, Qnil); | |
| 1958 } | |
| 1959 | |
| 1960 if (COLOR_INSTANCEP (obj)) | |
| 1961 { | |
| 1962 /* Easiest one */ | |
| 1963 *(GTK_RETLOC_BOXED(*arg)) = COLOR_INSTANCE_GTK_COLOR (XCOLOR_INSTANCE (obj)); | |
| 1964 } | |
| 1965 else if (STRINGP (obj)) | |
| 1966 { | |
| 1967 invalid_argument ("Please use a color specifier or instance, not a string", obj); | |
| 1968 } | |
| 1969 else | |
| 1970 { | |
| 1971 invalid_argument ("Don't know how to convert to GdkColor", obj); | |
| 1972 } | |
| 1973 } | |
| 1974 else if (arg->type == GTK_TYPE_GDK_FONT) | |
| 1975 { | |
| 1976 if (SYMBOLP (obj)) | |
| 1977 { | |
| 1978 /* If it is a symbol, we treat that as a face name */ | |
| 1979 obj = Ffind_face (obj); | |
| 1980 } | |
| 1981 | |
| 1982 if (FACEP (obj)) | |
| 1983 { | |
| 1984 /* If it is a face, we just grab the font specifier, and | |
| 1985 cascade down until we finally reach a FONT_INSTANCE | |
| 1986 */ | |
| 1987 obj = Fget (obj, Qfont, Qnil); | |
| 1988 } | |
| 1989 | |
| 1990 if (FONT_SPECIFIERP (obj)) | |
| 1991 { | |
| 1992 /* If it is a specifier, we just convert it to an | |
| 1993 instance, and let the ifs below handle it | |
| 1994 */ | |
| 1995 obj = Fspecifier_instance (obj, Qnil, Qnil, Qnil); | |
| 1996 } | |
| 1997 | |
| 1998 if (FONT_INSTANCEP (obj)) | |
| 1999 { | |
| 2000 /* Easiest one */ | |
| 2001 *(GTK_RETLOC_BOXED(*arg)) = FONT_INSTANCE_GTK_FONT (XFONT_INSTANCE (obj)); | |
| 2002 } | |
| 2003 else if (STRINGP (obj)) | |
| 2004 { | |
| 2005 invalid_argument ("Please use a font specifier or instance, not a string", obj); | |
| 2006 } | |
| 2007 else | |
| 2008 { | |
| 2009 invalid_argument ("Don't know how to convert to GdkColor", obj); | |
| 2010 } | |
| 2011 } | |
| 2012 else | |
| 2013 { | |
| 2014 /* Unknown type to convert to boxed */ | |
| 2015 stderr_out ("Don't know how to convert to boxed!\n"); | |
| 2016 *(GTK_RETLOC_BOXED(*arg)) = NULL; | |
| 2017 } | |
| 2018 break; | |
| 2019 | |
| 2020 case GTK_TYPE_POINTER: | |
| 2021 if (NILP (obj)) | |
| 2022 *(GTK_RETLOC_POINTER(*arg)) = NULL; | |
| 2023 else | |
| 5013 | 2024 *(GTK_RETLOC_POINTER(*arg)) = STORE_LISP_IN_VOID (obj); |
| 1883 | 2025 break; |
| 2026 | |
| 2027 /* structured types */ | |
| 2028 case GTK_TYPE_SIGNAL: | |
| 2029 case GTK_TYPE_ARGS: /* This we can do as a list of values */ | |
| 2030 case GTK_TYPE_C_CALLBACK: | |
| 2031 case GTK_TYPE_FOREIGN: | |
| 2032 stderr_out ("Do not know how to convert `%s' from lisp!\n", gtk_type_name (arg->type)); | |
| 2033 return (-1); | |
| 2034 | |
| 2035 #if 0 | |
| 2036 /* #### BILL! */ | |
| 2037 /* This is not used, and does not work with union type */ | |
| 2038 case GTK_TYPE_CALLBACK: | |
| 2039 { | |
| 2040 GUI_ID id; | |
| 2041 | |
| 2042 id = new_gui_id (); | |
| 2043 obj = Fcons (Qnil, obj); /* Empty data */ | |
| 2044 obj = Fcons (make_int (id), obj); | |
| 2045 | |
| 2046 gcpro_popup_callbacks (id, obj); | |
| 2047 | |
| 2048 *(GTK_RETLOC_CALLBACK(*arg)).marshal = __internal_callback_marshal; | |
| 2049 *(GTK_RETLOC_CALLBACK(*arg)).data = (gpointer) obj; | |
| 2050 *(GTK_RETLOC_CALLBACK(*arg)).notify = __internal_callback_destroy; | |
| 2051 } | |
| 2052 break; | |
| 2053 #endif | |
| 2054 | |
| 2055 /* base type of the object system */ | |
| 2056 case GTK_TYPE_OBJECT: | |
| 2057 if (NILP (obj)) | |
| 2058 *(GTK_RETLOC_OBJECT (*arg)) = NULL; | |
| 2059 else | |
| 2060 { | |
| 2061 CHECK_GTK_OBJECT (obj); | |
| 2062 if (XGTK_OBJECT (obj)->alive_p) | |
| 2063 *(GTK_RETLOC_OBJECT (*arg)) = XGTK_OBJECT (obj)->object; | |
| 2064 else | |
| 2065 invalid_argument ("Attempting to pass dead object to GTK function", obj); | |
| 2066 } | |
| 2067 break; | |
| 2068 | |
| 2069 default: | |
| 2054 | 2070 if (IS_XEMACS_GTK_FUNDAMENTAL_TYPE(arg->type, GTK_TYPE_ARRAY)) |
| 1883 | 2071 { |
| 2072 if (NILP (obj)) | |
| 2073 *(GTK_RETLOC_POINTER(*arg)) = NULL; | |
| 2074 else | |
| 2075 { | |
| 2076 xemacs_list_to_array (obj, arg); | |
| 2077 } | |
| 2078 } | |
| 2054 | 2079 else if (IS_XEMACS_GTK_FUNDAMENTAL_TYPE(arg->type, GTK_TYPE_LISTOF)) |
| 1883 | 2080 { |
| 2081 if (NILP (obj)) | |
| 2082 *(GTK_RETLOC_POINTER(*arg)) = NULL; | |
| 2083 else | |
| 2084 { | |
| 2085 xemacs_list_to_gtklist (obj, arg); | |
| 2086 } | |
| 2087 } | |
| 2088 else | |
| 2089 { | |
| 2090 stderr_out ("Do not know how to convert `%s' from lisp!\n", gtk_type_name (arg->type)); | |
| 2500 | 2091 ABORT(); |
| 1883 | 2092 } |
| 2093 break; | |
| 2094 } | |
| 2095 | |
| 2096 return (0); | |
| 2097 } | |
| 2098 | |
| 462 | 2099 /* This is used in glyphs-gtk.c as well */ |
| 2100 static Lisp_Object | |
| 2101 get_enumeration (GtkType t) | |
| 2102 { | |
| 2103 Lisp_Object alist; | |
| 2104 | |
| 2105 if (NILP (Venumeration_info)) | |
| 2106 { | |
| 2107 Venumeration_info = call2 (intern ("make-hashtable"), make_int (100), Qequal); | |
| 2108 } | |
| 2109 | |
| 2110 alist = Fgethash (make_int (t), Venumeration_info, Qnil); | |
| 2111 | |
| 2112 if (NILP (alist)) | |
| 2113 { | |
| 2114 import_gtk_enumeration_internal (t); | |
| 2115 alist = Fgethash (make_int (t), Venumeration_info, Qnil); | |
| 2116 } | |
| 2117 return (alist); | |
| 2118 } | |
| 2119 | |
| 2120 guint | |
| 2121 symbol_to_enum (Lisp_Object obj, GtkType t) | |
| 2122 { | |
| 2123 Lisp_Object alist = get_enumeration (t); | |
| 2124 Lisp_Object value = Qnil; | |
| 2125 | |
| 2126 if (NILP (alist)) | |
| 2127 { | |
|
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
2128 invalid_argument ("Unknown enumeration", build_cistring (gtk_type_name (t))); |
| 462 | 2129 } |
| 2130 | |
| 2131 value = Fassq (obj, alist); | |
| 2132 | |
| 2133 if (NILP (value)) | |
| 2134 { | |
| 563 | 2135 invalid_argument ("Unknown value", obj); |
| 462 | 2136 } |
| 2137 | |
| 2138 CHECK_INT (XCDR (value)); | |
| 2139 | |
| 2140 return (XINT (XCDR (value))); | |
| 2141 } | |
| 2142 | |
| 2143 static guint | |
| 2144 lisp_to_flag (Lisp_Object obj, GtkType t) | |
| 2145 { | |
| 2146 guint val = 0; | |
| 2147 | |
| 2148 if (NILP (obj)) | |
| 2149 { | |
| 2150 /* Do nothing */ | |
| 2151 } | |
| 2152 else if (SYMBOLP (obj)) | |
| 2153 { | |
| 2154 val = symbol_to_enum (obj, t); | |
| 2155 } | |
| 2156 else if (LISTP (obj)) | |
| 2157 { | |
| 2158 while (!NILP (obj)) | |
| 2159 { | |
| 2160 val |= symbol_to_enum (XCAR (obj), t); | |
| 2161 obj = XCDR (obj); | |
| 2162 } | |
| 2163 } | |
| 2164 else | |
| 2165 { | |
| 2500 | 2166 /* ABORT ()? */ |
| 462 | 2167 } |
| 2168 return (val); | |
| 2169 } | |
| 2170 | |
| 2171 static Lisp_Object | |
| 2172 flags_to_list (guint value, GtkType t) | |
| 2173 { | |
| 2174 Lisp_Object rval = Qnil; | |
| 2175 Lisp_Object alist = get_enumeration (t); | |
| 2176 | |
| 2177 while (!NILP (alist)) | |
| 2178 { | |
| 2179 if (value & XINT (XCDR (XCAR (alist)))) | |
| 2180 { | |
| 2181 rval = Fcons (XCAR (XCAR (alist)), rval); | |
| 2182 value &= ~(XINT (XCDR (XCAR (alist)))); | |
| 2183 } | |
| 2184 alist = XCDR (alist); | |
| 2185 } | |
| 2186 return (rval); | |
| 2187 } | |
| 2188 | |
| 2189 static Lisp_Object | |
| 2190 enum_to_symbol (guint value, GtkType t) | |
| 2191 { | |
| 2192 Lisp_Object alist = get_enumeration (t); | |
| 2193 Lisp_Object cell = Qnil; | |
| 2194 | |
| 2195 if (NILP (alist)) | |
| 2196 { | |
|
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
2197 invalid_argument ("Unknown enumeration", build_cistring (gtk_type_name (t))); |
| 462 | 2198 } |
| 2199 | |
| 2200 cell = Frassq (make_int (value), alist); | |
| 2201 | |
| 2202 return (NILP (cell) ? Qnil : XCAR (cell)); | |
| 2203 } |