LCOV - code coverage report
Current view: top level - lisp - case-table.el (source / functions) Hit Total Coverage
Test: tramp-tests-after.info Lines: 0 88 0.0 %
Date: 2017-08-30 10:12:24 Functions: 0 10 0.0 %

          Line data    Source code
       1             : ;;; case-table.el --- code to extend the character set and support case tables  -*- lexical-binding: t -*-
       2             : 
       3             : ;; Copyright (C) 1988, 1994, 2001-2017 Free Software Foundation, Inc.
       4             : 
       5             : ;; Author: Howard Gayle
       6             : ;; Maintainer: emacs-devel@gnu.org
       7             : ;; Keywords: i18n
       8             : ;; Package: emacs
       9             : 
      10             : ;; This file is part of GNU Emacs.
      11             : 
      12             : ;; GNU Emacs 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             : ;; GNU Emacs 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 GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
      24             : 
      25             : ;;; Commentary:
      26             : 
      27             : ;; Written by:
      28             : ;; TN/ETX/TX/UMG Howard Gayle        UUCP : seismo!enea!erix!howard
      29             : ;; Telefonaktiebolaget L M Ericsson  Phone: +46 8 719 55 65
      30             : ;; Ericsson Telecom                  Telex: 14910 ERIC S
      31             : ;; S-126 25 Stockholm                FAX  : +46 8 719 64 82
      32             : ;; Sweden
      33             : 
      34             : ;;; Code:
      35             : 
      36             : (defun describe-buffer-case-table ()
      37             :   "Describe the case table of the current buffer."
      38             :   (interactive)
      39           0 :   (let ((description (make-char-table 'case-table)))
      40           0 :     (map-char-table
      41           0 :      (function (lambda (key value)
      42           0 :                  (if (not (natnump value))
      43           0 :                      (if (consp key)
      44           0 :                          (set-char-table-range description key "case-invariant")
      45           0 :                        (aset description key "case-invariant"))
      46           0 :                    (let (from to)
      47           0 :                      (if (consp key)
      48           0 :                          (setq from (car key) to (cdr key))
      49           0 :                        (setq from (setq to key)))
      50           0 :                      (while (<= from to)
      51           0 :                        (aset
      52           0 :                         description from
      53           0 :                         (cond ((/= from (downcase from))
      54           0 :                                (concat "uppercase, matches "
      55           0 :                                        (char-to-string (downcase from))))
      56           0 :                               ((/= from (upcase from))
      57           0 :                                (concat "lowercase, matches "
      58           0 :                                        (char-to-string (upcase from))))
      59           0 :                               (t "case-invariant")))
      60           0 :                        (setq from (1+ from)))))))
      61           0 :      (current-case-table))
      62           0 :     (save-excursion
      63           0 :      (with-output-to-temp-buffer "*Help*"
      64           0 :        (set-buffer standard-output)
      65           0 :        (describe-vector description)
      66           0 :        (help-mode)))))
      67             : 
      68             : (defun case-table-get-table (case-table table)
      69             :   "Return the TABLE of CASE-TABLE.
      70             : TABLE can be `down', `up', `eqv' or `canon'."
      71           0 :   (let ((slot-nb (cdr (assq table '((up . 0) (canon . 1) (eqv . 2))))))
      72           0 :     (or (if (eq table 'down) case-table)
      73           0 :         (char-table-extra-slot case-table slot-nb)
      74             :         ;; Setup all extra slots of CASE-TABLE by temporarily selecting
      75             :         ;; it as the standard case table.
      76           0 :         (let ((old (standard-case-table)))
      77           0 :           (unwind-protect
      78           0 :               (progn
      79           0 :                 (set-standard-case-table case-table)
      80           0 :                 (char-table-extra-slot case-table slot-nb))
      81           0 :             (or (eq case-table old)
      82           0 :                 (set-standard-case-table old)))))))
      83             : 
      84             : (defun get-upcase-table (case-table)
      85             :   "Return the upcase table of CASE-TABLE."
      86           0 :   (case-table-get-table case-table 'up))
      87             : (make-obsolete 'get-upcase-table 'case-table-get-table "24.4")
      88             : 
      89             : (defun copy-case-table (case-table)
      90           0 :   (let ((copy (copy-sequence case-table))
      91           0 :         (up (char-table-extra-slot case-table 0)))
      92             :     ;; Clear out the extra slots (except for upcase table) so that
      93             :     ;; they will be recomputed from the main (downcase) table.
      94           0 :     (if up
      95           0 :         (set-char-table-extra-slot copy 0 (copy-sequence up)))
      96           0 :     (set-char-table-extra-slot copy 1 nil)
      97           0 :     (set-char-table-extra-slot copy 2 nil)
      98           0 :     copy))
      99             : 
     100             : (defun set-case-syntax-delims (l r table)
     101             :   "Make characters L and R a matching pair of non-case-converting delimiters.
     102             : This sets the entries for L and R in TABLE, which is a string
     103             : that will be used as the downcase part of a case table.
     104             : It also modifies `standard-syntax-table' to
     105             : indicate left and right delimiters."
     106           0 :   (aset table l l)
     107           0 :   (aset table r r)
     108           0 :   (let ((up (case-table-get-table table 'up)))
     109           0 :     (aset up l l)
     110           0 :     (aset up r r))
     111             :   ;; Clear out the extra slots so that they will be
     112             :   ;; recomputed from the main (downcase) table and upcase table.
     113           0 :   (set-char-table-extra-slot table 1 nil)
     114           0 :   (set-char-table-extra-slot table 2 nil)
     115           0 :   (modify-syntax-entry l (concat "(" (char-to-string r) "  ")
     116           0 :                        (standard-syntax-table))
     117           0 :   (modify-syntax-entry r (concat ")" (char-to-string l) "  ")
     118           0 :                        (standard-syntax-table)))
     119             : 
     120             : (defun set-case-syntax-pair (uc lc table)
     121             :   "Make characters UC and LC a pair of inter-case-converting letters.
     122             : This sets the entries for characters UC and LC in TABLE, which is a string
     123             : that will be used as the downcase part of a case table.
     124             : It also modifies `standard-syntax-table' to give them the syntax of
     125             : word constituents."
     126           0 :   (aset table uc lc)
     127           0 :   (aset table lc lc)
     128           0 :   (let ((up (case-table-get-table table 'up)))
     129           0 :     (aset up uc uc)
     130           0 :     (aset up lc uc))
     131             :   ;; Clear out the extra slots so that they will be
     132             :   ;; recomputed from the main (downcase) table and upcase table.
     133           0 :   (set-char-table-extra-slot table 1 nil)
     134           0 :   (set-char-table-extra-slot table 2 nil)
     135           0 :   (modify-syntax-entry lc "w   " (standard-syntax-table))
     136           0 :   (modify-syntax-entry uc "w   " (standard-syntax-table)))
     137             : 
     138             : (defun set-upcase-syntax (uc lc table)
     139             :   "Make character UC an upcase of character LC.
     140             : It also modifies `standard-syntax-table' to give them the syntax of
     141             : word constituents."
     142           0 :   (aset table lc lc)
     143           0 :   (let ((up (case-table-get-table table 'up)))
     144           0 :     (aset up uc uc)
     145           0 :     (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           0 :   (set-char-table-extra-slot table 1 nil)
     149           0 :   (set-char-table-extra-slot table 2 nil)
     150           0 :   (modify-syntax-entry lc "w   " (standard-syntax-table))
     151           0 :   (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           0 :   (aset table uc lc)
     158           0 :   (aset table lc lc)
     159           0 :   (let ((up (case-table-get-table table 'up)))
     160           0 :     (aset up uc uc))
     161             :   ;; Clear out the extra slots so that they will be
     162             :   ;; recomputed from the main (downcase) table and upcase table.
     163           0 :   (set-char-table-extra-slot table 1 nil)
     164           0 :   (set-char-table-extra-slot table 2 nil)
     165           0 :   (modify-syntax-entry lc "w   " (standard-syntax-table))
     166           0 :   (modify-syntax-entry uc "w   " (standard-syntax-table)))
     167             : 
     168             : (defun set-case-syntax (c syntax table)
     169             :   "Make character C case-invariant with syntax SYNTAX.
     170             : This sets the entry for character C in TABLE, which is a string
     171             : that will be used as the downcase part of a case table.
     172             : It also modifies `standard-syntax-table'.
     173             : SYNTAX should be \" \", \"w\", \".\" or \"_\"."
     174           0 :   (aset table c c)
     175           0 :   (let ((up (case-table-get-table table 'up)))
     176           0 :     (aset up c c))
     177             :   ;; Clear out the extra slots so that they will be
     178             :   ;; recomputed from the main (downcase) table and upcase table.
     179           0 :   (set-char-table-extra-slot table 1 nil)
     180           0 :   (set-char-table-extra-slot table 2 nil)
     181           0 :   (modify-syntax-entry c syntax (standard-syntax-table)))
     182             : 
     183             : (provide 'case-table)
     184             : 
     185             : ;;; case-table.el ends here

Generated by: LCOV version 1.12