![[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] / 43BSD / contrib / emacs / lisp|
Return to scheme.el CVS log | Up to [CSRG BSD Unix] / 43BSD / contrib / emacs / lisp |
1.1 root 1: ;; Scheme mode, and its idiosyncratic commands.
2: ;; Copyright (C) 1985 Bill Rozas & Richard M. Stallman
3:
4: ;; This file is part of GNU Emacs.
5:
6: ;; GNU Emacs is distributed in the hope that it will be useful,
7: ;; but WITHOUT ANY WARRANTY. No author or distributor
8: ;; accepts responsibility to anyone for the consequences of using it
9: ;; or for whether it serves any particular purpose or works at all,
10: ;; unless he says so in writing. Refer to the GNU Emacs General Public
11: ;; License for full details.
12:
13: ;; Everyone is granted permission to copy, modify and redistribute
14: ;; GNU Emacs, but only under the conditions described in the
15: ;; GNU Emacs General Public License. A copy of this license is
16: ;; supposed to have been given to you along with GNU Emacs so you
17: ;; can know your rights and responsibilities. It should be in a
18: ;; file named COPYING. Among other things, the copyright notice
19: ;; and this notice must be preserved on all copies.
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: (provide 'scheme)
27:
28: (defvar scheme-mode-syntax-table nil "")
29: (defvar scheme-mode-abbrev-table nil "")
30:
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: (while (< i ?0)
36: (modify-syntax-entry i "_ ")
37: (setq i (1+ i)))
38: (setq i (1+ ?9))
39: (while (< i ?A)
40: (modify-syntax-entry i "_ ")
41: (setq i (1+ i)))
42: (setq i (1+ ?Z))
43: (while (< i ?a)
44: (modify-syntax-entry i "_ ")
45: (setq i (1+ i)))
46: (setq i (1+ ?z))
47: (while (< i 128)
48: (modify-syntax-entry i "_ ")
49: (setq i (1+ i)))
50: (modify-syntax-entry ? " ")
51: (modify-syntax-entry ?\t " ")
52: (modify-syntax-entry ?\n "> ")
53: (modify-syntax-entry ?\f "> ")
54: (modify-syntax-entry ?\; "< ")
55: (modify-syntax-entry ?` "' ")
56: (modify-syntax-entry ?' "' ")
57: (modify-syntax-entry ?, "' ")
58: (modify-syntax-entry ?. "' ")
59: (modify-syntax-entry ?# "' ")
60: (modify-syntax-entry ?\" "\" ")
61: (modify-syntax-entry ?\\ "\\ ")
62: (modify-syntax-entry ?\( "() ")
63: (modify-syntax-entry ?\) ")( ")))
64:
65: (define-abbrev-table 'scheme-mode-abbrev-table ())
66:
67: (defun scheme-mode-variables ()
68: (set-syntax-table scheme-mode-syntax-table)
69: (setq local-abbrev-table scheme-mode-abbrev-table)
70: (make-local-variable 'paragraph-start)
71: (setq paragraph-start (concat "^$\\|" page-delimiter))
72: (make-local-variable 'paragraph-separate)
73: (setq paragraph-separate paragraph-start)
74: (make-local-variable 'indent-line-function)
75: (setq indent-line-function 'scheme-indent-line)
76: (make-local-variable 'comment-start)
77: (setq comment-start ";")
78: (make-local-variable 'comment-start-skip)
79: (setq comment-start-skip ";+ *")
80: (make-local-variable 'comment-column)
81: (setq comment-column 40)
82: (make-local-variable 'comment-indent-hook)
83: (setq comment-indent-hook 'scheme-comment-indent))
84:
85: (defun scheme-mode-commands (map)
86: (define-key map "\t" 'scheme-indent-line)
87: (define-key map "\177" 'backward-delete-char-untabify)
88: (define-key map "\eo" 'scheme-send-buffer)
89: (define-key map "\ez" 'scheme-zap-define)
90: (define-key map "\e\C-q" 'scheme-indent-sexp)
91: (define-key map "\e\C-s" 'find-scheme-definition)
92: (define-key map "\e\C-y" 'scheme-zap-define-and-resume)
93: (define-key map "\e\C-z" 'resume-scheme))
94:
95: (defvar scheme-mode-map (make-sparse-keymap))
96: ;; (define-key scheme-mode-map "\e\C-x" 'scheme-send-definition)
97: (scheme-mode-commands scheme-mode-map)
98:
99: (defun scheme-mode ()
100: "Major mode for editing Scheme code.
101: Commands:
102: Delete converts tabs to spaces as it moves back.
103: Blank lines separate paragraphs. Semicolons start comments.
104: \\{scheme-mode-map}
105: Entry to this mode calls the value of scheme-mode-hook
106: if that value is non-nil."
107: (interactive)
108: (kill-all-local-variables)
109: (use-local-map scheme-mode-map)
110: (setq major-mode 'scheme-mode)
111: (setq mode-name "Scheme")
112: (scheme-mode-variables)
113: (run-hooks 'scheme-mode-hook))
114:
115: ;; This will do unless shell.el is loaded.
116: (defun scheme-send-definition ()
117: "Send the current definition to the Scheme process made by M-x run-scheme."
118: (interactive)
119: (error "Process scheme does not exist"))
120:
121: (defun scheme-comment-indent (&optional pos)
122: (save-excursion
123: (if pos (goto-char pos))
124: (if (looking-at ";;;")
125: (current-column)
126: (if (looking-at ";;")
127: (let ((tem (calculate-scheme-indent)))
128: (if (listp tem) (car tem) tem))
129: comment-column))))
130:
131: (defvar scheme-indent-offset nil "")
132: (defvar scheme-indent-hook 'scheme-indent-hook "")
133:
134: (defun scheme-indent-line (&optional whole-exp)
135: "Indent current line as Scheme code.
136: With argument, indent any additional lines of the same expression
137: rigidly along with this one."
138: (interactive "P")
139: (let ((indent (calculate-scheme-indent)) shift-amt beg end
140: (pos (- (point-max) (point))))
141: (beginning-of-line)
142: (setq beg (point))
143: (skip-chars-forward " \t")
144: (if (looking-at "[ \t]*;;;")
145: ;; Don't alter indentation of a ;;; comment line.
146: nil
147: (if (listp indent) (setq indent (car indent)))
148: (setq shift-amt (- indent (current-column)))
149: (if (zerop shift-amt)
150: nil
151: (delete-region beg (point))
152: (indent-to indent))
153: ;; If initial point was within line's indentation,
154: ;; position after the indentation. Else stay at same point in text.
155: (if (> (- (point-max) pos) (point))
156: (goto-char (- (point-max) pos)))
157: ;; If desired, shift remaining lines of expression the same amount.
158: (and whole-exp (not (zerop shift-amt))
159: (save-excursion
160: (goto-char beg)
161: (forward-sexp 1)
162: (setq end (point))
163: (goto-char beg)
164: (forward-line 1)
165: (setq beg (point))
166: (> end beg))
167: (indent-code-rigidly beg end shift-amt)))))
168:
169: (defun calculate-scheme-indent (&optional parse-start)
170: "Return appropriate indentation for current line as scheme code.
171: In usual case returns an integer: the column to indent to.
172: Can instead return a list, whose car is the column to indent to.
173: This means that following lines at the same level of indentation
174: should not necessarily be indented the same way.
175: The second element of the list is the buffer position
176: of the start of the containing expression."
177: (save-excursion
178: (beginning-of-line)
179: (let ((indent-point (point)) state paren-depth desired-indent (retry t)
180: last-sexp containing-sexp)
181: (if parse-start
182: (goto-char parse-start)
183: (beginning-of-defun))
184: ;; Find outermost containing sexp
185: (while (< (point) indent-point)
186: (setq state (parse-partial-sexp (point) indent-point 0)))
187: ;; Find innermost containing sexp
188: (while (and retry (setq paren-depth (car state)) (> paren-depth 0))
189: (setq retry nil)
190: (setq last-sexp (nth 2 state))
191: (setq containing-sexp (car (cdr state)))
192: ;; Position following last unclosed open.
193: (goto-char (1+ containing-sexp))
194: ;; Is there a complete sexp since then?
195: (if (and last-sexp (> last-sexp (point)))
196: ;; Yes, but is there a containing sexp after that?
197: (let ((peek (parse-partial-sexp last-sexp indent-point 0)))
198: (if (setq retry (car (cdr peek))) (setq state peek))))
199: (if (not retry)
200: ;; Innermost containing sexp found
201: (progn
202: (goto-char (1+ containing-sexp))
203: (if (not last-sexp)
204: ;; indent-point immediately follows open paren.
205: ;; Don't call hook.
206: (setq desired-indent (current-column))
207: ;; Move to first sexp after containing open paren
208: (parse-partial-sexp (point) last-sexp 0 t)
209: (cond
210: ((looking-at "\\s(")
211: ;; Looking at a list. Don't call hook.
212: (if (not (> (save-excursion (forward-line 1) (point)) last-sexp))
213: (progn (goto-char last-sexp)
214: (beginning-of-line)
215: (parse-partial-sexp (point) last-sexp 0 t)))
216: ;; Indent under the list or under the first sexp on the
217: ;; same line as last-sexp. Note that first thing on that
218: ;; line has to be complete sexp since we are inside the
219: ;; innermost containing sexp.
220: (backward-prefix-chars)
221: (setq desired-indent (current-column)))
222: ((> (save-excursion (forward-line 1) (point))
223: last-sexp)
224: ;; Last sexp is on same line as containing sexp.
225: ;; It's almost certainly a function call.
226: (parse-partial-sexp (point) last-sexp 0 t)
227: (if (/= (point) last-sexp)
228: ;; Indent beneath first argument or, if only one sexp
229: ;; on line, indent beneath that.
230: (progn (forward-sexp 1)
231: (parse-partial-sexp (point) last-sexp 0 t)))
232: (backward-prefix-chars))
233: (t
234: ;; Indent beneath first sexp on same line as last-sexp.
235: ;; Again, it's almost certainly a function call.
236: (goto-char last-sexp)
237: (beginning-of-line)
238: (parse-partial-sexp (point) last-sexp 0 t)
239: (backward-prefix-chars)))))))
240: ;; Point is at the point to indent under unless we are inside a string.
241: ;; Call indentation hook except when overriden by scheme-indent-offset
242: ;; or if the desired indentation has already been computed.
243: (cond ((car (nthcdr 3 state))
244: ;; Inside a string, don't change indentation.
245: (goto-char indent-point)
246: (skip-chars-forward " \t")
247: (setq desired-indent (current-column)))
248: ((and (integerp scheme-indent-offset) containing-sexp)
249: ;; Indent by constant offset
250: (goto-char containing-sexp)
251: (setq desired-indent (+ scheme-indent-offset (current-column))))
252: ((not (or desired-indent
253: (and (boundp 'scheme-indent-hook)
254: scheme-indent-hook
255: (not retry)
256: (setq desired-indent
257: (funcall scheme-indent-hook
258: indent-point state)))))
259: ;; Use default indentation if not computed yet
260: (setq desired-indent (current-column))))
261: desired-indent)))
262:
263: (defun scheme-indent-hook (indent-point state)
264: (let ((normal-indent (current-column)))
265: (save-excursion
266: (goto-char (1+ (car (cdr state))))
267: (re-search-forward "\\sw\\|\\s_")
268: (if (/= (point) (car (cdr state)))
269: (let ((function (buffer-substring (progn (forward-char -1) (point))
270: (progn (forward-sexp 1) (point))))
271: method)
272: ;; Who cares about this, really?
273: ;(if (not (string-match "\\\\\\||" function)))
274: (setq function (downcase function))
275: (setq method (get (intern-soft function) 'scheme-indent-hook))
276: (cond ((integerp method)
277: (scheme-indent-specform method state indent-point))
278: (method
279: (funcall method state indent-point))
280: ((and (> (length function) 3)
281: (string-equal (substring function 0 3) "def"))
282: (scheme-indent-defform state indent-point))))))))
283:
284: (defvar scheme-body-indent 2 "")
285:
286: (defun scheme-indent-specform (count state indent-point)
287: (let ((containing-form-start (car (cdr state))) (i count)
288: body-indent containing-form-column)
289: ;; Move to the start of containing form, calculate indentation
290: ;; to use for non-distinguished forms (> count), and move past the
291: ;; function symbol. scheme-indent-hook guarantees that there is at
292: ;; least one word or symbol character following open paren of containing
293: ;; form.
294: (goto-char containing-form-start)
295: (setq containing-form-column (current-column))
296: (setq body-indent (+ scheme-body-indent containing-form-column))
297: (forward-char 1)
298: (forward-sexp 1)
299: ;; Now find the start of the last form.
300: (parse-partial-sexp (point) indent-point 1 t)
301: (while (and (< (point) indent-point)
302: (condition-case nil
303: (progn
304: (setq count (1- count))
305: (forward-sexp 1)
306: (parse-partial-sexp (point) indent-point 1 t))
307: (error nil))))
308: ;; Point is sitting on first character of last (or count) sexp.
309: (if (> count 0)
310: ;; A distinguished form. If it is the first or second form
311: ;; use double scheme-body-indent, else normal indent. With
312: ;; scheme-body-indent bound to 2 (the default), this just
313: ;; happens to work the same with if as the older code, but it
314: ;; makes unwind-protect, condition-case,
315: ;; with-output-to-temp-buffer, et. al. much more tasteful.
316: ;; The older, less hacked, behavior can be obtained by
317: ;; replacing below with (list normal-indent containing-form-start).
318: (if (<= (- i count) 1)
319: (list (+ containing-form-column (* 2 scheme-body-indent))
320: containing-form-start)
321: (list normal-indent containing-form-start))
322: ;; A non-distinguished form. Use body-indent if there are no
323: ;; distinguished forms and this is the first undistinguished
324: ;; form, or if this is the first undistinguished form and
325: ;; the preceding distinguished form has indentation at
326: ;; least as great as body-indent.
327: (if (or (and (= i 0) (= count 0))
328: (and (= count 0) (<= body-indent normal-indent)))
329: body-indent
330: normal-indent))))
331:
332: (defun scheme-indent-defform (state indent-point)
333: (goto-char (car (cdr state)))
334: (forward-line 1)
335: (if (> (point) (car (cdr (cdr state))))
336: (progn
337: (goto-char (car (cdr state)))
338: (+ scheme-body-indent (current-column)))))
339:
340: ;;; Let is different in Scheme
341:
342: (defun would-be-symbol (string)
343: (not (string-equal (substring string 0 1) "(")))
344:
345: (defun next-sexp-as-string ()
346: ;; Assumes that protected by a save-excursion
347: (forward-sexp 1)
348: (let ((the-end (point)))
349: (backward-sexp 1)
350: (buffer-substring (point) the-end)))
351:
352: ;; This is correct but too slow.
353: ;; The one below works almost always.
354: ;;(defun scheme-let-indent (state indent-point)
355: ;; (if (would-be-symbol (next-sexp-as-string))
356: ;; (scheme-indent-specform 2 state indent-point)
357: ;; (scheme-indent-specform 1 state indent-point)))
358:
359: (defun scheme-let-indent (state indent-point)
360: (skip-chars-forward " \t")
361: (if (looking-at "[a-zA-Z0-9+-*/?!@$%^&_:~]")
362: (scheme-indent-specform 2 state indent-point)
363: (scheme-indent-specform 1 state indent-point)))
364:
365: ;; (put 'begin 'scheme-indent-hook 0), say, causes begin to be indented
366: ;; like defun if the first form is placed on the next line, otherwise
367: ;; it is indented like any other form (i.e. forms line up under first).
368:
369: (put 'begin 'scheme-indent-hook 0)
370: (put 'case 'scheme-indent-hook 1)
371: (put 'do 'scheme-indent-hook 2)
372: (put 'fluid-let 'scheme-indent-hook 1)
373: (put 'if 'scheme-indent-hook 3)
374: (put 'in-package 'scheme-indent-hook 1)
375: (put 'lambda 'scheme-indent-hook 1)
376: (put 'let 'scheme-indent-hook 'scheme-let-indent)
377: (put 'let* 'scheme-indent-hook 1)
378: (put 'let-syntax 'scheme-indent-hook 1)
379: (put 'letrec 'scheme-indent-hook 1)
380: (put 'local-declare 'scheme-indent-hook 1)
381: (put 'macro 'scheme-indent-hook 1)
382: (put 'make-environment 'scheme-indent-hook 0)
383: (put 'make-package 'scheme-indent-hook 2)
384: (put 'named-lambda 'scheme-indent-hook 1)
385: (put 'sequence 'scheme-indent-hook 0)
386: (put 'using-syntax 'scheme-indent-hook 1)
387:
388:
389: (defun scheme-indent-sexp ()
390: "Indent each line of the list starting just after point."
391: (interactive)
392: (let ((indent-stack (list nil)) (next-depth 0) bol
393: outer-loop-done inner-loop-done state this-indent)
394: (save-excursion (forward-sexp 1))
395: (save-excursion
396: (setq outer-loop-done nil)
397: (while (not outer-loop-done)
398: (setq last-depth next-depth
399: innerloop-done nil)
400: (while (and (not innerloop-done)
401: (not (setq outer-loop-done (eobp))))
402: (setq state (parse-partial-sexp (point) (progn (end-of-line) (point))
403: nil nil state))
404: (setq next-depth (car state))
405: (if (car (nthcdr 4 state))
406: (progn (indent-for-comment)
407: (end-of-line)
408: (setcar (nthcdr 4 state) nil)))
409: (if (car (nthcdr 3 state))
410: (progn
411: (forward-line 1)
412: (setcar (nthcdr 5 state) nil))
413: (setq innerloop-done t)))
414: (if (setq outer-loop-done (<= next-depth 0))
415: nil
416: (while (> last-depth next-depth)
417: (setq indent-stack (cdr indent-stack)
418: last-depth (1- last-depth)))
419: (while (< last-depth next-depth)
420: (setq indent-stack (cons nil indent-stack)
421: last-depth (1+ last-depth)))
422: (forward-line 1)
423: (setq bol (point))
424: (skip-chars-forward " \t")
425: (if (or (eobp) (looking-at "[;\n]"))
426: nil
427: (if (and (car indent-stack)
428: (>= (car indent-stack) 0))
429: (setq this-indent (car indent-stack))
430: (let ((val (calculate-scheme-indent
431: (if (car indent-stack) (- (car indent-stack))))))
432: (if (integerp val)
433: (setcar indent-stack
434: (setq this-indent val))
435: (setcar indent-stack (- (car (cdr val))))
436: (setq this-indent (car val)))))
437: (if (/= (current-column) this-indent)
438: (progn (delete-region bol (point))
439: (indent-to this-indent)))))))))
440:
441: ;;; Schedit commands (old scheme interface)
442:
443: (defvar scheme-zap-name (expand-file-name "fromedit.zap" nil)
444: "Name of transfer file between Scheme and Emacs")
445:
446: (defvar scheme-invocation-string "%scheme"
447: "*String to give to the Cshell to proceed a sibling Scheme")
448:
449: (defun goto-parallel-scheme-fork ()
450: (suspend-emacs scheme-invocation-string))
451:
452: ;; This currently assumes that Emacs runs as an inferior to Scheme
453:
454: (fset 'goto-scheme 'suspend-emacs)
455:
456: ;; if not, do (fset 'goto-scheme 'goto-parallel-scheme-fork)
457:
458: (defun resume-scheme ()
459: "Suspend Emacs and resume Scheme"
460: (interactive)
461: (let ((zap-buffer (get-buffer scheme-zap-name))
462: (this-buffer (current-buffer)))
463: (if zap-buffer
464: (save-excursion
465: (unwind-protect
466: (progn (set-buffer zap-buffer)
467: (or buffer-file-name
468: (setq buffer-file-name scheme-zap-name))
469: (save-buffer)
470: (erase-buffer)
471: (setq buffer-modified-p nil))
472: (set-buffer this-buffer)))))
473: (goto-scheme))
474:
475: (defun scheme-do-zap-region (start end buffer &optional separate)
476: "Internal routine which zaps a region of text for Scheme."
477: (let ((the-text (buffer-substring start end)))
478: (save-excursion
479: (unwind-protect
480: (progn (set-buffer (get-buffer-create scheme-zap-name))
481: (insert-string the-text)
482: (if separate (newline 2)))
483: (set-buffer buffer)))))
484:
485: (defun scheme-zap-region (start end)
486: "Zap region between point and mark into Scheme."
487: (interactive "r")
488: (scheme-do-zap-region start end (current-buffer)))
489:
490: (defun scheme-zap-expression (arg)
491: "Zap sexp before point into Scheme."
492: (interactive "P")
493: (scheme-do-zap-region
494: (let ((stab (syntax-table)))
495: (unwind-protect
496: (save-excursion
497: (set-syntax-table lisp-mode-syntax-table)
498: (forward-sexp -1)
499: (point))
500: (set-syntax-table stab)))
501: (point)
502: (current-buffer)
503: t))
504:
505: (defun scheme-zap-define (arg)
506: "Zap current definition into Scheme."
507: (interactive "P")
508: (let ((stab (syntax-table)))
509: (unwind-protect
510: (save-excursion
511: (set-syntax-table scheme-mode-syntax-table)
512: (if (not (= (point) (point-max))) (forward-char 1))
513: (beginning-of-defun 1)
514: (let ((start (point)))
515: (forward-sexp 1)
516: (scheme-do-zap-region start
517: (point)
518: (current-buffer)
519: t)))
520: (set-syntax-table stab))))
521:
522: (defun scheme-send-buffer (arg)
523: "Zap whole buffer and resume Scheme"
524: (interactive "P")
525: (scheme-do-zap-region (point-min)
526: (point-max)
527: (current-buffer))
528: (resume-scheme))
529:
530: (defun scheme-zap-define-and-resume (arg)
531: "Zap current definition and resume Scheme"
532: (interactive "P")
533: (scheme-zap-define arg)
534: (resume-scheme))
535:
536: (defun defining-p ()
537: (save-excursion
538: (let* ((here (point))
539: (name (buffer-substring (progn (backward-sexp 1) (point)) here)))
540: (beginning-of-defun 1)
541: (if (char-equal (char-after (point)) ?\()
542: (progn (forward-char 1)
543: (let ((sub (substring (next-sexp-as-string) 0 3)))
544: (if (or (string-equal sub "def") (string-equal sub "DEF"))
545: (progn (forward-sexp 1)
546: (forward-word 1)
547: (backward-word 1)
548: (string-equal name
549: (next-sexp-as-string))))))))))
550:
551: (defun find-scheme-definition (name)
552: "Find the definition of its argument in the current buffer"
553: (interactive "sFind Scheme definition of: ")
554: (beginning-of-buffer)
555: (let ((stop nil))
556: (while (not stop)
557: (search-forward name)
558: (setq stop (defining-p)))))
559:
560: ;;; Autoloads from xscheme:
561:
562: (autoload 'scheme "xscheme"
563: "Run an inferior Scheme process reading a command line from the terminal."
564: t)
565:
566: (autoload 'run-scheme "xscheme"
567: "Run an inferior Scheme process."
568: t)
569:
570: (autoload 'scheme-send-definition "xscheme"
571: "Send the current definition to the Scheme process made by M-x run-scheme."
572: t)
573:
574: (autoload 'scheme-send-definition-and-go "xscheme"
575: "Send the current definition to the inferior Scheme, and switch to *scheme* buffer."
576: t)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.