home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / prim / syntax.el < prev    next >
Encoding:
Text File  |  1995-05-12  |  11.7 KB  |  321 lines
  1. ;; Syntax-table hacking stuff, moved from syntax.c
  2. ;; Copyright (C) 1993 Free Software Foundation, Inc.
  3.  
  4. ;; This file is part of XEmacs.
  5.  
  6. ;; XEmacs is free software; you can redistribute it and/or modify it
  7. ;; under the terms of the GNU General Public License as published by
  8. ;; the Free Software Foundation; either version 2, or (at your option)
  9. ;; any later version.
  10.  
  11. ;; XEmacs is distributed in the hope that it will be useful, but
  12. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14. ;; General Public License for more details.
  15.  
  16. ;; You should have received a copy of the GNU General Public License
  17. ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  18. ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. ;;; Synched up with: FSF 19.28.
  21.  
  22. (defun make-syntax-table (&optional oldtable)
  23.   "Return a new syntax table.
  24. It inherits all letters and control characters from the standard
  25. syntax table; other characters are copied from the standard syntax table."
  26.   (if oldtable
  27.       (copy-syntax-table oldtable)
  28.     (let ((table (copy-syntax-table))
  29.       i)
  30.       (setq i 0)
  31.       (while (<= i 31)
  32.     (aset table i 13)
  33.     (setq i (1+ i)))
  34.       (setq i ?A)
  35.       (while (<= i ?Z)
  36.     (aset table i 13)
  37.     (setq i (1+ i)))
  38.       (setq i ?a)
  39.       (while (<= i ?z)
  40.     (aset table i 13)
  41.     (setq i (1+ i)))
  42.       (setq i 128)
  43.       (while (<= i 255)
  44.     (aset table i 13)
  45.     (setq i (1+ i)))
  46.       table)))
  47.  
  48. (defun modify-syntax-entry (char spec &optional table)
  49.   "Set syntax for character CHAR according to string S.
  50. The syntax is changed only for table TABLE, which defaults to
  51.  the current buffer's syntax table.
  52. The first character of S should be one of the following:
  53.   Space    whitespace syntax.    w   word constituent.
  54.   _        symbol constituent.   .   punctuation.
  55.   \(        open-parenthesis.     \)   close-parenthesis.
  56.   \"        string quote.         \\   character-quote.
  57.   $        paired delimiter.     '   expression quote or prefix operator.
  58.   <       comment starter.     >   comment ender.
  59.   /           character-quote.      @   inherit from `standard-syntax-table'.
  60.  
  61. Only single-character comment start and end sequences are represented thus.
  62. Two-character sequences are represented as described below.
  63. The second character of S is the matching parenthesis,
  64.  used only if the first character is `(' or `)'.
  65. Any additional characters are flags.
  66. Defined flags are the characters 1, 2, 3, 4, 5, 6, 7, 8, p, a, and b.
  67.  1 means C is the first of a two-char comment start sequence of style a.
  68.  2 means C is the second character of such a sequence.
  69.  3 means C is the first of a two-char comment end sequence of style a.
  70.  4 means C is the second character of such a sequence.
  71.  5 means C is the first of a two-char comment start sequence of style b.
  72.  6 means C is the second character of such a sequence.
  73.  7 means C is the first of a two-char comment end sequence of style b.
  74.  8 means C is the second character of such a sequence.
  75.  p means C is a prefix character for `backward-prefix-chars';
  76.    such characters are treated as whitespace when they occur
  77.    between expressions.
  78.  a means C is comment starter or comment ender for comment style a (default)
  79.  b means C is comment starter or comment ender for comment style b."
  80.   (interactive 
  81.    ;; I really don't know why this is interactive
  82.    ;; help-form should at least be made useful whilst reading the second arg
  83.    "cSet syntax for character: \nsSet syntax for %c to: ")
  84.   (cond ((syntax-table-p table))
  85.         ((not table)
  86.          (setq table (syntax-table)))
  87.         (t
  88.          (setq table 
  89.                (signal 'wrong-type-argument (list 'syntax-table-p table)))))
  90.   (let* ((codes (if (featurep 'mule) " .w_()'\"$\\/<>@e" " .w_()'\"$\\/<>@"))
  91.          (code nil)
  92.          (bflag nil)
  93.          (b3 0)
  94.          i)
  95.     (setq i 0)
  96.     (while (< i (length codes))
  97.       (if (eq (elt codes i) (elt spec 0))
  98.           (setq code i))
  99.       (setq i (1+ i)))
  100.     (or code 
  101.         (error "Invalid syntax description letter: %S" spec))
  102.     (setq i 2)
  103.     (while (< i (length spec))
  104.       (let ((ch (elt spec i)))
  105.         (setq i (1+ i))
  106.         (cond ((= ch ?1)
  107.                (setq b3 (logior b3 128)))
  108.               ((= ch ?2)
  109.                (setq b3 (logior b3 32)))
  110.               ((= ch ?3)
  111.                (setq b3 (logior b3 8)))
  112.               ((= ch ?4)
  113.                (setq b3 (logior b3 2)))
  114.               ((= ch ?5)
  115.                (setq b3 (logior b3 64)))
  116.               ((= ch ?6)
  117.                (setq b3 (logior b3 16)))
  118.               ((= ch ?7)
  119.                (setq b3 (logior b3 4)))
  120.               ((= ch ?8)
  121.                (setq b3 (logior b3 1)))
  122.               ((= ch ?a)
  123.                (cond ((= (elt spec 0) ?<)
  124.                       (setq b3 (logior b3 128)))
  125.                      ((= (elt spec 0) ?>)
  126.                       (setq b3 (logior b3 8)))))
  127.               ((= ch ?b)
  128.                (cond ((= (elt spec 0) ?<)
  129.                       (setq b3 (logior b3 64)
  130.                             bflag t))
  131.                      ((= (elt spec 0) ?>)
  132.                       (setq b3 (logior b3 4)
  133.                             bflag t))))
  134.               ((= ch ?p)
  135.                (setq code (logior code (lsh 1 7))))
  136.               ((= ch ?\ )
  137.                ;; ignore for compatibility
  138.                )
  139.               (t
  140.                (error "Invalid syntax description flag: %S" spec)))))
  141.     ;; default single char style is a if b has not been seen
  142.     (if (not bflag)
  143.         (cond ((= (elt spec 0) ?<)
  144.                (setq b3 (logior b3 128)))
  145.               ((= (elt spec 0) ?>)
  146.                (setq b3 (logior b3 8)))))
  147.     (aset table
  148.           char
  149.           (logior code
  150.                   (if (and (> (length spec) 1)
  151.                            ;; tough luck if you want to make space a paren!
  152.                            (/= (elt spec 1) ?\  ))
  153.                       ;; tough luck if you want to make \000 a paren!
  154.                       (lsh (elt spec 1) 8)
  155.                       0)
  156.                   (lsh b3 16)))
  157.     nil))
  158.  
  159. ;(defun test-xm ()
  160. ;  (let ((o (copy-syntax-table))
  161. ;        (n (copy-syntax-table))
  162. ;        (codes (if (featurep 'mule) " .w_()'\"$\\/<>@e" " .w_()'\"$\\/<>@"))
  163. ;        (flags "12345678abp"))
  164. ;    (while t
  165. ;      (let ((spec (concat (char-to-string (aref codes (random (length codes))))
  166. ;                          (if (= (random 4) 0)
  167. ;                              "b"
  168. ;                              " ")
  169. ;                          (let* ((n (random 4))
  170. ;                                 (s (make-string n 0)))
  171. ;                            (while (> n 0)
  172. ;                              (setq n (1- n))
  173. ;                              (aset s n (aref flags (random (length flags)))))
  174. ;                            s))))
  175. ;        (message "%S..." spec)
  176. ;        (modify-syntax-entry ?a spec o)
  177. ;        (xmodify-syntax-entry ?a spec n)
  178. ;        (or (= (aref o ?a) (aref n ?a))
  179. ;            (error "%s"
  180. ;                   (format "fucked with %S: %x %x"
  181. ;                           spec (aref o ?a) (aref n ?a))))))))
  182.  
  183.  
  184. (defun describe-syntax-table (table stream)
  185.   (let* (;(limit (cond ((numberp ctl-arrow) ctl-arrow)
  186. ;              ((memq ctl-arrow '(t nil)) 256)
  187. ;              (t 160)))
  188.      (describe-one #'(lambda (first last)
  189.                (let* ((tem (text-char-description first))
  190.                   (pos (length tem)))
  191.                  (princ tem stream)
  192.                  (if (> last first)
  193.                  (progn
  194.                    (princ " .. " stream)
  195.                    (setq tem (text-char-description last))
  196.                    (princ tem stream)
  197.                    (setq pos (+ pos (length tem) 4))))
  198.                  (while (progn (write-char ?\  stream)
  199.                        (setq pos (1+ pos))
  200.                        (< pos 16))))
  201.                (describe-syntax-code (elt table first) stream))))
  202.     (let ((range 0)
  203.           (i 0)
  204.           (code (elt table 0)))
  205.       (while (cond ((= i (length table))
  206.                     (funcall describe-one (1- i) (1- i))
  207.                     nil)
  208.                    ((eq code (elt table i))
  209.                     t)
  210.                    (t
  211.                     (funcall describe-one range (1- i))
  212.                     (setq code (elt table i)
  213.                           range i)
  214.                     t))
  215.         (setq i (1+ i))))))
  216.  
  217. (defun describe-syntax-code (code stream)
  218.   (let ((codes (if (featurep 'mule) " .w_()'\"$\\/<>@e" " .w_()'\"$\\/<>@"))
  219.         (invalid (gettext "**invalid**")) ;(empty "") ;constants
  220.     (standard-output (or stream standard-output))
  221.     ;; #### I18N3 should temporarily set buffer to output-translatable
  222.         (in #'(lambda (string)
  223.                 (princ ",\n\t\t\t\t ")
  224.                 (princ string))))
  225.     (if (or (not (integerp code))
  226.             (> (logand code 127) (length codes)))
  227.         (princ invalid)
  228.       (let* ((spec (elt codes (logand code 127)))
  229.          (match (logand (lsh code -8) 255))
  230.          (b3 (lsh code -16))
  231.          (start1  (/= 0 (logand b3 128))) ;logtest!
  232.          (start1b (/= 0 (logand b3  64)))
  233.          (start2  (/= 0 (logand b3  32)))
  234.          (start2b (/= 0 (logand b3  16)))
  235.          (end1    (/= 0 (logand b3   8)))
  236.          (end1b   (/= 0 (logand b3   4)))
  237.          (end2    (/= 0 (logand b3   2)))
  238.          (end2b   (/= 0 (logand b3   1)))
  239.          (prefix  (/= 0 (logand code 128)))
  240.          (single-char-p (or (= spec ?<) (= spec ?>)))
  241.          )
  242.         (write-char spec)
  243.     (write-char (if (= 0 match) 32 match))
  244. ;;    (if start1 (if single-char-p (write-char ?a) (write-char ?1)))
  245.     (if start1 (if single-char-p (write-char ? ) (write-char ?1)))
  246.     (if start2 (write-char ?2))
  247. ;;    (if end1 (if single-char-p (write-char ?a) (write-char ?3)))
  248.     (if end1 (if single-char-p (write-char ? ) (write-char ?3)))
  249.     (if end2 (write-char ?4))
  250.     (if start1b (if single-char-p (write-char ?b) (write-char ?5)))
  251.     (if start2b (write-char ?6))
  252.     (if end1b (if single-char-p (write-char ?b) (write-char ?7)))
  253.     (if end2b (write-char ?8))
  254.     (if prefix (write-char ?p))
  255.  
  256.         (princ "\tmeaning: ")
  257.         (princ (aref ["whitespace" "punctuation" "word-constituent"
  258.               "symbol-constituent" "open-paren" "close-paren"
  259.               "expression-prefix" "string-quote" "paired-delimiter"
  260.               "escape" "character-quote" "comment-begin" "comment-end"
  261.               "inherit" "extended-word-constituent"]
  262.              (logand code 127)))
  263.  
  264.         (if (/= 0 match)
  265.             (progn
  266.               (princ ", matches ")
  267.           (princ (text-char-description match))))
  268.     (if start1
  269.         (if single-char-p
  270.         (princ ", style A")
  271.               (funcall in (gettext "first character of comment-start sequence A"))))
  272.     (if start2
  273.         (funcall in (gettext "second character of comment-start sequence A")))
  274.     (if end1
  275.         (if single-char-p
  276.         (princ ", style A")
  277.               (funcall in (gettext "first character of comment-end sequence A"))))
  278.     (if end2
  279.         (funcall in (gettext "second character of comment-end sequence A")))
  280.     (if start1b
  281.         (if single-char-p
  282.         (princ ", style B")
  283.               (funcall in (gettext "first character of comment-start sequence B"))))
  284.     (if start2b
  285.         (funcall in (gettext "second character of comment-start sequence B")))
  286.     (if end1b
  287.         (if single-char-p
  288.         (princ ", style B")
  289.               (funcall in (gettext "first character of comment-end sequence B"))))
  290.     (if end2b
  291.         (funcall in (gettext "second character of comment-end sequence B")))
  292.     (if prefix
  293.         (funcall in (gettext "prefix character for `backward-prefix-chars'")))))
  294.     (terpri stream)))
  295.  
  296. (defun symbol-near-point ()
  297.   "Return the first textual item to the nearest point."
  298.   (interactive)
  299.   ;alg stolen from etag.el
  300.   (save-excursion
  301.     (if (not (memq (char-syntax (preceding-char)) '(?w ?_)))
  302.         (while (not (looking-at "\\sw\\|\\s_\\|\\'"))
  303.           (forward-char 1)))
  304.     (while (looking-at "\\sw\\|\\s_")
  305.       (forward-char 1))
  306.     (if (re-search-backward "\\sw\\|\\s_" nil t)
  307.         (regexp-quote
  308.          (progn (forward-char 1)
  309.             (buffer-substring (point)
  310.                       (progn (forward-sexp -1)
  311.                          (while (looking-at "\\s'")
  312.                            (forward-char 1))
  313.                          (point)))))
  314.       nil)))
  315.  
  316.  
  317.  
  318.  
  319.  
  320.  
  321.