![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to scheme.el CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Apple XNU] / GNUtools / emacs / lisp|
Return to scheme.el CVS log | Up to [Apple XNU] / GNUtools / emacs / lisp |
1.1 root 1: ;; Scheme mode, and its idiosyncratic commands.
2: ;; Copyright (C) 1986, 1987, 1988, 1990 Free Software Foundation, Inc.
3: ;; Adapted from Lisp mode by Bill Rozas, jinx@prep.
4:
5: ;; This file is part of GNU Emacs.
6:
7: ;; GNU Emacs is free software; you can redistribute it and/or modify
8: ;; it under the terms of the GNU General Public License as published by
9: ;; the Free Software Foundation; either version 1, or (at your option)
10: ;; any later version.
11:
12: ;; GNU Emacs is distributed in the hope that it will be useful,
13: ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14: ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15: ;; GNU General Public License for more details.
16:
17: ;; You should have received a copy of the GNU General Public License
18: ;; along with GNU Emacs; see the file COPYING. If not, write to
19: ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
20:
21:
22: ;; Initially a query replace of Lisp mode, except for the indentation
23: ;; of special forms. Probably the code should be merged at some point
24: ;; so that there is sharing between both libraries.
25:
26: ;;; $Header: scheme.el,v 1.7 88/07/15 20:20:00 GMT cph Exp $
27:
28: (provide 'scheme)
29:
30: (defvar scheme-mode-syntax-table nil "")
31: (if (not scheme-mode-syntax-table)
32: (let ((i 0))
33: (setq scheme-mode-syntax-table (make-syntax-table))
34: (set-syntax-table scheme-mode-syntax-table)
35:
36: ;; Default is atom-constituent.
37: (while (< i 256)
38: (modify-syntax-entry i "_ ")
39: (setq i (1+ i)))
40:
41: ;; Word components.
42: (setq i ?0)
43: (while (<= i ?9)
44: (modify-syntax-entry i "w ")
45: (setq i (1+ i)))
46: (setq i ?A)
47: (while (<= i ?Z)
48: (modify-syntax-entry i "w ")
49: (setq i (1+ i)))
50: (setq i ?a)
51: (while (<= i ?z)
52: (modify-syntax-entry i "w ")
53: (setq i (1+ i)))
54:
55: ;; Whitespace
56: (modify-syntax-entry ?\t " ")
57: (modify-syntax-entry ?\n "> ")
58: (modify-syntax-entry ?\f " ")
59: (modify-syntax-entry ?\r " ")
60: (modify-syntax-entry ? " ")
61:
62: ;; These characters are delimiters but otherwise undefined.
63: ;; Brackets and braces balance for editing convenience.
64: (modify-syntax-entry ?[ "(] ")
65: (modify-syntax-entry ?] ")[ ")
66: (modify-syntax-entry ?{ "(} ")
67: (modify-syntax-entry ?} "){ ")
68: (modify-syntax-entry ?\| " ")
69:
70: ;; Other atom delimiters
71: (modify-syntax-entry ?\( "() ")
72: (modify-syntax-entry ?\) ")( ")
73: (modify-syntax-entry ?\; "< ")
74: (modify-syntax-entry ?\" "\" ")
75: (modify-syntax-entry ?' "' ")
76: (modify-syntax-entry ?` "' ")
77:
78: ;; Special characters
79: (modify-syntax-entry ?, "' ")
80: (modify-syntax-entry ?@ "' ")
81: (modify-syntax-entry ?# "' ")
82: (modify-syntax-entry ?\\ "\\ ")))
83:
84: (defvar scheme-mode-abbrev-table nil "")
85: (define-abbrev-table 'scheme-mode-abbrev-table ())
86:
87: (defun scheme-mode-variables ()
88: (set-syntax-table scheme-mode-syntax-table)
89: (setq local-abbrev-table scheme-mode-abbrev-table)
90: (make-local-variable 'paragraph-start)
91: (setq paragraph-start (concat "^$\\|" page-delimiter))
92: (make-local-variable 'paragraph-separate)
93: (setq paragraph-separate paragraph-start)
94: (make-local-variable 'paragraph-ignore-fill-prefix)
95: (setq paragraph-ignore-fill-prefix t)
96: (make-local-variable 'indent-line-function)
97: (setq indent-line-function 'scheme-indent-line)
98: (make-local-variable 'comment-start)
99: (setq comment-start ";")
100: (make-local-variable 'comment-start-skip)
101: (setq comment-start-skip ";+[ \t]*")
102: (make-local-variable 'comment-column)
103: (setq comment-column 40)
104: (make-local-variable 'comment-indent-hook)
105: (setq comment-indent-hook 'scheme-comment-indent)
106: (setq mode-line-process '("" scheme-mode-line-process)))
107:
108: (defvar scheme-mode-line-process "")
109:
110: (defun scheme-mode-commands (map)
111: (define-key map "\t" 'scheme-indent-line)
112: (define-key map "\177" 'backward-delete-char-untabify)
113: (define-key map "\e\C-q" 'scheme-indent-sexp))
114:
115: (defvar scheme-mode-map nil)
116: (if (not scheme-mode-map)
117: (progn
118: (setq scheme-mode-map (make-sparse-keymap))
119: (scheme-mode-commands scheme-mode-map)))
120:
121: (defun scheme-mode ()
122: "Major mode for editing Scheme code.
123: Editing commands are similar to those of lisp-mode.
124:
125: In addition, if an inferior Scheme process is running, some additional
126: commands will be defined, for evaluating expressions and controlling
127: the interpreter, and the state of the process will be displayed in the
128: modeline of all Scheme buffers. The names of commands that interact
129: with the Scheme process start with \"xscheme-\". For more information
130: see the documentation for xscheme-interaction-mode.
131:
132: Commands:
133: Delete converts tabs to spaces as it moves back.
134: Blank lines separate paragraphs. Semicolons start comments.
135: \\{scheme-mode-map}
136: Entry to this mode calls the value of scheme-mode-hook
137: if that value is non-nil."
138: (interactive)
139: (kill-all-local-variables)
140: (scheme-mode-initialize)
141: (scheme-mode-variables)
142: (run-hooks 'scheme-mode-hook))
143:
144: (defun scheme-mode-initialize ()
145: (use-local-map scheme-mode-map)
146: (setq major-mode 'scheme-mode)
147: (setq mode-name "Scheme"))
148:
149: (defvar scheme-mit-dialect t
150: "If non-nil, scheme mode is specialized for MIT Scheme.
151: Set this to nil if you normally use another dialect.")
152:
153: (defun scheme-comment-indent (&optional pos)
154: (save-excursion
155: (if pos (goto-char pos))
156: (cond ((looking-at ";;;") (current-column))
157: ((looking-at ";;")
158: (let ((tem (calculate-scheme-indent)))
159: (if (listp tem) (car tem) tem)))
160: (t
161: (skip-chars-backward " \t")
162: (max (if (bolp) 0 (1+ (current-column)))
163: comment-column)))))
164:
165: (defvar scheme-indent-offset nil "")
166: (defvar scheme-indent-hook 'scheme-indent-hook "")
167:
168: (defun scheme-indent-line (&optional whole-exp)
169: "Indent current line as Scheme code.
170: With argument, indent any additional lines of the same expression
171: rigidly along with this one."
172: (interactive "P")
173: (let ((indent (calculate-scheme-indent)) shift-amt beg end
174: (pos (- (point-max) (point))))
175: (beginning-of-line)
176: (setq beg (point))
177: (skip-chars-forward " \t")
178: (if (looking-at "[ \t]*;;;")
179: ;; Don't alter indentation of a ;;; comment line.
180: nil
181: (if (listp indent) (setq indent (car indent)))
182: (setq shift-amt (- indent (current-column)))
183: (if (zerop shift-amt)
184: nil
185: (delete-region beg (point))
186: (indent-to indent))
187: ;; If initial point was within line's indentation,
188: ;; position after the indentation. Else stay at same point in text.
189: (if (> (- (point-max) pos) (point))
190: (goto-char (- (point-max) pos)))
191: ;; If desired, shift remaining lines of expression the same amount.
192: (and whole-exp (not (zerop shift-amt))
193: (save-excursion
194: (goto-char beg)
195: (forward-sexp 1)
196: (setq end (point))
197: (goto-char beg)
198: (forward-line 1)
199: (setq beg (point))
200: (> end beg))
201: (indent-code-rigidly beg end shift-amt)))))
202:
203: (defun calculate-scheme-indent (&optional parse-start)
204: "Return appropriate indentation for current line as scheme code.
205: In usual case returns an integer: the column to indent to.
206: Can instead return a list, whose car is the column to indent to.
207: This means that following lines at the same level of indentation
208: should not necessarily be indented the same way.
209: The second element of the list is the buffer position
210: of the start of the containing expression."
211: (save-excursion
212: (beginning-of-line)
213: (let ((indent-point (point)) state paren-depth desired-indent (retry t)
214: last-sexp containing-sexp first-sexp-list-p)
215: (if parse-start
216: (goto-char parse-start)
217: (beginning-of-defun))
218: ;; Find outermost containing sexp
219: (while (< (point) indent-point)
220: (setq state (parse-partial-sexp (point) indent-point 0)))
221: ;; Find innermost containing sexp
222: (while (and retry (setq paren-depth (car state)) (> paren-depth 0))
223: (setq retry nil)
224: (setq last-sexp (nth 2 state))
225: (setq containing-sexp (car (cdr state)))
226: ;; Position following last unclosed open.
227: (goto-char (1+ containing-sexp))
228: ;; Is there a complete sexp since then?
229: (if (and last-sexp (> last-sexp (point)))
230: ;; Yes, but is there a containing sexp after that?
231: (let ((peek (parse-partial-sexp last-sexp indent-point 0)))
232: (if (setq retry (car (cdr peek))) (setq state peek))))
233: (if (not retry)
234: ;; Innermost containing sexp found
235: (progn
236: (goto-char (1+ containing-sexp))
237: (if (not last-sexp)
238: ;; indent-point immediately follows open paren.
239: ;; Don't call hook.
240: (setq desired-indent (current-column))
241: ;; Move to first sexp after containing open paren
242: (parse-partial-sexp (point) last-sexp 0 t)
243: (setq first-sexp-list-p (looking-at "\\s("))
244: (cond
245: ((> (save-excursion (forward-line 1) (point))
246: last-sexp)
247: ;; Last sexp is on same line as containing sexp.
248: ;; It's almost certainly a function call.
249: (parse-partial-sexp (point) last-sexp 0 t)
250: (if (/= (point) last-sexp)
251: ;; Indent beneath first argument or, if only one sexp
252: ;; on line, indent beneath that.
253: (progn (forward-sexp 1)
254: (parse-partial-sexp (point) last-sexp 0 t)))
255: (backward-prefix-chars))
256: (t
257: ;; Indent beneath first sexp on same line as last-sexp.
258: ;; Again, it's almost certainly a function call.
259: (goto-char last-sexp)
260: (beginning-of-line)
261: (parse-partial-sexp (point) last-sexp 0 t)
262: (backward-prefix-chars)))))))
263: ;; If looking at a list, don't call hook.
264: (if first-sexp-list-p
265: (setq desired-indent (current-column)))
266: ;; Point is at the point to indent under unless we are inside a string.
267: ;; Call indentation hook except when overriden by scheme-indent-offset
268: ;; or if the desired indentation has already been computed.
269: (cond ((car (nthcdr 3 state))
270: ;; Inside a string, don't change indentation.
271: (goto-char indent-point)
272: (skip-chars-forward " \t")
273: (setq desired-indent (current-column)))
274: ((and (integerp scheme-indent-offset) containing-sexp)
275: ;; Indent by constant offset
276: (goto-char containing-sexp)
277: (setq desired-indent (+ scheme-indent-offset (current-column))))
278: ((not (or desired-indent
279: (and (boundp 'scheme-indent-hook)
280: scheme-indent-hook
281: (not retry)
282: (setq desired-indent
283: (funcall scheme-indent-hook
284: indent-point state)))))
285: ;; Use default indentation if not computed yet
286: (setq desired-indent (current-column))))
287: desired-indent)))
288:
289: (defun scheme-indent-hook (indent-point state)
290: (let ((normal-indent (current-column)))
291: (save-excursion
292: (goto-char (1+ (car (cdr state))))
293: (re-search-forward "\\sw\\|\\s_")
294: (if (/= (point) (car (cdr state)))
295: (let ((function (buffer-substring (progn (forward-char -1) (point))
296: (progn (forward-sexp 1) (point))))
297: method)
298: ;; Who cares about this, really?
299: ;(if (not (string-match "\\\\\\||" function)))
300: (setq function (downcase function))
301: (setq method (get (intern-soft function) 'scheme-indent-hook))
302: (cond ((integerp method)
303: (scheme-indent-specform method state indent-point))
304: (method
305: (funcall method state indent-point))
306: ((and (> (length function) 3)
307: (string-equal (substring function 0 3) "def"))
308: (scheme-indent-defform state indent-point))))))))
309:
310: (defvar scheme-body-indent 2 "")
311:
312: (defun scheme-indent-specform (count state indent-point)
313: (let ((containing-form-start (car (cdr state))) (i count)
314: body-indent containing-form-column)
315: ;; Move to the start of containing form, calculate indentation
316: ;; to use for non-distinguished forms (> count), and move past the
317: ;; function symbol. scheme-indent-hook guarantees that there is at
318: ;; least one word or symbol character following open paren of containing
319: ;; form.
320: (goto-char containing-form-start)
321: (setq containing-form-column (current-column))
322: (setq body-indent (+ scheme-body-indent containing-form-column))
323: (forward-char 1)
324: (forward-sexp 1)
325: ;; Now find the start of the last form.
326: (parse-partial-sexp (point) indent-point 1 t)
327: (while (and (< (point) indent-point)
328: (condition-case nil
329: (progn
330: (setq count (1- count))
331: (forward-sexp 1)
332: (parse-partial-sexp (point) indent-point 1 t))
333: (error nil))))
334: ;; Point is sitting on first character of last (or count) sexp.
335: (cond ((> count 0)
336: ;; A distinguished form. Use double scheme-body-indent.
337: (list (+ containing-form-column (* 2 scheme-body-indent))
338: containing-form-start))
339: ;; A non-distinguished form. Use body-indent if there are no
340: ;; distinguished forms and this is the first undistinguished
341: ;; form, or if this is the first undistinguished form and
342: ;; the preceding distinguished form has indentation at least
343: ;; as great as body-indent.
344: ((and (= count 0)
345: (or (= i 0)
346: (<= body-indent normal-indent)))
347: body-indent)
348: (t
349: normal-indent))))
350:
351: (defun scheme-indent-defform (state indent-point)
352: (goto-char (car (cdr state)))
353: (forward-line 1)
354: (if (> (point) (car (cdr (cdr state))))
355: (progn
356: (goto-char (car (cdr state)))
357: (+ scheme-body-indent (current-column)))))
358:
359: ;;; Let is different in Scheme
360:
361: (defun would-be-symbol (string)
362: (not (string-equal (substring string 0 1) "(")))
363:
364: (defun next-sexp-as-string ()
365: ;; Assumes that protected by a save-excursion
366: (forward-sexp 1)
367: (let ((the-end (point)))
368: (backward-sexp 1)
369: (buffer-substring (point) the-end)))
370:
371: ;; This is correct but too slow.
372: ;; The one below works almost always.
373: ;;(defun scheme-let-indent (state indent-point)
374: ;; (if (would-be-symbol (next-sexp-as-string))
375: ;; (scheme-indent-specform 2 state indent-point)
376: ;; (scheme-indent-specform 1 state indent-point)))
377:
378: (defun scheme-let-indent (state indent-point)
379: (skip-chars-forward " \t")
380: (if (looking-at "[a-zA-Z0-9+-*/?!@$%^&_:~]")
381: (scheme-indent-specform 2 state indent-point)
382: (scheme-indent-specform 1 state indent-point)))
383:
384: ;; (put 'begin 'scheme-indent-hook 0), say, causes begin to be indented
385: ;; like defun if the first form is placed on the next line, otherwise
386: ;; it is indented like any other form (i.e. forms line up under first).
387:
388: (put 'begin 'scheme-indent-hook 0)
389: (put 'case 'scheme-indent-hook 1)
390: (put 'delay 'scheme-indent-hook 0)
391: (put 'do 'scheme-indent-hook 2)
392: (put 'lambda 'scheme-indent-hook 1)
393: (put 'let 'scheme-indent-hook 'scheme-let-indent)
394: (put 'let* 'scheme-indent-hook 1)
395: (put 'letrec 'scheme-indent-hook 1)
396: (put 'sequence 'scheme-indent-hook 0)
397:
398: (put 'call-with-input-file 'scheme-indent-hook 1)
399: (put 'with-input-from-file 'scheme-indent-hook 1)
400: (put 'with-input-from-port 'scheme-indent-hook 1)
401: (put 'call-with-output-file 'scheme-indent-hook 1)
402: (put 'with-output-to-file 'scheme-indent-hook 1)
403: (put 'with-output-to-port 'scheme-indent-hook 1)
404:
405: ;;;; MIT Scheme specific indentation.
406:
407: (if scheme-mit-dialect
408: (progn
409: (put 'fluid-let 'scheme-indent-hook 1)
410: (put 'in-package 'scheme-indent-hook 1)
411: (put 'let-syntax 'scheme-indent-hook 1)
412: (put 'local-declare 'scheme-indent-hook 1)
413: (put 'macro 'scheme-indent-hook 1)
414: (put 'make-environment 'scheme-indent-hook 0)
415: (put 'named-lambda 'scheme-indent-hook 1)
416: (put 'using-syntax 'scheme-indent-hook 1)
417:
418: (put 'with-input-from-string 'scheme-indent-hook 1)
419: (put 'with-output-to-string 'scheme-indent-hook 0)
420: (put 'with-values 'scheme-indent-hook 1)
421:
422: (put 'syntax-table-define 'scheme-indent-hook 2)
423: (put 'list-transform-positive 'scheme-indent-hook 1)
424: (put 'list-transform-negative 'scheme-indent-hook 1)
425: (put 'list-search-positive 'scheme-indent-hook 1)
426: (put 'list-search-negative 'scheme-indent-hook 1)
427:
428: (put 'access-components 'scheme-indent-hook 1)
429: (put 'assignment-components 'scheme-indent-hook 1)
430: (put 'combination-components 'scheme-indent-hook 1)
431: (put 'comment-components 'scheme-indent-hook 1)
432: (put 'conditional-components 'scheme-indent-hook 1)
433: (put 'disjunction-components 'scheme-indent-hook 1)
434: (put 'declaration-components 'scheme-indent-hook 1)
435: (put 'definition-components 'scheme-indent-hook 1)
436: (put 'delay-components 'scheme-indent-hook 1)
437: (put 'in-package-components 'scheme-indent-hook 1)
438: (put 'lambda-components 'scheme-indent-hook 1)
439: (put 'lambda-components* 'scheme-indent-hook 1)
440: (put 'lambda-components** 'scheme-indent-hook 1)
441: (put 'open-block-components 'scheme-indent-hook 1)
442: (put 'pathname-components 'scheme-indent-hook 1)
443: (put 'procedure-components 'scheme-indent-hook 1)
444: (put 'sequence-components 'scheme-indent-hook 1)
445: (put 'unassigned\?-components 'scheme-indent-hook 1)
446: (put 'unbound\?-components 'scheme-indent-hook 1)
447: (put 'variable-components 'scheme-indent-hook 1)))
448:
449: (defun scheme-indent-sexp ()
450: "Indent each line of the list starting just after point."
451: (interactive)
452: (let ((indent-stack (list nil)) (next-depth 0) bol
453: outer-loop-done inner-loop-done state this-indent)
454: (save-excursion (forward-sexp 1))
455: (save-excursion
456: (setq outer-loop-done nil)
457: (while (not outer-loop-done)
458: (setq last-depth next-depth
459: innerloop-done nil)
460: (while (and (not innerloop-done)
461: (not (setq outer-loop-done (eobp))))
462: (setq state (parse-partial-sexp (point) (progn (end-of-line) (point))
463: nil nil state))
464: (setq next-depth (car state))
465: (if (car (nthcdr 4 state))
466: (progn (indent-for-comment)
467: (end-of-line)
468: (setcar (nthcdr 4 state) nil)))
469: (if (car (nthcdr 3 state))
470: (progn
471: (forward-line 1)
472: (setcar (nthcdr 5 state) nil))
473: (setq innerloop-done t)))
474: (if (setq outer-loop-done (<= next-depth 0))
475: nil
476: (while (> last-depth next-depth)
477: (setq indent-stack (cdr indent-stack)
478: last-depth (1- last-depth)))
479: (while (< last-depth next-depth)
480: (setq indent-stack (cons nil indent-stack)
481: last-depth (1+ last-depth)))
482: (forward-line 1)
483: (setq bol (point))
484: (skip-chars-forward " \t")
485: (if (or (eobp) (looking-at "[;\n]"))
486: nil
487: (if (and (car indent-stack)
488: (>= (car indent-stack) 0))
489: (setq this-indent (car indent-stack))
490: (let ((val (calculate-scheme-indent
491: (if (car indent-stack) (- (car indent-stack))))))
492: (if (integerp val)
493: (setcar indent-stack
494: (setq this-indent val))
495: (setcar indent-stack (- (car (cdr val))))
496: (setq this-indent (car val)))))
497: (if (/= (current-column) this-indent)
498: (progn (delete-region bol (point))
499: (indent-to this-indent)))))))))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.