Mercurial > hg > xemacs-beta
annotate src/gui-x.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 | ae48681c47fa |
| children | 308d34e9f07d |
| rev | line source |
|---|---|
| 428 | 1 /* General GUI code -- X-specific. (menubars, scrollbars, toolbars, dialogs) |
| 2 Copyright (C) 1995 Board of Trustees, University of Illinois. | |
| 1261 | 3 Copyright (C) 1995, 1996, 2000, 2001, 2002, 2003 Ben Wing. |
| 428 | 4 Copyright (C) 1995 Sun Microsystems, Inc. |
| 5 Copyright (C) 1998 Free Software Foundation, Inc. | |
| 6 | |
| 7 This file is part of XEmacs. | |
| 8 | |
| 9 XEmacs is free software; you can redistribute it and/or modify it | |
| 10 under the terms of the GNU General Public License as published by the | |
| 11 Free Software Foundation; either version 2, or (at your option) any | |
| 12 later version. | |
| 13 | |
| 14 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
| 15 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
| 16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
| 17 for more details. | |
| 18 | |
| 19 You should have received a copy of the GNU General Public License | |
| 20 along with XEmacs; see the file COPYING. If not, write to | |
| 21 the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
| 22 Boston, MA 02111-1307, USA. */ | |
| 23 | |
| 24 /* Synched up with: Not in FSF. */ | |
| 25 | |
| 442 | 26 /* This file Mule-ized by Ben Wing, 7-8-00. */ |
| 27 | |
| 428 | 28 #include <config.h> |
| 29 #include "lisp.h" | |
| 30 | |
| 872 | 31 #include "buffer.h" |
| 32 #include "device-impl.h" | |
| 33 #include "events.h" | |
| 34 #include "frame.h" | |
| 35 #include "glyphs.h" | |
| 36 #include "gui.h" | |
| 37 #include "menubar.h" | |
| 38 #include "opaque.h" | |
| 39 #include "redisplay.h" | |
| 40 | |
| 41 #include "console-x-impl.h" | |
| 42 | |
| 428 | 43 #ifdef LWLIB_USES_MOTIF |
| 1315 | 44 #include "xmotif.h" /* for XmVersion */ |
| 428 | 45 #endif |
| 46 | |
| 47 /* we need a unique id for each popup menu, dialog box, and scrollbar */ | |
| 647 | 48 static LWLIB_ID lwlib_id_tick; |
| 428 | 49 |
| 50 LWLIB_ID | |
| 51 new_lwlib_id (void) | |
| 52 { | |
| 1346 | 53 lwlib_id_tick++; |
| 54 if (!lwlib_id_tick) | |
| 55 lwlib_id_tick++; | |
| 56 return lwlib_id_tick; | |
| 428 | 57 } |
| 58 | |
| 59 widget_value * | |
| 60 xmalloc_widget_value (void) | |
| 61 { | |
| 62 widget_value *tmp = malloc_widget_value (); | |
| 63 if (!tmp) memory_full (); | |
| 64 return tmp; | |
| 65 } | |
| 66 | |
| 67 | |
| 1346 | 68 |
| 69 /* This contains an alist of (id . protect-me) for GCPRO'ing the callbacks | |
| 70 of the popup menus and dialog boxes. */ | |
| 71 static Lisp_Object Vpopup_callbacks; | |
| 428 | 72 |
| 1346 | 73 struct widget_value_mapper |
| 74 { | |
| 75 Lisp_Object protect_me; | |
| 1204 | 76 }; |
| 77 | |
| 78 static int | |
| 79 snarf_widget_value_mapper (widget_value *val, void *closure) | |
| 80 { | |
| 1346 | 81 struct widget_value_mapper *z = (struct widget_value_mapper *) closure; |
| 1204 | 82 |
| 83 if (val->call_data) | |
| 5013 | 84 z->protect_me = Fcons (GET_LISP_FROM_VOID (val->call_data), z->protect_me); |
| 1204 | 85 if (val->accel) |
| 5013 | 86 z->protect_me = Fcons (GET_LISP_FROM_VOID (val->accel), z->protect_me); |
| 1204 | 87 |
| 88 return 0; | |
| 89 } | |
| 90 | |
| 1261 | 91 /* Snarf the callbacks and other Lisp data that are hidden in the lwlib |
| 1346 | 92 call-data and accel associated with id ID and return them for |
| 93 proper marking. */ | |
| 1261 | 94 |
| 1346 | 95 static Lisp_Object |
| 96 snarf_widget_values_for_gcpro (LWLIB_ID id) | |
| 1261 | 97 { |
| 1346 | 98 struct widget_value_mapper z; |
| 1261 | 99 |
| 1346 | 100 z.protect_me = Qnil; |
| 101 lw_map_widget_values (id, snarf_widget_value_mapper, &z); | |
| 102 return z.protect_me; | |
| 103 } | |
| 1261 | 104 |
| 1346 | 105 /* Given an lwlib id ID associated with a widget tree, make sure that all |
| 106 Lisp callbacks in the tree are GC-protected. This can be called | |
| 107 multiple times on the same widget tree -- this should be done at | |
| 108 creation time and each time the tree is modified. */ | |
| 1261 | 109 |
| 428 | 110 void |
| 111 gcpro_popup_callbacks (LWLIB_ID id) | |
| 112 { | |
| 113 Lisp_Object lid = make_int (id); | |
| 2552 | 114 Lisp_Object this_callback = assq_no_quit (lid, Vpopup_callbacks); |
| 428 | 115 |
| 2552 | 116 if (!NILP (this_callback)) |
| 1346 | 117 { |
| 2552 | 118 free_list (XCDR (this_callback)); |
| 119 XCDR (this_callback) = snarf_widget_values_for_gcpro (id); | |
| 1346 | 120 } |
| 121 else | |
| 122 Vpopup_callbacks = Fcons (Fcons (lid, snarf_widget_values_for_gcpro (id)), | |
| 123 Vpopup_callbacks); | |
| 124 } | |
| 1204 | 125 |
| 1346 | 126 /* Remove GC-protection from the just-destroyed widget tree associated |
| 127 with lwlib id ID. */ | |
| 428 | 128 |
| 129 void | |
| 130 ungcpro_popup_callbacks (LWLIB_ID id) | |
| 131 { | |
| 132 Lisp_Object lid = make_int (id); | |
| 2552 | 133 Lisp_Object this_callback = assq_no_quit (lid, Vpopup_callbacks); |
| 1346 | 134 |
| 2552 | 135 assert (!NILP (this_callback)); |
| 136 free_list (XCDR (this_callback)); | |
| 137 Vpopup_callbacks = delq_no_quit (this_callback, Vpopup_callbacks); | |
| 428 | 138 } |
| 139 | |
| 140 int | |
| 141 popup_handled_p (LWLIB_ID id) | |
| 142 { | |
| 143 return NILP (assq_no_quit (make_int (id), Vpopup_callbacks)); | |
| 144 } | |
| 145 | |
| 146 /* menu_item_descriptor_to_widget_value() et al. mallocs a | |
| 147 widget_value, but then may signal lisp errors. If an error does | |
| 148 not occur, the opaque ptr we have here has had its pointer set to 0 | |
| 149 to tell us not to do anything. Otherwise we free the widget value. | |
| 150 (This has nothing to do with GC, it's just about not dropping | |
| 151 pointers to malloc'd data when errors happen.) */ | |
| 152 | |
| 153 Lisp_Object | |
| 154 widget_value_unwind (Lisp_Object closure) | |
| 155 { | |
| 156 widget_value *wv = (widget_value *) get_opaque_ptr (closure); | |
| 157 free_opaque_ptr (closure); | |
| 158 if (wv) | |
| 436 | 159 free_widget_value_tree (wv); |
| 428 | 160 return Qnil; |
| 161 } | |
| 162 | |
| 163 #if 0 | |
| 164 static void | |
| 165 print_widget_value (widget_value *wv, int depth) | |
| 166 { | |
| 442 | 167 /* strings in wv are in external format; use printf not stdout_out |
| 168 because the latter takes internal-format strings */ | |
| 169 Extbyte d [200]; | |
| 428 | 170 int i; |
| 171 for (i = 0; i < depth; i++) d[i] = ' '; | |
| 172 d[depth]=0; | |
| 173 /* #### - print type field */ | |
| 174 printf ("%sname: %s\n", d, (wv->name ? wv->name : "(null)")); | |
| 175 if (wv->value) printf ("%svalue: %s\n", d, wv->value); | |
| 176 if (wv->key) printf ("%skey: %s\n", d, wv->key); | |
| 177 printf ("%senabled: %d\n", d, wv->enabled); | |
| 178 if (wv->contents) | |
| 179 { | |
| 180 printf ("\n%scontents: \n", d); | |
| 181 print_widget_value (wv->contents, depth + 5); | |
| 182 } | |
| 183 if (wv->next) | |
| 184 { | |
| 185 printf ("\n"); | |
| 186 print_widget_value (wv->next, depth); | |
| 187 } | |
| 188 } | |
| 189 #endif | |
| 190 | |
| 191 /* This recursively calls free_widget_value() on the tree of widgets. | |
| 192 It must free all data that was malloc'ed for these widget_values. | |
| 193 | |
| 194 It used to be that emacs only allocated new storage for the `key' slot. | |
| 195 All other slots are pointers into the data of Lisp_Strings, and must be | |
| 196 left alone. */ | |
| 197 void | |
| 198 free_popup_widget_value_tree (widget_value *wv) | |
| 199 { | |
| 200 if (! wv) return; | |
|
4976
16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents:
4677
diff
changeset
|
201 if (wv->key) xfree (wv->key); |
|
16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents:
4677
diff
changeset
|
202 if (wv->value) xfree (wv->value); |
|
16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents:
4677
diff
changeset
|
203 if (wv->name) xfree (wv->name); |
| 428 | 204 |
| 1204 | 205 wv->name = wv->value = wv->key = (char *) 0xDEADBEEF; /* -559038737 base 10*/ |
| 428 | 206 |
| 207 if (wv->contents && (wv->contents != (widget_value*)1)) | |
| 208 { | |
| 209 free_popup_widget_value_tree (wv->contents); | |
| 210 wv->contents = (widget_value *) 0xDEADBEEF; | |
| 211 } | |
| 212 if (wv->next) | |
| 213 { | |
| 214 free_popup_widget_value_tree (wv->next); | |
| 215 wv->next = (widget_value *) 0xDEADBEEF; | |
| 216 } | |
| 217 free_widget_value (wv); | |
| 218 } | |
| 219 | |
| 220 /* The following is actually called from somewhere within XtDispatchEvent(), | |
| 2168 | 221 called from XtAppProcessEvent() in event-Xt.c. |
| 222 | |
| 223 Callback function for widgets and menus. | |
| 224 */ | |
| 428 | 225 |
| 226 void | |
| 2286 | 227 popup_selection_callback (Widget widget, LWLIB_ID UNUSED (id), |
| 428 | 228 XtPointer client_data) |
| 229 { | |
| 442 | 230 Lisp_Object data, image_instance, callback, callback_ex; |
| 231 Lisp_Object frame, event; | |
| 232 int update_subwindows_p = 0; | |
| 428 | 233 struct device *d = get_device_from_display (XtDisplay (widget)); |
| 234 struct frame *f = x_any_widget_or_parent_to_frame (d, widget); | |
| 235 | |
| 872 | 236 #ifdef HAVE_MENUBARS |
| 428 | 237 /* set in lwlib to the time stamp associated with the most recent menu |
| 238 operation */ | |
| 239 extern Time x_focus_timestamp_really_sucks_fix_me_better; | |
| 872 | 240 #endif |
| 428 | 241 |
| 242 if (!f) | |
| 243 return; | |
| 244 if (((EMACS_INT) client_data) == 0) | |
| 245 return; | |
| 5013 | 246 data = GET_LISP_FROM_VOID (client_data); |
| 793 | 247 frame = wrap_frame (f); |
| 428 | 248 |
| 249 #if 0 | |
| 250 /* #### What the hell? I can't understand why this call is here, | |
| 251 and doing it is really courting disaster in the new event | |
| 252 model, since popup_selection_callback is called from | |
| 253 within next_event_internal() and Faccept_process_output() | |
| 254 itself calls next_event_internal(). --Ben */ | |
| 255 | |
| 256 /* Flush the X and process input */ | |
| 257 Faccept_process_output (Qnil, Qnil, Qnil); | |
| 258 #endif | |
| 259 | |
| 260 if (((EMACS_INT) client_data) == -1) | |
| 261 { | |
| 442 | 262 event = Fmake_event (Qnil, Qnil); |
| 263 | |
| 934 | 264 XSET_EVENT_TYPE (event, misc_user_event); |
| 265 XSET_EVENT_CHANNEL (event, frame); | |
| 1204 | 266 XSET_EVENT_MISC_USER_FUNCTION (event, Qrun_hooks); |
| 267 XSET_EVENT_MISC_USER_OBJECT (event, Qmenu_no_selection_hook); | |
| 428 | 268 } |
| 269 else | |
| 270 { | |
| 442 | 271 image_instance = XCAR (data); |
| 272 callback = XCAR (XCDR (data)); | |
| 273 callback_ex = XCDR (XCDR (data)); | |
| 274 update_subwindows_p = 1; | |
| 275 /* It is possible for a widget action to cause it to get out of | |
| 276 sync with its instantiator. Thus it is necessary to signal | |
| 277 this possibility. */ | |
| 278 if (IMAGE_INSTANCEP (image_instance)) | |
| 279 XIMAGE_INSTANCE_WIDGET_ACTION_OCCURRED (image_instance) = 1; | |
| 280 | |
| 281 if (!NILP (callback_ex) && !UNBOUNDP (callback_ex)) | |
| 282 { | |
| 283 event = Fmake_event (Qnil, Qnil); | |
| 284 | |
| 934 | 285 XSET_EVENT_TYPE (event, misc_user_event); |
| 286 XSET_EVENT_CHANNEL (event, frame); | |
| 1204 | 287 XSET_EVENT_MISC_USER_FUNCTION (event, Qeval); |
| 288 XSET_EVENT_MISC_USER_OBJECT (event, list4 (Qfuncall, callback_ex, image_instance, event)); | |
| 442 | 289 } |
| 290 else if (NILP (callback) || UNBOUNDP (callback)) | |
| 291 event = Qnil; | |
| 292 else | |
| 293 { | |
| 294 Lisp_Object fn, arg; | |
| 295 | |
| 296 event = Fmake_event (Qnil, Qnil); | |
| 297 | |
| 298 get_gui_callback (callback, &fn, &arg); | |
| 934 | 299 XSET_EVENT_TYPE (event, misc_user_event); |
| 300 XSET_EVENT_CHANNEL (event, frame); | |
| 1204 | 301 XSET_EVENT_MISC_USER_FUNCTION (event, fn); |
| 302 XSET_EVENT_MISC_USER_OBJECT (event, arg); | |
| 442 | 303 } |
| 428 | 304 } |
| 305 | |
| 306 /* This is the timestamp used for asserting focus so we need to get an | |
| 444 | 307 up-to-date value event if no events have been dispatched to emacs |
| 428 | 308 */ |
| 872 | 309 #ifdef HAVE_MENUBARS |
| 428 | 310 DEVICE_X_MOUSE_TIMESTAMP (d) = x_focus_timestamp_really_sucks_fix_me_better; |
| 311 #else | |
| 312 DEVICE_X_MOUSE_TIMESTAMP (d) = DEVICE_X_GLOBAL_MOUSE_TIMESTAMP (d); | |
| 313 #endif | |
| 442 | 314 if (!NILP (event)) |
| 1204 | 315 enqueue_dispatch_event (event); |
| 442 | 316 /* The result of this evaluation could cause other instances to change so |
| 317 enqueue an update callback to check this. */ | |
| 318 if (update_subwindows_p && !NILP (event)) | |
| 319 enqueue_magic_eval_event (update_widget_instances, frame); | |
| 428 | 320 } |
| 321 | |
| 322 #if 1 | |
| 323 /* Eval the activep slot of the menu item */ | |
| 1914 | 324 # define wv_set_evalable_slot(slot,form) do { \ |
| 325 Lisp_Object wses_form = (form); \ | |
| 326 (slot) = (NILP (wses_form) ? 0 : \ | |
| 327 EQ (wses_form, Qt) ? 1 : \ | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2552
diff
changeset
|
328 !NILP (in_display ? \ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2552
diff
changeset
|
329 IGNORE_MULTIPLE_VALUES (eval_within_redisplay (wses_form)) \ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2552
diff
changeset
|
330 : IGNORE_MULTIPLE_VALUES (Feval (wses_form)))); \ |
| 428 | 331 } while (0) |
| 332 #else | |
| 333 /* Treat the activep slot of the menu item as a boolean */ | |
| 334 # define wv_set_evalable_slot(slot,form) \ | |
| 335 ((void) (slot = (!NILP (form)))) | |
| 336 #endif | |
| 337 | |
| 442 | 338 Extbyte * |
| 867 | 339 menu_separator_style_and_to_external (const Ibyte *s) |
| 428 | 340 { |
| 867 | 341 const Ibyte *p; |
| 342 Ibyte first; | |
| 428 | 343 |
| 344 if (!s || s[0] == '\0') | |
| 345 return NULL; | |
| 346 first = s[0]; | |
| 347 if (first != '-' && first != '=') | |
| 348 return NULL; | |
| 349 for (p = s; *p == first; p++) | |
| 350 DO_NOTHING; | |
| 351 | |
| 352 /* #### - cannot currently specify a separator tag "--!tag" and a | |
| 353 separator style "--:style" at the same time. */ | |
| 354 /* #### - Also, the motif menubar code doesn't deal with the | |
| 355 double etched style yet, so it's not good to get into the habit of | |
| 356 using "===" in menubars to get double-etched lines */ | |
| 357 if (*p == '!' || *p == '\0') | |
| 358 return ((first == '-') | |
| 359 ? NULL /* single etched is the default */ | |
| 360 : xstrdup ("shadowDoubleEtchedIn")); | |
| 361 else if (*p == ':') | |
| 442 | 362 { |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4677
diff
changeset
|
363 return ITEXT_TO_EXTERNAL_MALLOC (p + 1, Qlwlib_encoding); |
| 442 | 364 } |
| 428 | 365 |
| 366 return NULL; | |
| 367 } | |
| 368 | |
| 442 | 369 Extbyte * |
| 370 add_accel_and_to_external (Lisp_Object string) | |
| 371 { | |
| 372 int i; | |
| 373 int found_accel = 0; | |
| 374 Extbyte *retval; | |
| 867 | 375 Ibyte *name = XSTRING_DATA (string); |
| 442 | 376 |
| 377 for (i = 0; name[i]; ++i) | |
| 378 if (name[i] == '%' && name[i+1] == '_') | |
| 379 { | |
| 380 found_accel = 1; | |
| 381 break; | |
| 382 } | |
| 383 | |
| 384 if (found_accel) | |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4677
diff
changeset
|
385 retval = LISP_STRING_TO_EXTERNAL_MALLOC (string, Qlwlib_encoding); |
| 442 | 386 else |
| 387 { | |
| 647 | 388 Bytecount namelen = XSTRING_LENGTH (string); |
| 2367 | 389 Ibyte *chars = alloca_ibytes (namelen + 3); |
| 442 | 390 chars[0] = '%'; |
| 391 chars[1] = '_'; | |
| 392 memcpy (chars + 2, name, namelen + 1); | |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4677
diff
changeset
|
393 retval = ITEXT_TO_EXTERNAL_MALLOC (chars, Qlwlib_encoding); |
| 442 | 394 } |
| 395 | |
| 396 return retval; | |
| 397 } | |
| 428 | 398 |
| 853 | 399 /* This does the dirty work. GC is inhibited when this is called. |
| 400 */ | |
| 428 | 401 int |
| 442 | 402 button_item_to_widget_value (Lisp_Object gui_object_instance, |
| 403 Lisp_Object gui_item, widget_value *wv, | |
| 404 int allow_text_field_p, int no_keys_p, | |
| 405 int menu_entry_p, int accel_p) | |
| 428 | 406 { |
| 853 | 407 /* This function cannot GC because GC is inhibited when it's called */ |
| 440 | 408 Lisp_Gui_Item* pgui = 0; |
| 428 | 409 |
| 410 /* degenerate case */ | |
| 411 if (STRINGP (gui_item)) | |
| 412 { | |
| 413 wv->type = TEXT_TYPE; | |
| 442 | 414 if (accel_p) |
| 415 wv->name = add_accel_and_to_external (gui_item); | |
| 416 else | |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4677
diff
changeset
|
417 wv->name = LISP_STRING_TO_EXTERNAL_MALLOC (gui_item, Qlwlib_encoding); |
| 428 | 418 return 1; |
| 419 } | |
| 420 else if (!GUI_ITEMP (gui_item)) | |
| 563 | 421 invalid_argument ("need a string or a gui_item here", gui_item); |
| 428 | 422 |
| 423 pgui = XGUI_ITEM (gui_item); | |
| 424 | |
| 425 if (!NILP (pgui->filter)) | |
| 563 | 426 sferror (":filter keyword not permitted on leaf nodes", gui_item); |
| 428 | 427 |
| 428 #ifdef HAVE_MENUBARS | |
| 442 | 429 if (menu_entry_p && !gui_item_included_p (gui_item, Vmenubar_configuration)) |
| 428 | 430 { |
| 431 /* the include specification says to ignore this item. */ | |
| 432 return 0; | |
| 433 } | |
| 434 #endif /* HAVE_MENUBARS */ | |
| 435 | |
| 442 | 436 if (!STRINGP (pgui->name)) |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2552
diff
changeset
|
437 pgui->name = IGNORE_MULTIPLE_VALUES (Feval (pgui->name)); |
| 442 | 438 |
| 428 | 439 CHECK_STRING (pgui->name); |
| 442 | 440 if (accel_p) |
| 441 { | |
| 442 wv->name = add_accel_and_to_external (pgui->name); | |
| 5013 | 443 wv->accel = STORE_LISP_IN_VOID (gui_item_accelerator (gui_item)); |
| 442 | 444 } |
| 445 else | |
| 446 { | |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4677
diff
changeset
|
447 wv->name = LISP_STRING_TO_EXTERNAL_MALLOC (pgui->name, Qlwlib_encoding); |
| 5013 | 448 wv->accel = STORE_LISP_IN_VOID (Qnil); |
| 442 | 449 } |
| 428 | 450 |
| 451 if (!NILP (pgui->suffix)) | |
| 452 { | |
| 453 Lisp_Object suffix2; | |
| 454 | |
| 455 /* Shortcut to avoid evaluating suffix each time */ | |
| 456 if (STRINGP (pgui->suffix)) | |
| 457 suffix2 = pgui->suffix; | |
| 458 else | |
| 459 { | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2552
diff
changeset
|
460 suffix2 = IGNORE_MULTIPLE_VALUES (Feval (pgui->suffix)); |
| 428 | 461 CHECK_STRING (suffix2); |
| 462 } | |
| 463 | |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4677
diff
changeset
|
464 wv->value = LISP_STRING_TO_EXTERNAL_MALLOC (suffix2, Qlwlib_encoding); |
| 428 | 465 } |
| 466 | |
| 467 wv_set_evalable_slot (wv->enabled, pgui->active); | |
| 468 wv_set_evalable_slot (wv->selected, pgui->selected); | |
| 469 | |
| 442 | 470 if (!NILP (pgui->callback) || !NILP (pgui->callback_ex)) |
| 5013 | 471 wv->call_data = STORE_LISP_IN_VOID (cons3 (gui_object_instance, |
| 442 | 472 pgui->callback, |
| 473 pgui->callback_ex)); | |
| 428 | 474 |
| 475 if (no_keys_p | |
| 476 #ifdef HAVE_MENUBARS | |
| 442 | 477 || (menu_entry_p && !menubar_show_keybindings) |
| 428 | 478 #endif |
| 479 ) | |
| 480 wv->key = 0; | |
| 481 else if (!NILP (pgui->keys)) /* Use this string to generate key bindings */ | |
| 482 { | |
| 483 CHECK_STRING (pgui->keys); | |
| 484 pgui->keys = Fsubstitute_command_keys (pgui->keys); | |
| 485 if (XSTRING_LENGTH (pgui->keys) > 0) | |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4677
diff
changeset
|
486 wv->key = LISP_STRING_TO_EXTERNAL_MALLOC (pgui->keys, Qlwlib_encoding); |
| 428 | 487 else |
| 488 wv->key = 0; | |
| 489 } | |
| 490 else if (SYMBOLP (pgui->callback)) /* Show the binding of this command. */ | |
| 491 { | |
| 793 | 492 DECLARE_EISTRING_MALLOC (buf); |
| 428 | 493 /* #### Warning, dependency here on current_buffer and point */ |
| 494 where_is_to_char (pgui->callback, buf); | |
| 793 | 495 if (eilen (buf) > 0) |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4677
diff
changeset
|
496 wv->key = ITEXT_TO_EXTERNAL_MALLOC (eidata (buf), Qlwlib_encoding); |
| 428 | 497 else |
| 498 wv->key = 0; | |
| 793 | 499 eifree (buf); |
| 428 | 500 } |
| 501 | |
| 502 CHECK_SYMBOL (pgui->style); | |
| 503 if (NILP (pgui->style)) | |
| 504 { | |
| 867 | 505 Ibyte *intname; |
| 2286 | 506 Bytecount unused_intlen; |
| 428 | 507 /* If the callback is nil, treat this item like unselectable text. |
| 508 This way, dashes will show up as a separator. */ | |
| 509 if (!wv->enabled) | |
| 510 wv->type = BUTTON_TYPE; | |
| 444 | 511 TO_INTERNAL_FORMAT (C_STRING, wv->name, |
| 2286 | 512 ALLOCA, (intname, unused_intlen), |
| 444 | 513 Qlwlib_encoding); |
| 442 | 514 if (separator_string_p (intname)) |
| 428 | 515 { |
| 516 wv->type = SEPARATOR_TYPE; | |
| 442 | 517 wv->value = menu_separator_style_and_to_external (intname); |
| 428 | 518 } |
| 519 else | |
| 520 { | |
| 521 #if 0 | |
| 522 /* #### - this is generally desirable for menubars, but it breaks | |
| 523 a package that uses dialog boxes and next_command_event magic | |
| 524 to use the callback slot in dialog buttons for data instead of | |
| 525 a real callback. | |
| 526 | |
| 527 Code is data, right? The beauty of LISP abuse. --Stig */ | |
| 528 if (NILP (callback)) | |
| 529 wv->type = TEXT_TYPE; | |
| 530 else | |
| 531 #endif | |
| 532 wv->type = BUTTON_TYPE; | |
| 533 } | |
| 534 } | |
| 535 else if (EQ (pgui->style, Qbutton)) | |
| 536 wv->type = BUTTON_TYPE; | |
| 537 else if (EQ (pgui->style, Qtoggle)) | |
| 538 wv->type = TOGGLE_TYPE; | |
| 539 else if (EQ (pgui->style, Qradio)) | |
| 540 wv->type = RADIO_TYPE; | |
| 541 else if (EQ (pgui->style, Qtext)) | |
| 542 { | |
| 543 wv->type = TEXT_TYPE; | |
| 544 #if 0 | |
| 545 wv->value = wv->name; | |
| 546 wv->name = "value"; | |
| 547 #endif | |
| 548 } | |
| 549 else | |
| 563 | 550 invalid_constant_2 ("Unknown style", pgui->style, gui_item); |
| 428 | 551 |
| 552 if (!allow_text_field_p && (wv->type == TEXT_TYPE)) | |
| 563 | 553 sferror ("Text field not allowed in this context", gui_item); |
| 428 | 554 |
| 555 if (!NILP (pgui->selected) && EQ (pgui->style, Qtext)) | |
| 563 | 556 sferror |
| 442 | 557 (":selected only makes sense with :style toggle, radio or button", |
| 558 gui_item); | |
| 428 | 559 return 1; |
| 560 } | |
| 561 | |
| 562 /* parse tree's of gui items into widget_value hierarchies */ | |
| 442 | 563 static void gui_item_children_to_widget_values (Lisp_Object |
| 564 gui_object_instance, | |
| 565 Lisp_Object items, | |
| 566 widget_value* parent, | |
| 567 int accel_p); | |
| 428 | 568 |
| 569 static widget_value * | |
| 442 | 570 gui_items_to_widget_values_1 (Lisp_Object gui_object_instance, |
| 571 Lisp_Object items, widget_value* parent, | |
| 572 widget_value* prev, int accel_p) | |
| 428 | 573 { |
| 574 widget_value* wv = 0; | |
| 575 | |
| 576 assert ((parent || prev) && !(parent && prev)); | |
| 577 /* now walk the tree creating widget_values as appropriate */ | |
| 578 if (!CONSP (items)) | |
| 579 { | |
| 442 | 580 wv = xmalloc_widget_value (); |
| 428 | 581 if (parent) |
| 582 parent->contents = wv; | |
| 440 | 583 else |
| 428 | 584 prev->next = wv; |
| 442 | 585 if (!button_item_to_widget_value (gui_object_instance, |
| 586 items, wv, 0, 1, 0, accel_p)) | |
| 428 | 587 { |
| 436 | 588 free_widget_value_tree (wv); |
| 428 | 589 if (parent) |
| 590 parent->contents = 0; | |
| 440 | 591 else |
| 428 | 592 prev->next = 0; |
| 593 } | |
| 440 | 594 else |
| 442 | 595 wv->value = xstrdup (wv->name); /* what a mess... */ |
| 428 | 596 } |
| 597 else | |
| 598 { | |
| 599 /* first one is the parent */ | |
| 600 if (CONSP (XCAR (items))) | |
| 563 | 601 sferror ("parent item must not be a list", XCAR (items)); |
| 428 | 602 |
| 603 if (parent) | |
| 442 | 604 wv = gui_items_to_widget_values_1 (gui_object_instance, |
| 605 XCAR (items), parent, 0, accel_p); | |
| 428 | 606 else |
| 442 | 607 wv = gui_items_to_widget_values_1 (gui_object_instance, |
| 608 XCAR (items), 0, prev, accel_p); | |
| 428 | 609 /* the rest are the children */ |
| 442 | 610 gui_item_children_to_widget_values (gui_object_instance, |
| 611 XCDR (items), wv, accel_p); | |
| 428 | 612 } |
| 613 return wv; | |
| 614 } | |
| 615 | |
| 616 static void | |
| 442 | 617 gui_item_children_to_widget_values (Lisp_Object gui_object_instance, |
| 618 Lisp_Object items, widget_value* parent, | |
| 619 int accel_p) | |
| 428 | 620 { |
| 621 widget_value* wv = 0, *prev = 0; | |
| 622 Lisp_Object rest; | |
| 623 CHECK_CONS (items); | |
| 624 | |
| 625 /* first one is master */ | |
| 442 | 626 prev = gui_items_to_widget_values_1 (gui_object_instance, XCAR (items), |
| 627 parent, 0, accel_p); | |
| 428 | 628 /* the rest are the children */ |
| 629 LIST_LOOP (rest, XCDR (items)) | |
| 630 { | |
| 631 Lisp_Object tab = XCAR (rest); | |
| 442 | 632 wv = gui_items_to_widget_values_1 (gui_object_instance, tab, 0, prev, |
| 633 accel_p); | |
| 428 | 634 prev = wv; |
| 635 } | |
| 636 } | |
| 637 | |
| 638 widget_value * | |
| 442 | 639 gui_items_to_widget_values (Lisp_Object gui_object_instance, Lisp_Object items, |
| 640 int accel_p) | |
| 428 | 641 { |
| 642 /* This function can GC */ | |
| 643 widget_value *control = 0, *tmp = 0; | |
| 771 | 644 int count; |
| 428 | 645 Lisp_Object wv_closure; |
| 646 | |
| 647 if (NILP (items)) | |
| 563 | 648 sferror ("must have some items", items); |
| 428 | 649 |
| 650 /* Inhibit GC during this conversion. The reasons for this are | |
| 651 the same as in menu_item_descriptor_to_widget_value(); see | |
| 652 the large comment above that function. */ | |
| 771 | 653 count = begin_gc_forbidden (); |
| 428 | 654 |
| 655 /* Also make sure that we free the partially-created widget_value | |
| 656 tree on Lisp error. */ | |
| 442 | 657 control = xmalloc_widget_value (); |
| 428 | 658 wv_closure = make_opaque_ptr (control); |
| 659 record_unwind_protect (widget_value_unwind, wv_closure); | |
| 660 | |
| 442 | 661 gui_items_to_widget_values_1 (gui_object_instance, items, control, 0, |
| 662 accel_p); | |
| 428 | 663 |
| 664 /* mess about getting the data we really want */ | |
| 665 tmp = control; | |
| 666 control = control->contents; | |
| 667 tmp->next = 0; | |
| 668 tmp->contents = 0; | |
| 436 | 669 free_widget_value_tree (tmp); |
| 428 | 670 |
| 671 /* No more need to free the half-filled-in structures. */ | |
| 672 set_opaque_ptr (wv_closure, 0); | |
| 771 | 673 unbind_to (count); |
| 428 | 674 |
| 675 return control; | |
| 676 } | |
| 677 | |
| 678 void | |
| 679 syms_of_gui_x (void) | |
| 680 { | |
| 681 } | |
| 682 | |
| 683 void | |
| 684 reinit_vars_of_gui_x (void) | |
| 685 { | |
| 686 lwlib_id_tick = (1<<16); /* start big, to not conflict with Energize */ | |
| 687 #ifdef HAVE_POPUPS | |
| 688 popup_up_p = 0; | |
| 689 #endif | |
| 690 } | |
| 691 | |
| 692 void | |
| 693 vars_of_gui_x (void) | |
| 694 { | |
| 695 Vpopup_callbacks = Qnil; | |
| 696 staticpro (&Vpopup_callbacks); | |
| 697 } |