Hello. As you might have guessed, I've been going through an old build workspace and cleaning out the stuff in it. The one controversial thing is the change to display tables. This is logically a good thing, but it breaks some code that assumes that the result of `make-display-table' is always a vector of 256 and hence it can call `aset' on the return value. This occurs maybe 3 or 4 times in the packages and I've fixed them up to check for the existence of `put-display-table' and use it preferentially. But before I commit something like this that causes breakage, I'd like some comments, hopefully of the "go ahead and commit" variety :) ben lisp/ChangeLog addition: 2005-11-13 Ben Wing <ben(a)xemacs.org&gt; * disp-table.el: * disp-table.el (describe-display-table): * disp-table.el (make-display-table): * disp-table.el (display-table-p): New. * disp-table.el (frob-display-table): * disp-table.el (put-display-table-range): New. * disp-table.el (put-display-table): New. * disp-table.el (get-display-table): New. * disp-table.el (standard-display-default-1): * disp-table.el (standard-display-ascii): * disp-table.el (standard-display-g1): * disp-table.el (standard-display-graphic): * disp-table.el (standard-display-underline): * disp-table.el (standard-display-european): * font.el: * font.el (font-caps-display-table): Make display tables be char tables, not vectors of 256. Create new functions `put-display-table', `get-display-table', `put-display-table-range' for accessing/modifying a display table in an abstract fashion. Rewrite font.el to use them. NOTE: This will break code that assumes it can `aset' display tables. build source patch: Diff command: bash -ci "cvs-diff --show-c-function -no-changelog " Files affected: lisp/font.el lisp/disp-table.el cvs server: Diffing lisp Index: lisp/disp-table.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/disp-table.el,v retrieving revision 1.2 diff -u -p -r1.2 disp-table.el --- lisp/disp-table.el 1997/12/06 22:26:09 1.2 +++ lisp/disp-table.el 2005/11/13 10:58:32 ＠＠ -2,8 +2,8 ＠＠ ;; Copyright (C) 1987, 1994, 1997 Free Software Foundation, Inc. ;; Copyright (C) 1995 Sun Microsystems. +;; Copyright (C) 2005 Ben Wing. -;; Author: Howard Gayle ;; Maintainer: XEmacs Development Team ;; Keywords: i18n, internal ＠＠ -28,15 +28,13 ＠＠ ;;; Commentary: -;; #### Need lots of work. make-display-table depends on a value -;; that is a define in the C code. Maybe we should just move the -;; function into C. +;; #### Needs work. -;; #### display-tables-as-vectors is really evil and a big pain in -;; the ass. - ;; Rewritten for XEmacs July 1995, Ben Wing. - +;; November 1998?, display tables generalized to char/range tables, Hrvoje +;; Niksic. +;; February 2005, rewrite this file to handle generalized display tables, +;; Ben Wing.  ;;; Code: ＠＠ -45,39 +43,54 ＠＠ (with-displaying-help-buffer (lambda () (princ "\nCharacter display glyph sequences:\n") - (save-excursion - (let ((vector (make-vector 256 nil)) - (i 0)) - (while (< i 256) - (aset vector i (aref dt i)) - (incf i)) - ;; FSF calls `describe-vector' here, but it is so incredibly - ;; lame a function for that name that I cannot bring myself - ;; to porting it. Here is what `describe-vector' does: - (terpri) - (let ((old (aref vector 0)) - (oldpos 0) - (i 1) - str) - (while (<= i 256) - (when (or (= i 256) - (not (equal old (aref vector i)))) - (if (eq oldpos (1- i)) - (princ (format "%s\t\t%s\n" - (single-key-description (int-char oldpos)) - old)) - (setq str (format "%s - %s" - (single-key-description (int-char oldpos)) - (single-key-description (int-char (1- i))))) - (princ str) - (princ (make-string (max (- 2 (/ (length str) - tab-width)) 1) ?\t)) - (princ old) - (terpri)) - (or (= i 256) - (setq old (aref vector i) - oldpos i))) - (incf i)))))))) + (flet ((describe-display-table-entry + (entry stream) + ;; #### Write better version + (princ entry stream)) + (describe-display-table-range + (first last entry) + (if (eq first last) + (princ (format "%s\t\t" + (single-key-description (int-char first)))) + (let ((str (format "%s - %s" + (single-key-description (int-char first)) + (single-key-description (int-char last))))) + (princ str) + (princ (make-string (max (- 2 (/ (length str) + tab-width)) 1) ?\t)))) + (describe-display-table-entry entry standard-output) + (terpri))) + (cond ((vectorp dt) + (save-excursion + (let ((vector (make-vector 256 nil)) + (i 0)) + (while (< i 256) + (aset vector i (aref dt i)) + (incf i)) + ;; FSF calls `describe-vector' here, but it is so incredibly + ;; lame a function for that name that I cannot bring myself + ;; to port it. Here is what `describe-vector' does: + (terpri) + (let ((old (aref vector 0)) + (oldpos 0) + (i 1)) + (while (<= i 256) + (when (or (= i 256) + (not (equal old (aref vector i)))) + (describe-display-table-range oldpos (1- i) old) + (or (= i 256) + (setq old (aref vector i) + oldpos i))) + (incf i)))))) + ((char-table-p dt) + (describe-char-table dt 'map-char-table + 'describe-display-table-entry + standard-output)) + ((range-table-p dt) + (map-range-table + #'(lambda (beg end value) + (describe-display-table-range beg end value)) + dt))))))) ;;;###autoload (defun describe-current-display-table (&optional domain) ＠＠ -91,19 +104,39 ＠＠ ;;;###autoload (defun make-display-table () - "Return a new, empty display table." - (make-vector 256 nil)) + "Return a new, empty display table. +Modify a display table using `put-display-table'. Look up in display tables +using `get-display-table'. The exact format of display tables and their +specs is described in `current-display-table'." + ;; #### This should do something smarter. + ;; #### Should use range table but there are bugs in range table and + ;; perhaps in callers not expecting this. + ;(make-range-table 'start-closed-end-closed) + ;(make-vector 256 nil) + ;; #### Should be type `display-table' + (make-char-table 'generic)) + +(defun display-table-p (object) + "Return t if OBJECT is a display table. +See `make-display-table'." + (or (and (vectorp object) (= (length object) 256)) + (and (char-table-p object) (memq (char-table-type object) + '(char generic display))) + (range-table-p object))) ;; #### we need a generic frob-specifier function. ;; #### this also needs to be redone like frob-face-property. ;; Let me say one more time how much dynamic scoping sucks. + +;; #### Need more thinking about basic primitives for modifying a specifier. +;; cf `modify-specifier-instances'. -(defun frob-display-table (fdt-function fdt-locale) +(defun frob-display-table (fdt-function fdt-locale &optional tag-set) (or fdt-locale (setq fdt-locale 'global)) - (or (specifier-spec-list current-display-table fdt-locale) + (or (specifier-spec-list current-display-table fdt-locale tag-set) (add-spec-to-specifier current-display-table (make-display-table) - fdt-locale)) + fdt-locale tag-set)) (add-spec-list-to-specifier current-display-table (list (cons fdt-locale ＠＠ -112,11 +145,62 ＠＠ (funcall fdt-function (cdr fdt-x)) fdt-x) (cdar (specifier-spec-list current-display-table - fdt-locale))))))) + fdt-locale tag-set))))))) +(defun put-display-table-range (l h spec display-table) + "Display characters in range L .. H, inclusive, in DISPLAY-TABLE using SPEC. +Display tables are described in `current-display-table'." + (check-argument-type 'display-table-p display-table) + (cond ((vectorp display-table) + (while (<= l h) + (aset display-table l spec) + (setq l (1+ l)))) + ((char-table-p display-table) + (while (<= l h) + (put-char-table l spec display-table) + (setq l (1+ l)))) + ((range-table-p display-table) + (put-range-table l h spec display-table)))) + +(defun put-display-table (ch spec display-table) + "Display character spec CH in DISPLAY-TABLE using SPEC. +CH can be a character, a charset, or t for all characters. +Display tables are described in `current-display-table'." + (cond ((eq ch t) + (cond ((vectorp display-table) + (put-display-table-range 0 (1- (length display-table)) spec + display-table)) + ((range-table-p display-table) + ; major hack + (put-display-table-range 0 (string-to-int "3FFFFFFF" 16) + spec display-table)) + ((char-table-p display-table) + (put-char-table t spec display-table)))) + ((charsetp ch) + (cond ((vectorp display-table) + ;; #### fix + nil) + ((range-table-p display-table) + ;; #### fix + nil) + ((char-table-p display-table) + (put-char-table ch spec display-table)))) + (t (put-display-table-range ch ch spec display-table)))) + +(defun get-display-table (char display-table) + "Return SPEC of CHAR in DISPLAY-TABLE. +See `current-display-table'." + (check-argument-type 'display-table-p display-table) + (cond ((vectorp display-table) + (aref display-table char)) + ((char-table-p display-table) + (get-char-table char display-table)) + ((range-table-p display-table) + (get-range-table char display-table)))) + (defun standard-display-8bit-1 (dt l h) (while (<= l h) - (aset dt l (char-to-string l)) + (put-display-table l (char-to-string l) dt) (setq l (1+ l)))) ;;;###autoload ＠＠ -129,7 +213,7 ＠＠ (defun standard-display-default-1 (dt l h) (while (<= l h) - (aset dt l nil) + (put-display-table l nil dt) (setq l (1+ l)))) ;;;###autoload ＠＠ -145,36 +229,30 ＠＠ "Display character C using printable string S." (frob-display-table (lambda (x) - (aset x c s)) + (put-display-table c s x)) locale)) - -;;; #### should frob in a 'tty locale. - ;;;###autoload (defun standard-display-g1 (c sc &optional locale) "Display character C as character SC in the g1 character set. -This function assumes that your terminal uses the SO/SI characters; -it is meaningless for an X frame." +This only has an effect on TTY devices and assumes that your terminal uses +the SO/SI characters." (frob-display-table (lambda (x) - (aset x c (concat "\016" (char-to-string sc) "\017"))) - locale)) - - -;;; #### should frob in a 'tty locale. + (put-display-table c (concat "\016" (char-to-string sc) "\017") x)) + locale + 'tty)) ;;;###autoload (defun standard-display-graphic (c gc &optional locale) "Display character C as character GC in graphics character set. -This function assumes VT100-compatible escapes; it is meaningless for an -X frame." +This only has an effect on TTY devices and assumes VT100-compatible escapes." (frob-display-table (lambda (x) - (aset x c (concat "\e(0" (char-to-string gc) "\e(B"))) - locale)) + (put-display-table c (concat "\e(0" (char-to-string gc) "\e(B") x)) + locale + 'tty)) -;;; #### should frob in a 'tty locale. ;;; #### the FSF equivalent of this makes this character be displayed ;;; in the 'underline face. There's no current way to do this with ;;; XEmacs display tables. ＠＠ -184,8 +262,9 ＠＠ X frame." "Display character C as character UC plus underlining." (frob-display-table (lambda (x) - (aset x c (concat "\e[4m" (char-to-string uc) "\e[m"))) - locale)) + (put-display-table c (concat "\e[4m" (char-to-string uc) "\e[m") x)) + locale + 'tty)) ;;;###autoload (defun standard-display-european (arg &optional locale) ＠＠ -198,7 +277,7 ＠＠ With prefix argument, enable European ch (lambda (x) (if (or (<= (prefix-numeric-value arg) 0) (and (null arg) - (equal (aref x 160) (char-to-string 160)))) + (equal (get-display-table 160 x) (char-to-string 160)))) (standard-display-default-1 x 160 255) (standard-display-8bit-1 x 160 255))) locale)) Index: lisp/font.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/font.el,v retrieving revision 1.17 diff -u -p -r1.17 font.el --- lisp/font.el 2005/03/25 15:58:03 1.17 +++ lisp/font.el 2005/11/13 10:58:32 ＠＠ -2,7 +2,7 ＠＠ ;; Copyright (c) 1995, 1996 by William M. Perry (wmperry(a)cs.indiana.edu) ;; Copyright (c) 1996, 1997 Free Software Foundation, Inc. -;; Copyright (C) 2002, 2004 Ben Wing. +;; Copyright (C) 2002, 2004, 2005 Ben Wing. ;; Author: wmperry ;; Maintainer: XEmacs Development Team ＠＠ -245,16 +245,16 ＠＠ for use in the 'weight' field of an X fo (i 0)) ;; Standard ASCII characters (while (< i 26) - (aset table (+ i ?a) (+ i ?A)) + (put-display-table (+ i ?a) (+ i ?A) table) (setq i (1+ i))) ;; Now ISO translations (setq i 224) (while (< i 247) ;; Agrave - Ouml - (aset table i (- i 32)) + (put-display-table i (- i 32) table) (setq i (1+ i))) (setq i 248) (while (< i 255) ;; Oslash - Thorn - (aset table i (- i 32)) + (put-display-table i (- i 32) table) (setq i (1+ i))) table))  cvs server: Diffing lisp/mule cvs server: Diffing lisp/term