Mercurial > hg > xemacs-beta

view lisp/gtk-font-menu.el @ 4677:8f1ee2d15784

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Support full Common Lisp multiple values in C. lisp/ChangeLog 2009-08-11 Aidan Kehoe <kehoea@parhasard.net> * bytecomp.el : Update this file to support full C-level multiple values. This involves: -- Four new bytecodes, and special compiler functions to compile multiple-value-call, multiple-value-list-internal, values, values-list, and, since it now needs to pass back multiple values and is a special form, throw. -- There's a new compiler variable, byte-compile-checks-on-load, which is a list of forms that are evaluated at the very start of a file, with an error thrown if any of them give nil. -- The header is now inserted *after* compilation, giving a chance for the compilation process to influence what those checks are. There is still a check done before compilation for non-ASCII characters, to try to turn off dynamic docstrings if appopriate, in `byte-compile-maybe-reset-coding'. Space is reserved for checks; comments describing the version of the byte compiler generating the file are inserted if space remains for them. * bytecomp.el (byte-compile-version): Update this, we're a newer version of the byte compiler. * byte-optimize.el (byte-optimize-funcall): Correct a comment. * bytecomp.el (byte-compile-lapcode): Discard the arg with byte-multiple-value-call. * bytecomp.el (byte-compile-checks-and-comments-space): New variable, describe how many octets to reserve for checks at the start of byte-compiled files. * cl-compat.el: Remove the fake multiple-value implementation. Have the functions that use it use the real multiple-value implementation instead. * cl-macs.el (cl-block-wrapper, cl-block-throw): Revise the byte-compile properties of these symbols to work now we've made throw into a special form; keep the byte-compile properties as anonymous lambdas, since we don't have docstrings for them. * cl-macs.el (multiple-value-bind, multiple-value-setq) (multiple-value-list, nth-value): Update these functions to work with the C support for multiple values. * cl-macs.el (values): Modify the setf handler for this to call #'multiple-value-list-internal appropriately. * cl-macs.el (cl-setf-do-store): If the store form is a cons, treat it specially as wrapping the store value. * cl.el (cl-block-wrapper): Make this an alias of #'and, not #'identity, since it needs to pass back multiple values. * cl.el (multiple-value-apply): We no longer support this, mark it obsolete. * lisp-mode.el (eval-interactive-verbose): Remove a useless space in the docstring. * lisp-mode.el (eval-interactive): Update this function and its docstring. It now passes back a list, basically wrapping any eval calls with multiple-value-list. This allows multiple values to be printed by default in *scratch*. * lisp-mode.el (prin1-list-as-multiple-values): New function, printing a list as multiple values in the manner of Bruno Haible's clisp, separating each entry with " ;\n". * lisp-mode.el (eval-last-sexp): Call #'prin1-list-as-multiple-values on the return value of #'eval-interactive. * lisp-mode.el (eval-defun): Call #'prin1-list-as-multiple-values on the return value of #'eval-interactive. * mouse.el (mouse-eval-sexp): Deal with lists corresponding to multiple values from #'eval-interactive. Call #'cl-prettyprint, which is always available, instead of sometimes calling #'pprint and sometimes falling back to prin1. * obsolete.el (obsolete-throw): New function, called from eval.c when #'funcall encounters an attempt to call #'throw (now a special form) as a function. Only needed for compatibility with 21.4 byte-code. man/ChangeLog addition: 2009-08-11 Aidan Kehoe <kehoea@parhasard.net> * cl.texi (Organization): Remove references to the obsolete multiple-value emulating code. src/ChangeLog addition: 2009-08-11 Aidan Kehoe <kehoea@parhasard.net> * bytecode.c (enum Opcode /* Byte codes */): Add four new bytecodes, to deal with multiple values. (POP_WITH_MULTIPLE_VALUES): New macro. (POP): Modify this macro to ignore multiple values. (DISCARD_PRESERVING_MULTIPLE_VALUES): New macro. (DISCARD): Modify this macro to ignore multiple values. (TOP_WITH_MULTIPLE_VALUES): New macro. (TOP_ADDRESS): New macro. (TOP): Modify this macro to ignore multiple values. (TOP_LVALUE): New macro. (Bcall): Ignore multiple values where appropriate. (Breturn): Pass back multiple values. (Bdup): Preserve multiple values. Use TOP_LVALUE with most bytecodes that assign anything to anything. (Bbind_multiple_value_limits, Bmultiple_value_call, Bmultiple_value_list_internal, Bthrow): Implement the new bytecodes. (Bgotoifnilelsepop, Bgotoifnonnilelsepop, BRgotoifnilelsepop, BRgotoifnonnilelsepop): Discard any multiple values. * callint.c (Fcall_interactively): Ignore multiple values when calling #'eval, in two places. * device-x.c (x_IO_error_handler): * macros.c (pop_kbd_macro_event): * eval.c (Fsignal): * eval.c (flagged_a_squirmer): Call throw_or_bomb_out, not Fthrow, now that the latter is a special form. * eval.c: Make Qthrow, Qobsolete_throw available as symbols. Provide multiple_value_current_limit, multiple-values-limit (the latter as specified by Common Lisp. * eval.c (For): Ignore multiple values when comparing with Qnil, but pass any multiple values back for the last arg. * eval.c (Fand): Ditto. * eval.c (Fif): Ignore multiple values when examining the result of the condition. * eval.c (Fcond): Ignore multiple values when comparing what the clauses give, but pass them back if a clause gave non-nil. * eval.c (Fprog2): Never pass back multiple values. * eval.c (FletX, Flet): Ignore multiple when evaluating what exactly symbols should be bound to. * eval.c (Fwhile): Ignore multiple values when evaluating the test. * eval.c (Fsetq, Fdefvar, Fdefconst): Ignore multiple values. * eval.c (Fthrow): Declare this as a special form; ignore multiple values for TAG, preserve them for VALUE. * eval.c (throw_or_bomb_out): Make this available to other files, now Fthrow is a special form. * eval.c (Feval): Ignore multiple values when calling a compiled function, a non-special-form subr, or a lambda expression. * eval.c (Ffuncall): If we attempt to call #'throw (now a special form) as a function, don't error, call #'obsolete-throw instead. * eval.c (make_multiple_value, multiple_value_aset) (multiple_value_aref, print_multiple_value, mark_multiple_value) (size_multiple_value): Implement the multiple_value type. Add a long comment describing our implementation. * eval.c (bind_multiple_value_limits): New function, used by the bytecode and by #'multiple-value-call, #'multiple-value-list-internal. * eval.c (multiple_value_call): New function, used by the bytecode and #'multiple-value-call. * eval.c (Fmultiple_value_call): New special form. * eval.c (multiple_value_list_internal): New function, used by the byte code and #'multiple-value-list-internal. * eval.c (Fmultiple_value_list_internal, Fmultiple_value_prog1): New special forms. * eval.c (Fvalues, Fvalues_list): New Lisp functions. * eval.c (values2): New function, for C code returning multiple values. * eval.c (syms_of_eval): Make our new Lisp functions and symbols available. * eval.c (multiple-values-limit): Make this available to Lisp. * event-msw.c (dde_eval_string): * event-stream.c (execute_help_form): * glade.c (connector): * glyphs-widget.c (glyph_instantiator_to_glyph): * glyphs.c (evaluate_xpm_color_symbols): * gui-x.c (wv_set_evalable_slot, button_item_to_widget_value): * gui.c (gui_item_value, gui_item_display_flush_left): * lread.c (check_if_suppressed): * menubar-gtk.c (menu_convert, menu_descriptor_to_widget_1): * menubar-msw.c (populate_menu_add_item): * print.c (Fwith_output_to_temp_buffer): * symbols.c (Fsetq_default): Ignore multiple values when calling Feval. * symeval.h: Add the header declarations necessary for the multiple-values implementation. * inline.c: #include symeval.h, now that it has some inline functions. * lisp.h: Update Fthrow's declaration. Make throw_or_bomb_out available to all files. * lrecord.h (enum lrecord_type): Add the multiple_value type here.
author Aidan Kehoe <kehoea@parhasard.net>
date Sun, 16 Aug 2009 20:55:49 +0100
parents b4f4e0cc90f1
children 2a54dfbe434f 308d34e9f07d
line wrap: on
line source

