/[emacs]/emacs/lisp/case-table.el
ViewVC logotype

Diff of /emacs/lisp/case-table.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.28 by rms, Fri Jan 21 00:26:39 2005 UTC revision 1.29 by handa, Wed Feb 2 00:57:07 2005 UTC
# Line 1  Line 1 
1  ;;; case-table.el --- code to extend the character set and support case tables  ;;; case-table.el --- code to extend the character set and support case tables
2    
3  ;; Copyright (C) 1988, 1994 Free Software Foundation, Inc.  ;; Copyright (C) 1988, 1994, 2005 Free Software Foundation, Inc.
4    
5  ;; Author: Howard Gayle  ;; Author: Howard Gayle
6  ;; Maintainer: FSF  ;; Maintainer: FSF
# Line 62  Line 62 
62         (describe-vector description)         (describe-vector description)
63         (help-mode)))))         (help-mode)))))
64    
65    (defun get-upcase-table (case-table)
66      "Return the upcase table of CASE-TABLE."
67      (or (char-table-extra-slot case-table 0)
68          ;; Setup all extra slots of CASE-TABLE by temporarily selecting
69          ;; it as the standard case table.
70          (let ((old (standard-case-table)))
71            (unwind-protect
72                (progn
73                  (set-standard-case-table case-table)
74                  (char-table-extra-slot case-table 0))
75              (or (eq case-table old)
76                  (set-standard-case-table old))))))
77    
78  (defun copy-case-table (case-table)  (defun copy-case-table (case-table)
79    (let ((copy (copy-sequence case-table)))    (let ((copy (copy-sequence case-table))
80      ;; Clear out the extra slots so that they will be          (up (char-table-extra-slot case-table 0)))
81      ;; recomputed from the main (downcase) table.      ;; Clear out the extra slots (except for upcase table) so that
82      (set-char-table-extra-slot copy 0 nil)      ;; they will be recomputed from the main (downcase) table.
83        (if up
84            (set-char-table-extra-slot copy 0 (copy-sequence up)))
85      (set-char-table-extra-slot copy 1 nil)      (set-char-table-extra-slot copy 1 nil)
86      (set-char-table-extra-slot copy 2 nil)      (set-char-table-extra-slot copy 2 nil)
87      copy))      copy))
# Line 87  indicate left and right delimiters." Line 102  indicate left and right delimiters."
102    (setq r (set-case-syntax-1 r))    (setq r (set-case-syntax-1 r))
103    (aset table l l)    (aset table l l)
104    (aset table r r)    (aset table r r)
105      (let ((up (get-upcase-table table)))
106        (aset up l l)
107        (aset up r r))
108    ;; Clear out the extra slots so that they will be    ;; Clear out the extra slots so that they will be
109    ;; recomputed from the main (downcase) table.    ;; recomputed from the main (downcase) table and upcase table.
   (set-char-table-extra-slot table 0 nil)  
110    (set-char-table-extra-slot table 1 nil)    (set-char-table-extra-slot table 1 nil)
111    (set-char-table-extra-slot table 2 nil)    (set-char-table-extra-slot table 2 nil)
112    (modify-syntax-entry l (concat "(" (char-to-string r) "  ")    (modify-syntax-entry l (concat "(" (char-to-string r) "  ")
# Line 103  This sets the entries for characters UC Line 120  This sets the entries for characters UC
120  that will be used as the downcase part of a case table.  that will be used as the downcase part of a case table.
121  It also modifies `standard-syntax-table' to give them the syntax of  It also modifies `standard-syntax-table' to give them the syntax of
122  word constituents."  word constituents."
123    (unless (= (charset-bytes (char-charset uc))    (setq uc (set-case-syntax-1 uc))
124               (charset-bytes (char-charset lc)))    (setq lc (set-case-syntax-1 lc))
125      (error "Can't casify chars with different `charset-bytes' values"))    (aset table uc lc)
126      (aset table lc lc)
127      (let ((up (get-upcase-table table)))
128        (aset up uc uc)
129        (aset up lc uc))
130      ;; Clear out the extra slots so that they will be
131      ;; recomputed from the main (downcase) table and upcase table.
132      (set-char-table-extra-slot table 1 nil)
133      (set-char-table-extra-slot table 2 nil)
134      (modify-syntax-entry lc "w   " (standard-syntax-table))
135      (modify-syntax-entry uc "w   " (standard-syntax-table)))
136    
137    (defun set-upcase-syntax (uc lc table)
138      "Make character UC an upcase of character LC.
139    It also modifies `standard-syntax-table' to give them the syntax of
140    word constituents."
141      (setq uc (set-case-syntax-1 uc))
142      (setq lc (set-case-syntax-1 lc))
143      (let ((up (get-upcase-table table)))
144        (aset up uc uc)
145        (aset up lc uc))
146      ;; Clear out the extra slots so that they will be
147      ;; recomputed from the main (downcase) table and upcase table.
148      (set-char-table-extra-slot table 1 nil)
149      (set-char-table-extra-slot table 2 nil)
150      (modify-syntax-entry lc "w   " (standard-syntax-table))
151      (modify-syntax-entry uc "w   " (standard-syntax-table)))
152    
153    (defun set-downcase-syntax (uc lc table)
154      "Make character LC a downcase of character UC.
155    It also modifies `standard-syntax-table' to give them the syntax of
156    word constituents."
157    (setq uc (set-case-syntax-1 uc))    (setq uc (set-case-syntax-1 uc))
158    (setq lc (set-case-syntax-1 lc))    (setq lc (set-case-syntax-1 lc))
159    (aset table uc lc)    (aset table uc lc)
160    (aset table lc lc)    (aset table lc lc)
161    ;; Clear out the extra slots so that they will be    ;; Clear out the extra slots so that they will be
162    ;; recomputed from the main (downcase) table.    ;; recomputed from the main (downcase) table and upcase table.
   (set-char-table-extra-slot table 0 nil)  
163    (set-char-table-extra-slot table 1 nil)    (set-char-table-extra-slot table 1 nil)
164    (set-char-table-extra-slot table 2 nil)    (set-char-table-extra-slot table 2 nil)
165    (modify-syntax-entry lc "w   " (standard-syntax-table))    (modify-syntax-entry lc "w   " (standard-syntax-table))
# Line 126  It also modifies `standard-syntax-table' Line 173  It also modifies `standard-syntax-table'
173  SYNTAX should be \" \", \"w\", \".\" or \"_\"."  SYNTAX should be \" \", \"w\", \".\" or \"_\"."
174    (setq c (set-case-syntax-1 c))    (setq c (set-case-syntax-1 c))
175    (aset table c c)    (aset table c c)
176      (let ((up (get-upcase-table table)))
177        (aset up c c))
178    ;; Clear out the extra slots so that they will be    ;; Clear out the extra slots so that they will be
179    ;; recomputed from the main (downcase) table.    ;; recomputed from the main (downcase) table and upcase table.
   (set-char-table-extra-slot table 0 nil)  
180    (set-char-table-extra-slot table 1 nil)    (set-char-table-extra-slot table 1 nil)
181    (set-char-table-extra-slot table 2 nil)    (set-char-table-extra-slot table 2 nil)
182    (modify-syntax-entry c syntax (standard-syntax-table)))    (modify-syntax-entry c syntax (standard-syntax-table)))

Legend:
Removed from v.1.28  
changed lines
  Added in v.1.29

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26