scheme.el 23.3 KB
Newer Older
1
;;; scheme.el --- Scheme (and DSSSL) editing mode
Eric S. Raymond's avatar
Eric S. Raymond committed
2

3 4
;; Copyright (C) 1986-1988, 1997-1998, 2001-2013 Free Software
;; Foundation, Inc.
Eric S. Raymond's avatar
Eric S. Raymond committed
5

Richard M. Stallman's avatar
Richard M. Stallman committed
6
;; Author: Bill Rozas <jinx@martigny.ai.mit.edu>
7
;; Adapted-by: Dave Love <d.love@dl.ac.uk>
Eric S. Raymond's avatar
Eric S. Raymond committed
8
;; Keywords: languages, lisp
Eric S. Raymond's avatar
Eric S. Raymond committed
9

Richard M. Stallman's avatar
Richard M. Stallman committed
10 11
;; This file is part of GNU Emacs.

12
;; GNU Emacs is free software: you can redistribute it and/or modify
Richard M. Stallman's avatar
Richard M. Stallman committed
13
;; it under the terms of the GNU General Public License as published by
14 15
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
Richard M. Stallman's avatar
Richard M. Stallman committed
16 17 18 19 20 21 22

;; GNU Emacs 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
23
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
Richard M. Stallman's avatar
Richard M. Stallman committed
24

Eric S. Raymond's avatar
Eric S. Raymond committed
25
;;; Commentary:
Richard M. Stallman's avatar
Richard M. Stallman committed
26

27 28 29 30 31 32 33
;; The major mode for editing Scheme-type Lisp code, very similar to
;; the Lisp mode documented in the Emacs manual.  `dsssl-mode' is a
;; variant of scheme-mode for editing DSSSL specifications for SGML
;; documents.  [As of Apr 1997, some pointers for DSSSL may be found,
;; for instance, at <URL:http://www.sil.org/sgml/related.html#dsssl>.]
;; All these Lisp-ish modes vary basically in details of the language
;; syntax they highlight/indent/index, but dsssl-mode uses "^;;;" as
Juanma Barranquero's avatar
Juanma Barranquero committed
34
;; the page-delimiter since ^L isn't normally a valid SGML character.
35 36 37 38
;;
;; For interacting with a Scheme interpreter See also `run-scheme' in
;; the `cmuscheme' package and also the implementation-specific
;; `xscheme' package.
Richard M. Stallman's avatar
Richard M. Stallman committed
39