;; gtk-font-menu.el --- Managing menus of GTK fonts.

;; Copyright (C) 1994 Free Software Foundation, Inc.
;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp.
;; Copyright (C) 1997 Sun Microsystems

;; Author: Jamie Zawinski <jwz@jwz.org>
;; Restructured by: Jonathan Stigelman <Stig@hackvan.com>
;; Mule-ized by: Martin Buchholz
;; More restructuring for MS-Windows by Andy Piper <andy@xemacs.org>
;; GTK-ized by: William Perry <wmperry@xemacs.org>

;; This file is part of XEmacs.

;; XEmacs is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; XEmacs is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with XEmacs; see the file COPYING.  If not, write to the 
;; Free Software Foundation, 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Code:

;; #### - The comment that this file was GTK-ized by Wm Perry is a lie;
;; nothing was done except to rename everything that was x- to gtk-.
;; This is harmless, but we should reintegrate so that GTK can take
;; advantage of fontconfig, too, I think.

;; #### - implement these...
;;
;;; (defvar font-menu-ignore-proportional-fonts nil
;;;   "*If non-nil, then the font menu will only show fixed-width fonts.")

(require 'font-menu)

(globally-declare-boundp
 '(gtk-font-regexp
   gtk-font-regexp-foundry-and-family
   gtk-font-regexp-spacing))

