;;; -*- Mode: Emacs-Lisp -*-

;;;; Taylor R. Campbell's Emacs Initialization Code
;;;; Lisp Section

;;; This code is written by Taylor R. Campbell and placed in the Public
;;; Domain.  All warranties are disclaimed.

;;;; Scheme Setup

(autoload 'run-scheme "cmuscheme" "Run an inferior Scheme process." t)
(autoload 't-mode "tea" "Major mode for editing T code." t)
(autoload 'run-tea "tea" "Run an inferior T process." t)
(autoload 'scheme48-mode "scheme48"
  "Major mode for improved Scheme48 interaction."
  t)

(setq auto-mode-alist
      (append '(("\\.ss$"  . scheme-mode) ; Silly PLT & Chez
                ("\\.sch$" . scheme-mode) ; Silly Bigloo & Larceny
                ("\\.sc$"  . scheme-mode) ; Silly JMS
                ("\\.t$"   . t-mode)
                ("\\.asd$" . lisp-mode))  ; ASDF system files
              auto-mode-alist))

(setq scheme-program-name "scheme48")

(add-hook 'scheme-mode-hook
          (lambda ()
            ;; Prevent font-lock from being confused about #| ... |#
            ;; comments.
            (set (make-local-variable 'comment-start-skip)
                 (rx (and
                      ;; If any backslashes are prefixed, ensure that
                      ;; there be an even number of them.
                      (submatch (or line-start (not (any ?\\)))
                                (* "\\\\"))
                      (or (+ ";") "#|")
                      (* (any " \t")))))))

(autoload 'scheme48-safe-variable "scheme48"
  "Return non-nil when VAR is a valid value of `scheme48-package'.")

(put 'scheme48-package 'safe-local-variable 'scheme48-safe-variable)

(defun maybe-scheme48-mode ()
  "Enter Scheme48 Mode if `scheme48-package' is non-nil.
Hack the local variables after doing so in order to maintain the value
  of the `scheme48-package' variable if it was set in the `-*-' line."
  (if (and (eq major-mode 'scheme-mode)
           (boundp 'scheme48-package)
           scheme48-package)
      (progn
        (scheme48-mode)
        (hack-local-variables))))

(add-hook 'hack-local-variables-hook 'maybe-scheme48-mode)

;;; We really want this stuff toggled per Scheme system; in T & scsh,
;;; for instance, | is a symbol constituent, whereas with MIT Scheme
;;; and some other Scheme systems, it is a symbol delimiter.  I see
;;; more code in scsh & T that uses | than I do in MIT Scheme &c.,
;;; however, and it is probably less annoying to see the latter break.

(eval-after-load "scheme"
  '(progn
     (modify-syntax-entry ?\| "_ 23bn" scheme-mode-syntax-table)
     (modify-syntax-entry ?\# "' 14bn" scheme-mode-syntax-table)))

;;;; Paredit

(autoload 'paredit-mode "paredit"
  "Minor mode for pseudo-structurally editing Lisp code."
  t)

(eval-after-load "paredit"
  '(progn
     (define-key paredit-mode-map (kbd "RET") 'paredit-newline)
     (define-key paredit-mode-map (kbd "C-j") nil)))

(mapc (lambda (hook) (add-hook hook (lambda ()
                                      (paredit-mode +1))))
      '(lisp-mode-hook
        emacs-lisp-mode-hook
        scheme-mode-hook
        t-mode-hook))

(if window-system (show-paren-mode +1))

;;;; SLIME

(add-to-load-path "slime")

(autoload 'slime "slime"
  "Start an inferior^_superior Lisp and connect to its Swank server."
  t)

(eval-after-load "slime"
  '(progn
     (slime-setup)
     ;; (setq slime-space-information-p nil)
     (setq slime-lisp-implementations
           `((sbcl ("sbcl"))
             (cmucl ("lisp"))
             (openmcl ("openmcl"))
             (s48 ("scheme48") :init slime48-init-command)
             (s48-large ("scheme48" "-h" "80000000")
                        :init slime48-init-command)
             (lsw ("~/programming/soc/2007/lsw/trunk/bin/lsw"))
             (abcl ("abcl"))
             ,@slime-lisp-implementations))))

(autoload 'slime48-init-command "slime48"
  "Return a string to initialize Scheme48 running under SLIME.")

(eval-after-load "slime48"
  '(add-hook 'slime-mode-hook
             (lambda ()
               (if (and (boundp 'scheme48-package)
                        scheme48-package)
                   (setq slime-buffer-package
                         (with-output-to-string
                           (prin1 scheme48-package)))))))

(add-hook 'lisp-mode-hook (lambda ()
                            (cond ((not (featurep 'slime))
                                   (require 'slime)
                                   (normal-mode)))))

;;; Why is this `find-tag' by default?  Yuck.

(define-key emacs-lisp-mode-map (kbd "M-.") 'find-function)

;;;; TRC's Lisp Source Header Insertion

(defun lisp-insert-header (mode local-vars title subtitle copyright)
  "Insert TRC's Lisp source file header."
  ;; Remember that elisp evaluates arguments left-to-right here.
  (interactive (list (read-string      "Mode: ")
                     (trc-read-local-variables)
                     (read-string     "Title: ")
                     (read-string  "Subtitle: ")
                     (read-string "Copyright: ")))
  ((lambda (body)
     (if (bobp)
         (funcall body)
         (save-excursion (funcall body))))
   (lambda ()
     (goto-char (point-min))
     (insert ";;; -*- Mode: " mode)
     (mapc (lambda (var)
             (insert "; " var))
           local-vars)
     (insert " -*-\n\n")
     (insert ";;;; " title ?\n)
     (if (not (string= subtitle ""))
         (insert ";;;; " subtitle ?\n))
     (cond ((or (string= copyright "public domain")
                (string= copyright "pd"))
            (insert public-domain-string))
           ((not (string= copyright ""))
            (insert (car copyright-format)
                    copyright
                    (cdr copyright-format))))
     (newline)))
  (normal-mode))         ; Fix up the mode for the added -*- cruft.

(defun trc-read-local-variables ()
  (let ((vars '()))
    (while (let ((var (read-string "Local variable: ")))
             (if (string= var "")
                 nil
               (push var vars)
               t)))
    vars))

(defconst public-domain-string "
;;; This code is written by Taylor R. Campbell and placed in the Public
;;; Domain.  All warranties are disclaimed.
")

(defconst copyright-format (cons "
;;; Copyright (c) " ", Taylor R. Campbell
;;; See the LICENCE file for licence terms.
"))

;;;; Scheme Indentation Hacks

(put 'herald 'scheme-indent-function 1)

;;; Why on *earth* is this set to 3 by default?

(put 'dynamic-wind 'scheme-indent-function 0)

(eval-after-load "scheme" '(progn

;;; This is a *slightly* modified version of what is in scheme.el,
;;; which is itself a slight modification of `lisp-indent-function'
;;; from lisp-mode.el.  Gee, you'd think that someone would think of
;;; the notion of 'abstraction' here...

(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 (downcase         ;** downcasage added by TRC
                       (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))
              ;** WITH-... & CALL-WITH-... forms added by TRC
              ((or (eq method 'with-...)
                   (eq method 'call-with-...)
                   (and (null method)
                        (or (and (> (length function) 5)
                                 (string-match "\\`with-" function))
                            (and (> (length function) 9)
                                 (string-match "\\`call-with-" function)))))
               (lisp-indent-withform state indent-point))
              ((integerp method)
               (lisp-indent-specform method state
                                     indent-point normal-indent))
              (method
               (funcall method state indent-point normal-indent)))))))

;;; This could be generalized to negative special form indent methods; e.g.,
;;;
;;;   (put 'with-frobbotzim 'scheme-indent-function -2)
;;;
;;; and then
;;;
;;;   (with-frobbotzim frob grovel
;;;       full lexical
;;;       mumble chumble
;;;       spuzz
;;;     (lambda (foo) ...)
;;;     (lambda (bar) ...))
;;;
;;; That is, the last two subforms would be indented two spaces, whereas all
;;; preceding subforms would get four spaces.

(defun lisp-indent-withform (state indent-point)
  (if (not (and (boundp 'paredit-mode)
                paredit-mode))
      ;; If we're not in paredit mode, it's not really safe to go backwards
      ;; from the end and to try to indent based on that, since there may not
      ;; be an end to work backwards from (i.e. the structure not be valid).
      (lisp-indent-defform state indent-point)
    (goto-char (nth 1 state))
    (let ((body-column (+ (current-column)
                          lisp-body-indent)))
      (forward-sexp 1)
      (backward-char 1)
      (backward-sexp 1)
      (skip-chars-backward " \t" (point-at-bol))
      (if (= (point) indent-point)
          body-column
          ;; If it's not the last argument, then we must specify not only the
          ;; column to indent to but also the start of the containing sexp,
          ;; which implies (don't ask me how) that any *following* subforms
          ;; must be indented separately, and not just on this column.  This
          ;; allows C-M-q to know to indent the penultimate arguments with four
          ;; spaces, but to keep recomputing the indentation so that it doesn't
          ;; assume the last one will go to the same column, which is a wrong
          ;; assumption.
          (list (+ body-column lisp-body-indent)
                (nth 1 state))))))

(put 'let-fluids 'scheme-indent-function 'with-...)

;;; Nested foof-loop forms

(put 'iterate 'scheme-indent-function 'with-...)
(put 'iterate! 'scheme-indent-function 'with-...)
(put 'iterate* 'scheme-indent-function 'with-...)
(put 'iterate-values 'scheme-indent-function 'with-...)
(put 'lazy-recur 'scheme-indent-function 'with-...)
(put 'lazy-recur* 'scheme-indent-function 'with-...)
(put 'recur 'scheme-indent-function 'with-...)
(put 'recur* 'scheme-indent-function 'with-...)

;;; This is silly, but so would altering the definition of
;;; `scheme-indent-function' yet again to include a test for
;;; `collect-...'.  Better would be to have a table mapping regular
;;; expressions to indent functions, as Edwin has.  But this is
;;; expedient for now.

(put 'collect-average 'scheme-indent-function 'with-...)
(put 'collect-display 'scheme-indent-function 'with-...)
(put 'collect-list 'scheme-indent-function 'with-...)
(put 'collect-list! 'scheme-indent-function 'with-...)
(put 'collect-list-into! 'scheme-indent-function 'with-...)
(put 'collect-list-reverse 'scheme-indent-function 'with-...)
(put 'collect-max 'scheme-indent-function 'with-...)
(put 'collect-min 'scheme-indent-function 'with-...)
(put 'collect-product 'scheme-indent-function 'with-...)
(put 'collect-stream 'scheme-indent-function 'with-...)
(put 'collect-string 'scheme-indent-function 'with-...)
(put 'collect-string-of-length 'scheme-indent-function 'with-...)
(put 'collect-sum 'scheme-indent-function 'with-...)
(put 'collect-vector 'scheme-indent-function 'with-...)
(put 'collect-vector-of-length 'scheme-indent-function 'with-...)

;;; This one doesn't follow the same pattern as the others, because
;;; there is no expression; (COLLECT-COUNT ...) is the same as
;;; (COLLECT-SUM ... 1).

(put 'collect-count 'scheme-indent-function 0)

;;;; RECEIVE Indentation

;;; (RECEIVE <bvl>           ; Line up BVL & producer.
;;;          <producer>
;;;   <body>)

(defun scheme-indent-receive (state indent-point normal-indent)
  (let ((containing-form-start (nth 1 state))
        (i 0)
        containing-form-column)
    ;; <snip documentation>
    (goto-char containing-form-start)
    (setq containing-form-column (current-column))
    (forward-char 1)
    (forward-sexp 1)
    ;; Now find the start of the last form.
    (parse-partial-sexp (point) indent-point 1 t)
    (while (and (< (point) indent-point)
                (condition-case ()
                    (progn
                      (setq i (1+ i))
                      (forward-sexp 1)
                      (parse-partial-sexp (point) indent-point 1 t))
                  (error nil))))
    ;; Point is sitting on first character of last (or count) sexp.
    (cond ((= i 0)
           (+ containing-form-column (* 2 lisp-body-indent)))
          ((= i 1) (list normal-indent containing-form-start))
          (t (+ containing-form-column lisp-body-indent)))))

(put 'receive 'scheme-indent-function 'scheme-indent-receive)

))        ; end of eval-after-load for scheme.el