40 41 42 43 44 45 46 47 48 49 50
;; Here's a recipe to generate a TAGS file for DSSSL, by the way:
;; etags --lang=scheme --regex='/[ \t]*(\(mode\|element\)[ \t
;; ]+\([^ \t(
;; ]+\)/\2/' --regex='/[ \t]*(element[ \t
;; ]*([^)]+[ \t
;; ]+\([^)]+\)[ \t
;; ]*)/\1/' --regex='/(declare[^ \t
;; ]*[ \t
;; ]+\([^ \t
;; ]+\)/\1/' "$@"

Eric S. Raymond's avatar
Eric S. Raymond committed
51
;;; Code:
Richard M. Stallman's avatar
Richard M. Stallman committed
52

53 54
(require 'lisp-mode)

55 56 57
(defvar scheme-mode-syntax-table
  (let ((st (make-syntax-table))
	(i 0))
58 59 60 61 62
    ;; Symbol constituents
    ;; We used to treat chars 128-256 as symbol-constituent, but they
    ;; should be valid word constituents (Bug#8843).  Note that valid
    ;; identifier characters are Scheme-implementation dependent.
    (while (< i ?0)
63 64
      (modify-syntax-entry i "_   " st)
      (setq i (1+ i)))
65 66 67
    (setq i (1+ ?9))
    (while (< i ?A)
      (modify-syntax-entry i "_   " st)
68
      (setq i (1+ i)))
69 70 71
    (setq i (1+ ?Z))
    (while (< i ?a)
      (modify-syntax-entry i "_   " st)
72
      (setq i (1+ i)))
73 74 75
    (setq i (1+ ?z))
    (while (< i 128)
      (modify-syntax-entry i "_   " st)
76 77 78 79 80 81 82
      (setq i (1+ i)))

    ;; Whitespace
    (modify-syntax-entry ?\t "    " st)
    (modify-syntax-entry ?\n ">   " st)
    (modify-syntax-entry ?\f "    " st)
    (modify-syntax-entry ?\r "    " st)
83
    (modify-syntax-entry ?\s "    " st)
84 85 86 87 88 89 90

    ;; These characters are delimiters but otherwise undefined.
    ;; Brackets and braces balance for editing convenience.
    (modify-syntax-entry ?\[ "(]  " st)
    (modify-syntax-entry ?\] ")[  " st)
    (modify-syntax-entry ?{ "(}  " st)
    (modify-syntax-entry ?} "){  " st)
91 92 93 94 95 96
    (modify-syntax-entry ?\| "\" 23bn" st)
    ;; Guile allows #! ... !# comments.
    ;; But SRFI-22 defines the comment as #!...\n instead.
    ;; Also Guile says that the !# should be on a line of its own.
    ;; It's too difficult to get it right, for too little benefit.
    ;; (modify-syntax-entry ?! "_ 2" st)
97 98 99 100

    ;; Other atom delimiters
    (modify-syntax-entry ?\( "()  " st)
    (modify-syntax-entry ?\) ")(  " st)
101 102 103
    ;; It's used for single-line comments as well as for #;(...) sexp-comments.
    (modify-syntax-entry ?\; "< 2 " st)
    (modify-syntax-entry ?\" "\"   " st)
104 105
    (modify-syntax-entry ?' "'   " st)
    (modify-syntax-entry ?` "'   " st)
106 107

    ;; Special characters
108 109
    (modify-syntax-entry ?, "'   " st)
    (modify-syntax-entry ?@ "'   " st)
110
    (modify-syntax-entry ?# "' 14" st)
111
    (modify-syntax-entry ?\\ "\\   " st)
112
    st))
Richard M. Stallman's avatar
Richard M. Stallman committed
113

Dave Love's avatar
Dave Love committed
114
(defvar scheme-mode-abbrev-table nil)
Richard M. Stallman's avatar
Richard M. Stallman committed
115 116
(define-abbrev-table 'scheme-mode-abbrev-table ())

117
(defvar scheme-imenu-generic-expression
Dave Love's avatar
Dave Love committed
118
      '((nil
119
	 "^(define\\(\\|-\\(generic\\(\\|-procedure\\)\\|method\\)\\)*\\s-+(?\\(\\sw+\\)" 4)
Dave Love's avatar
Dave Love committed
120
	("Types"
121
	 "^(define-class\\s-+(?\\(\\sw+\\)" 1)
Dave Love's avatar
Dave Love committed
122
	("Macros"
123
	 "^(\\(defmacro\\|define-macro\\|define-syntax\\)\\s-+(?\\(\\sw+\\)" 2))
124 125
  "Imenu generic expression for Scheme mode.  See `imenu-generic-expression'.")

Richard M. Stallman's avatar
Richard M. Stallman committed
126 127 128
(defun scheme-mode-variables ()
  (set-syntax-table scheme-mode-syntax-table)
  (setq local-abbrev-table scheme-mode-abbrev-table)
129 130 131 132
  (set (make-local-variable 'paragraph-start) (concat "$\\|" page-delimiter))
  (set (make-local-variable 'paragraph-separate) paragraph-start)
  (set (make-local-variable 'paragraph-ignore-fill-prefix) t)
  (set (make-local-variable 'fill-paragraph-function) 'lisp-fill-paragraph)
133 134 135
  ;; Adaptive fill mode gets in the way of auto-fill,
  ;; and should make no difference for explicit fill
  ;; because lisp-fill-paragraph should do the job.
136 137 138 139 140
  (set (make-local-variable 'adaptive-fill-mode) nil)
  (set (make-local-variable 'indent-line-function) 'lisp-indent-line)
  (set (make-local-variable 'parse-sexp-ignore-comments) t)
  (set (make-local-variable 'outline-regexp) ";;; \\|(....")
  (set (make-local-variable 'comment-start) ";")
141
  (set (make-local-variable 'comment-add) 1)
142 143
  ;; Look within the line for a ; following an even number of backslashes
  ;; after either a non-backslash or the line beginning.
144 145
  (set (make-local-variable 'comment-start-skip)
       "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+[ \t]*")
146
  (set (make-local-variable 'font-lock-comment-start-skip) ";+ *")
147 148 149
  (set (make-local-variable 'comment-column) 40)
  (set (make-local-variable 'parse-sexp-ignore-comments) t)
  (set (make-local-variable 'lisp-indent-function) 'scheme-indent-function)
150
  (setq mode-line-process '("" scheme-mode-line-process))
151
  (set (make-local-variable 'imenu-case-fold-search) t)
Dave Love's avatar
Dave Love committed
152
  (setq imenu-generic-expression scheme-imenu-generic-expression)
153 154
  (set (make-local-variable 'imenu-syntax-alist)
	'(("+-*/.<>=?!$%_&~^:" . "w")))
155 156 157 158 159 160 161 162 163 164 165 166
  (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))
Richard M. Stallman's avatar
Richard M. Stallman committed
167 168 169

(defvar scheme-mode-line-process "")

170 171 172 173 174
(defvar scheme-mode-map
  (let ((smap (make-sparse-keymap))
	(map (make-sparse-keymap "Scheme")))
    (set-keymap-parent smap lisp-mode-shared-map)
    (define-key smap [menu-bar scheme] (cons "Scheme" map))
Dave Love's avatar
Dave Love committed
175 176 177 178 179 180 181 182 183 184
    (define-key map [run-scheme] '("Run Inferior Scheme" . run-scheme))
    (define-key map [uncomment-region]
      '("Uncomment Out Region" . (lambda (beg end)
                                   (interactive "r")
                                   (comment-region beg end '(4)))))
    (define-key map [comment-region] '("Comment Out Region" . comment-region))
    (define-key map [indent-region] '("Indent Region" . indent-region))
    (define-key map [indent-line] '("Indent Line" . lisp-indent-line))
    (put 'comment-region 'menu-enable 'mark-active)
    (put 'uncomment-region 'menu-enable 'mark-active)
185 186 187 188
    (put 'indent-region 'menu-enable 'mark-active)
    smap)
  "Keymap for Scheme mode.
All commands in `lisp-mode-shared-map' are inherited by this map.")
189 190

;; Used by cmuscheme
Richard M. Stallman's avatar
Richard M. Stallman committed
191
(defun scheme-mode-commands (map)
Richard M. Stallman's avatar
Richard M. Stallman committed
192
  ;;(define-key map "\t" 'indent-for-tab-command) ; default
Richard M. Stallman's avatar
Richard M. Stallman committed
193
  (define-key map "\177" 'backward-delete-char-untabify)
Richard M. Stallman's avatar
Richard M. Stallman committed
194
  (define-key map "\e\C-q" 'indent-sexp))
Richard M. Stallman's avatar
Richard M. Stallman committed
195

Jim Blandy's avatar
Jim Blandy committed
196
;;;###autoload
197
(define-derived-mode scheme-mode prog-mode "Scheme"
Richard M. Stallman's avatar
Richard M. Stallman committed
198
  "Major mode for editing Scheme code.
Dave Love's avatar
Dave Love committed
199
Editing commands are similar to those of `lisp-mode'.
Richard M. Stallman's avatar
Richard M. Stallman committed
200 201 202 203

In addition, if an inferior Scheme process is running, some additional
commands will be defined, for evaluating expressions and controlling
the interpreter, and the state of the process will be displayed in the
204
mode line of all Scheme buffers.  The names of commands that interact
205 206 207 208
with the Scheme process start with \"xscheme-\" if you use the MIT
Scheme-specific `xscheme' package; for more information see the
documentation for `xscheme-interaction-mode'.  Use \\[run-scheme] to
start an inferior Scheme using the more general `cmuscheme' package.
Richard M. Stallman's avatar
Richard M. Stallman committed
209 210 211 212 213

Commands:
Delete converts tabs to spaces as it moves back.
Blank lines separate paragraphs.  Semicolons start comments.
\\{scheme-mode-map}
Dave Love's avatar
Dave Love committed
214
Entry to this mode calls the value of `scheme-mode-hook'
Richard M. Stallman's avatar
Richard M. Stallman committed
215
if that value is non-nil."
216
  (scheme-mode-variables))
Richard M. Stallman's avatar
Richard M. Stallman committed
217

Richard M. Stallman's avatar
Richard M. Stallman committed
218
(defgroup scheme nil
219
  "Editing Scheme code."
220
  :link '(custom-group-link :tag "Font Lock Faces group" font-lock-faces)
Richard M. Stallman's avatar
Richard M. Stallman committed
221 222 223
  :group 'lisp)

(defcustom scheme-mit-dialect t
Richard M. Stallman's avatar
Richard M. Stallman committed
224
  "If non-nil, scheme mode is specialized for MIT Scheme.
Richard M. Stallman's avatar
Richard M. Stallman committed
225 226 227
Set this to nil if you normally use another dialect."
  :type 'boolean
  :group 'scheme)
228

Richard M. Stallman's avatar
Richard M. Stallman committed
229
(defcustom dsssl-sgml-declaration
230 231
  "<!DOCTYPE style-sheet PUBLIC \"-//James Clark//DTD DSSSL Style Sheet//EN\">
"
232
  "An SGML declaration for the DSSSL file.
233
If it is defined as a string this will be inserted into an empty buffer
Dave Love's avatar
Dave Love committed
234
which is in `dsssl-mode'.  It is typically James Clark's style-sheet
Richard M. Stallman's avatar
Richard M. Stallman committed
235
doctype, as required for Jade."
Dave Love's avatar
Dave Love committed
236
  :type '(choice (string :tag "Specified string")
237 238 239 240
                 (const :tag "None" :value nil))
  :group 'scheme)

(defcustom scheme-mode-hook nil
Dave Love's avatar
Dave Love committed
241
  "Normal hook run when entering `scheme-mode'.
242 243 244 245 246
See `run-hooks'."
  :type 'hook
  :group 'scheme)

(defcustom dsssl-mode-hook nil
Dave Love's avatar
Dave Love committed
247
  "Normal hook run when entering `dsssl-mode'.
248 249
See `run-hooks'."
  :type 'hook
Richard M. Stallman's avatar
Richard M. Stallman committed
250
  :group 'scheme)
251

Dave Love's avatar
Dave Love committed
252 253
;; This is shared by cmuscheme and xscheme.
(defcustom scheme-program-name "scheme"
254
  "Program invoked by the `run-scheme' command."
Dave Love's avatar
Dave Love committed
255 256 257
  :type 'string
  :group 'scheme)

258 259 260 261 262
(defvar dsssl-imenu-generic-expression
  ;; Perhaps this should also look for the style-sheet DTD tags.  I'm
  ;; not sure it's the best way to organize it; perhaps one type
  ;; should be at the first level, though you don't see this anyhow if
  ;; it gets split up.
Dave Love's avatar
Dave Love committed
263
  '(("Defines"
264
     "^(define\\s-+(?\\(\\sw+\\)" 1)
Dave Love's avatar
Dave Love committed
265
    ("Modes"
266
     "^\\s-*(mode\\s-+\\(\\(\\sw\\|\\s-\\)+\\)" 1)
Dave Love's avatar
Dave Love committed
267
    ("Elements"
268
     ;; (element foo ...) or (element (foo bar ...) ...)
269
     ;; Fixme: Perhaps it should do `root'.
270
     "^\\s-*(element\\s-+(?\\(\\(\\sw\\|\\s-\\)+\\))?" 1)
Dave Love's avatar
Dave Love committed
271
    ("Declarations"
272
     "^(declare\\(-\\sw+\\)+\\>\\s-+\\(\\sw+\\)" 2))
273 274
  "Imenu generic expression for DSSSL mode.  See `imenu-generic-expression'.")

275 276 277 278 279 280
(defconst scheme-font-lock-keywords-1
  (eval-when-compile
    (list
     ;;
     ;; Declarations.  Hannes Haug <hannes.haug@student.uni-tuebingen.de> says
     ;; this works for SOS, STklos, SCOOPS, Meroon and Tiny CLOS.
281
     (list (concat "(\\(define\\*?\\("
282
		   ;; Function names.
283
		   "\\(\\|-public\\|-method\\|-generic\\(-procedure\\)?\\)\\|"
284
		   ;; Macro names, as variable names.  A bit dubious, this.
285
		   "\\(-syntax\\|-macro\\)\\|"
286 287
		   ;; Class names.
		   "-class"
288 289
                   ;; Guile modules.
                   "\\|-module"
290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312
		   "\\)\\)\\>"
		   ;; Any whitespace and declared object.
		   "[ \t]*(?"
		   "\\(\\sw+\\)?")
	   '(1 font-lock-keyword-face)
	   '(6 (cond ((match-beginning 3) font-lock-function-name-face)
		     ((match-beginning 5) font-lock-variable-name-face)
		     (t font-lock-type-face))
	       nil t))
     ))
  "Subdued expressions to highlight in Scheme modes.")

(defconst scheme-font-lock-keywords-2
  (append scheme-font-lock-keywords-1
   (eval-when-compile
     (list
      ;;
      ;; Control structures.
      (cons
       (concat
	"(" (regexp-opt
	     '("begin" "call-with-current-continuation" "call/cc"
	       "call-with-input-file" "call-with-output-file" "case" "cond"
313
	       "do" "else" "for-each" "if" "lambda" "λ"
314
	       "let" "let*" "let-syntax" "letrec" "letrec-syntax"
315 316
	       ;; SRFI 11 usage comes up often enough.
	       "let-values" "let*-values"
317
	       ;; Hannes Haug <hannes.haug@student.uni-tuebingen.de> wants:
318
	       "and" "or" "delay" "force"
319 320 321 322 323
	       ;; Stefan Monnier <stefan.monnier@epfl.ch> says don't bother:
	       ;;"quasiquote" "quote" "unquote" "unquote-splicing"
	       "map" "syntax" "syntax-rules") t)
	"\\>") 1)
      ;;
324 325 326 327
      ;; It wouldn't be Scheme w/o named-let.
      '("(let\\s-+\\(\\sw+\\)"
        (1 font-lock-function-name-face))
      ;;
328 329 330
      ;; David Fox <fox@graphics.cs.nyu.edu> for SOS/STklos class specifiers.
      '("\\<<\\sw+>\\>" . font-lock-type-face)
      ;;
331 332
      ;; Scheme `:' and `#:' keywords as builtins.
      '("\\<#?:\\sw+\\>" . font-lock-builtin-face)
333 334 335 336 337 338
      )))
  "Gaudy expressions to highlight in Scheme modes.")

(defvar scheme-font-lock-keywords scheme-font-lock-keywords-1
  "Default expressions to highlight in Scheme modes.")

339 340 341 342 343 344 345 346 347 348 349 350 351 352 353
(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)))

354
(defun scheme-font-lock-syntactic-face-function (state)
355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375
  (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))
376

377
;;;###autoload
378
(define-derived-mode dsssl-mode scheme-mode "DSSSL"
379
  "Major mode for editing DSSSL code.
Dave Love's avatar
Dave Love committed
380
Editing commands are similar to those of `lisp-mode'.
381 382 383 384 385

Commands:
Delete converts tabs to spaces as it moves back.
Blank lines separate paragraphs.  Semicolons start comments.
\\{scheme-mode-map}
386 387 388
Entering this mode runs the hooks `scheme-mode-hook' and then
`dsssl-mode-hook' and inserts the value of `dsssl-sgml-declaration' if
that variable's value is a string."
389
  (set (make-local-variable 'page-delimiter) "^;;;") ; ^L not valid SGML char
390
  ;; Insert a suitable SGML declaration into an empty buffer.
391
  ;; FIXME: This should use `auto-insert-alist' instead.
392
  (and (zerop (buffer-size))
393
       (stringp dsssl-sgml-declaration)
394 395
       (not buffer-read-only)
       (insert dsssl-sgml-declaration))
396 397 398 399
  (setq font-lock-defaults '(dsssl-font-lock-keywords
			     nil t (("+-*/.<>=?$%_&~^:" . "w"))
			     beginning-of-defun
			     (font-lock-mark-block-function . mark-defun)))
400
  (set (make-local-variable 'imenu-case-fold-search) nil)
Dave Love's avatar
Dave Love committed
401
  (setq imenu-generic-expression dsssl-imenu-generic-expression)
402
  (set (make-local-variable 'imenu-syntax-alist)
403
       '(("+-*/.<>=?$%_&~^:" . "w"))))
404 405 406 407 408 409

;; Extra syntax for DSSSL.  This isn't separated from Scheme, but
;; shouldn't cause much trouble in scheme-mode.
(put 'element 'scheme-indent-function 1)
(put 'mode 'scheme-indent-function 1)
(put 'with-mode 'scheme-indent-function 1)
410
(put 'make 'scheme-indent-function 1)
411 412
(put 'style 'scheme-indent-function 1)
(put 'root 'scheme-indent-function 1)
413
(put 'λ 'scheme-indent-function 1)
414 415

(defvar dsssl-font-lock-keywords
416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436
  (eval-when-compile
    (list
     ;; Similar to Scheme
     (list "(\\(define\\(-\\w+\\)?\\)\\>[ 	]*\\\((?\\)\\(\\sw+\\)\\>"
	   '(1 font-lock-keyword-face)
	   '(4 font-lock-function-name-face))
     (cons
      (concat "(\\("
	      ;; (make-regexp '("case" "cond" "else" "if" "lambda"
	      ;; "let" "let*" "letrec" "and" "or" "map" "with-mode"))
	      "and\\|c\\(ase\\|ond\\)\\|else\\|if\\|"
	      "l\\(ambda\\|et\\(\\|*\\|rec\\)\\)\\|map\\|or\\|with-mode"
	      "\\)\\>")
      1)
     ;; DSSSL syntax
     '("(\\(element\\|mode\\|declare-\\w+\\)\\>[ 	]*\\(\\sw+\\)"
       (1 font-lock-keyword-face)
       (2 font-lock-type-face))
     '("(\\(element\\)\\>[ 	]*(\\(\\S)+\\))"
       (1 font-lock-keyword-face)
       (2 font-lock-type-face))
437
     '("\\<\\sw+:\\>" . font-lock-constant-face) ; trailing `:' c.f. scheme
438 439 440
     ;; SGML markup (from sgml-mode) :
     '("<\\([!?][-a-z0-9]+\\)" 1 font-lock-keyword-face)
     '("<\\(/?[-a-z0-9]+\\)" 1 font-lock-function-name-face)))
441 442
  "Default expressions to highlight in DSSSL mode.")

Richard M. Stallman's avatar
Richard M. Stallman committed
443

444 445
(defvar calculate-lisp-indent-last-sexp)

446 447 448

;; FIXME this duplicates almost all of lisp-indent-function.
;; Extract common code to a subroutine.
Richard M. Stallman's avatar
Richard M. Stallman committed
449
(defun scheme-indent-function (indent-point state)
450 451 452 453
  "Scheme mode function for the value of the variable `lisp-indent-function'.
This behaves like the function `lisp-indent-function', except that:

i) it checks for a non-nil value of the property `scheme-indent-function'
454
\(or the deprecated `scheme-indent-hook'), rather than `lisp-indent-function'.
455

456
ii) if that property specifies a function, it is called with three
457 458
arguments (not two), the third argument being the default (i.e., current)
indentation."
Richard M. Stallman's avatar
Richard M. Stallman committed
459
  (let ((normal-indent (current-column)))
460 461 462 463
    (goto-char (1+ (elt state 1)))
    (parse-partial-sexp (point) calculate-lisp-indent-last-sexp 0 t)
    (if (and (elt state 2)
             (not (looking-at "\\sw\\|\\s_")))
Juanma Barranquero's avatar
Juanma Barranquero committed
464
        ;; car of form doesn't seem to be a symbol
465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491
        (progn
          (if (not (> (save-excursion (forward-line 1) (point))
                      calculate-lisp-indent-last-sexp))
              (progn (goto-char calculate-lisp-indent-last-sexp)
                     (beginning-of-line)
                     (parse-partial-sexp (point)
					 calculate-lisp-indent-last-sexp 0 t)))
          ;; Indent under the list or under the first sexp on the same
          ;; line as calculate-lisp-indent-last-sexp.  Note that first
          ;; thing on that line has to be complete sexp since we are
          ;; inside the innermost containing sexp.
          (backward-prefix-chars)
          (current-column))
      (let ((function (buffer-substring (point)
					(progn (forward-sexp 1) (point))))
	    method)
	(setq method (or (get (intern-soft function) 'scheme-indent-function)
			 (get (intern-soft function) 'scheme-indent-hook)))
	(cond ((or (eq method 'defun)
		   (and (null method)
			(> (length function) 3)
			(string-match "\\`def" function)))
	       (lisp-indent-defform state indent-point))
	      ((integerp method)
	       (lisp-indent-specform method state
				     indent-point normal-indent))
	      (method
492
		(funcall method state indent-point normal-indent)))))))
493

Richard M. Stallman's avatar
Richard M. Stallman committed
494 495 496 497 498 499 500

;;; Let is different in Scheme

(defun would-be-symbol (string)
  (not (string-equal (substring string 0 1) "(")))

(defun next-sexp-as-string ()
Dave Love's avatar
Dave Love committed
501
  ;; Assumes that it is protected by a save-excursion
Richard M. Stallman's avatar
Richard M. Stallman committed
502 503 504 505 506 507 508 509 510 511 512 513
  (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))
;;      (scheme-indent-specform 2 state indent-point)
;;      (scheme-indent-specform 1 state indent-point)))

514
(defun scheme-let-indent (state indent-point normal-indent)
Richard M. Stallman's avatar
Richard M. Stallman committed
515
  (skip-chars-forward " \t")
516
  (if (looking-at "[-a-zA-Z0-9+*/?!@$%^&_:~]")
517 518
      (lisp-indent-specform 2 state indent-point normal-indent)
    (lisp-indent-specform 1 state indent-point normal-indent)))
Richard M. Stallman's avatar
Richard M. Stallman committed
519 520 521 522 523 524 525 526 527 528 529 530 531

;; (put 'begin 'scheme-indent-function 0), say, causes begin to be indented
;; like defun if the first form is placed on the next line, otherwise
;; it is indented like any other form (i.e. forms line up under first).

(put 'begin 'scheme-indent-function 0)
(put 'case 'scheme-indent-function 1)
(put 'delay 'scheme-indent-function 0)
(put 'do 'scheme-indent-function 2)
(put 'lambda 'scheme-indent-function 1)
(put 'let 'scheme-indent-function 'scheme-let-indent)
(put 'let* 'scheme-indent-function 1)
(put 'letrec 'scheme-indent-function 1)
532 533
(put 'let-values 'scheme-indent-function 1) ; SRFI 11
(put 'let*-values 'scheme-indent-function 1) ; SRFI 11
534 535 536 537
(put 'sequence 'scheme-indent-function 0) ; SICP, not r4rs
(put 'let-syntax 'scheme-indent-function 1)
(put 'letrec-syntax 'scheme-indent-function 1)
(put 'syntax-rules 'scheme-indent-function 1)
Dave Love's avatar
Dave Love committed
538
(put 'syntax-case 'scheme-indent-function 2) ; not r5rs
Richard M. Stallman's avatar
Richard M. Stallman committed
539 540 541 542 543 544 545

(put 'call-with-input-file 'scheme-indent-function 1)
(put 'with-input-from-file 'scheme-indent-function 1)
(put 'with-input-from-port 'scheme-indent-function 1)
(put 'call-with-output-file 'scheme-indent-function 1)
(put 'with-output-to-file 'scheme-indent-function 1)
(put 'with-output-to-port 'scheme-indent-function 1)
546 547
(put 'call-with-values 'scheme-indent-function 1) ; r5rs?
(put 'dynamic-wind 'scheme-indent-function 3) ; r5rs?
Richard M. Stallman's avatar
Richard M. Stallman committed
548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590

;;;; MIT Scheme specific indentation.

(if scheme-mit-dialect
    (progn
      (put 'fluid-let 'scheme-indent-function 1)
      (put 'in-package 'scheme-indent-function 1)
      (put 'local-declare 'scheme-indent-function 1)
      (put 'macro 'scheme-indent-function 1)
      (put 'make-environment 'scheme-indent-function 0)
      (put 'named-lambda 'scheme-indent-function 1)
      (put 'using-syntax 'scheme-indent-function 1)

      (put 'with-input-from-string 'scheme-indent-function 1)
      (put 'with-output-to-string 'scheme-indent-function 0)
      (put 'with-values 'scheme-indent-function 1)

      (put 'syntax-table-define 'scheme-indent-function 2)
      (put 'list-transform-positive 'scheme-indent-function 1)
      (put 'list-transform-negative 'scheme-indent-function 1)
      (put 'list-search-positive 'scheme-indent-function 1)
      (put 'list-search-negative 'scheme-indent-function 1)

      (put 'access-components 'scheme-indent-function 1)
      (put 'assignment-components 'scheme-indent-function 1)
      (put 'combination-components 'scheme-indent-function 1)
      (put 'comment-components 'scheme-indent-function 1)
      (put 'conditional-components 'scheme-indent-function 1)
      (put 'disjunction-components 'scheme-indent-function 1)
      (put 'declaration-components 'scheme-indent-function 1)
      (put 'definition-components 'scheme-indent-function 1)
      (put 'delay-components 'scheme-indent-function 1)
      (put 'in-package-components 'scheme-indent-function 1)
      (put 'lambda-components 'scheme-indent-function 1)
      (put 'lambda-components* 'scheme-indent-function 1)
      (put 'lambda-components** 'scheme-indent-function 1)
      (put 'open-block-components 'scheme-indent-function 1)
      (put 'pathname-components 'scheme-indent-function 1)
      (put 'procedure-components 'scheme-indent-function 1)
      (put 'sequence-components 'scheme-indent-function 1)
      (put 'unassigned\?-components 'scheme-indent-function 1)
      (put 'unbound\?-components 'scheme-indent-function 1)
      (put 'variable-components 'scheme-indent-function 1)))
Jim Blandy's avatar
Jim Blandy committed
591 592

(provide 'scheme)
Eric S. Raymond's avatar
Eric S. Raymond committed
593 594

;;; scheme.el ends here