Mercurial > emacs

--- a/lisp/generic.el	Wed Oct 04 05:02:12 2000 +0000
+++ b/lisp/generic.el	Wed Oct 04 05:14:25 2000 +0000
@@ -51,11 +51,11 @@
 ;;   different from `font-lock-keyword-face', you can use the convenience
 ;;   function `generic-make-keywords-list' (which see), and add the
 ;;   result to the following list:
-;;
+;;
 ;; * Additional expressions to font-lock.  This should be a list of
 ;;   expressions, each of which should be of the same form
 ;;   as those in `font-lock-defaults-alist'.
-;;
+;;
 ;; * List of regular expressions to be placed in auto-mode-alist.
 ;;
 ;; * List of functions to call to do some additional setup
@@ -73,7 +73,7 @@
 ;;
 ;; Do NOT use "mode: generic"!
 ;; See also "AUTOMATICALLY ENTERING GENERIC MODE" below.
-;;
+;;
 ;; DEFINING NEW GENERIC MODES:
 ;;
 ;; Use the `define-generic-mode' function to define new modes.
@@ -84,7 +84,7 @@
 ;;                        (list ?% )
 ;;                        (list "keyword")
 ;;                        nil
-;;			  (list "\.FOO")
+;;			  (list "\\.FOO\\'")
 ;;			  (list 'foo-setup-function))
 ;;
 ;; defines a new generic-mode `foo-generic-mode', which has '%' as a
@@ -102,18 +102,23 @@
 ;; to nil BEFORE loading generic-mode. See the variables
 ;; `generic-lines-to-scan' and `generic-find-file-regexp' for customization
 ;; options.
-;;
+;;
 ;; GOTCHAS:
 ;;
 ;; Be careful that your font-lock definitions are correct.  Getting them
 ;; wrong can cause emacs to continually attempt to fontify! This problem
 ;; is not specific to generic-mode.
-;;
+;;

 ;; Credit for suggestions, brainstorming, help with debugging:
 ;;   ACorreir@pervasive-sw.com (Alfred Correira)
+;; Extensive cleanup by:
+;;   Stefan Monnier (monnier+gnu/emacs@flint.cs.yale.edu)
+;;
+;;; Code:

-;;; Code:
+(eval-when-compile
+  (require 'cl))

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Internal Variables
@@ -123,38 +128,8 @@
   "Global defaults for font-lock in a generic mode.")
 (make-variable-buffer-local 'generic-font-lock-defaults)

-(defvar generic-mode-name 'default-generic-mode
-  "The name of the generic mode.
-This is the car of one of the items in `generic-mode-alist'.
-This variable is buffer-local.")
-(make-variable-buffer-local 'generic-mode-name)
-
-(defvar generic-comment-list nil
-  "List of comment characters for a generic mode.")
-(make-variable-buffer-local 'generic-comment-list)
-
-(defvar generic-keywords-list nil
-  "List of keywords for a generic mode.")
-(make-variable-buffer-local 'generic-keywords-list)
-
-(defvar generic-font-lock-expressions nil
-  "List of font-lock expressions for a generic mode.")
-(make-variable-buffer-local 'generic-font-lock-expressions)
-
-(defvar generic-mode-function-list nil
-  "List of customization functions to call for a generic mode.")
-(make-variable-buffer-local 'generic-mode-function-list)
-
-(defvar generic-mode-syntax-table nil
-  "Syntax table for use in a generic mode.")
-(make-variable-buffer-local 'generic-mode-syntax-table)
-
-(defvar generic-mode-alist nil
-  "An association list for `generic-mode'.
-Each entry in the list looks like this:
-
- NAME COMMENT-LIST KEYWORD-LIST FONT-LOCK-LIST AUTO-MODE-LIST FUNCTION-LIST.
-
+(defvar generic-mode-list nil
+  "A list of mode names for `generic-mode'.
 Do not add entries to this list directly; use `define-generic-mode'
 instead (which see).")

@@ -183,7 +158,7 @@
   :type  'integer
   )

-(defcustom generic-find-file-regexp "#.*\n\\(.*\n\\)?"
+(defcustom generic-find-file-regexp "^#"
   "*Regular expression used by `generic-mode-find-file-hook'.
 Used to determine if files in fundamental mode should be put into
 `default-generic-mode' instead."
@@ -198,27 +173,8 @@
 (defsubst generic-read-type ()
   (completing-read
    "Generic Type: "
-   (mapcar
-    '(lambda (elt) (list (symbol-name (car elt))))
-    generic-mode-alist) nil t))
-
-;; Basic sanity checks. It does *not* check whether the elements of the lists
-;; are of the correct type.
-(defsubst generic-mode-sanity-check (name comment-list   keyword-list
-					  font-lock-list auto-mode-list
-					  function-list  &optional description)
-  (and (not (symbolp name))
-      (error "%s is not a symbol" (princ name)))
-
-  (mapcar '(lambda (elt)
-	     (if (not (listp elt))
-		 (error "%s is not a list" (princ elt))))
-	  (list comment-list   keyword-list font-lock-list
-		auto-mode-list function-list))
-
-  (and (not (or (null description) (stringp description)))
-      (error "Description must be a string or nil"))
-)
+   generic-mode-list
+   nil t))

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Functions
@@ -240,8 +196,8 @@
 COMMENT-LIST is a list, whose entries are either a single character,
 a one or two character string or a cons pair. If the entry is a character
 or a one-character string, it is added to the mode's syntax table with
-comment-start syntax. If the entry is a cons pair, the elements of the
-pair are considered to be comment-start and comment-end respectively.
+`comment-start' syntax.  If the entry is a cons pair, the elements of the
+pair are considered to be `comment-start' and `comment-end' respectively.
 Note that Emacs has limitations regarding comment characters.

 KEYWORD-LIST is a list of keywords to highlight with `font-lock-keyword-face'.
@@ -250,122 +206,61 @@
 FONT-LOCK-LIST is a list of additional expressions to highlight. Each entry
 in the list should have the same form as an entry in `font-lock-defaults-alist'

-AUTO-MODE-LIST is a list of regular expressions to add to auto-mode-alist.
-These regexps are added to auto-mode-alist as soon as `define-generic-mode'
+AUTO-MODE-LIST is a list of regular expressions to add to `auto-mode-alist'.
+These regexps are added to `auto-mode-alist' as soon as `define-generic-mode'
 is called; any old regexps with the same name are removed.

 FUNCTION-LIST is a list of functions to call to do some additional setup.

 See the file generic-x.el for some examples of `define-generic-mode'."

-  ;; Basic sanity check
-  (generic-mode-sanity-check name
-			     comment-list    keyword-list   font-lock-list
-			     auto-mode-list  function-list  description)
-
-  ;; Remove any old entry
-  (setq generic-mode-alist
-	(delq (assq name generic-mode-alist)
-	      generic-mode-alist))
-
   ;; Add a new entry
-  (setq generic-mode-alist
-	(append
-	 (list
-	  (list
-	   name comment-list keyword-list font-lock-list
-	   auto-mode-list    function-list
-	   ))
-	 generic-mode-alist))
+  (unless (assq name generic-mode-list)
+    (push (list name) generic-mode-list))

   ;; Add it to auto-mode-alist
-  (generic-add-to-auto-mode name auto-mode-list t)
-
-  ;; Define a function for it
-  (generic-create-generic-function name description)
+  (dolist (re auto-mode-list)
+    (add-to-list 'auto-mode-alist (cons re name)))
+
+  ;; Define a function for it using `defalias' (not `fset') to make
+  ;; the mode appear on load-history.
+  (defalias name
+    `(lambda nil
+       ,(or description (concat "Generic mode for type " (symbol-name name)))
+       (interactive)
+       (generic-mode-internal ',name ',comment-list ',keyword-list
+			      ',font-lock-list ',function-list)))
   )

-(defun generic-add-to-auto-mode (mode auto-mode-list
-				      &optional remove-old prepend)
-  "Add the entries for MODE to `auto-mode-alist', supplied as AUTO-MODE-ALIST.
-If remove-old is non-nil, removes old entries first. If prepend is
-non-nil, prepends entries to auto-mode-alist; otherwise, appends them."
-
-  (if (not (listp auto-mode-list))
-      (error "%s is not a list" (princ auto-mode-list)))
-
-  (let ((new-mode (intern (symbol-name mode))))
-    (and remove-old
-	 (let ((auto-mode-entry))
-	   (while (setq auto-mode-entry (rassq new-mode auto-mode-alist))
-	     (setq auto-mode-alist
-		   (delq auto-mode-entry
-			 auto-mode-alist)))))
-
-    (mapcar '(lambda (entry)
-	       (generic-add-auto-mode-entry new-mode entry prepend))
-	    auto-mode-list)))
-
-(defun generic-add-auto-mode-entry (name entry &optional prepend)
-  "Add a new NAME regexp with ENTRY to the end of `auto-mode-alist'.
-If prepend is non-nil, add the entry to the front of the list."
-  (let ((new-entry (list (cons entry name))))
-    (setq auto-mode-alist
-	  (if prepend
-	      (append new-entry auto-mode-alist)
-	    (append auto-mode-alist new-entry)))))
-
-(defun generic-create-generic-function (name &optional description)
-  "Create a generic mode function with NAME.
-If DESCRIPTION is provided, it is used as the docstring."
-  (let ((symname (symbol-name name)))
-    ;; Use `defalias', not `fset' to make the mode appear on
-    ;; load-history.
-    (defalias (intern symname)
-      (list 'lambda nil
-	    (or description
-		(concat "Generic mode for type " symname))
-	    (list 'interactive)
-	    (list 'generic-mode-with-type (list 'quote name))))))
-
-(defun generic-mode-with-type (&optional mode)
+(defun generic-mode-internal (mode comments keywords font-lock-list funs)
   "Go into the generic-mode MODE."
-  (let* ((type (or mode generic-mode-name))
-	 (generic-mode-list  (assoc type generic-mode-alist))
-	 (generic-mode-hooks (intern (concat (symbol-name type) "-hooks")))
+  (let* ((generic-mode-hooks (intern (concat (symbol-name mode) "-hook")))
+	 (modename (symbol-name mode))
+	 (name (if (string-match "-mode\\'" modename)
+		   (substring modename 0 (match-beginning 0))
+		 modename))
 	 )

-    (and (not generic-mode-list)
-	 (error "Can't find generic-mode information for type %s"
-		(princ generic-mode-name)))
-
     ;; Put this after the point where we read generic-mode-name!
     (kill-all-local-variables)

     (setq
-     generic-mode-name             type
-     generic-comment-list          (nth 1 generic-mode-list)
-     generic-keywords-list	   (nth 2 generic-mode-list)
-     generic-font-lock-expressions (nth 3 generic-mode-list)
-     generic-mode-function-list	   (nth 5 generic-mode-list)
-     major-mode			   type
-     mode-name			   (symbol-name type)
+     major-mode			   mode
+     mode-name			   (capitalize name)
      )

-    (generic-mode-set-comments     generic-comment-list)
+    (generic-mode-set-comments     comments)

     ;; Font-lock functionality
     ;; Font-lock-defaults are always set even if there are no keywords
     ;; or font-lock expressions, so comments can be highlighted.
     (setq generic-font-lock-defaults nil)
-    (generic-mode-set-font-lock      generic-keywords-list
-				     generic-font-lock-expressions)
+    (generic-mode-set-font-lock      keywords font-lock-list)
     (make-local-variable	    'font-lock-defaults)
     (setq font-lock-defaults (list 'generic-font-lock-defaults nil))

     ;; Call a list of functions
-    (and generic-mode-function-list
-	 (mapcar 'funcall generic-mode-function-list))
+    (mapcar 'funcall funs)

     (run-hooks generic-mode-hooks)
     )
@@ -374,159 +269,88 @@
 ;;;###autoload
 (defun generic-mode (type)
   "Basic comment and font-lock functionality for `generic' files.
-(Files which are too small to warrant their own mode, but have
+\(Files which are too small to warrant their own mode, but have
 comment characters, keywords, and the like.)

 To define a generic-mode, use the function `define-generic-mode'.
 Some generic modes are defined in `generic-x.el'."
   (interactive
    (list (generic-read-type)))
-  (generic-mode-with-type (intern type)))
+  (funcall (intern type)))

 ;;; Comment Functionality
 (defun generic-mode-set-comments (comment-list)
   "Set up comment functionality for generic mode."
-  (if (null comment-list)
-      nil
-    (let ((generic-mode-syntax-table (make-syntax-table)))
-      (make-local-variable	     'comment-start)
-      (make-local-variable	     'comment-start-skip)
-      (make-local-variable	     'comment-end)
-      (mapcar 'generic-mode-set-a-comment comment-list)
-      (set-syntax-table    generic-mode-syntax-table))))
+  (let ((st (make-syntax-table))
+	(chars nil)
+	(comstyles))
+    (make-local-variable	     'comment-start)
+    (make-local-variable	     'comment-start-skip)
+    (make-local-variable	     'comment-end)

-(defun generic-mode-set-a-comment (comment)
-  (and (char-or-string-p comment)
-       (if (stringp comment)
-	   (cond
-	    ((eq (length comment) 1)
-	     (generic-mode-set-comment-char
-	      (string-to-char comment)))
-	    ((eq (length comment) 2)
-	     (generic-mode-set-comment-string comment))
-	    (t
-	     (error "Character string %s must be one or two characters long"
-		    comment))
-	    )
-	 (generic-mode-set-comment-char comment)))
-  (and (consp comment)
-       (generic-mode-set-comment-pair comment)))
+    ;; Go through all the comments
+    (dolist (start comment-list)
+      (let ((end ?\n) (comstyle ""))
+	;; Normalize
+	(when (consp start)
+	  (setq end (or (cdr start) end))
+	  (setq start (car start)))
+	(when (char-valid-p start) (setq start (char-to-string start)))
+	(when (char-valid-p end)   (setq end (char-to-string end)))

-(defun generic-mode-set-comment-char (comment-char)
-  "Set COMMENT-CHAR as a comment character for generic mode."
-  (if (not comment-char)
-      nil
-    (setq
-     comment-end         ""
-     comment-start       (char-to-string comment-char)
-     comment-start-skip  (concat comment-start "+ *")
-     )
-
-    (modify-syntax-entry comment-char "<"
-			 generic-mode-syntax-table)
-    (modify-syntax-entry ?\n ">"
-			 generic-mode-syntax-table)))
+	;; Setup the vars for `comment-region'
+	(if comment-start
+	    ;; We have already setup a comment-style, so use style b
+	    (progn
+	      (setq comstyle "b")
+	      (setq comment-start-skip
+		    (concat comment-start-skip "\\|" (regexp-quote start) "+\\s-*")))
+	  ;; First comment-style
+	  (setq comment-start start)
+	  (setq comment-end (unless (string-equal end "\n") end))
+	  (setq comment-start-skip (concat (regexp-quote start) "+\\s-*")))

-(defun generic-mode-set-comment-string (comment-string)
-  "Set COMMENT-STRING as a comment string for generic mode."
-  (if (not comment-string)
-      nil
-    (setq
-     comment-end         ""
-     comment-start       comment-string
-     comment-start-skip  (concat comment-start " *")
-     )
-
-    (let ((first  (elt comment-string 0))
-	  (second (elt comment-string 1)))
-      ;; C++ style comments
-      (if (char-equal first second)
-	  (progn
-	    (modify-syntax-entry first "<12b"
-				 generic-mode-syntax-table)
-	    (modify-syntax-entry ?\n ">b"
-				 generic-mode-syntax-table)))
-      ;; Some other two character string
-      (modify-syntax-entry first  "<1"
-			   generic-mode-syntax-table)
-      (modify-syntax-entry second "<2"
-			   generic-mode-syntax-table)
-      (modify-syntax-entry ?\n ">"
-			   generic-mode-syntax-table))))
-
-(defun generic-mode-set-comment-pair (comment-pair)
-  "Set COMMENT-PAIR as a comment start and end for generic mode."
-  (let ((generic-comment-start (car comment-pair))
-	(generic-comment-end   (cdr comment-pair))
-	)
-    (setq
-     comment-end         generic-comment-end
-     comment-start       generic-comment-start
-     comment-start-skip  (concat generic-comment-start " *")
-     )
+       ;; Reuse comstyles if necessary
+       (setq comstyle
+             (or (cdr (assoc start comstyles))
+                 (cdr (assoc end comstyles))
+                 comstyle))
+       (push (cons start comstyle) comstyles)
+       (push (cons end comstyle) comstyles)

-    ;; Sanity checks
-    (and (not (and (stringp generic-comment-start)
-		   (stringp generic-comment-end)))
-	 (error "Elements of cons pair must be strings"))
-    (and (not (and (equal (length generic-comment-start) 2)
-		   (equal (length generic-comment-end) 2)))
-	(error "Start and end must be exactly two characters long"))
-
-    (let ((first   (elt generic-comment-start 0))
-	  (second  (elt generic-comment-start 1))
-	  (third   (elt generic-comment-end   0))
-	  (fourth  (elt generic-comment-end   1))
-	  )
-
-      (modify-syntax-entry first   ". 1" generic-mode-syntax-table)
-      (modify-syntax-entry second  ". 2" generic-mode-syntax-table)
+	;; Setup the syntax table
+	(if (= (length start) 1)
+	    (modify-syntax-entry (string-to-char start)
+				 (concat "< " comstyle) st)
+	  (let ((c0 (elt start 0)) (c1 (elt start 1)))
+	    ;; Store the relevant info but don't update yet
+	    (push (cons c0 (concat (cdr (assoc c0 chars)) "1")) chars)
+	    (push (cons c1 (concat (cdr (assoc c1 chars))
+				   (concat "2" comstyle))) chars)))
+	(if (= (length end) 1)
+	    (modify-syntax-entry (string-to-char end)
+				 (concat ">" comstyle) st)
+	  (let ((c0 (elt end 0)) (c1 (elt end 1)))
+	    ;; Store the relevant info but don't update yet
+	    (push (cons c0 (concat (cdr (assoc c0 chars))
+				   (concat "3" comstyle))) chars)
+	    (push (cons c1 (concat (cdr (assoc c1 chars)) "4")) chars)))))

-      (modify-syntax-entry
-       third
-       (concat
-	"."
-	(cond
-	 ((char-equal first   third) " 13")
-	 ((char-equal second  third) " 23")
-	 (t			     " 3"))
-	)
-       generic-mode-syntax-table)
-
-      (modify-syntax-entry
-       fourth
-       (concat
-	"."
-	(cond
-	 ((char-equal first   fourth) " 14")
-	 ((char-equal second  fourth) " 24")
-	 (t			      " 4"))
-	)
-       generic-mode-syntax-table)
-      )))
+    ;; Process the chars that were part of a 2-char comment marker
+    (dolist (cs (nreverse chars))
+      (modify-syntax-entry (car cs)
+			   (concat (char-to-string (char-syntax (car cs)))
+				   " " (cdr cs))
+			   st))
+    (set-syntax-table st)))

 (defun generic-mode-set-font-lock (keywords font-lock-expressions)
   "Set up font-lock functionality for generic mode."
-  (let ((generic-font-lock-expressions))
-    ;; Keywords
-    (and keywords
-	(setq
-	 generic-font-lock-expressions
-	 (append
-	  (list (let ((regexp (regexp-opt keywords)))
-		  (list (concat "\\<\\(" regexp "\\)\\>")
-			1
-			'font-lock-keyword-face)))
-	  generic-font-lock-expressions)))
-    ;; Other font-lock expressions
-    (and font-lock-expressions
-	(setq generic-font-lock-expressions
-	      (append
-	       font-lock-expressions
-	       generic-font-lock-expressions)))
-    (and (or font-lock-expressions keywords)
-	 (setq generic-font-lock-defaults generic-font-lock-expressions))
-    ))
+  (setq generic-font-lock-defaults
+	(append
+	 (when keywords
+	   (list (generic-make-keywords-list keywords font-lock-keyword-face)))
+	 font-lock-expressions)))

 ;; Support for [KEYWORD] constructs found in INF, INI and Samba files
 (defun generic-bracket-support ()
@@ -542,28 +366,20 @@
 ;; generic-mode on the fly. I think this gives us most of what we
 ;; want.
 (defun generic-mode-find-file-hook ()
-  "Hook function to enter default-generic-mode automatically.
+  "Hook function to enter `default-generic-mode' automatically.
 Done if the first few lines of a file in `fundamental-mode' start with
 a hash comment character.  This hook will be installed if the variable
 `generic-use-find-file-hook' is non-nil.  The variable
 `generic-lines-to-scan' determines the number of lines to look at."
-  (if (not (eq major-mode 'fundamental-mode))
-      nil
-    (and (or (> 1  generic-lines-to-scan)
-	     (< 50 generic-lines-to-scan))
-	 (error "Variable `generic-lines-to-scan' should be set to a small"
-		" positive number"))
-    (let ((comment-regexp "")
-	  (count 0)
-	  )
-      (while (< count generic-lines-to-scan)
-	(setq comment-regexp (concat comment-regexp
-				     generic-find-file-regexp))
-	(setq count (1+ count)))
-      (save-excursion
+  (when (eq major-mode 'fundamental-mode)
+    (save-excursion
+      (goto-char (point-min))
+      (when (re-search-forward generic-find-file-regexp
+			       (save-excursion
+				 (forward-line generic-lines-to-scan)
+				 (point)) t)
 	(goto-char (point-min))
-	(and (looking-at comment-regexp)
-	     (generic-mode-with-type 'default-generic-mode))))))
+	(default-generic-mode)))))

 (defun generic-mode-ini-file-find-file-hook ()
   "Hook function to enter default-generic-mode automatically for INI files.
@@ -573,7 +389,7 @@
        (save-excursion
 	 (goto-char (point-min))
 	 (and (looking-at "^\\s-*\\[.*\\]")
-	      (generic-mode-with-type 'ini-generic-mode)))))
+	      (ini-generic-mode)))))

 (and generic-use-find-file-hook
     (add-hook 'find-file-hooks 'generic-mode-find-file-hook))
@@ -581,14 +397,12 @@
 (defun generic-make-keywords-list (keywords-list face &optional prefix suffix)
   "Return a regular expression matching the specified KEYWORDS-LIST.
 The regexp is highlighted with FACE."
-  (and (not (listp keywords-list))
-       (error "Keywords argument must be a list of strings"))
-  (list (concat (or prefix "")
-		"\\<\\("
+  (unless (listp keywords-list)
+    (error "Keywords argument must be a list of strings"))
+  (list (concat prefix "\\<"
 		;; Use an optimized regexp.
 		(regexp-opt keywords-list t)
-		"\\)\\>"
-		(or suffix ""))
+		"\\>" suffix)
 	1
 	face))