Mercurial > hg > xemacs-beta
annotate lisp/gtk-init.el @ 5553:62edcc6a11ec
Add an assertion about argument order to #'apply-partially compiler macro
lisp/ChangeLog addition:
2011-08-24 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (apply-partially):
Add an assertion to this compiler macro, requiring that the order
of the placeholders corresponding to the arguments in the
constants vector of the constructed compiled function be the same
as the order of the arguments to #'apply-partially.
tests/ChangeLog addition:
2011-08-24 Aidan Kehoe <kehoea@parhasard.net>
* automated/lisp-tests.el:
Add a test of apply partially that depends on the relative order
of its arguments.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Wed, 24 Aug 2011 11:06:41 +0100 |
| parents | 3d1f8f0e690f |
| children |
| rev | line source |
|---|---|
| 462 | 1 ;;; gtk-init.el --- initialization code for mswindows |
| 2 ;; Copyright (C) 1990, 1993, 1994 Free Software Foundation, Inc. | |
| 3 ;; Copyright (C) 1995 Board of Trustees, University of Illinois. | |
| 4 ;; Copyright (C) 1995, 1996 Ben Wing. | |
| 5 | |
| 6 ;; Author: various | |
| 7 ;; Rewritten for Gtk by: William Perry | |
| 8 | |
| 9 ;; This file is part of XEmacs. | |
| 10 | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4477
diff
changeset
|
11 ;; XEmacs is free software: you can redistribute it and/or modify it |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4477
diff
changeset
|
12 ;; under the terms of the GNU General Public License as published by the |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4477
diff
changeset
|
13 ;; Free Software Foundation, either version 3 of the License, or (at your |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4477
diff
changeset
|
14 ;; option) any later version. |
| 462 | 15 |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4477
diff
changeset
|
16 ;; XEmacs is distributed in the hope that it will be useful, but WITHOUT |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4477
diff
changeset
|
17 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4477
diff
changeset
|
18 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4477
diff
changeset
|
19 ;; for more details. |
| 462 | 20 |
| 21 ;; You should have received a copy of the GNU General Public License | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4477
diff
changeset
|
22 ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>. |
| 462 | 23 |
| 502 | 24 (globally-declare-boundp |
|
4477
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
25 '(gtk-initial-argv-list gtk-initial-geometry)) |
| 506 | 26 |
| 27 (globally-declare-fboundp | |
| 28 '(gtk-keysym-on-keyboard-p)) | |
| 502 | 29 |
|
4477
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
30 (defvar gtk-early-lisp-options-file "~/.xemacs/gtk-options.el" |
|
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
31 "Path where GTK-specific early options should be stored. |
|
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
32 |
|
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
33 This allows the user to set initial geometry without using GNOME and session |
|
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
34 management, and, since it is read before GTK is initialized, it avoids |
|
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
35 window flicker on resizing. |
|
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
36 |
|
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
37 It is normally not useful to change without recompiling XEmacs.") |
| 462 | 38 |
| 39 (defvar gtk-command-switch-alist | |
| 40 '( | |
| 41 ;; GNOME Options | |
| 42 ("--disable-sound" . nil) | |
| 43 ("--enable-sound" . nil) | |
| 44 ("--espeaker" . t) | |
| 45 | |
| 46 ;; GTK Options | |
| 47 ("--gdk-debug" . t) | |
| 48 ("--gdk-no-debug" . t) | |
| 49 ("--display" . t) | |
| 50 ("--sync" . nil) | |
| 51 ("--no-xshm" . nil) | |
| 52 ("--name" . t) | |
| 53 ("--class" . t) | |
| 54 ("--gxid_host" . t) | |
| 55 ("--gxid_port" . t) | |
| 56 ("--xim-preedit" . t) | |
| 57 ("--xim-status" . t) | |
| 58 ("--gtk-debug" . t) | |
| 59 ("--gtk-no-debug" . t) | |
| 60 ("--gtk-module" . t) | |
| 61 | |
| 62 ;; Glib options | |
| 63 ("--g-fatal-warnings" . nil) | |
| 64 | |
| 65 ;; Session management options | |
| 66 ("--sm-client-id" . t) | |
| 67 ("--sm-config-prefix" . t) | |
| 68 ("--sm-disable" . t) | |
| 69 ) | |
| 70 | |
|
4477
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
71 "An assoc list of command line args that should be in gtk-initial-argv-list. |
|
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
72 This is necessary because GTK and GNOME consider it a fatal error if they |
|
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
73 receive unknown command line arguments (perfectly reasonable). But this |
|
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
74 means that if the user specifies a file name on the command line they will |
|
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
75 be unable to start. So we filter the command line and allow only items in |
|
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
76 this list in. |
|
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
77 |
|
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
78 The CDR of the assoc list is whether it accepts an argument. For the |
|
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
79 moment, all options are in GNU long form.") |
|
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
80 |
|
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
81 (defvar make-device-early-gtk-entry-point-called-p nil |
|
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
82 "Whether `make-device-early-gtk-entry-point' has been called, at least once. |
|
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
83 |
|
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
84 Much of the GTK-specific Lisp init code should only be called the first time |
|
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
85 a GTK device is created; this variable allows for that.") |
| 462 | 86 |
|
4477
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
87 (defvar make-device-late-gtk-entry-point-called-p nil |
|
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
88 "Whether `make-device-late-gtk-entry-point' has been called, at least once. |
|
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
89 |
|
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
90 Much of the GTK-specific Lisp init code should only be called the first time |
|
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
91 a GTK device is created; this variable allows for that.") |
| 462 | 92 |
|
4477
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
93 (defun make-device-early-gtk-entry-point () |
|
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
94 "Entry point to set up the Lisp environment before GTK device creation." |
|
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
95 (unless make-device-early-gtk-entry-point-called-p |
|
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
96 (setq initial-frame-plist |
|
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
97 (and initial-frame-unmapped-p '(initially-unmapped t)) |
|
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
98 gtk-initial-argv-list |
|
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
99 (cons (car command-line-args) (gtk-filter-arguments)) |
|
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
100 gtk-initial-geometry |
|
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
101 (nth 1 (member "-geometry" command-line-args-left)) |
|
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
102 make-device-early-gtk-entry-point-called-p t) |
|
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
103 (unless vanilla-inhibiting |
|
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
104 (load gtk-early-lisp-options-file t t t)))) |
| 462 | 105 |
| 106 (defun gtk-init-handle-geometry (arg) | |
| 107 "Set up initial geometry info for GTK devices." | |
| 108 (setq gtk-initial-geometry (pop command-line-args-left))) | |
| 109 | |
|
4477
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
110 (defun make-device-late-gtk-entry-point (device) |
|
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
111 "Entry-Point to do any Lisp-level GTK device-specific initialization." |
|
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
112 (unless make-device-late-gtk-entry-point-called-p |
|
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
113 (setq make-device-late-gtk-entry-point-called-p t))) |
|
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4380
diff
changeset
|
114 |
| 462 | 115 (defun gtk-filter-arguments () |
| 116 (let ((accepted nil) | |
| 117 (rejected nil) | |
| 118 (todo nil)) | |
| 119 (setq todo (mapcar (lambda (argdesc) | |
| 120 (if (cdr argdesc) | |
| 121 ;; Need to look for --foo=bar | |
| 122 (concat "^" (car argdesc) "=") | |
| 123 ;; Just a simple arg | |
| 124 (concat "^" (regexp-quote (car argdesc)) "$"))) | |
| 125 gtk-command-switch-alist)) | |
| 126 | |
| 127 (while command-line-args-left | |
| 128 (if (catch 'found | |
| 129 (mapc (lambda (r) | |
| 130 (if (string-match r (car command-line-args-left)) | |
| 131 (throw 'found t))) todo) | |
| 132 (mapc (lambda (argdesc) | |
| 133 (if (cdr argdesc) | |
| 134 ;; This time we only care about argument items | |
| 135 ;; that take an argument. We'll check to see if | |
| 136 ;; someone used --foo bar instead of --foo=bar | |
| 137 (if (string-match (concat "^" (car argdesc) "$") (car command-line-args-left)) | |
| 138 ;; Yup! Need to push | |
| 139 (progn | |
| 140 (push (pop command-line-args-left) accepted) | |
| 141 (throw 'found t))))) | |
| 142 gtk-command-switch-alist) | |
| 143 nil) | |
| 144 (push (pop command-line-args-left) accepted) | |
| 145 (push (pop command-line-args-left) rejected))) | |
| 146 (setq command-line-args-left (nreverse rejected)) | |
| 147 (nreverse accepted))) | |
| 148 | |
| 149 (push '("-geometry" . gtk-init-handle-geometry) command-switch-alist) | |
| 150 |