view lisp/progmodes/scheme.el @ 51195:3cbf29813eea

(struct frame): Rename members height to text_lines, width to text_cols, window_height to total_lines, window_width to total_cols, new_height to new_text_lines, new_width to new_text_cols. All uses changed. (struct frame): New members which consolidate common members of x_output, w32_output, and mac_output structures: left_pos, top_pos, pixel_height, pixel_width, x_pixels_diff, y_pixels_diff, win_gravity, size_hint_flags, border_width, internal_border_width, line_height, fringe_cols, left_fringe_width, right_fringe_width, want_fullscreen. All uses changed. (struct frame): New member column_width contaning the canonical column width, analogue to line_height. All uses changed. (struct frame): Rename members scroll_bar_pixel_width to config_scroll_bar_width, and scroll_bar_cols to config_scroll_bar_cols. All uses changed. (struct frame): New member scroll_bar_actual_width which consolidates and renames the vertical_scroll_bar_extra member of x_output, w32_output, and mac_output structures. All uses changed. (FRAME_PIXEL_HEIGHT): Renamed from PIXEL_HEIGHT and moved from x/w32/macterm.h files. All uses changed. Also change code which referred to f->output_data...->pixel_height. (FRAME_PIXEL_WIDTH): Renamed from PIXEL_WIDTH and moved from x/w32/macterm.h files. All uses changed. Also change code which referred to f->output_data...->pixel_width. (FRAME_LINES): Renamed from FRAME_HEIGHT. All uses changed. Also change code which referred to f->height. (FRAME_COLS): Renamed from FRAME_WIDTH. All uses changed. Also change code which referred to f->width. (FRAME_NEW_HEIGHT, FRAME_NEW_WIDTH): Remove macros; change uses to update new_text_lines and new_text_cols members directly. (FRAME_CONFIG_SCROLL_BAR_WIDTH): Renamed from FRAME_SCROLL_BAR_PIXEL_WIDTH. All uses changed. (FRAME_CONFIG_SCROLL_BAR_COLS): Renamed from FRAME_SCROLL_BAR_COLS. All uses changed. (FRAME_LEFT_SCROLL_BAR_COLS, FRAME_RIGHT_SCROLL_BAR_COLS): Renamed from FRAME_LEFT_SCROLL_BAR_WIDTH and FRAME_RIGHT_SCROLL_BAR_WIDTH, resp. All uses changed. (FRAME_SCROLL_BAR_AREA_WIDTH, FRAME_LEFT_SCROLL_BAR_AREA_WIDTH) (FRAME_RIGHT_SCROLL_BAR_AREA_WIDTH): New macros. (FRAME_TOTAL_COLS): Renamed from FRAME_WINDOW_WIDTH. (SET_FRAME_COLS): Renamed from SET_FRAME_WIDTH. (FRAME_TOTAL_COLS_ARG): Renamed from FRAME_WINDOW_WIDTH_ARG. (WINDOW_VERTICAL_SCROLL_BAR_COLUMN): Remove unused macro. (WINDOW_VERTICAL_SCROLL_BAR_HEIGHT): Remove unused macro. (FRAME_LINE_HEIGHT): Renamed from CANON_Y_UNIT. Unconditionally return line_height member (it now has proper value also for non-window frames). (FRAME_COLUMN_WIDTH): Renamed from CANON_X_UNIT. Unconditionally return new column_width member (rather than the default font width). (FRAME_FRINGE_COLS, FRAME_LEFT_FRINGE_WIDTH) (FRAME_RIGHT_FRINGE_WIDTH): Renamed from FRAME_X_... and moved from x/w32/macterm.h files. Unconditionally return corresponding member of frame structure (they now have proper values also for non-window frames). (FRAME_TOTAL_FRINGE_WIDTH): Renamed from FRAME_FRINGE_WIDTH. Calculate return value from left and right widths. (FRAME_INTERNAL_BORDER_WIDTH): Unconditionally return internal_border_width member (has proper value for non-window frame). (FRAME_PIXEL_X_FROM_CANON_X): Renamed from PIXEL_X_FROM_CANON_X. (FRAME_PIXEL_Y_FROM_CANON_Y): Renamed from PIXEL_Y_FROM_CANON_Y. (FRAME_CANON_X_FROM_PIXEL_X): Renamed from CANON_X_FROM_PIXEL_X. (FRAME_CANON_Y_FROM_PIXEL_Y): Renamed from CANON_Y_FROM_PIXEL_Y. (FRAME_LINE_TO_PIXEL_Y): Renamed from CHAR_TO_PIXEL_ROW, consolidated from xterm.h, macterm.h, and w32term.h. (FRAME_COL_TO_PIXEL_X): Renamed from CHAR_TO_PIXEL_COL, consolidated from xterm.h, macterm.h, and w32term.h. (FRAME_TEXT_COLS_TO_PIXEL_WIDTH): Renamed from CHAR_TO_PIXEL_WIDTH consolidated from x/mac/w32term.h. (FRAME_TEXT_LINES_TO_PIXEL_HEIGHT): Renamed from CHAR_TO_PIXEL_HEIGHT consolidated from x/mac/w32term.h. (FRAME_PIXEL_Y_TO_LINE): Renamed from PIXEL_TO_CHAR_ROW consolidated from x/mac/w32term.h. (FRAME_PIXEL_X_TO_COL): Renamed from PIXEL_TO_CHAR_COL consolidated from x/mac/w32term.h. (FRAME_PIXEL_WIDTH_TO_TEXT_COLS): Renamed from PIXEL_TO_CHAR_WIDTH consolidated from x/mac/w32term.h. (FRAME_PIXEL_HEIGHT_TO_TEXT_LINES): Renamed from PIXEL_TO_CHAR_HEIGHT consolidated from x/mac/w32term.h.

