cgit.sxemacs.org Git - sxemacs/blob - lisp/disp-table.el

   1 ;;; disp-table.el --- functions for dealing with char tables.
   2
   3 ;; Copyright (C) 1987, 1994, 1997 Free Software Foundation, Inc.
   4 ;; Copyright (C) 1995 Sun Microsystems.
   5
   6 ;; Author: Howard Gayle
   7 ;; Maintainer: SXEmacs Development Team
   8 ;; Keywords: i18n, internal
   9
  10 ;; This file is part of SXEmacs.
  11
  12 ;; SXEmacs is free software: you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation, either version 3 of the License, or
  15 ;; (at your option) any later version.
  16
  17 ;; SXEmacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 ;;; Synched up with: Not synched with FSF.
  26
  27 ;;; Commentary:
  28
  29 ;; #### Need lots of work.  make-display-table depends on a value
  30 ;; that is a define in the C code.  Maybe we should just move the
  31 ;; function into C.
  32
  33 ;; #### display-tables-as-vectors is really evil and a big pain in
  34 ;; the ass.
  35
  36 ;; Rewritten for XEmacs July 1995, Ben Wing.
  37
  38 \f
  39 ;;; Code:
  40
  41 (defun describe-display-table (dt)
  42   "Describe the display table DT in a help buffer."
  43   (with-displaying-help-buffer
  44    (lambda ()
  45      (princ "\nCharacter display glyph sequences:\n")
  46      (save-excursion
  47        (let ((vector (make-vector 256 nil))
  48              (i 0))
  49          (while (< i 256)
  50            (aset vector i (aref dt i))
  51            (incf i))
  52          ;; FSF calls `describe-vector' here, but it is so incredibly
  53          ;; lame a function for that name that I cannot bring myself
  54          ;; to porting it.  Here is what `describe-vector' does:
  55          (terpri)
  56          (let ((old (aref vector 0))
  57                (oldpos 0)
  58                (i 1)
  59                str)
  60            (while (<= i 256)
  61              (when (or (= i 256)
  62                        (not (equal old (aref vector i))))
  63                (if (eq oldpos (1- i))
  64                    (princ (format "%s\t\t%s\n"
  65                                   (single-key-description (int-char oldpos))
  66                                   old))
  67                  (setq str (format "%s - %s"
  68                                    (single-key-description (int-char oldpos))
  69                                    (single-key-description (int-char (1- i)))))
  70                  (princ str)
  71                  (princ (make-string (max (- 2 (/ (length str)
  72                                                   tab-width)) 1) ?\t))
  73                  (princ old)
  74                  (terpri))
  75                (or (= i 256)
  76                    (setq old (aref vector i)
  77                          oldpos i)))
  78              (incf i))))))))
  79
  80 ;;;###autoload
  81 (defun describe-current-display-table (&optional domain)
  82   "Describe the display table in use in the selected window and buffer."
  83   (interactive)
  84   (or domain (setq domain (selected-window)))
  85   (let ((disptab (specifier-instance current-display-table domain)))
  86     (if disptab
  87         (describe-display-table disptab)
  88       (message "No display table"))))
  89
  90 ;;;###autoload
  91 (defun make-display-table ()
  92   "Return a new, empty display table."
  93   (make-vector 256 nil))
  94
  95 ;; #### we need a generic frob-specifier function.
  96 ;; #### this also needs to be redone like frob-face-property.
  97
  98 ;; Let me say one more time how much dynamic scoping sucks.
  99
 100 (defun frob-display-table (fdt-function fdt-locale)
 101   (or fdt-locale (setq fdt-locale 'global))
 102   (or (specifier-spec-list current-display-table fdt-locale)
 103       (add-spec-to-specifier current-display-table (make-display-table)
 104                              fdt-locale))
 105   (add-spec-list-to-specifier
 106    current-display-table
 107    (list (cons fdt-locale
 108                (mapcar
 109                 (lambda (fdt-x)
 110                   (funcall fdt-function (cdr fdt-x))
 111                   fdt-x)
 112                 (cdar (specifier-spec-list current-display-table
 113                                            fdt-locale)))))))
 114
 115 (defun standard-display-8bit-1 (dt l h)
 116   (while (<= l h)
 117     (aset dt l (char-to-string l))
 118     (setq l (1+ l))))
 119
 120 ;;;###autoload
 121 (defun standard-display-8bit (l h &optional locale)
 122   "Display characters in the range L to H literally."
 123   (frob-display-table
 124    (lambda (x)
 125      (standard-display-8bit-1 x l h))
 126    locale))
 127
 128 (defun standard-display-default-1 (dt l h)
 129   (while (<= l h)
 130     (aset dt l nil)
 131     (setq l (1+ l))))
 132
 133 ;;;###autoload
 134 (defun standard-display-default (l h &optional locale)
 135   "Display characters in the range L to H using the default notation."
 136   (frob-display-table
 137    (lambda (x)
 138      (standard-display-default-1 x l h))
 139    locale))
 140
 141 ;;;###autoload
 142 (defun standard-display-ascii (c s &optional locale)
 143   "Display character C using printable string S."
 144   (frob-display-table
 145    (lambda (x)
 146      (aset x c s))
 147    locale))
 148
 149
 150 ;;; #### should frob in a 'tty locale.
 151
 152 ;;;###autoload
 153 (defun standard-display-g1 (c sc &optional locale)
 154   "Display character C as character SC in the g1 character set.
 155 This function assumes that your terminal uses the SO/SI characters;
 156 it is meaningless for an X frame."
 157   (frob-display-table
 158    (lambda (x)
 159      (aset x c (concat "\016" (char-to-string sc) "\017")))
 160    locale))
 161
 162
 163 ;;; #### should frob in a 'tty locale.
 164
 165 ;;;###autoload
 166 (defun standard-display-graphic (c gc &optional locale)
 167   "Display character C as character GC in graphics character set.
 168 This function assumes VT100-compatible escapes; it is meaningless for an
 169 X frame."
 170   (frob-display-table
 171    (lambda (x)
 172      (aset x c (concat "\e(0" (char-to-string gc) "\e(B")))
 173    locale))
 174
 175 ;;; #### should frob in a 'tty locale.
 176 ;;; #### the FSF equivalent of this makes this character be displayed
 177 ;;; in the 'underline face.  There's no current way to do this with
 178 ;;; XEmacs display tables.
 179
 180 ;;;###autoload
 181 (defun standard-display-underline (c uc &optional locale)
 182   "Display character C as character UC plus underlining."
 183   (frob-display-table
 184    (lambda (x)
 185      (aset x c (concat "\e[4m" (char-to-string uc) "\e[m")))
 186    locale))
 187
 188 ;;;###autoload
 189 (defun standard-display-european (arg &optional locale)
 190   "Toggle display of European characters encoded with ISO 8859.
 191 When enabled, characters in the range of 160 to 255 display not
 192 as octal escapes, but as accented characters.
 193 With prefix argument, enable European character display iff arg is positive."
 194   (interactive "P")
 195   (frob-display-table
 196    (lambda (x)
 197      (if (or (<= (prefix-numeric-value arg) 0)
 198              (and (null arg)
 199                   (equal (aref x 160) (char-to-string 160))))
 200          (standard-display-default-1 x 160 255)
 201        (standard-display-8bit-1 x 160 255)))
 202    locale))
 203
 204 (provide 'disp-table)
 205
 206 ;;; disp-table.el ends here