Mercurial > hg > xemacs-beta
annotate lisp/gtk-font-menu.el @ 5574:d4f334808463
Support inlining labels, bytecomp.el.
lisp/ChangeLog addition:
2011-10-02 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el (byte-compile-initial-macro-environment):
Add #'declare to this, so it doesn't need to rely on
#'cl-compiling file to determine when we're byte-compiling.
Update #'labels to support declaring labels inline, as Common Lisp
requires.
* bytecomp.el (byte-compile-function-form):
Don't error if FUNCTION is quoting a non-lambda, non-symbol, just
return it.
* cl-extra.el (cl-macroexpand-all):
If a label name has been quoted, expand to the label placeholder
quoted with 'function. This allows the byte compiler to
distinguish between uses of the placeholder as data and uses in
contexts where it should be inlined.
* cl-macs.el:
* cl-macs.el (cl-do-proclaim):
When proclaming something as inline, if it is bound as a label,
don't modify the symbol's plist; instead, treat the first element
of its placeholder constant vector as a place to store compile
information.
* cl-macs.el (declare):
Leave processing declarations while compiling to the
implementation of #'declare in
byte-compile-initial-macro-environment.
tests/ChangeLog addition:
2011-10-02 Aidan Kehoe <kehoea@parhasard.net>
* automated/lisp-tests.el:
* automated/lisp-tests.el (+):
Test #'labels and inlining.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Sun, 02 Oct 2011 15:32:16 +0100 |
| parents | ac37a5f7e5be |
| children | cc6f0266bc36 |
| rev | line source |
|---|---|
| 462 | 1 ;; gtk-font-menu.el --- Managing menus of GTK fonts. |
| 2 | |
| 3 ;; Copyright (C) 1994 Free Software Foundation, Inc. | |
| 4 ;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp. | |
| 5 ;; Copyright (C) 1997 Sun Microsystems | |
| 6 | |
| 7 ;; Author: Jamie Zawinski <jwz@jwz.org> | |
| 8 ;; Restructured by: Jonathan Stigelman <Stig@hackvan.com> | |
| 9 ;; Mule-ized by: Martin Buchholz | |
| 10 ;; More restructuring for MS-Windows by Andy Piper <andy@xemacs.org> | |
| 11 ;; GTK-ized by: William Perry <wmperry@xemacs.org> | |
| 12 | |
| 13 ;; This file is part of XEmacs. | |
| 14 | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4103
diff
changeset
|
15 ;; 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:
4103
diff
changeset
|
16 ;; 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:
4103
diff
changeset
|
17 ;; 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:
4103
diff
changeset
|
18 ;; option) any later version. |
| 462 | 19 |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4103
diff
changeset
|
20 ;; 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:
4103
diff
changeset
|
21 ;; 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:
4103
diff
changeset
|
22 ;; 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:
4103
diff
changeset
|
23 ;; for more details. |
| 462 | 24 |
| 25 ;; 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:
4103
diff
changeset
|
26 ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>. |
| 462 | 27 ;;; Code: |
| 28 | |
| 2297 | 29 ;; #### - The comment that this file was GTK-ized by Wm Perry is a lie; |
| 30 ;; nothing was done except to rename everything that was x- to gtk-. | |
| 31 ;; This is harmless, but we should reintegrate so that GTK can take | |
| 32 ;; advantage of fontconfig, too, I think. | |
| 33 | |
| 462 | 34 ;; #### - implement these... |
| 35 ;; | |
| 36 ;;; (defvar font-menu-ignore-proportional-fonts nil | |
| 37 ;;; "*If non-nil, then the font menu will only show fixed-width fonts.") | |
| 38 | |
| 39 (require 'font-menu) | |
| 40 | |
| 502 | 41 (globally-declare-boundp |
| 42 '(gtk-font-regexp | |
| 2297 | 43 gtk-font-regexp-foundry-and-family |
| 44 gtk-font-regexp-spacing)) | |
| 502 | 45 |
| 462 | 46 (defvar gtk-font-menu-registry-encoding nil |
| 47 "Registry and encoding to use with font menu fonts.") | |
| 48 | |
| 49 (defvar gtk-fonts-menu-junk-families | |
| 50 (mapconcat | |
| 51 #'identity | |
| 52 '("cursor" "glyph" "symbol" ; Obvious losers. | |
| 53 "\\`Ax...\\'" ; FrameMaker fonts - there are just way too | |
| 54 ; many of these, and there is a different | |
| 55 ; font family for each font face! Losers. | |
| 56 ; "Axcor" -> "Applix Courier Roman", | |
| 57 ; "Axcob" -> "Applix Courier Bold", etc. | |
| 58 ) | |
| 59 "\\|") | |
| 60 "A regexp matching font families which are uninteresting (e.g. cursor fonts).") | |
| 61 | |
| 62 (defun hack-font-truename (fn) | |
| 2297 | 63 ;; #### This is duplicated from x-font-menu.el. |
| 64 "Filter the output of `font-instance-truename' to deal with font sets." | |
| 462 | 65 (if (string-match "," (font-instance-truename fn)) |
| 66 (let ((fpnt (nth 8 (split-string (font-instance-name fn) "-"))) | |
| 67 (flist (split-string (font-instance-truename fn) ",")) | |
| 68 ret) | |
| 69 (while flist | |
| 70 (if (string-equal fpnt (nth 8 (split-string (car flist) "-"))) | |
| 71 (progn (setq ret (car flist)) (setq flist nil)) | |
| 72 (setq flist (cdr flist)) | |
| 73 )) | |
| 74 ret) | |
| 75 (font-instance-truename fn))) | |
| 76 | |
| 77 (defvar gtk-font-regexp-ascii nil | |
| 78 "This is used to filter out font families that can't display ASCII text. | |
| 79 It must be set at run-time.") | |
| 80 | |
| 81 ;;;###autoload | |
| 82 (defun gtk-reset-device-font-menus (device &optional debug) | |
| 83 "Generates the `Font', `Size', and `Weight' submenus for the Options menu. | |
| 84 This is run the first time that a font-menu is needed for each device. | |
| 85 If you don't like the lazy invocation of this function, you can add it to | |
| 86 `create-device-hook' and that will make the font menus respond more quickly | |
| 87 when they are selected for the first time. If you add fonts to your system, | |
| 88 or if you change your font path, you can call this to re-initialize the menus." | |
| 89 ;; by Stig@hackvan.com | |
| 90 ;; #### - this should implement a `menus-only' option, which would | |
| 2527 | 91 ;; recalculate the menus from the cache w/o having to do font-list again. |
| 462 | 92 (unless gtk-font-regexp-ascii |
|
5368
ed74d2ca7082
Use ', not #', when a given symbol may not have a function binding at read time
Aidan Kehoe <kehoea@parhasard.net>
parents:
5344
diff
changeset
|
93 (setq gtk-font-regexp-ascii (if-fboundp 'charset-registries |
| 4103 | 94 (aref (charset-registries 'ascii) 0) |
| 95 "iso8859-1"))) | |
| 462 | 96 (setq gtk-font-menu-registry-encoding |
| 97 (if (featurep 'mule) "*-*" "iso8859-1")) | |
| 98 (let ((case-fold-search t) | |
| 99 family size weight entry monospaced-p | |
| 100 dev-cache cache families sizes weights) | |
| 101 (dolist (name (cond ((null debug) ; debugging kludge | |
| 2527 | 102 (font-list "*-*-*-*-*-*-*-*-*-*-*-*-*-*" device)) |
| 462 | 103 ((stringp debug) (split-string debug "\n")) |
| 104 (t debug))) | |
| 105 (when (and (string-match gtk-font-regexp-ascii name) | |
| 106 (string-match gtk-font-regexp name)) | |
| 107 (setq weight (capitalize (match-string 1 name)) | |
| 108 size (string-to-int (match-string 6 name))) | |
| 109 (or (string-match gtk-font-regexp-foundry-and-family name) | |
| 110 (error "internal error")) | |
| 111 (setq family (capitalize (match-string 1 name))) | |
| 112 (or (string-match gtk-font-regexp-spacing name) | |
| 113 (error "internal error")) | |
| 114 (setq monospaced-p (string= "m" (match-string 1 name))) | |
| 115 (unless (string-match gtk-fonts-menu-junk-families family) | |
| 116 (setq entry (or (vassoc family cache) | |
| 117 (car (setq cache | |
| 118 (cons (vector family nil nil t) | |
| 119 cache))))) | |
| 120 (or (member family families) (push family families)) | |
| 121 (or (member weight weights) (push weight weights)) | |
| 122 (or (member size sizes) (push size sizes)) | |
| 123 (or (member weight (aref entry 1)) (push weight (aref entry 1))) | |
| 124 (or (member size (aref entry 2)) (push size (aref entry 2))) | |
| 125 (aset entry 3 (and (aref entry 3) monospaced-p))))) | |
| 126 ;; | |
| 127 ;; Hack scalable fonts. | |
| 128 ;; Some fonts come only in scalable versions (the only size is 0) | |
| 129 ;; and some fonts come in both scalable and non-scalable versions | |
| 130 ;; (one size is 0). If there are any scalable fonts at all, make | |
| 131 ;; sure that the union of all point sizes contains at least some | |
| 132 ;; common sizes - it's possible that some sensible sizes might end | |
| 133 ;; up not getting mentioned explicitly. | |
| 134 ;; | |
| 135 (if (member 0 sizes) | |
| 136 (let ((common '(60 80 100 120 140 160 180 240))) | |
| 137 (while common | |
| 138 (or;;(member (car common) sizes) ; not enough slack | |
| 139 (let ((rest sizes) | |
| 140 (done nil)) | |
| 141 (while (and (not done) rest) | |
| 142 (if (and (> (car common) (- (car rest) 5)) | |
| 143 (< (car common) (+ (car rest) 5))) | |
| 144 (setq done t)) | |
| 145 (setq rest (cdr rest))) | |
| 146 done) | |
| 147 (setq sizes (cons (car common) sizes))) | |
| 148 (setq common (cdr common))) | |
| 149 (setq sizes (delq 0 sizes)))) | |
| 150 | |
| 151 (setq families (sort families 'string-lessp) | |
| 152 weights (sort weights 'string-lessp) | |
| 153 sizes (sort sizes '<)) | |
| 154 | |
| 155 (dolist (entry cache) | |
| 156 (aset entry 1 (sort (aref entry 1) 'string-lessp)) | |
| 157 (aset entry 2 (sort (aref entry 2) '<))) | |
| 158 | |
| 159 (setq dev-cache (assq device device-fonts-cache)) | |
| 160 (or dev-cache | |
| 161 (setq dev-cache (car (push (list device) device-fonts-cache)))) | |
| 162 (setcdr | |
| 163 dev-cache | |
| 164 (vector | |
| 165 cache | |
| 166 (mapcar (lambda (x) | |
| 167 (vector x | |
| 168 (list 'font-menu-set-font x nil nil) | |
|
5344
2a54dfbe434f
Don't quote keywords, they've been self-quoting for well over a decade.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4103
diff
changeset
|
169 :style 'radio :active nil :selected nil)) |
| 462 | 170 families) |
| 171 (mapcar (lambda (x) | |
| 172 (vector (if (/= 0 (% x 10)) | |
| 1104 | 173 (number-to-string (/ x 10.0)) |
| 174 (number-to-string (/ x 10))) | |
| 462 | 175 (list 'font-menu-set-font nil nil x) |
|
5344
2a54dfbe434f
Don't quote keywords, they've been self-quoting for well over a decade.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4103
diff
changeset
|
176 :style 'radio :active nil :selected nil)) |
| 462 | 177 sizes) |
| 178 (mapcar (lambda (x) | |
| 179 (vector x | |
| 180 (list 'font-menu-set-font nil x nil) | |
|
5344
2a54dfbe434f
Don't quote keywords, they've been self-quoting for well over a decade.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4103
diff
changeset
|
181 :style 'radio :active nil :selected nil)) |
| 462 | 182 weights))) |
| 183 (cdr dev-cache))) | |
| 184 | |
| 185 ;; Extract font information from a face. We examine both the | |
| 186 ;; user-specified font name and the canonical (`true') font name. | |
| 187 ;; These can appear to have totally different properties. | |
| 188 ;; For examples, see the prolog above. | |
| 189 | |
| 190 ;; We use the user-specified one if possible, else use the truename. | |
| 191 ;; If the user didn't specify one (with "-dt-*-*", for example) | |
| 192 ;; get the truename and use the possibly suboptimal data from that. | |
| 193 ;;;###autoload | |
| 194 (defun* gtk-font-menu-font-data (face dcache) | |
| 195 (defvar gtk-font-regexp) | |
| 196 (defvar gtk-font-regexp-foundry-and-family) | |
| 197 (let* ((case-fold-search t) | |
| 198 (domain (if font-menu-this-frame-only-p | |
| 199 (selected-frame) | |
| 200 (selected-device))) | |
| 201 (name (font-instance-name (face-font-instance face domain))) | |
| 202 (truename (font-instance-truename | |
| 203 (face-font-instance face domain | |
| 204 (if (featurep 'mule) 'ascii)))) | |
| 205 family size weight entry slant) | |
| 206 (when (string-match gtk-font-regexp-foundry-and-family name) | |
| 207 (setq family (capitalize (match-string 1 name))) | |
| 208 (setq entry (vassoc family (aref dcache 0)))) | |
| 209 (when (and (null entry) | |
| 210 (string-match gtk-font-regexp-foundry-and-family truename)) | |
| 211 (setq family (capitalize (match-string 1 truename))) | |
| 212 (setq entry (vassoc family (aref dcache 0)))) | |
| 213 (when (null entry) | |
| 214 (return-from gtk-font-menu-font-data (make-vector 5 nil))) | |
| 215 | |
| 216 (when (string-match gtk-font-regexp name) | |
| 217 (setq weight (capitalize (match-string 1 name))) | |
| 218 (setq size (string-to-int (match-string 6 name)))) | |
| 219 | |
| 220 (when (string-match gtk-font-regexp truename) | |
| 221 (when (not (member weight (aref entry 1))) | |
| 222 (setq weight (capitalize (match-string 1 truename)))) | |
| 223 (when (not (member size (aref entry 2))) | |
| 224 (setq size (string-to-int (match-string 6 truename)))) | |
| 225 (setq slant (capitalize (match-string 2 truename)))) | |
| 226 | |
| 227 (vector entry family size weight slant))) | |
| 228 | |
| 229 (defun gtk-font-menu-load-font (family weight size slant resolution) | |
| 230 "Try to load a font with the requested properties. | |
| 231 The weight, slant and resolution are only hints." | |
| 232 (when (integerp size) (setq size (int-to-string size))) | |
| 233 (let (font) | |
| 234 (catch 'got-font | |
| 235 (dolist (weight (list weight "*")) | |
| 236 (dolist (slant | |
| 237 (cond ((string-equal slant "O") '("O" "I" "*")) | |
| 238 ((string-equal slant "I") '("I" "O" "*")) | |
| 239 ((string-equal slant "*") '("*")) | |
| 240 (t (list slant "*")))) | |
| 241 (dolist (resolution | |
| 242 (if (string-equal resolution "*-*") | |
| 243 (list resolution) | |
| 244 (list resolution "*-*"))) | |
| 245 (when (setq font | |
| 246 (make-font-instance | |
| 247 (concat "-*-" family "-" weight "-" slant "-*-*-*-" | |
| 248 size "-" resolution "-*-*-" | |
| 249 gtk-font-menu-registry-encoding) | |
| 250 nil t)) | |
| 251 (throw 'got-font font)))))))) | |
| 252 | |
| 253 (provide 'gtk-font-menu) | |
| 254 | |
| 255 ;;; gtk-font-menu.el ends here |