;;; scheme.el --- Scheme (and DSSSL) editing mode

;; Copyright (C) 1986, 87, 88, 97, 1998 Free Software Foundation, Inc.

;; Author: Bill Rozas <[e-mail]>
;; Adapted-by: Dave Love <[e-mail]>
;; Keywords: languages, lisp

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; 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
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;; 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
;; the page-delimiter since ^L isn't normally a legal SGML character.
;;
;; For interacting with a Scheme interpreter See also `run-scheme' in
;; the `cmuscheme' package and also the implementation-specific
;; `xscheme' package.

;; 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/' "$@"

;;; Code:

(require 'lisp-mode)

(defvar scheme-mode-syntax-table
  (let ((st (make-syntax-table))
	(i 0))

    ;; Default is atom-constituent.
    (while (< i 256)
      (modify-syntax-entry i "_   " st)
      (setq i (1+ i)))

    ;; Word components.
    (setq i ?0)
    (while (<= i ?9)
      (modify-syntax-entry i "w   " st)
      (setq i (1+ i)))
    (setq i ?A)
    (while (<= i ?Z)
      (modify-syntax-entry i "w   " st)
      (setq i (1+ i)))
    (setq i ?a)
    (while (<= i ?z)
      (modify-syntax-entry i "w   " st)
      (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)
    (modify-syntax-entry ?  "    " st)

    ;; 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)
    (modify-syntax-entry ?\| "  23" st)

    ;; Other atom delimiters
    (modify-syntax-entry ?\( "()  " st)
    (modify-syntax-entry ?\) ")(  " st)
    (modify-syntax-entry ?\; "<   " st)
    (modify-syntax-entry ?\" "\"    " st)
    (modify-syntax-entry ?' "'   " st)
    (modify-syntax-entry ?` "'   " st)

    ;; Special characters
    (modify-syntax-entry ?, "'   " st)
    (modify-syntax-entry ?@ "'   " st)
    (modify-syntax-entry ?# "'  14" st)
    (modify-syntax-entry ?\\ "\\   " st)
    st))

