(require 'lisp-mode)
(defvar scheme-mode-syntax-table nil)
(if (not scheme-mode-syntax-table)
(let ((i 0))
(setq scheme-mode-syntax-table (make-syntax-table))
(set-syntax-table scheme-mode-syntax-table)
(while (< i 256)
(modify-syntax-entry i "_ ")
(setq i (1+ i)))
(setq i ?0)
(while (<= i ?9)
(modify-syntax-entry i "w ")
(setq i (1+ i)))
(setq i ?A)
(while (<= i ?Z)
(modify-syntax-entry i "w ")
(setq i (1+ i)))
(setq i ?a)
(while (<= i ?z)
(modify-syntax-entry i "w ")
(setq i (1+ i)))
(modify-syntax-entry ?\t " ")
(modify-syntax-entry ?\n "> ")
(modify-syntax-entry ?\f " ")
(modify-syntax-entry ?\r " ")
(modify-syntax-entry ? " ")
(modify-syntax-entry ?\[ "(] ")
(modify-syntax-entry ?\] ")[ ")
(modify-syntax-entry ?{ "(} ")
(modify-syntax-entry ?} "){ ")
(modify-syntax-entry ?\| " 23")
(modify-syntax-entry ?\( "() ")
(modify-syntax-entry ?\) ")( ")
(modify-syntax-entry ?\ (modify-syntax-entry ?\" "\" ")
(modify-syntax-entry ?' " p")
(modify-syntax-entry ?` " p")
(modify-syntax-entry ?, "_ p")
(modify-syntax-entry ?@ "_ p")
(modify-syntax-entry ?# "_ p14")
(modify-syntax-entry ?\\ "\\ ")))
(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)
(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)
(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))))
(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)))
(defun scheme-mode-commands (map)
(define-key map "\177" 'backward-delete-char-untabify)
(define-key map "\e\C-q" 'indent-sexp))
(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)
(defcustom scheme-program-name "scheme"
"*Program invoked by the `run-scheme' command."
:type 'string
:group 'scheme)
(defvar dsssl-imenu-generic-expression
'(("Defines"
"^(define\\s-+(?\\(\\sw+\\)" 1)
("Modes"
"^\\s-*(mode\\s-+\\(\\(\\sw\\|\\s-\\)+\\)" 1)
("Elements"
"^\\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
(list (concat "(\\(define\\*?\\("
"\\(\\|-public\\|-method\\|-generic\\(-procedure\\)?\\)\\|"
"\\(-syntax\\|-macro\\)\\|"
"-class"
"\\|-module"
"\\)\\)\\>"
"[ \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
(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"
"and" "or" "delay"
"map" "syntax" "syntax-rules") t)
"\\>") 1)
'("\\<<\\sw+>\\>" . font-lock-type-face)
'("\\<:\\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.")
(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 "^;;;" major-mode 'dsssl-mode
mode-name "DSSSL")
(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))
(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
(list "(\\(define\\(-\\w+\\)?\\)\\>[ ]*\\\((?\\)\\(\\sw+\\)\\>"
'(1 font-lock-keyword-face)
'(4 font-lock-function-name-face))
(cons
(concat "(\\("
"and\\|c\\(ase\\|ond\\)\\|else\\|if\\|"
"l\\(ambda\\|et\\(\\|*\\|rec\\)\\)\\|map\\|or\\|with-mode"
"\\)\\>")
1)
'("(\\(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) '("<\\([!?][-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)
(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_")))
(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)))
(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)))))))
(defun would-be-symbol (string)
(not (string-equal (substring string 0 1) "(")))
(defun next-sexp-as-string ()
(forward-sexp 1)
(let ((the-end (point)))
(backward-sexp 1)
(buffer-substring (point) the-end)))
(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)
(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) (put 'let-syntax 'scheme-indent-function 1)
(put 'letrec-syntax 'scheme-indent-function 1)
(put 'syntax-rules 'scheme-indent-function 1)
(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) (put 'dynamic-wind 'scheme-indent-function 3)
(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)