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