X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/d95af087de80d8309b92b38122451e660df0e398..21c3ef84cc73ded6aa4882afe3e93bc7bd81aca7:/lisp/progmodes/scheme.el

diff --git a/lisp/progmodes/scheme.el b/lisp/progmodes/scheme.el
index cae3ac582e..15ab8edaad 100644
--- a/lisp/progmodes/scheme.el
+++ b/lisp/progmodes/scheme.el
@@ -100,8 +100,9 @@
     ;; Other atom delimiters
     (modify-syntax-entry ?\( "()  " st)
     (modify-syntax-entry ?\) ")(  " st)
-    (modify-syntax-entry ?\; "<   " st)
-    (modify-syntax-entry ?\" "\"    " st)
+    ;; It's used for single-line comments as well as for #;(...) sexp-comments.
+    (modify-syntax-entry ?\; "< 2 " st)
+    (modify-syntax-entry ?\" "\"   " st)
     (modify-syntax-entry ?' "'   " st)
     (modify-syntax-entry ?` "'   " st)
 
@@ -168,15 +169,18 @@
   (setq imenu-generic-expression scheme-imenu-generic-expression)
   (set (make-local-variable 'imenu-syntax-alist)
 	'(("+-*/.<>=?!$%_&~^:" . "w")))
-  (make-local-variable 'font-lock-defaults)
-  (setq font-lock-defaults
-        '((scheme-font-lock-keywords
-           scheme-font-lock-keywords-1 scheme-font-lock-keywords-2)
-          nil t (("+-*/.<>=!?$%_&~^:" . "w") (?#. "w 14"))
-          beginning-of-defun
-          (font-lock-mark-block-function . mark-defun)
-          (font-lock-syntactic-face-function
-           . scheme-font-lock-syntactic-face-function))))
+  (set (make-local-variable 'font-lock-defaults)
+       '((scheme-font-lock-keywords
+          scheme-font-lock-keywords-1 scheme-font-lock-keywords-2)
+         nil t (("+-*/.<>=!?$%_&~^:" . "w") (?#. "w 14"))
+         beginning-of-defun
+         (font-lock-mark-block-function . mark-defun)
+         (font-lock-syntactic-face-function
+          . scheme-font-lock-syntactic-face-function)
+         (parse-sexp-lookup-properties . t)
+         (font-lock-extra-managed-props syntax-table)))
+  (set (make-local-variable 'lisp-doc-string-elt-property)
+       'scheme-doc-string-elt))
 
 (defvar scheme-mode-line-process "")
 
@@ -352,15 +356,43 @@ See `run-hooks'."
 (defvar scheme-font-lock-keywords scheme-font-lock-keywords-1
   "Default expressions to highlight in Scheme modes.")
 
+(defconst scheme-sexp-comment-syntax-table
+  (let ((st (make-syntax-table scheme-mode-syntax-table)))
+    (modify-syntax-entry ?\; "." st)
+    (modify-syntax-entry ?\n " " st)
+    (modify-syntax-entry ?#  "'" st)
+    st))
+
+(put 'lambda 'scheme-doc-string-elt 2)
+;; Docstring's pos in a `define' depends on whether it's a var or fun def.
+(put 'define 'scheme-doc-string-elt
+     (lambda ()
+       ;; The function is called with point right after "define".
+       (forward-comment (point-max))
+       (if (eq (char-after) ?\() 2 0)))
+
 (defun scheme-font-lock-syntactic-face-function (state)
-  (if (nth 3 state)
-      ;; In a string.
-      (if (eq (char-after (nth 8 state)) ?|)
-          ;; This is not a string, but a |...| symbol.
-          nil
-        font-lock-string-face)
-    ;; In a comment.
-    font-lock-comment-face))
+  (when (and (null (nth 3 state))
+             (eq (char-after (nth 8 state)) ?#)
+             (eq (char-after (1+ (nth 8 state))) ?\;))
+    ;; It's a sexp-comment.  Tell parse-partial-sexp where it ends.
+    (save-excursion
+      (let ((pos (point))
+            (end
+             (condition-case err
+                 (let ((parse-sexp-lookup-properties nil))
+                   (goto-char (+ 2 (nth 8 state)))
+                   ;; FIXME: this doesn't handle the case where the sexp
+                   ;; itself contains a #; comment.
+                   (forward-sexp 1)
+                   (point))
+               (scan-error (nth 2 err)))))
+        (when (< pos (- end 2))
+          (put-text-property pos (- end 2)
+                             'syntax-table scheme-sexp-comment-syntax-table))
+        (put-text-property (- end 1) end 'syntax-table '(12)))))
+  ;; Choose the face to use.
+  (lisp-font-lock-syntactic-face-function state))
 
 ;;;###autoload
 (define-derived-mode dsssl-mode scheme-mode "DSSSL"