(defvar scheme-mode-abbrev-table nil)
(define-abbrev-table 'scheme-mode-abbrev-table ())

(defvar scheme-imenu-generic-expression
      '((nil
	 "^(define\\(\\|-\\(generic\\(\\|-procedure\\)\\|method\\)\\)*\\s-+(?\\(\\sw+\\)" 4)
	("Types"
	 "^(define-class\\s-+(?\\(\\sw+\\)" 1)
	("Macros"
	 "^(\\(defmacro\\|define-macro\\|define-syntax\\)\\s-+(?\\(\\sw+\\)" 2))
  "Imenu generic expression for Scheme mode.  See `imenu-generic-expression'.")

(defun scheme-mode-variables ()
  (set-syntax-table scheme-mode-syntax-table)
  (setq local-abbrev-table scheme-mode-abbrev-table)
  (make-local-variable 'paragraph-start)
  (setq paragraph-start (concat "$\\|" page-delimiter))
  (make-local-variable 'paragraph-separate)
  (setq paragraph-separate paragraph-start)
  (make-local-variable 'paragraph-ignore-fill-prefix)
  (setq paragraph-ignore-fill-prefix t)
  (make-local-variable 'fill-paragraph-function)
  (setq fill-paragraph-function 'lisp-fill-paragraph)
  ;; 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.
  (make-local-variable 'adaptive-fill-mode)
  (setq adaptive-fill-mode nil)
  (make-local-variable 'normal-auto-fill-function)
  (setq normal-auto-fill-function 'lisp-mode-auto-fill)
  (make-local-variable 'indent-line-function)
  (setq indent-line-function 'lisp-indent-line)
  (make-local-variable 'parse-sexp-ignore-comments)
  (setq parse-sexp-ignore-comments t)
  (make-local-variable 'outline-regexp)
  (setq outline-regexp ";;; \\|(....")
  (make-local-variable 'comment-start)
  (setq comment-start ";")
  (make-local-variable 'comment-start-skip)
  ;; Look within the line for a ; following an even number of backslashes
  ;; after either a non-backslash or the line beginning.
  (setq comment-start-skip "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+[ \t]*")
  (make-local-variable 'comment-column)
  (setq comment-column 40)
  (make-local-variable 'comment-indent-function)
  (setq comment-indent-function 'lisp-comment-indent)
  (make-local-variable 'parse-sexp-ignore-comments)
  (setq parse-sexp-ignore-comments t)
  (make-local-variable 'lisp-indent-function)
  (set lisp-indent-function 'scheme-indent-function)
  (setq mode-line-process '("" scheme-mode-line-process))
  (set (make-local-variable 'imenu-case-fold-search) t)
  (setq imenu-generic-expression scheme-imenu-generic-expression)
  (set (make-local-variable 'imenu-syntax-alist)
	'(("+-*/.<>=?!$%_&~^:" . "w")))
  (make-local-variable 'font-lock-defaults)
  (setq font-lock-defaults
        '((scheme-font-lock-keywords
           scheme-font-lock-keywords-1 scheme-font-lock-keywords-2)
          nil t (("+-*/.<>=!?$%_&~^:" . "w")) beginning-of-defun
          (font-lock-mark-block-function . mark-defun)
          (font-lock-syntactic-face-function . lisp-font-lock-syntactic-face-function))))

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

(defvar scheme-mode-map nil
  "Keymap for Scheme mode.
All commands in `lisp-mode-shared-map' are inherited by this map.")

(unless scheme-mode-map
  (let ((map (make-sparse-keymap "Scheme")))
    (setq scheme-mode-map (make-sparse-keymap))
    (set-keymap-parent scheme-mode-map lisp-mode-shared-map)
    (define-key scheme-mode-map [menu-bar] (make-sparse-keymap))
    (define-key scheme-mode-map [menu-bar scheme]
      (cons "Scheme" map))
    (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)
    (put 'indent-region 'menu-enable 'mark-active)))

;; Used by cmuscheme
(defun scheme-mode-commands (map)
  ;;(define-key map "\t" 'indent-for-tab-command) ; default
  (define-key map "\177" 'backward-delete-char-untabify)
  (define-key map "\e\C-q" 'indent-sexp))

;;;###autoload
(defun scheme-mode ()
  "Major mode for editing Scheme code.
Editing commands are similar to those of `lisp-mode'.

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
modeline of all Scheme buffers.  The names of commands that interact
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.

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."
  (interactive)
  (kill-all-local-variables)
  (scheme-mode-initialize)
  (scheme-mode-variables)
  (run-hooks 'scheme-mode-hook))

(defun scheme-mode-initialize ()
  (use-local-map scheme-mode-map)
  (setq major-mode 'scheme-mode)
  (setq mode-name "Scheme"))

(defgroup scheme nil
  "Editing Scheme code"
  :group 'lisp)

(defcustom scheme-mit-dialect t
  "If non-nil, scheme mode is specialized for MIT Scheme.
Set this to nil if you normally use another dialect."
  :type 'boolean
  :group 'scheme)

(defcustom dsssl-sgml-declaration
  "<!DOCTYPE style-sheet PUBLIC \"-//James Clark//DTD DSSSL Style Sheet//EN\">
"
  "*An SGML declaration for the DSSSL file.
If it is defined as a string this will be inserted into an empty buffer
which is in `dsssl-mode'.  It is typically James Clark's style-sheet
doctype, as required for Jade."
  :type '(choice (string :tag "Specified string")
                 (const :tag "None" :value nil))
  :group 'scheme)

(defcustom scheme-mode-hook nil
  "Normal hook run when entering `scheme-mode'.
See `run-hooks'."
  :type 'hook
  :group 'scheme)

(defcustom dsssl-mode-hook nil
  "Normal hook run when entering `dsssl-mode'.
See `run-hooks'."
  :type 'hook
  :group 'scheme)

;; This is shared by cmuscheme and xscheme.
(defcustom scheme-program-name "scheme"
  "*Program invoked by the `run-scheme' command."
  :type 'string
  :group 'scheme)

(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.
  '(("Defines"
     "^(define\\s-+(?\\(\\sw+\\)" 1)
    ("Modes"
     "^\\s-*(mode\\s-+\\(\\(\\sw\\|\\s-\\)+\\)" 1)
    ("Elements"
     ;; (element foo ...) or (element (foo bar ...) ...)
     ;; Fixme: Perhaps it should do `root'.
     "^\\s-*(element\\s-+(?\\(\\(\\sw\\|\\s-\\)+\\))?" 1)
    ("Declarations"
     "^(declare\\(-\\sw+\\)+\\>\\s-+\\(\\sw+\\)" 2))
  "Imenu generic expression for DSSSL mode.  See `imenu-generic-expression'.")

(defconst scheme-font-lock-keywords-1
  (eval-when-compile
    (list
     ;;
     ;; Declarations.  Hannes Haug <[e-mail]> says
     ;; this works for SOS, STklos, SCOOPS, Meroon and Tiny CLOS.
     (list (concat "(\\(define\\*?\\("
		   ;; Function names.
		   "\\(\\|-public\\|-method\\|-generic\\(-procedure\\)?\\)\\|"
		   ;; Macro names, as variable names.  A bit dubious, this.
		   "\\(-syntax\\|-macro\\)\\|"
		   ;; Class names.
		   "-class"
                   ;; Guile modules.
                   "\\|-module"
		   "\\)\\)\\>"
		   ;; 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"
	       "do" "else" "for-each" "if" "lambda"
	       "let" "let*" "let-syntax" "letrec" "letrec-syntax"
	       ;; Hannes Haug <[e-mail]> wants:
	       "and" "or" "delay"
	       ;; Stefan Monnier <[e-mail]> says don't bother:
	       ;;"quasiquote" "quote" "unquote" "unquote-splicing"
	       "map" "syntax" "syntax-rules") t)
	"\\>") 1)
      ;;
      ;; David Fox <[e-mail]> for SOS/STklos class specifiers.
      '("\\<<\\sw+>\\>" . font-lock-type-face)
      ;;
      ;; Scheme `:' keywords as builtins.
      '("\\<:\\sw+\\>" . font-lock-builtin-face)
      )))
  "Gaudy expressions to highlight in Scheme modes.")

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

;;;###autoload
(defun dsssl-mode ()
  "Major mode for editing DSSSL code.
Editing commands are similar to those of `lisp-mode'.

Commands:
Delete converts tabs to spaces as it moves back.
Blank lines separate paragraphs.  Semicolons start comments.
\\{scheme-mode-map}
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."
  (interactive)
  (kill-all-local-variables)
  (use-local-map scheme-mode-map)
  (scheme-mode-initialize)
  (make-local-variable 'page-delimiter)
  (setq page-delimiter "^;;;" ; ^L not valid SGML char
	major-mode 'dsssl-mode
	mode-name "DSSSL")
  ;; Insert a suitable SGML declaration into an empty buffer.
  (and (zerop (buffer-size))
       (stringp dsssl-sgml-declaration)
       (not buffer-read-only)
       (insert dsssl-sgml-declaration))
  (scheme-mode-variables)
  (setq font-lock-defaults '(dsssl-font-lock-keywords
			     nil t (("+-*/.<>=?$%_&~^:" . "w"))
			     beginning-of-defun
			     (font-lock-mark-block-function . mark-defun)))
  (set (make-local-variable 'imenu-case-fold-search) nil)
  (setq imenu-generic-expression dsssl-imenu-generic-expression)
  (set (make-local-variable 'imenu-syntax-alist)
       '(("+-*/.<>=?$%_&~^:" . "w")))
  (run-hooks 'scheme-mode-hook)
  (run-hooks 'dsssl-mode-hook))

;; 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)
(put 'make 'scheme-indent-function 1)
(put 'style 'scheme-indent-function 1)
(put 'root 'scheme-indent-function 1)

(defvar dsssl-font-lock-keywords
  (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))
     '("\\<\\sw+:\\>" . font-lock-constant-face) ; trailing `:' c.f. scheme
     ;; SGML markup (from sgml-mode) :
     '("<\\([!?][-a-z0-9]+\\)" 1 font-lock-keyword-face)
     '("<\\(/?[-a-z0-9]+\\)" 1 font-lock-function-name-face)))
  "Default expressions to highlight in DSSSL mode.")


(defvar calculate-lisp-indent-last-sexp)

;; Copied from lisp-indent-function, but with gets of
;; scheme-indent-{function,hook}.
(defun scheme-indent-function (indent-point state)
  (let ((normal-indent (current-column)))
    (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_")))
        ;; car of form doesn't seem to be a symbol
        (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
		(funcall method state indent-point normal-indent)))))))


;;; Let is different in Scheme

(defun 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)))

;; 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)))

(defun scheme-let-indent (state indent-point normal-indent)
  (skip-chars-forward " \t")
  (if (looking-at "[-a-zA-Z0-9+*/?!@$%^&_:~]")
      (lisp-indent-specform 2 state indent-point normal-indent)
    (lisp-indent-specform 1 state indent-point normal-indent)))

;; (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)
(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)
(put 'syntax-case 'scheme-indent-function 2) ; not r5rs

(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)
(put 'call-with-values 'scheme-indent-function 1) ; r5rs?
(put 'dynamic-wind 'scheme-indent-function 3) ; r5rs?

;;;; 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)))

(provide 'scheme)

;;; scheme.el ends here