Mercurial > hg > xemacs-beta
annotate src/menubar-msw.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 | 635f4b506855 |
| children | 308d34e9f07d |
| rev | line source |
|---|---|
| 428 | 1 /* Implements an elisp-programmable menubar -- Win32 |
| 2 Copyright (C) 1993, 1994 Free Software Foundation, Inc. | |
| 3 Copyright (C) 1995 Tinker Systems and INS Engineering Corp. | |
| 442 | 4 Copyright (C) 1997 Kirill M. Katsnelson <kkm@kis.ru>. |
| 1333 | 5 Copyright (C) 2000, 2001, 2002, 2003 Ben Wing. |
| 428 | 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 | |
| 771 | 26 /* This function mostly Mule-ized (except perhaps some Unicode splitting). |
| 27 5-2000. */ | |
| 28 | |
| 428 | 29 /* Author: |
| 30 Initially written by kkm 12/24/97, | |
| 31 peeking into and copying stuff from menubar-x.c | |
| 32 */ | |
| 33 | |
| 34 /* Algorithm for handling menus is as follows. When window's menubar | |
| 35 * is created, current-menubar is not traversed in depth. Rather, only | |
| 36 * top level items, both items and pulldowns, are added to the | |
| 37 * menubar. Each pulldown is initially empty. When a pulldown is | |
| 38 * selected and about to open, corresponding element of | |
| 39 * current-menubar is found, and the newly open pulldown is | |
| 40 * populated. This is made again in the same non-recursive manner. | |
| 41 * | |
| 42 * This algorithm uses hash tables to find out element of the menu | |
| 43 * descriptor list given menu handle. The key is an opaque ptr data | |
| 44 * type, keeping menu handle, and the value is a list of strings | |
| 45 * representing the path from the root of the menu to the item | |
| 46 * descriptor. Each frame has an associated hash table. | |
| 47 * | |
| 48 * Leaf items are assigned a unique id based on item's hash. When an | |
| 49 * item is selected, Windows sends back the id. Unfortunately, only | |
| 50 * low 16 bit of the ID are sent, and there's no way to get the 32-bit | |
| 51 * value. Yes, Win32 is just a different set of bugs than X! Aside | |
| 52 * from this blame, another hashing mechanism is required to map menu | |
| 53 * ids to commands (which are actually Lisp_Object's). This mapping is | |
| 54 * performed in the same hash table, as the lifetime of both maps is | |
| 55 * exactly the same. This is unambigous, as menu handles are | |
| 56 * represented by lisp opaques, while command ids are by lisp | |
| 57 * integers. The additional advantage for this is that command forms | |
| 58 * are automatically GC-protected, which is important because these | |
| 59 * may be transient forms generated by :filter functions. | |
| 60 * | |
| 61 * The hash table is not allowed to grow too much; it is pruned | |
| 62 * whenever this is safe to do. This is done by re-creating the menu | |
| 63 * bar, and clearing and refilling the hash table from scratch. | |
| 64 * | |
| 65 * Popup menus are handled identically to pulldowns. A static hash | |
| 66 * table is used for popup menus, and lookup is made not in | |
| 67 * current-menubar but in a lisp form supplied to the `popup' | |
| 68 * function. | |
| 69 * | |
| 70 * Another Windows weirdness is that there's no way to tell that a | |
| 71 * popup has been dismissed without making selection. We need to know | |
| 72 * that to cleanup the popup menu hash table, but this is not honestly | |
| 73 * doable using *documented* sequence of messages. Sticking to | |
| 74 * particular knowledge is bad because this may break in Windows NT | |
| 75 * 5.0, or Windows 98, or other future version. Instead, I allow the | |
| 76 * hash tables to hang around, and not clear them, unless WM_COMMAND is | |
| 442 | 77 * received. This is worth some memory but more safe. Hacks welcome, |
| 428 | 78 * anyways! |
| 79 * | |
| 80 */ | |
| 81 | |
| 82 #include <config.h> | |
| 83 #include "lisp.h" | |
| 84 | |
| 85 #include "buffer.h" | |
| 86 #include "commands.h" | |
| 872 | 87 #include "console-msw-impl.h" |
| 428 | 88 #include "elhash.h" |
| 89 #include "events.h" | |
| 872 | 90 #include "frame-impl.h" |
| 428 | 91 #include "gui.h" |
| 92 #include "lisp.h" | |
| 93 #include "menubar.h" | |
| 94 #include "opaque.h" | |
| 872 | 95 #include "window-impl.h" |
| 428 | 96 |
| 97 /* #### */ | |
| 442 | 98 #define REPLACE_ME_WITH_GLOBAL_VARIABLE_WHICH_CONTROLS_RIGHT_FLUSH 0 |
| 428 | 99 |
| 5013 | 100 #define EMPTY_ITEM_ID ((UINT)STORE_LISP_IN_VOID (Qunbound)) |
| 771 | 101 #define EMPTY_ITEM_NAME "(empty)" /* WARNING: uses of this need XETEXT */ |
| 428 | 102 |
| 103 /* Current menu (bar or popup) descriptor. gcpro'ed */ | |
| 104 static Lisp_Object current_menudesc; | |
| 105 | |
| 106 /* Current menubar or popup hash table. gcpro'ed */ | |
| 107 static Lisp_Object current_hash_table; | |
| 108 | |
| 109 /* This is used to allocate unique ids to menu items. | |
| 110 Items ids are in MENU_ITEM_ID_MIN to MENU_ITEM_ID_MAX. | |
| 111 Allocation checks that the item is not already in | |
| 112 the TOP_LEVEL_MENU */ | |
| 113 | |
| 114 /* #### defines go to gui-msw.h, as the range is shared with toolbars | |
| 115 (If only toolbars will be implemented as common controls) */ | |
| 116 #define MENU_ITEM_ID_MIN 0x8000 | |
| 117 #define MENU_ITEM_ID_MAX 0xFFFF | |
| 118 #define MENU_ITEM_ID_BITS(x) (((x) & 0x7FFF) | 0x8000) | |
| 119 static HMENU top_level_menu; | |
| 120 | |
| 121 /* | |
| 122 * This returns Windows-style menu item string: | |
| 123 * "Left Flush\tRight Flush" | |
| 124 */ | |
| 442 | 125 |
| 771 | 126 static Lisp_Object |
| 867 | 127 displayable_menu_item (Lisp_Object gui_item, int bar_p, Ichar *accel) |
| 428 | 128 { |
| 771 | 129 Lisp_Object left, right = Qnil; |
| 428 | 130 |
| 131 /* Left flush part of the string */ | |
| 771 | 132 left = gui_item_display_flush_left (gui_item); |
| 428 | 133 |
| 771 | 134 left = mswindows_translate_menu_or_dialog_item (left, accel); |
| 428 | 135 |
| 136 /* Right flush part, unless we're at the top-level where it's not allowed */ | |
| 137 if (!bar_p) | |
| 771 | 138 right = gui_item_display_flush_right (gui_item); |
| 442 | 139 |
| 771 | 140 if (!NILP (right)) |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4677
diff
changeset
|
141 return concat3 (left, build_ascstring ("\t"), right); |
| 771 | 142 else |
| 143 return left; | |
| 428 | 144 } |
| 145 | |
| 146 /* | |
| 147 * hmenu_to_lisp_object() returns an opaque ptr given menu handle. | |
| 148 */ | |
| 149 static Lisp_Object | |
| 150 hmenu_to_lisp_object (HMENU hmenu) | |
| 151 { | |
| 152 return make_opaque_ptr (hmenu); | |
| 153 } | |
| 154 | |
| 155 /* | |
| 156 * Allocation tries a hash based on item's path and name first. This | |
| 157 * almost guarantees that the same item will override its old value in | |
| 158 * the hash table rather than abandon it. | |
| 159 */ | |
| 160 static Lisp_Object | |
| 161 allocate_menu_item_id (Lisp_Object path, Lisp_Object name, Lisp_Object suffix) | |
| 162 { | |
|
5192
635f4b506855
Call internal_hash() with its new arg, Win32-specific code, fixing build
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
163 UINT id = MENU_ITEM_ID_BITS (HASH3 (internal_hash (path, 0, 0), |
|
635f4b506855
Call internal_hash() with its new arg, Win32-specific code, fixing build
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
164 internal_hash (name, 0, 0), |
|
635f4b506855
Call internal_hash() with its new arg, Win32-specific code, fixing build
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
165 internal_hash (suffix, 0, 0))); |
| 428 | 166 do { |
| 167 id = MENU_ITEM_ID_BITS (id + 1); | |
| 168 } while (GetMenuState (top_level_menu, id, MF_BYCOMMAND) != 0xFFFFFFFF); | |
| 169 return make_int (id); | |
| 170 } | |
| 171 | |
| 172 static HMENU | |
| 173 create_empty_popup_menu (void) | |
| 174 { | |
| 175 return CreatePopupMenu (); | |
| 176 } | |
| 177 | |
| 178 static void | |
| 179 empty_menu (HMENU menu, int add_empty_p) | |
| 180 { | |
| 181 while (DeleteMenu (menu, 0, MF_BYPOSITION)); | |
| 182 if (add_empty_p) | |
| 771 | 183 qxeAppendMenu (menu, MF_STRING | MF_GRAYED, EMPTY_ITEM_ID, |
| 184 XETEXT (EMPTY_ITEM_NAME)); | |
| 428 | 185 } |
| 186 | |
| 187 /* | |
| 188 * The idea of checksumming is that we must hash minimal object | |
| 189 * which is necessarily changes when the item changes. For separator | |
| 190 * this is a constant, for grey strings and submenus these are hashes | |
| 191 * of names, since submenus are unpopulated until opened so always | |
| 192 * equal otherwise. For items, this is a full hash value of a callback, | |
| 193 * because a callback may me a form which can be changed only somewhere | |
| 194 * in depth. | |
| 195 */ | |
| 196 static unsigned long | |
| 197 checksum_menu_item (Lisp_Object item) | |
| 198 { | |
| 199 if (STRINGP (item)) | |
| 200 { | |
| 201 /* Separator or unselectable text - hash as a string + 13 */ | |
| 202 if (separator_string_p (XSTRING_DATA (item))) | |
| 203 return 13; | |
| 204 else | |
|
5192
635f4b506855
Call internal_hash() with its new arg, Win32-specific code, fixing build
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
205 return internal_hash (item, 0, 0) + 13; |
| 428 | 206 } |
| 207 else if (CONSP (item)) | |
| 208 { | |
| 209 /* Submenu - hash by its string name + 0 */ | |
|
5192
635f4b506855
Call internal_hash() with its new arg, Win32-specific code, fixing build
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
210 return internal_hash (XCAR (item), 0, 0); |
| 428 | 211 } |
| 212 else if (VECTORP (item)) | |
| 213 { | |
| 214 /* An ordinary item - hash its name and callback form. */ | |
|
5192
635f4b506855
Call internal_hash() with its new arg, Win32-specific code, fixing build
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
215 return HASH2 (internal_hash (XVECTOR_DATA(item)[0], 0, 0), |
|
635f4b506855
Call internal_hash() with its new arg, Win32-specific code, fixing build
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
216 internal_hash (XVECTOR_DATA(item)[1], 0, 0)); |
| 428 | 217 } |
| 442 | 218 |
| 428 | 219 /* An error - will be caught later */ |
| 220 return 0; | |
| 221 } | |
| 222 | |
| 223 static void | |
| 224 populate_menu_add_item (HMENU menu, Lisp_Object path, | |
| 225 Lisp_Object hash_tab, Lisp_Object item, | |
| 442 | 226 Lisp_Object *accel_list, |
| 428 | 227 int flush_right, int bar_p) |
| 228 { | |
| 771 | 229 MENUITEMINFOW item_info; |
| 428 | 230 |
| 231 item_info.cbSize = sizeof (item_info); | |
| 232 item_info.fMask = MIIM_TYPE | MIIM_STATE | MIIM_ID; | |
| 233 item_info.fState = 0; | |
| 234 item_info.wID = 0; | |
| 235 item_info.fType = 0; | |
| 236 | |
| 237 if (STRINGP (item)) | |
| 238 { | |
| 239 /* Separator or unselectable text */ | |
| 240 if (separator_string_p (XSTRING_DATA (item))) | |
| 771 | 241 item_info.fType = MFT_SEPARATOR; |
| 428 | 242 else |
| 243 { | |
| 244 item_info.fType = MFT_STRING; | |
| 245 item_info.fState = MFS_DISABLED; | |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
246 item_info.dwTypeData = (XELPTSTR) LISP_STRING_TO_TSTR (item); |
| 428 | 247 } |
| 248 } | |
| 249 else if (CONSP (item)) | |
| 250 { | |
| 251 /* Submenu */ | |
| 252 HMENU submenu; | |
| 253 Lisp_Object gui_item = allocate_gui_item (); | |
| 442 | 254 Lisp_Gui_Item *pgui_item = XGUI_ITEM (gui_item); |
| 255 struct gcpro gcpro1, gcpro2, gcpro3; | |
| 867 | 256 Ichar accel; |
| 428 | 257 |
| 442 | 258 GCPRO3 (gui_item, path, *accel_list); |
| 428 | 259 |
| 260 menu_parse_submenu_keywords (item, gui_item); | |
| 261 | |
| 262 if (!STRINGP (pgui_item->name)) | |
| 563 | 263 invalid_argument ("Menu name (first element) must be a string", |
| 442 | 264 item); |
| 428 | 265 |
| 266 if (!gui_item_included_p (gui_item, Vmenubar_configuration)) | |
| 442 | 267 { |
| 268 UNGCPRO; | |
| 269 goto done; | |
| 270 } | |
| 428 | 271 |
| 1913 | 272 if (!gui_item_active_p (gui_item)) |
| 771 | 273 item_info.fState = MFS_GRAYED; |
| 428 | 274 /* Temptation is to put 'else' right here. Although, the |
| 275 displayed item won't have an arrow indicating that it is a | |
| 276 popup. So we go ahead a little bit more and create a popup */ | |
| 442 | 277 submenu = create_empty_popup_menu (); |
| 428 | 278 |
| 279 item_info.fMask |= MIIM_SUBMENU; | |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
280 item_info.dwTypeData = (XELPTSTR) |
|
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
281 LISP_STRING_TO_TSTR (displayable_menu_item (gui_item, bar_p, &accel)); |
| 428 | 282 item_info.hSubMenu = submenu; |
| 442 | 283 |
| 284 if (accel && bar_p) | |
| 285 *accel_list = Fcons (make_char (accel), *accel_list); | |
| 428 | 286 |
| 287 if (!(item_info.fState & MFS_GRAYED)) | |
| 288 { | |
| 289 /* Now add the full submenu path as a value to the hash table, | |
| 290 keyed by menu handle */ | |
| 291 if (NILP(path)) | |
| 292 path = list1 (pgui_item->name); | |
| 293 else | |
| 294 { | |
| 295 Lisp_Object arg[2]; | |
| 296 arg[0] = path; | |
| 297 arg[1] = list1 (pgui_item->name); | |
| 298 path = Fappend (2, arg); | |
| 299 } | |
| 300 | |
| 301 Fputhash (hmenu_to_lisp_object (submenu), path, hash_tab); | |
| 302 } | |
| 442 | 303 UNGCPRO; |
| 304 } | |
| 428 | 305 else if (VECTORP (item)) |
| 306 { | |
| 307 /* An ordinary item */ | |
| 308 Lisp_Object style, id; | |
| 309 Lisp_Object gui_item = gui_parse_item_keywords (item); | |
| 442 | 310 Lisp_Gui_Item *pgui_item = XGUI_ITEM (gui_item); |
| 311 struct gcpro gcpro1, gcpro2; | |
| 867 | 312 Ichar accel; |
| 428 | 313 |
| 442 | 314 GCPRO2 (gui_item, *accel_list); |
| 428 | 315 |
| 316 if (!gui_item_included_p (gui_item, Vmenubar_configuration)) | |
| 442 | 317 { |
| 318 UNGCPRO; | |
| 319 goto done; | |
| 320 } | |
| 321 | |
| 322 if (!STRINGP (pgui_item->name)) | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2500
diff
changeset
|
323 pgui_item->name = IGNORE_MULTIPLE_VALUES (Feval (pgui_item->name)); |
| 428 | 324 |
| 1913 | 325 if (!gui_item_active_p (gui_item)) |
| 771 | 326 item_info.fState = MFS_GRAYED; |
| 428 | 327 |
| 328 style = (NILP (pgui_item->selected) || NILP (Feval (pgui_item->selected)) | |
| 329 ? Qnil : pgui_item->style); | |
| 330 | |
| 331 if (EQ (style, Qradio)) | |
| 332 { | |
| 333 item_info.fType |= MFT_RADIOCHECK; | |
| 334 item_info.fState |= MFS_CHECKED; | |
| 335 } | |
| 336 else if (EQ (style, Qtoggle)) | |
| 771 | 337 item_info.fState |= MFS_CHECKED; |
| 428 | 338 |
| 339 id = allocate_menu_item_id (path, pgui_item->name, | |
| 340 pgui_item->suffix); | |
| 341 Fputhash (id, pgui_item->callback, hash_tab); | |
| 342 | |
| 442 | 343 item_info.wID = (UINT) XINT (id); |
| 428 | 344 item_info.fType |= MFT_STRING; |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
345 item_info.dwTypeData = (XELPTSTR) |
|
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
346 LISP_STRING_TO_TSTR (displayable_menu_item (gui_item, bar_p, &accel)); |
| 428 | 347 |
| 442 | 348 if (accel && bar_p) |
| 349 *accel_list = Fcons (make_char (accel), *accel_list); | |
| 350 | |
| 351 UNGCPRO; | |
| 428 | 352 } |
| 353 else | |
| 563 | 354 sferror ("Malformed menu item descriptor", item); |
| 428 | 355 |
| 356 if (flush_right) | |
| 771 | 357 item_info.fType |= MFT_RIGHTJUSTIFY; |
| 428 | 358 |
| 771 | 359 qxeInsertMenuItem (menu, UINT_MAX, TRUE, &item_info); |
| 442 | 360 |
| 361 done:; | |
| 362 } | |
| 428 | 363 |
| 364 /* | |
| 365 * This function is called from populate_menu and checksum_menu. | |
| 366 * When called to populate, MENU is a menu handle, PATH is a | |
| 367 * list of strings representing menu path from root to this submenu, | |
| 368 * DESCRIPTOR is a menu descriptor, HASH_TAB is a hash table associated | |
| 369 * with root menu, BAR_P indicates whether this called for a menubar or | |
| 370 * a popup, and POPULATE_P is non-zero. Return value must be ignored. | |
| 371 * When called to checksum, DESCRIPTOR has the same meaning, POPULATE_P | |
| 372 * is zero, PATH must be Qnil, and the rest of parameters is ignored. | |
| 373 * Return value is the menu checksum. | |
| 374 */ | |
| 375 static unsigned long | |
| 376 populate_or_checksum_helper (HMENU menu, Lisp_Object path, Lisp_Object desc, | |
| 377 Lisp_Object hash_tab, int bar_p, int populate_p) | |
| 378 { | |
| 379 int deep_p, flush_right; | |
| 442 | 380 struct gcpro gcpro1, gcpro2, gcpro3; |
| 428 | 381 unsigned long checksum; |
| 382 Lisp_Object gui_item = allocate_gui_item (); | |
| 442 | 383 Lisp_Object accel_list = Qnil; |
| 384 Lisp_Gui_Item *pgui_item = XGUI_ITEM (gui_item); | |
| 385 | |
| 386 GCPRO3 (gui_item, accel_list, desc); | |
| 428 | 387 |
| 388 /* We are sometimes called with the menubar unchanged, and with changed | |
| 389 right flush. We have to update the menubar in this case, | |
| 390 so account for the compliance setting in the hash value */ | |
| 442 | 391 checksum = REPLACE_ME_WITH_GLOBAL_VARIABLE_WHICH_CONTROLS_RIGHT_FLUSH; |
| 428 | 392 |
| 393 /* Will initially contain only "(empty)" */ | |
| 394 if (populate_p) | |
| 395 empty_menu (menu, 1); | |
| 396 | |
| 397 /* PATH set to nil indicates top-level popup or menubar */ | |
| 398 deep_p = !NILP (path); | |
| 399 | |
| 400 /* Fetch keywords prepending the item list */ | |
| 401 desc = menu_parse_submenu_keywords (desc, gui_item); | |
| 402 | |
| 403 /* Check that menu name is specified when expected */ | |
| 404 if (NILP (pgui_item->name) && deep_p) | |
| 563 | 405 sferror ("Menu must have a name", desc); |
| 428 | 406 |
| 407 /* Apply filter if specified */ | |
| 408 if (!NILP (pgui_item->filter)) | |
| 409 desc = call1 (pgui_item->filter, desc); | |
| 410 | |
| 411 /* Loop thru the desc's CDR and add items for each entry */ | |
| 412 flush_right = 0; | |
| 2367 | 413 { |
| 414 EXTERNAL_LIST_LOOP_2 (elt, desc) | |
| 415 { | |
| 416 if (NILP (elt)) | |
| 417 { | |
| 418 /* Do not flush right menubar items when MS style compliant */ | |
| 419 if (bar_p && !REPLACE_ME_WITH_GLOBAL_VARIABLE_WHICH_CONTROLS_RIGHT_FLUSH) | |
| 420 flush_right = 1; | |
| 421 if (!populate_p) | |
| 422 checksum = HASH2 (checksum, LISP_HASH (Qnil)); | |
| 423 } | |
| 424 else if (populate_p) | |
| 425 populate_menu_add_item (menu, path, hash_tab, | |
| 426 elt, &accel_list, | |
| 427 flush_right, bar_p); | |
| 428 else | |
| 429 checksum = HASH2 (checksum, | |
| 430 checksum_menu_item (elt)); | |
| 431 } | |
| 432 } | |
| 442 | 433 |
| 428 | 434 if (populate_p) |
| 435 { | |
| 436 /* Remove the "(empty)" item, if there are other ones */ | |
| 437 if (GetMenuItemCount (menu) > 1) | |
| 438 RemoveMenu (menu, EMPTY_ITEM_ID, MF_BYCOMMAND); | |
| 439 | |
| 440 /* Add the header to the popup, if told so. The same as in X - an | |
| 441 insensitive item, and a separator (Seems to me, there were | |
| 442 | 442 two separators in X... In Windows this looks ugly, anyways.) */ |
| 443 if (!bar_p && !deep_p && popup_menu_titles && !NILP (pgui_item->name)) | |
| 428 | 444 { |
| 771 | 445 qxeInsertMenu (menu, 0, MF_BYPOSITION | MF_STRING | MF_DISABLED, |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
446 0, LISP_STRING_TO_TSTR (displayable_menu_item |
|
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
447 (gui_item, bar_p, NULL))); |
| 771 | 448 qxeInsertMenu (menu, 1, MF_BYPOSITION | MF_SEPARATOR, 0, NULL); |
| 449 SetMenuDefaultItem (menu, 0, MF_BYPOSITION); | |
| 428 | 450 } |
| 451 } | |
| 442 | 452 |
| 453 if (bar_p) | |
| 454 Fputhash (Qt, accel_list, hash_tab); | |
| 455 | |
| 456 UNGCPRO; | |
| 428 | 457 return checksum; |
| 458 } | |
| 459 | |
| 460 static void | |
| 461 populate_menu (HMENU menu, Lisp_Object path, Lisp_Object desc, | |
| 442 | 462 Lisp_Object hash_tab, int bar_p) |
| 428 | 463 { |
| 464 populate_or_checksum_helper (menu, path, desc, hash_tab, bar_p, 1); | |
| 465 } | |
| 466 | |
| 467 static unsigned long | |
| 468 checksum_menu (Lisp_Object desc) | |
| 469 { | |
| 470 return populate_or_checksum_helper (NULL, Qnil, desc, Qunbound, 0, 0); | |
| 471 } | |
| 472 | |
| 473 static void | |
| 442 | 474 update_frame_menubar_maybe (struct frame *f) |
| 428 | 475 { |
| 476 HMENU menubar = GetMenu (FRAME_MSWINDOWS_HANDLE (f)); | |
| 477 struct window *w = XWINDOW (FRAME_LAST_NONMINIBUF_WINDOW (f)); | |
| 478 Lisp_Object desc = (!NILP (w->menubar_visible_p) | |
| 479 ? symbol_value_in_buffer (Qcurrent_menubar, w->buffer) | |
| 480 : Qnil); | |
| 442 | 481 struct gcpro gcpro1; |
| 482 | |
| 483 GCPRO1 (desc); /* it's safest to do this, just in case some filter | |
| 484 or something changes the value of current-menubar */ | |
| 428 | 485 |
| 486 top_level_menu = menubar; | |
| 487 | |
| 488 if (NILP (desc) && menubar != NULL) | |
| 489 { | |
| 490 /* Menubar has gone */ | |
| 442 | 491 FRAME_MSWINDOWS_MENU_HASH_TABLE (f) = Qnil; |
| 428 | 492 SetMenu (FRAME_MSWINDOWS_HANDLE (f), NULL); |
| 493 DestroyMenu (menubar); | |
| 494 DrawMenuBar (FRAME_MSWINDOWS_HANDLE (f)); | |
| 442 | 495 UNGCPRO; |
| 428 | 496 return; |
| 497 } | |
| 498 | |
| 499 if (!NILP (desc) && menubar == NULL) | |
| 500 { | |
| 501 /* Menubar has appeared */ | |
| 502 menubar = CreateMenu (); | |
| 503 goto populate; | |
| 504 } | |
| 505 | |
| 506 if (NILP (desc)) | |
| 507 { | |
| 508 /* We did not have the bar and are not going to */ | |
| 442 | 509 UNGCPRO; |
| 428 | 510 return; |
| 511 } | |
| 512 | |
| 513 /* Now we bail out if the menubar has not changed */ | |
| 442 | 514 if (FRAME_MSWINDOWS_MENU_CHECKSUM (f) == checksum_menu (desc)) |
| 515 { | |
| 516 UNGCPRO; | |
| 517 return; | |
| 518 } | |
| 428 | 519 |
| 520 populate: | |
| 521 /* Come with empty hash table */ | |
| 442 | 522 if (NILP (FRAME_MSWINDOWS_MENU_HASH_TABLE (f))) |
| 523 FRAME_MSWINDOWS_MENU_HASH_TABLE (f) = | |
|
5191
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5013
diff
changeset
|
524 make_lisp_hash_table (50, HASH_TABLE_NON_WEAK, Qequal); |
| 428 | 525 else |
| 442 | 526 Fclrhash (FRAME_MSWINDOWS_MENU_HASH_TABLE (f)); |
| 428 | 527 |
| 528 Fputhash (hmenu_to_lisp_object (menubar), Qnil, | |
| 442 | 529 FRAME_MSWINDOWS_MENU_HASH_TABLE (f)); |
| 428 | 530 populate_menu (menubar, Qnil, desc, |
| 442 | 531 FRAME_MSWINDOWS_MENU_HASH_TABLE (f), 1); |
| 428 | 532 SetMenu (FRAME_MSWINDOWS_HANDLE (f), menubar); |
| 533 DrawMenuBar (FRAME_MSWINDOWS_HANDLE (f)); | |
| 534 | |
| 442 | 535 FRAME_MSWINDOWS_MENU_CHECKSUM (f) = checksum_menu (desc); |
| 536 | |
| 537 UNGCPRO; | |
| 428 | 538 } |
| 539 | |
| 540 static void | |
| 541 prune_menubar (struct frame *f) | |
| 542 { | |
| 543 HMENU menubar = GetMenu (FRAME_MSWINDOWS_HANDLE (f)); | |
| 544 Lisp_Object desc = current_frame_menubar (f); | |
| 442 | 545 struct gcpro gcpro1; |
| 546 | |
| 428 | 547 if (menubar == NULL) |
| 548 return; | |
| 549 | |
| 2500 | 550 /* #### If a filter function has set desc to Qnil, this ABORT() |
| 428 | 551 triggers. To resolve, we must prevent filters explicitly from |
| 552 mangling with the active menu. In apply_filter probably? | |
| 553 Is copy-tree on the whole menu too expensive? */ | |
| 442 | 554 if (NILP (desc)) |
| 2500 | 555 /* ABORT(); */ |
| 428 | 556 return; |
| 557 | |
| 442 | 558 GCPRO1 (desc); /* just to be safe -- see above */ |
| 428 | 559 /* We do the trick by removing all items and re-populating top level */ |
| 560 empty_menu (menubar, 0); | |
| 561 | |
| 442 | 562 assert (HASH_TABLEP (FRAME_MSWINDOWS_MENU_HASH_TABLE (f))); |
| 563 Fclrhash (FRAME_MSWINDOWS_MENU_HASH_TABLE (f)); | |
| 428 | 564 |
| 565 Fputhash (hmenu_to_lisp_object (menubar), Qnil, | |
| 442 | 566 FRAME_MSWINDOWS_MENU_HASH_TABLE (f)); |
| 567 populate_menu (menubar, Qnil, desc, | |
| 568 FRAME_MSWINDOWS_MENU_HASH_TABLE (f), 1); | |
| 569 UNGCPRO; | |
| 428 | 570 } |
| 571 | |
| 572 /* | |
| 573 * This is called when cleanup is possible. It is better not to | |
| 574 * clean things up at all than do it too early! | |
| 575 */ | |
| 576 static void | |
| 577 menu_cleanup (struct frame *f) | |
| 578 { | |
| 579 /* This function can GC */ | |
| 580 current_menudesc = Qnil; | |
| 581 current_hash_table = Qnil; | |
| 582 prune_menubar (f); | |
| 583 } | |
| 442 | 584 |
| 585 int | |
| 867 | 586 mswindows_char_is_accelerator (struct frame *f, Ichar ch) |
| 442 | 587 { |
| 588 Lisp_Object hash = FRAME_MSWINDOWS_MENU_HASH_TABLE (f); | |
| 589 | |
| 590 if (NILP (hash)) | |
| 591 return 0; | |
| 771 | 592 return !NILP (memq_no_quit |
| 593 (make_char | |
| 594 (DOWNCASE (WINDOW_XBUFFER (FRAME_SELECTED_XWINDOW (f)), ch)), | |
| 595 Fgethash (Qt, hash, Qnil))); | |
| 442 | 596 } |
| 597 | |
| 428 | 598 |
| 599 /*------------------------------------------------------------------------*/ | |
| 600 /* Message handlers */ | |
| 601 /*------------------------------------------------------------------------*/ | |
| 602 static Lisp_Object | |
| 2286 | 603 unsafe_handle_wm_initmenupopup_1 (HMENU menu, struct frame *UNUSED (f)) |
| 428 | 604 { |
| 605 /* This function can call lisp, beat dogs and stick chewing gum to | |
| 606 everything! */ | |
| 607 | |
| 608 Lisp_Object path, desc; | |
| 609 struct gcpro gcpro1; | |
| 707 | 610 |
| 428 | 611 /* Find which guy is going to explode */ |
| 612 path = Fgethash (hmenu_to_lisp_object (menu), current_hash_table, Qunbound); | |
| 613 assert (!UNBOUNDP (path)); | |
| 614 #ifdef DEBUG_XEMACS | |
| 615 /* Allow to continue in a debugger after assert - not so fatal */ | |
| 616 if (UNBOUNDP (path)) | |
| 563 | 617 signal_error (Qinternal_error, "internal menu error", Qunbound); |
| 428 | 618 #endif |
| 619 | |
| 620 /* Now find a desc chunk for it. If none, then probably menu open | |
| 621 hook has played too much games around stuff */ | |
| 622 desc = Fmenu_find_real_submenu (current_menudesc, path); | |
| 623 if (NILP (desc)) | |
| 563 | 624 invalid_state ("This menu does not exist any more", path); |
| 428 | 625 |
| 626 /* Now, stuff it */ | |
| 627 /* DESC may be generated by filter, so we have to gcpro it */ | |
| 628 GCPRO1 (desc); | |
| 629 populate_menu (menu, path, desc, current_hash_table, 0); | |
| 630 UNGCPRO; | |
| 631 return Qt; | |
| 632 } | |
| 633 | |
| 634 static Lisp_Object | |
| 442 | 635 unsafe_handle_wm_initmenu_1 (struct frame *f) |
| 428 | 636 { |
| 637 /* This function can call lisp */ | |
| 638 | |
| 639 /* NOTE: This is called for the bar only, WM_INITMENU | |
| 640 for popups is filtered out */ | |
| 641 | |
| 642 /* #### - this menubar update mechanism is expensively anti-social and | |
| 643 the activate-menubar-hook is now mostly obsolete. */ | |
| 644 | |
| 645 /* We simply ignore return value. In any case, we construct the bar | |
| 646 on the fly */ | |
| 853 | 647 run_hook_trapping_problems |
| 1333 | 648 (Qmenubar, Qactivate_menubar_hook, |
| 853 | 649 INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION); |
| 428 | 650 |
| 651 update_frame_menubar_maybe (f); | |
| 652 | |
| 653 current_menudesc = current_frame_menubar (f); | |
| 442 | 654 current_hash_table = FRAME_MSWINDOWS_MENU_HASH_TABLE (f); |
| 428 | 655 assert (HASH_TABLEP (current_hash_table)); |
| 656 | |
| 657 return Qt; | |
| 658 } | |
| 659 | |
| 660 /* | |
| 661 * Return value is Qt if we have dispatched the command, | |
| 662 * or Qnil if id has not been mapped to a callback. | |
| 663 * Window procedure may try other targets to route the | |
| 664 * command if we return nil | |
| 665 */ | |
| 666 Lisp_Object | |
| 442 | 667 mswindows_handle_wm_command (struct frame *f, WORD id) |
| 428 | 668 { |
| 669 /* Try to map the command id through the proper hash table */ | |
| 670 Lisp_Object data, fn, arg, frame; | |
| 671 struct gcpro gcpro1; | |
| 672 | |
| 673 if (NILP (current_hash_table)) | |
| 674 return Qnil; | |
| 675 | |
| 676 data = Fgethash (make_int (id), current_hash_table, Qunbound); | |
| 677 | |
| 678 if (UNBOUNDP (data)) | |
| 679 { | |
| 680 menu_cleanup (f); | |
| 681 return Qnil; | |
| 682 } | |
| 683 | |
| 684 /* Need to gcpro because the hash table may get destroyed by | |
| 685 menu_cleanup(), and will not gcpro the data any more */ | |
| 686 GCPRO1 (data); | |
| 687 menu_cleanup (f); | |
| 688 | |
| 689 /* Ok, this is our one. Enqueue it. */ | |
| 690 get_gui_callback (data, &fn, &arg); | |
| 793 | 691 frame = wrap_frame (f); |
| 428 | 692 /* this used to call mswindows_enqueue_misc_user_event but that |
| 693 breaks customize because the misc_event gets eval'ed in some | |
| 442 | 694 circumstances. Don't change it back unless you can fix the |
| 771 | 695 customize problem also. */ |
| 707 | 696 mswindows_enqueue_misc_user_event (frame, fn, arg); |
| 428 | 697 |
| 698 UNGCPRO; /* data */ | |
| 699 return Qt; | |
| 700 } | |
| 701 | |
| 702 | |
| 703 /*------------------------------------------------------------------------*/ | |
| 704 /* Message handling proxies */ | |
| 705 /*------------------------------------------------------------------------*/ | |
| 706 | |
| 1268 | 707 struct handle_wm_initmenu |
| 708 { | |
| 709 HMENU menu; | |
| 710 struct frame *frame; | |
| 711 }; | |
| 428 | 712 |
| 713 static Lisp_Object | |
| 1268 | 714 unsafe_handle_wm_initmenupopup (void *arg) |
| 428 | 715 { |
| 1268 | 716 struct handle_wm_initmenu *z = (struct handle_wm_initmenu *) arg; |
| 717 return unsafe_handle_wm_initmenupopup_1 (z->menu, z->frame); | |
| 428 | 718 } |
| 719 | |
| 720 static Lisp_Object | |
| 1268 | 721 unsafe_handle_wm_initmenu (void *arg) |
| 428 | 722 { |
| 1268 | 723 struct handle_wm_initmenu *z = (struct handle_wm_initmenu *) arg; |
| 724 return unsafe_handle_wm_initmenu_1 (z->frame); | |
| 428 | 725 } |
| 726 | |
| 727 Lisp_Object | |
| 442 | 728 mswindows_handle_wm_initmenupopup (HMENU hmenu, struct frame *frm) |
| 428 | 729 { |
| 1268 | 730 struct handle_wm_initmenu z; |
| 1279 | 731 int depth = internal_bind_int (&in_menu_callback, 1); |
| 732 Lisp_Object retval; | |
| 1268 | 733 |
| 734 z.menu = hmenu; | |
| 735 z.frame = frm; | |
| 736 | |
| 737 /* [[ Allow runaway filter code, e.g. custom, to be aborted. We are | |
| 853 | 738 usually called from next_event_internal(), which has turned off |
| 1268 | 739 quit checking to read the C-g as an event.]] |
| 740 | |
| 741 #### This is bogus because by the very act of calling | |
| 742 event_stream_protect_modal_loop(), we disable event retrieval! */ | |
| 1279 | 743 retval = event_stream_protect_modal_loop ("Error during menu handling", |
| 744 unsafe_handle_wm_initmenupopup, &z, | |
| 745 UNINHIBIT_QUIT); | |
| 746 unbind_to (depth); | |
| 747 | |
| 748 return retval; | |
| 428 | 749 } |
| 750 | |
| 751 Lisp_Object | |
| 442 | 752 mswindows_handle_wm_initmenu (HMENU hmenu, struct frame *f) |
| 428 | 753 { |
| 754 /* Handle only frame menubar, ignore if from popup or system menu */ | |
| 442 | 755 if (GetMenu (FRAME_MSWINDOWS_HANDLE (f)) == hmenu) |
| 428 | 756 { |
| 1268 | 757 struct handle_wm_initmenu z; |
| 758 | |
| 759 z.frame = f; | |
| 760 return event_stream_protect_modal_loop ("Error during menu handling", | |
| 761 unsafe_handle_wm_initmenu, &z, | |
| 762 UNINHIBIT_QUIT); | |
| 428 | 763 } |
| 764 return Qt; | |
| 765 } | |
| 766 | |
| 767 | |
| 768 /*------------------------------------------------------------------------*/ | |
| 769 /* Methods */ | |
| 770 /*------------------------------------------------------------------------*/ | |
| 771 | |
| 772 static void | |
| 442 | 773 mswindows_update_frame_menubars (struct frame *f) |
| 428 | 774 { |
| 775 update_frame_menubar_maybe (f); | |
| 776 } | |
| 777 | |
| 778 static void | |
| 442 | 779 mswindows_free_frame_menubars (struct frame *f) |
| 428 | 780 { |
| 442 | 781 FRAME_MSWINDOWS_MENU_HASH_TABLE (f) = Qnil; |
| 428 | 782 } |
| 783 | |
| 784 static void | |
| 785 mswindows_popup_menu (Lisp_Object menu_desc, Lisp_Object event) | |
| 786 { | |
| 787 struct frame *f = selected_frame (); | |
| 440 | 788 Lisp_Event *eev = NULL; |
| 428 | 789 HMENU menu; |
| 790 POINT pt; | |
| 791 int ok; | |
| 442 | 792 struct gcpro gcpro1; |
| 793 | |
| 794 GCPRO1 (menu_desc); /* to be safe -- see above */ | |
| 428 | 795 |
| 796 if (!NILP (event)) | |
| 797 { | |
| 798 CHECK_LIVE_EVENT (event); | |
| 799 eev = XEVENT (event); | |
| 800 if (eev->event_type != button_press_event | |
| 801 && eev->event_type != button_release_event) | |
| 802 wrong_type_argument (Qmouse_event_p, event); | |
| 803 } | |
| 804 else if (!NILP (Vthis_command_keys)) | |
| 805 { | |
| 806 /* if an event wasn't passed, use the last event of the event sequence | |
| 807 currently being executed, if that event is a mouse event */ | |
| 808 eev = XEVENT (Vthis_command_keys); /* last event first */ | |
| 809 if (eev->event_type != button_press_event | |
| 810 && eev->event_type != button_release_event) | |
| 811 eev = NULL; | |
| 812 } | |
| 813 | |
| 707 | 814 popup_up_p++; |
| 815 | |
| 428 | 816 /* Default is to put the menu at the point (10, 10) in frame */ |
| 817 if (eev) | |
| 818 { | |
| 1204 | 819 pt.x = EVENT_BUTTON_X (eev); |
| 820 pt.y = EVENT_BUTTON_Y (eev); | |
| 428 | 821 ClientToScreen (FRAME_MSWINDOWS_HANDLE (f), &pt); |
| 822 } | |
| 823 else | |
| 824 pt.x = pt.y = 10; | |
| 825 | |
| 826 if (SYMBOLP (menu_desc)) | |
| 827 menu_desc = Fsymbol_value (menu_desc); | |
| 828 CHECK_CONS (menu_desc); | |
| 829 CHECK_STRING (XCAR (menu_desc)); | |
| 830 | |
| 707 | 831 menu_cleanup (f); |
| 832 | |
| 428 | 833 current_menudesc = menu_desc; |
| 834 current_hash_table = | |
|
5191
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5013
diff
changeset
|
835 make_lisp_hash_table (10, HASH_TABLE_NON_WEAK, Qequal); |
| 442 | 836 menu = create_empty_popup_menu (); |
| 428 | 837 Fputhash (hmenu_to_lisp_object (menu), Qnil, current_hash_table); |
| 838 top_level_menu = menu; | |
| 442 | 839 |
| 428 | 840 /* see comments in menubar-x.c */ |
| 841 if (zmacs_regions) | |
| 842 zmacs_region_stays = 1; | |
| 442 | 843 |
| 428 | 844 ok = TrackPopupMenu (menu, |
| 845 TPM_LEFTALIGN | TPM_LEFTBUTTON | TPM_RIGHTBUTTON, | |
| 846 pt.x, pt.y, 0, | |
| 847 FRAME_MSWINDOWS_HANDLE (f), NULL); | |
| 848 | |
| 849 DestroyMenu (menu); | |
| 850 | |
| 707 | 851 /* A WM_COMMAND is not issued until TrackPopupMenu returns. This |
| 852 makes setting popup_up_p fairly pointless since we cannot keep | |
| 853 the menu up and dispatch events. Furthermore, we seem to have | |
| 854 little control over what happens to the menu when we click. */ | |
| 855 popup_up_p--; | |
| 856 | |
| 857 /* Signal a signal if caught by Track...() modal loop. */ | |
| 858 /* I think this is pointless, the code hasn't actually put us in a | |
| 859 modal loop at this time -- andyp. */ | |
| 428 | 860 mswindows_unmodalize_signal_maybe (); |
| 861 | |
| 862 /* This is probably the only real reason for failure */ | |
| 442 | 863 if (!ok) |
| 864 { | |
| 865 menu_cleanup (f); | |
| 563 | 866 invalid_operation ("Cannot track popup menu while in menu", |
| 867 menu_desc); | |
| 442 | 868 } |
| 869 UNGCPRO; | |
| 428 | 870 } |
| 871 | |
| 872 | |
| 873 /*------------------------------------------------------------------------*/ | |
| 874 /* Initialization */ | |
| 875 /*------------------------------------------------------------------------*/ | |
| 876 void | |
| 877 syms_of_menubar_mswindows (void) | |
| 878 { | |
| 879 } | |
| 880 | |
| 881 void | |
| 882 console_type_create_menubar_mswindows (void) | |
| 883 { | |
| 884 CONSOLE_HAS_METHOD (mswindows, update_frame_menubars); | |
| 885 CONSOLE_HAS_METHOD (mswindows, free_frame_menubars); | |
| 886 CONSOLE_HAS_METHOD (mswindows, popup_menu); | |
| 887 } | |
| 888 | |
| 889 void | |
| 890 vars_of_menubar_mswindows (void) | |
| 891 { | |
| 892 current_menudesc = Qnil; | |
| 893 current_hash_table = Qnil; | |
| 894 | |
| 895 staticpro (¤t_menudesc); | |
| 896 staticpro (¤t_hash_table); | |
| 897 } |