X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/1abfd3e85fa9b340699430cd9e15dd9f0073bdbe..32a9496d8d7f87bb7695b62340e2602eb9cab615:/lisp/progmodes/scheme.el diff --git a/lisp/progmodes/scheme.el b/lisp/progmodes/scheme.el index aae5526ea8..32ee3c2399 100644 --- a/lisp/progmodes/scheme.el +++ b/lisp/progmodes/scheme.el @@ -1,6 +1,6 @@ -;;; scheme.el --- Scheme (and DSSSL) editing mode +;;; scheme.el --- Scheme (and DSSSL) editing mode -*- lexical-binding: t; -*- -;; Copyright (C) 1986-1988, 1997-1998, 2001-2013 Free Software +;; Copyright (C) 1986-1988, 1997-1998, 2001-2014 Free Software ;; Foundation, Inc. ;; Author: Bill Rozas @@ -99,7 +99,7 @@ (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) (modify-syntax-entry ?` "' " st) @@ -140,29 +140,22 @@ (setq-local add-log-current-defun-function #'lisp-current-defun-name) (setq-local comment-start ";") (setq-local comment-add 1) - ;; Look within the line for a ; following an even number of backslashes - ;; after either a non-backslash or the line beginning. - (setq-local comment-start-skip - "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+[ \t]*") - (setq-local font-lock-comment-start-skip ";+ *") + (setq-local comment-start-skip ";+[ \t]*") + (setq-local comment-use-syntax t) (setq-local comment-column 40) (setq-local parse-sexp-ignore-comments t) (setq-local lisp-indent-function 'scheme-indent-function) (setq mode-line-process '("" scheme-mode-line-process)) (setq-local imenu-case-fold-search t) - (setq imenu-generic-expression scheme-imenu-generic-expression) - (setq-local imenu-syntax-alist - '(("+-*/.<>=?!$%_&~^:" . "w"))) + (setq-local imenu-generic-expression scheme-imenu-generic-expression) + (setq-local imenu-syntax-alist '(("+-*/.<>=?!$%_&~^:" . "w"))) + (setq-local syntax-propertize-function #'scheme-syntax-propertize) (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) - (parse-sexp-lookup-properties . t) - (font-lock-extra-managed-props syntax-table))) + (font-lock-mark-block-function . mark-defun))) (setq-local lisp-doc-string-elt-property 'scheme-doc-string-elt)) (defvar scheme-mode-line-process "") @@ -210,9 +203,7 @@ start an inferior Scheme using the more general `cmuscheme' package. Commands: Delete converts tabs to spaces as it moves back. Blank lines separate paragraphs. Semicolons start comments. -\\{scheme-mode-map} -Entry to this mode calls the value of `scheme-mode-hook' -if that value is non-nil." +\\{scheme-mode-map}" (scheme-mode-variables)) (defgroup scheme nil @@ -289,7 +280,9 @@ See `run-hooks'." "\\|-module" "\\)\\)\\>" ;; Any whitespace and declared object. - "[ \t]*(?" + ;; The "(*" is for curried definitions, e.g., + ;; (define ((sum a) b) (+ a b)) + "[ \t]*(*" "\\(\\sw+\\)?") '(1 font-lock-keyword-face) '(6 (cond ((match-beginning 3) font-lock-function-name-face) @@ -310,8 +303,10 @@ See `run-hooks'." "(" (regexp-opt '("begin" "call-with-current-continuation" "call/cc" "call-with-input-file" "call-with-output-file" "case" "cond" - "do" "else" "for-each" "if" "lambda" + "do" "else" "for-each" "if" "lambda" "λ" "let" "let*" "let-syntax" "letrec" "letrec-syntax" + ;; R6RS library subforms. + "export" "import" ;; SRFI 11 usage comes up often enough. "let-values" "let*-values" ;; Hannes Haug wants: @@ -330,6 +325,10 @@ See `run-hooks'." ;; ;; Scheme `:' and `#:' keywords as builtins. '("\\<#?:\\sw+\\>" . font-lock-builtin-face) + ;; R6RS library declarations. + '("(\\(\\\\)\\s-*(?\\(\\sw+\\)?" + (1 font-lock-keyword-face) + (2 font-lock-type-face)) ))) "Gaudy expressions to highlight in Scheme modes.") @@ -351,28 +350,28 @@ See `run-hooks'." (forward-comment (point-max)) (if (eq (char-after) ?\() 2 0))) -(defun scheme-font-lock-syntactic-face-function (state) - (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)) +(defun scheme-syntax-propertize (beg end) + (goto-char beg) + (scheme-syntax-propertize-sexp-comment (point) end) + (funcall + (syntax-propertize-rules + ("\\(#\\);" (1 (prog1 "< cn" + (scheme-syntax-propertize-sexp-comment (point) end))))) + (point) end)) + +(defun scheme-syntax-propertize-sexp-comment (_ end) + (let ((state (syntax-ppss))) + (when (eq 2 (nth 7 state)) + ;; It's a sexp-comment. Tell parse-partial-sexp where it ends. + (condition-case nil + (progn + (goto-char (+ 2 (nth 8 state))) + ;; FIXME: this doesn't handle the case where the sexp + ;; itself contains a #; comment. + (forward-sexp 1) + (put-text-property (1- (point)) (point) + 'syntax-table (string-to-syntax "> cn"))) + (scan-error (goto-char end)))))) ;;;###autoload (define-derived-mode dsssl-mode scheme-mode "DSSSL" @@ -410,6 +409,7 @@ that variable's value is a string." (put 'make 'scheme-indent-function 1) (put 'style 'scheme-indent-function 1) (put 'root 'scheme-indent-function 1) +(put 'λ 'scheme-indent-function 1) (defvar dsssl-font-lock-keywords (eval-when-compile @@ -493,20 +493,20 @@ indentation." ;;; Let is different in Scheme -(defun would-be-symbol (string) - (not (string-equal (substring string 0 1) "("))) +;; (defun scheme-would-be-symbol (string) +;; (not (string-equal (substring string 0 1) "("))) -(defun next-sexp-as-string () - ;; Assumes that it is protected by a save-excursion - (forward-sexp 1) - (let ((the-end (point))) - (backward-sexp 1) - (buffer-substring (point) the-end))) +;; (defun scheme-next-sexp-as-string () +;; ;; Assumes that it is protected by a save-excursion +;; (forward-sexp 1) +;; (let ((the-end (point))) +;; (backward-sexp 1) +;; (buffer-substring (point) the-end))) ;; This is correct but too slow. ;; The one below works almost always. ;;(defun scheme-let-indent (state indent-point) -;; (if (would-be-symbol (next-sexp-as-string)) +;; (if (scheme-would-be-symbol (scheme-next-sexp-as-string)) ;; (scheme-indent-specform 2 state indent-point) ;; (scheme-indent-specform 1 state indent-point))) @@ -535,6 +535,7 @@ indentation." (put 'letrec-syntax 'scheme-indent-function 1) (put 'syntax-rules 'scheme-indent-function 1) (put 'syntax-case 'scheme-indent-function 2) ; not r5rs +(put 'library 'scheme-indent-function 1) ; R6RS (put 'call-with-input-file 'scheme-indent-function 1) (put 'with-input-from-file 'scheme-indent-function 1) @@ -587,6 +588,67 @@ indentation." (put 'unassigned\?-components 'scheme-indent-function 1) (put 'unbound\?-components 'scheme-indent-function 1) (put 'variable-components 'scheme-indent-function 1))) + +;; Scheme Interaction Mode + +(defun scheme-eval-defun () + (interactive) + (let ((debug-on-error eval-expression-debug-on-error) + (print-length eval-expression-print-length) + (print-level eval-expression-print-level)) + (let* ((value (eval-scheme (thing-at-point 'defun t))) + (str (eval-expression-print-format value))) + (prin1 value t) + (if str (princ str)) + value))) + +(defun scheme-eval-print-last-sexp (arg) + (interactive "P") + (setq arg (or arg t)) + (let ((standard-output (current-buffer))) + (terpri) + (let ((standard-output (if arg (current-buffer) t)) + (form (buffer-substring-no-properties + (save-excursion (backward-sexp) (point)) + (point)))) + (eval-last-sexp-print-value (eval-scheme form) arg)) + (terpri))) + +(defvar scheme-interaction-mode-map + (let ((map (make-sparse-keymap)) + (menu-map (make-sparse-keymap "Scheme-Interaction"))) + (set-keymap-parent map lisp-mode-shared-map) + (define-key map "\e\C-x" 'scheme-eval-defun) + (define-key map "\n" 'scheme-eval-print-last-sexp) + (bindings--define-key map [menu-bar scheme-interaction] + (cons "Scheme-Interaction" menu-map)) + (bindings--define-key menu-map [eval-defun] + '(menu-item "Evaluate Defun" scheme-eval-defun + :help "Evaluate the top-level form containing point, or after point")) + (bindings--define-key menu-map [print-last-sexp] + '(menu-item "Evaluate and Print" scheme-eval-print-last-sexp + :help "Evaluate sexp before point; print value into current buffer")) + (bindings--define-key menu-map [indent-sexp] + '(menu-item "Indent" indent-sexp + :help "Indent each line of the list starting just after point")) + map) + "Keymap for Scheme Interaction mode. +All commands in `lisp-mode-shared-map' are inherited by this map.") + +(define-derived-mode scheme-interaction-mode scheme-mode "Scheme Interaction" + "Major mode for typing and evaluating Scheme forms. +Like Scheme mode except that \\[scheme-eval-print-last-sexp] evals the +Scheme expression before point, and prints its value into the +buffer, advancing point. Note that printing is controlled by +`eval-expression-print-length' and `eval-expression-print-level'. + +Commands: +Delete converts tabs to spaces as it moves back. +Paragraphs are separated only by blank lines. +Semicolons start comments. + +\\{scheme-interaction-mode-map}" + :abbrev-table nil) (provide 'scheme)