Mercurial > hg > xemacs-beta

comparison lisp/utils/symbol-syntax.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children 0293115a14e9
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;; symbol-syntax.el --- find chars with symbol syntax
2
3 ;; Copyright (C) 1992, 1993 Free Software Foundation, Inc.
4 ;; Copyright (C) 1995 Sun Microsystems.
5
6 ;; Created by: JBW, JBW@_CORTEZ
7 ;; Created on: Wed Jun 20 15:15:34 1990
8 ;; Last modified by: Ben Wing, wing@666.com
9 ;; Last modified on: Mon Oct 2 02:32:05 GMT 1995
10 ;; Filename: symbol-syntax.el
11 ;; Keywords: matching
12
13 ;; This file is part of XEmacs.
14
15 ;; XEmacs is free software; you can redistribute it and/or modify it
16 ;; under the terms of the GNU General Public License as published by
17 ;; the Free Software Foundation; either version 2, or (at your option)
18 ;; any later version.
19
20 ;; XEmacs is distributed in the hope that it will be useful, but
21 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
22 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
23 ;; General Public License for more details.
24
25 ;; You should have received a copy of the GNU General Public License
26 ;; along with XEmacs; see the file COPYING. If not, write to the Free
27 ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
28
29 ;;; Synched up with: Not in FSF.
30
31 (defvar symbol-syntax-table-alist nil)
32 ;; '((c-mode-syntax-table)
33 ;; (emacs-lisp-mode-syntax-table)
34 ;; (lisp-mode-syntax-table)
35 ;; (text-mode-syntax-table)))
36
37 (defun update-symbol-syntax-table-alist ()
38 (let ((alist symbol-syntax-table-alist)
39 item)
40 (while (consp alist)
41 (cond ((null (car alist))
42 (error "Missing alist item"))
43 ((null (car (car alist)))
44 (error "Alist item with null car"))
45 ;; this functionality not used
46 ((symbolp (setq item (car (car alist))))
47 (or (null (cdr (car alist)))
48 (error "Alist item expected to have null cdr"))
49 (while (symbolp item)
50 (setq item (symbol-value item)))
51 (setcar (car alist) item)))
52 (cond ((not (syntax-table-p (car (car alist))))
53 (error "Alist item car expected to be symbol table"))
54 ((null (cdr (car alist)))
55 (setcdr (car alist)
56 (make-symbol-syntax-table (car (car alist))))))
57 (setq alist (cdr alist)))))
58
59 (defun get-symbol-syntax-table (norm-table)
60 (let (result)
61 (if (setq result (assq norm-table symbol-syntax-table-alist))
62 nil
63 (update-symbol-syntax-table-alist)
64 (if (setq result (assq norm-table symbol-syntax-table-alist))
65 nil
66 (setq symbol-syntax-table-alist
67 (cons (list norm-table)
68 symbol-syntax-table-alist))
69 (update-symbol-syntax-table-alist)
70 (or (setq result (assq norm-table symbol-syntax-table-alist))
71 (error "Syntax table missing from symbol-syntax-table-alist"))))
72 (or (setq result (cdr result))
73 (error "Alist item has null cdr"))
74 (or (syntax-table-p result)
75 (error "Non-syntax-table item in alist"))
76 result))
77
78 (defun make-symbol-syntax-table (in-table)
79 (let ((osyn (syntax-table))
80 (out-table (copy-syntax-table in-table))
81 (i 0)
82 (syntax nil))
83 (while (< i 256)
84 (setq syntax (aref out-table i))
85 (if (eq 3 (logand 255 syntax))
86 (aset out-table i (logior 2 (logand (lognot 255) syntax))))
87 (setq i (1+ i)))
88 out-table))
89
90 ;; stuff for examining contents of syntax tables
91 ;;(show-chars-with-syntax
92 ;; '(c-mode-syntax-table
93 ;; emacs-lisp-mode-syntax-table
94 ;; lisp-mode-syntax-table
95 ;; text-mode-syntax-table)
96 ;; ?_)
97
98 (defun show-chars-with-syntax (tables syntax)
99 (let ((osyn (syntax-table))
100 (schars nil))
101 (unwind-protect
102 (while (consp tables)
103 (let* ((chars nil)
104 (table-symbol (car tables))
105 (table table-symbol)
106 (i 0))
107 (or (symbolp table-symbol)
108 (error "bad argument non-symbol"))
109 (while (symbolp table)
110 (setq table (symbol-value table)))
111 (set-syntax-table table)
112 (while (< i 256)
113 (if (eq syntax (char-syntax i))
114 (setq chars (cons (format "%c" i) chars)))
115 (setq i (1+ i)))
116 (setq schars (cons (list table-symbol
117 (mapconcat 'identity (nreverse chars) ""))
118 schars)))
119 (setq tables (cdr tables)))
120 (set-syntax-table osyn))
121 (nreverse schars)))
122
123 (provide 'symbol-syntax)