--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/utils/symbol-syntax.el	Mon Aug 13 08:45:50 2007 +0200
@@ -0,0 +1,123 @@
+;;; symbol-syntax.el --- find chars with symbol syntax
+
+;; Copyright (C) 1992, 1993 Free Software Foundation, Inc.
+;; Copyright (C) 1995 Sun Microsystems.
+
+;; Created by: JBW, JBW@_CORTEZ
+;; Created on: Wed Jun 20 15:15:34 1990
+;; Last modified by: Ben Wing, wing@666.com
+;; Last modified on: Mon Oct  2 02:32:05 GMT 1995
+;; Filename: symbol-syntax.el
+;; Keywords: matching
+
+;; This file is part of XEmacs.
+
+;; XEmacs is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; XEmacs is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with XEmacs; see the file COPYING.  If not, write to the Free
+;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Synched up with: Not in FSF.
+
+(defvar symbol-syntax-table-alist nil)
+;;  '((c-mode-syntax-table)
+;;    (emacs-lisp-mode-syntax-table)
+;;    (lisp-mode-syntax-table)
+;;    (text-mode-syntax-table)))
+
+(defun update-symbol-syntax-table-alist ()
+  (let ((alist symbol-syntax-table-alist)
+	item)
+    (while (consp alist)
+      (cond ((null (car alist))
+	     (error "Missing alist item"))
+	    ((null (car (car alist)))
+	     (error "Alist item with null car"))
+	    ;; this functionality not used
+	    ((symbolp (setq item (car (car alist))))
+	     (or (null (cdr (car alist)))
+		 (error "Alist item expected to have null cdr"))
+	     (while (symbolp item)
+	       (setq item (symbol-value item)))
+	     (setcar (car alist) item)))
+      (cond ((not (syntax-table-p (car (car alist))))
+	     (error "Alist item car expected to be symbol table"))
+	    ((null (cdr (car alist)))
+	     (setcdr (car alist)
+		     (make-symbol-syntax-table (car (car alist))))))
+      (setq alist (cdr alist)))))
+
+(defun get-symbol-syntax-table (norm-table)
+  (let (result)
+    (if (setq result (assq norm-table symbol-syntax-table-alist))
+	nil
+      (update-symbol-syntax-table-alist)
+      (if (setq result (assq norm-table symbol-syntax-table-alist))
+	  nil
+	(setq symbol-syntax-table-alist
+	      (cons (list norm-table)
+		    symbol-syntax-table-alist))
+	(update-symbol-syntax-table-alist)
+	(or (setq result (assq norm-table symbol-syntax-table-alist))
+	    (error "Syntax table missing from symbol-syntax-table-alist"))))
+    (or (setq result (cdr result))
+	(error "Alist item has null cdr"))
+    (or (syntax-table-p result)
+	(error "Non-syntax-table item in alist"))
+    result))
+
+(defun make-symbol-syntax-table (in-table)
+  (let ((osyn (syntax-table))
+	(out-table (copy-syntax-table in-table))
+	(i 0)
+	(syntax nil))
+    (while (< i 256)
+      (setq syntax (aref out-table i))
+      (if (eq 3 (logand 255 syntax))
+	  (aset out-table i (logior 2 (logand (lognot 255) syntax))))
+      (setq i (1+ i)))
+    out-table))
+
+;; stuff for examining contents of syntax tables
+;;(show-chars-with-syntax
+;; '(c-mode-syntax-table
+;;   emacs-lisp-mode-syntax-table
+;;   lisp-mode-syntax-table
+;;   text-mode-syntax-table)
+;; ?_)
+
+(defun show-chars-with-syntax (tables syntax)
+  (let ((osyn (syntax-table))
+	(schars nil))
+    (unwind-protect
+	(while (consp tables)
+	  (let* ((chars nil)
+		 (table-symbol (car tables))
+		 (table table-symbol)
+		 (i 0))
+	    (or (symbolp table-symbol)
+		(error "bad argument non-symbol"))
+	    (while (symbolp table)
+	      (setq table (symbol-value table)))
+	    (set-syntax-table table)
+	    (while (< i 256)
+	      (if (eq syntax (char-syntax i))
+		  (setq chars (cons (format "%c" i) chars)))
+	      (setq i (1+ i)))
+	    (setq schars (cons (list table-symbol
+				     (mapconcat 'identity (nreverse chars) ""))
+			       schars)))
+	  (setq tables (cdr tables)))
+      (set-syntax-table osyn))
+    (nreverse schars)))
+
+(provide 'symbol-syntax)