-Set this to nil if you normally use another dialect.")
-\f
-(defun scheme-comment-indent (&optional pos)
- (save-excursion
- (if pos (goto-char pos))
- (cond ((looking-at ";;;") (current-column))
- ((looking-at ";;")
- (let ((tem (calculate-scheme-indent)))
- (if (listp tem) (car tem) tem)))
- (t
- (skip-chars-backward " \t")
- (max (if (bolp) 0 (1+ (current-column)))
- comment-column)))))
-
-(defvar scheme-indent-offset nil "")
-(defvar scheme-indent-function 'scheme-indent-function "")
-
-(defun scheme-indent-line (&optional whole-exp)
- "Indent current line as Scheme code.
-With argument, indent any additional lines of the same expression
-rigidly along with this one."
- (interactive "P")
- (let ((indent (calculate-scheme-indent)) shift-amt beg end
- (pos (- (point-max) (point))))
- (beginning-of-line)
- (setq beg (point))
- (skip-chars-forward " \t")
- (if (looking-at "[ \t]*;;;")
- ;; Don't alter indentation of a ;;; comment line.
- nil
- (if (listp indent) (setq indent (car indent)))
- (setq shift-amt (- indent (current-column)))
- (if (zerop shift-amt)
- nil
- (delete-region beg (point))
- (indent-to indent))
- ;; If initial point was within line's indentation,
- ;; position after the indentation. Else stay at same point in text.
- (if (> (- (point-max) pos) (point))
- (goto-char (- (point-max) pos)))
- ;; If desired, shift remaining lines of expression the same amount.
- (and whole-exp (not (zerop shift-amt))
- (save-excursion
- (goto-char beg)
- (forward-sexp 1)
- (setq end (point))
- (goto-char beg)
- (forward-line 1)
- (setq beg (point))
- (> end beg))
- (indent-code-rigidly beg end shift-amt)))))
-\f
-(defun calculate-scheme-indent (&optional parse-start)
- "Return appropriate indentation for current line as scheme code.
-In usual case returns an integer: the column to indent to.
-Can instead return a list, whose car is the column to indent to.
-This means that following lines at the same level of indentation
-should not necessarily be indented the same way.
-The second element of the list is the buffer position
-of the start of the containing expression."
- (save-excursion
- (beginning-of-line)
- (let ((indent-point (point)) state paren-depth desired-indent (retry t)
- last-sexp containing-sexp first-sexp-list-p)
- (if parse-start
- (goto-char parse-start)
- (beginning-of-defun))
- ;; Find outermost containing sexp
- (while (< (point) indent-point)
- (setq state (parse-partial-sexp (point) indent-point 0)))
- ;; Find innermost containing sexp
- (while (and retry (setq paren-depth (car state)) (> paren-depth 0))
- (setq retry nil)
- (setq last-sexp (nth 2 state))
- (setq containing-sexp (car (cdr state)))
- ;; Position following last unclosed open.
- (goto-char (1+ containing-sexp))
- ;; Is there a complete sexp since then?
- (if (and last-sexp (> last-sexp (point)))
- ;; Yes, but is there a containing sexp after that?
- (let ((peek (parse-partial-sexp last-sexp indent-point 0)))
- (if (setq retry (car (cdr peek))) (setq state peek))))
- (if (not retry)
- ;; Innermost containing sexp found
- (progn
- (goto-char (1+ containing-sexp))
- (if (not last-sexp)
- ;; indent-point immediately follows open paren.
- ;; Don't call hook.
- (setq desired-indent (current-column))
- ;; Move to first sexp after containing open paren
- (parse-partial-sexp (point) last-sexp 0 t)
- (setq first-sexp-list-p (looking-at "\\s("))
- (cond
- ((> (save-excursion (forward-line 1) (point))
- last-sexp)
- ;; Last sexp is on same line as containing sexp.
- ;; It's almost certainly a function call.
- (parse-partial-sexp (point) last-sexp 0 t)
- (if (/= (point) last-sexp)
- ;; Indent beneath first argument or, if only one sexp
- ;; on line, indent beneath that.
- (progn (forward-sexp 1)
- (parse-partial-sexp (point) last-sexp 0 t)))
- (backward-prefix-chars))
- (t
- ;; Indent beneath first sexp on same line as last-sexp.
- ;; Again, it's almost certainly a function call.
- (goto-char last-sexp)
- (beginning-of-line)
- (parse-partial-sexp (point) last-sexp 0 t)
- (backward-prefix-chars)))))))
- ;; If looking at a list, don't call hook.
- (if first-sexp-list-p
- (setq desired-indent (current-column)))
- ;; Point is at the point to indent under unless we are inside a string.
- ;; Call indentation hook except when overridden by scheme-indent-offset
- ;; or if the desired indentation has already been computed.
- (cond ((car (nthcdr 3 state))
- ;; Inside a string, don't change indentation.
- (goto-char indent-point)
- (skip-chars-forward " \t")
- (setq desired-indent (current-column)))
- ((and (integerp scheme-indent-offset) containing-sexp)
- ;; Indent by constant offset
- (goto-char containing-sexp)
- (setq desired-indent (+ scheme-indent-offset (current-column))))
- ((not (or desired-indent
- (and (boundp 'scheme-indent-function)
- scheme-indent-function
- (not retry)
- (setq desired-indent
- (funcall scheme-indent-function
- indent-point state)))))
- ;; Use default indentation if not computed yet
- (setq desired-indent (current-column))))
- desired-indent)))
+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 <hannes.haug@student.uni-tuebingen.de> 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 <hannes.haug@student.uni-tuebingen.de> wants:
+ "and" "or" "delay" "force"
+ ;; Stefan Monnier <stefan.monnier@epfl.ch> says don't bother:
+ ;;"quasiquote" "quote" "unquote" "unquote-splicing"
+ "map" "syntax" "syntax-rules") t)
+ "\\>") 1)
+ ;;
+ ;; David Fox <fox@graphics.cs.nyu.edu> for SOS/STklos class specifiers.
+ '("\\<<\\sw+>\\>" . font-lock-type-face)
+ ;;
+ ;; Scheme `:' and `#:' 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.")
+