(defvar gtk-font-menu-registry-encoding nil
  "Registry and encoding to use with font menu fonts.")

(defvar gtk-fonts-menu-junk-families
  (mapconcat
   #'identity
   '("cursor" "glyph" "symbol"	; Obvious losers.
     "\\`Ax...\\'"		; FrameMaker fonts - there are just way too
				;  many of these, and there is a different
				;  font family for each font face!  Losers.
				;  "Axcor" -> "Applix Courier Roman",
				;  "Axcob" -> "Applix Courier Bold", etc.
     )
   "\\|")
  "A regexp matching font families which are uninteresting (e.g. cursor fonts).")

(defun hack-font-truename (fn)
  ;; #### This is duplicated from x-font-menu.el.
  "Filter the output of `font-instance-truename' to deal with font sets."
  (if (string-match "," (font-instance-truename fn))
      (let ((fpnt (nth 8 (split-string (font-instance-name fn) "-")))
	    (flist (split-string (font-instance-truename fn) ","))
	    ret)
	(while flist
	  (if (string-equal fpnt (nth 8 (split-string (car flist) "-")))
	      (progn (setq ret (car flist)) (setq flist nil))
	    (setq flist (cdr flist))
	    ))
	ret)
    (font-instance-truename fn)))

(defvar gtk-font-regexp-ascii nil
  "This is used to filter out font families that can't display ASCII text.
It must be set at run-time.")

;;;###autoload
(defun gtk-reset-device-font-menus (device &optional debug)
  "Generates the `Font', `Size', and `Weight' submenus for the Options menu.
This is run the first time that a font-menu is needed for each device.
If you don't like the lazy invocation of this function, you can add it to
`create-device-hook' and that will make the font menus respond more quickly
when they are selected for the first time.  If you add fonts to your system, 
or if you change your font path, you can call this to re-initialize the menus."
  ;; by Stig@hackvan.com
  ;; #### - this should implement a `menus-only' option, which would
  ;; recalculate the menus from the cache w/o having to do font-list again.
  (unless gtk-font-regexp-ascii
    (setq gtk-font-regexp-ascii (if-fboundp #'charset-registries
                                    (aref (charset-registries 'ascii) 0)
                                  "iso8859-1")))
  (setq gtk-font-menu-registry-encoding
	(if (featurep 'mule) "*-*" "iso8859-1"))
  (let ((case-fold-search t)
	family size weight entry monospaced-p
	dev-cache cache families sizes weights)
    (dolist (name (cond ((null debug)	; debugging kludge
			 (font-list "*-*-*-*-*-*-*-*-*-*-*-*-*-*" device))
			((stringp debug) (split-string debug "\n"))
			(t debug)))
      (when (and (string-match gtk-font-regexp-ascii name)
		 (string-match gtk-font-regexp name))
	(setq weight (capitalize (match-string 1 name))
	      size   (string-to-int (match-string 6 name)))
	(or (string-match gtk-font-regexp-foundry-and-family name)
	    (error "internal error"))
	(setq family (capitalize (match-string 1 name)))
	(or (string-match gtk-font-regexp-spacing name)
	    (error "internal error"))
	(setq monospaced-p (string= "m" (match-string 1 name)))
	(unless (string-match gtk-fonts-menu-junk-families family)
	  (setq entry (or (vassoc family cache)
			  (car (setq cache
				     (cons (vector family nil nil t)
					   cache)))))
	  (or (member family families) (push family families))
	  (or (member weight weights)  (push weight weights))
	  (or (member size   sizes)    (push size   sizes))
	  (or (member weight (aref entry 1)) (push weight (aref entry 1)))
	  (or (member size   (aref entry 2)) (push size   (aref entry 2)))
	  (aset entry 3 (and (aref entry 3) monospaced-p)))))
    ;;
    ;; Hack scalable fonts.
    ;; Some fonts come only in scalable versions (the only size is 0)
    ;; and some fonts come in both scalable and non-scalable versions
    ;; (one size is 0).  If there are any scalable fonts at all, make
    ;; sure that the union of all point sizes contains at least some
    ;; common sizes - it's possible that some sensible sizes might end
    ;; up not getting mentioned explicitly.
    ;;
    (if (member 0 sizes)
	(let ((common '(60 80 100 120 140 160 180 240)))
	  (while common
	    (or;;(member (car common) sizes)   ; not enough slack
	     (let ((rest sizes)
		   (done nil))
	       (while (and (not done) rest)
		 (if (and (> (car common) (- (car rest) 5))
			  (< (car common) (+ (car rest) 5)))
		     (setq done t))
		 (setq rest (cdr rest)))
	       done)
	     (setq sizes (cons (car common) sizes)))
	    (setq common (cdr common)))
	  (setq sizes (delq 0 sizes))))
    
    (setq families (sort families 'string-lessp)
	  weights  (sort weights 'string-lessp)
	  sizes    (sort sizes '<))
    
    (dolist (entry cache)
      (aset entry 1 (sort (aref entry 1) 'string-lessp))
      (aset entry 2 (sort (aref entry 2) '<)))

    (setq dev-cache (assq device device-fonts-cache))
    (or dev-cache
	(setq dev-cache (car (push (list device) device-fonts-cache))))
    (setcdr
     dev-cache
     (vector
      cache
      (mapcar (lambda (x)
		(vector x
			(list 'font-menu-set-font x nil nil)
			':style 'radio ':active nil ':selected nil))
	      families)
      (mapcar (lambda (x)
		(vector (if (/= 0 (% x 10))
			    (number-to-string (/ x 10.0))
			  (number-to-string (/ x 10)))
			(list 'font-menu-set-font nil nil x)
			':style 'radio ':active nil ':selected nil))
	      sizes)
      (mapcar (lambda (x)
		(vector x
			(list 'font-menu-set-font nil x nil)
			':style 'radio ':active nil ':selected nil))
	      weights)))
    (cdr dev-cache)))

;; Extract font information from a face.  We examine both the
;; user-specified font name and the canonical (`true') font name.
;; These can appear to have totally different properties.
;; For examples, see the prolog above.

;; We use the user-specified one if possible, else use the truename.
;; If the user didn't specify one (with "-dt-*-*", for example)
;; get the truename and use the possibly suboptimal data from that.
;;;###autoload
(defun* gtk-font-menu-font-data (face dcache)
  (defvar gtk-font-regexp)
  (defvar gtk-font-regexp-foundry-and-family)
  (let* ((case-fold-search t)
	 (domain (if font-menu-this-frame-only-p
				  (selected-frame)
				(selected-device)))
	 (name (font-instance-name (face-font-instance face domain)))
	 (truename (font-instance-truename
		    (face-font-instance face domain
					(if (featurep 'mule) 'ascii))))
	 family size weight entry slant)
    (when (string-match gtk-font-regexp-foundry-and-family name)
      (setq family (capitalize (match-string 1 name)))
      (setq entry (vassoc family (aref dcache 0))))
    (when (and (null entry)
	       (string-match gtk-font-regexp-foundry-and-family truename))
      (setq family (capitalize (match-string 1 truename)))
      (setq entry  (vassoc family (aref dcache 0))))
    (when (null entry)
      (return-from gtk-font-menu-font-data (make-vector 5 nil)))
    
    (when (string-match gtk-font-regexp name)
      (setq weight (capitalize    (match-string 1 name)))
      (setq size   (string-to-int (match-string 6 name))))
      
    (when (string-match gtk-font-regexp truename)
      (when (not (member weight (aref entry 1)))
	(setq weight (capitalize (match-string 1 truename))))
      (when (not (member size   (aref entry 2)))
	(setq size (string-to-int (match-string 6 truename))))
      (setq slant (capitalize (match-string 2 truename))))
      
    (vector entry family size weight slant)))

(defun gtk-font-menu-load-font (family weight size slant resolution)
  "Try to load a font with the requested properties.
The weight, slant and resolution are only hints."
  (when (integerp size) (setq size (int-to-string size)))
  (let (font)
    (catch 'got-font
      (dolist (weight (list weight "*"))
	(dolist (slant
		 (cond ((string-equal slant "O") '("O" "I" "*"))
		       ((string-equal slant "I") '("I" "O" "*"))
		       ((string-equal slant "*") '("*"))
		       (t (list slant "*"))))
	  (dolist (resolution
		   (if (string-equal resolution "*-*")
		       (list resolution)
		     (list resolution "*-*")))
	    (when (setq font
			(make-font-instance
			 (concat  "-*-" family "-" weight "-" slant "-*-*-*-"
				  size "-" resolution "-*-*-"
				  gtk-font-menu-registry-encoding)
			 nil t))
	      (throw 'got-font font))))))))

(provide 'gtk-font-menu)

;;; gtk-font-menu.el ends here