#xyzzy の設定をすっ飛ばしたので、復旧がてら中途半端なものを整理して貼っておく

.gitignore

*.lc
\#*\#

lisp-mode-misc.l

;;; -*- mode: lisp; package: editor -*-
;;;
;;; lisp-mode-misc.l  --- Miscellaneous stuff for lisp-mode.
;;;
;;; Author: bowbow99  <bowbow99@gmail.com>
;;; License: NYSL

;;; Code:

(in-package :editor)


;;;; utilities

(defun lisp-number-of-universal-arguments (&optional (n *prefix-value*))
  "Return number of `universal-argument` pressed before current command."
  (if (null n) 0
    (do ((n n (/ n 4))
         (i 0 (1+ i)))
        ((<= n 1) i))))

(defun lisp-toplevel-paren-balanced-p ()
  "Return true if toplevel form containing current point is balanced."
  (save-excursion
    ;(while (up-list -1 t))
    (while (backward-up-list 1 t))
    (ignore-errors (goto-matched-parenthesis))))

(defparameter +lisp-in-package-regexp+
  (compile-regexp "(in-package +[:'\"]\\(\\(?:\\sw\\|\\s_\\)+\\)\"?)"))

(defun lisp-point-package-name (&optional (point nil sv))
  "Return name of current package for POINT."
  (or (save-excursion
        (when point (goto-char point))
        (when (scan-buffer +lisp-in-package-regexp+
                           :regexp t :reverse t)
          (match-string 1)))
        *buffer-package*
      (save-excursion
        (goto-char (point-min))
        (when (and (scan-buffer "package: \\(\\(?:\\sw\\|\\s_\\)+\\).*-\\*-$"
                                :regexp t :limit 3000)
                   (eql (parse-point-syntax) :comment))
          (match-string 1)))
      "user"))

(defun lisp-count-complete-forms (end &optional start)
  "Return number of complete sexp between START (or current point) and END."
  (save-excursion
    (when start (goto-char start))
    (let ((count -1))
      (while (< (point) end)
        (skip-white-forward)
        (incf count)
        (or (forward-sexp 1 t)
            (return)))
      count)))


;;;; keyword highlight

#| 設定例
(add-hook 'ed:*lisp-mode-hook* 'lisp-setup-keyword-highlight)
(add-hook 'ed:*lisp-interaction-mode-hook* 'lisp-setup-keyword-highlight)
;|#

(export '(*lisp-keyword-file*
          lisp-setup-keyword-highlight))

(defvar *lisp-keyword-file* "lisp"
  "*lisp-mode などで使うキーワードファイルの名前。")

(defvar *lisp-keyword-hash-table* nil)

(defun lisp-setup-keyword-highlight ()
  "lisp-mode などで lisp のキーワードに色を付ける"
  (when (and *lisp-keyword-file*
             (not *lisp-keyword-hash-table*))
    (setf *lisp-keyword-hash-table*
          (load-keyword-file *lisp-keyword-file*)))
  (when *lisp-keyword-hash-table*
    (make-local-variable 'keyword-hash-table)
    (setf keyword-hash-table *lisp-keyword-hash-table*)))


;;;; regexp keyword highlight

#| 設定例
(labels ((expand (template &rest vars)
           "(expand \"foo ${bar} baz\" :bar \"hoge\") => \"foo hoge baz\""
           (apply #'concat
                  (mapcar (lambda (x)
                            (if (string-match "^{\\([-a-zA-Z_]+\\)}\\(.*\\)$" x)
                              (let* ((name (match-string 1))
                                     (rest (match-string 2))
                                     (str  (getf vars (intern (string-downcase name) :keyword) "")))
                                (concat str rest))
                              x))
                          (split-string template #\$)))))
  (setf *lisp-regexp-keyword-list*
        (mapcar (lambda (x)
                  (cons (expand (car x) :symbol "[-a-z0-9$!~^@?=<>{}/&_%\\.+\\*]")
                        (cdr x)))
                ;; (regexp case-fold color [context [begin [end]]])
                '(("#:${symbol}+\\_>" t (:color 4))    ; #:uninterned
                  ("\\_<:${symbol}+\\_>" t (:color 5)) ; :keyword
                  ("\\_<\\(?:${symbol}+::?\\)?\\*${symbol}+\\*\\_>" ; package:*special*
                   t (:color 3))
                  ))))

(add-hook 'ed:*lisp-mode-hook* 'lisp-setup-regexp-keyword-highlight)
(add-hook 'ed:*lisp-interaction-mode-hook* 'lisp-setup-regexp-keyword-highlight)
;|#

(export '(*lisp-regexp-keyword-list*
          lisp-setup-regexp-keyword-highlight))

(defvar *lisp-regexp-keyword-list* nil
  "*lisp-mode などで使う正規表現キーワードのリスト")

(defvar *lisp-compiled-regexp-keyword-list* nil)

(defun lisp-setup-regexp-keyword-highlight ()
  "lisp-mode などで正規表現キーワードに色を付ける。"
  (when (and *lisp-regexp-keyword-list*
             (not *lisp-compiled-regexp-keyword-list*))
    (setf *lisp-compiled-regexp-keyword-list*
          (compile-regexp-keyword-list *lisp-regexp-keyword-list*)))
  (when *lisp-compiled-regexp-keyword-list*
    (make-local-variable 'regexp-keyword-list)
    (setf regexp-keyword-list *lisp-compiled-regexp-keyword-list*)))


;;;; compile and/or load when saving lisp files

#| 設定例
(defun lisp-setup-save-and-compile/load ()
  (local-set-key '(#\C-x #\C-s) 'lisp-save-and-compile/load))

(add-hook 'ed:*lisp-mode-hook* 'lisp-setup-save-and-compile/load)
;|#

(export '(lisp-save-and-compile/load
          -lisp-load-on-save-
          -lisp-compile-on-save-
          lisp-toggle-load-on-save
          lisp-toggle-compile-on-save))

(defvar-local -lisp-load-on-save- :ask)
(defvar-local -lisp-compile-on-save- :auto)

(defun lisp-toggle-load-on-save ()
  (interactive)
  (setf -lisp-load-on-save- (not -lisp-load-on-save-))
  (message "load lisp file on save: ~:[disabled~;enabled~]"
           -lisp-load-on-save-))

(defun lisp-toggle-compile-on-save ()
  (interactive)
  (setf -lisp-compile-on-save-
        (case -lisp-compile-on-save-
          ((nil) :auto)
          (:auto t)
          (otherwise nil)))
  (message "compile lisp file on save: ~S"
           -lisp-compile-on-save-))

(defun lisp-save-and-compile/load ()
  (interactive "*")
  (let* ((srcfile  (get-buffer-file-name (selected-buffer)))
         (bytefile (concat srcfile "c")))
    (save-buffer)
    ;; compile if necessary
    (when (and (file-exist-p srcfile)
               (cond ((null -lisp-compile-on-save-) nil)
                     ((eql  -lisp-compile-on-save- :auto)
                      (file-exist-p bytefile))
                     (t t)))
      (let ((buffer (find-buffer "*Compile Log*")))
        (unless buffer
          (setf buffer (create-new-buffer "*Compile Log*"))
          (setup-temp-buffer buffer))
        (message "Compiling ~A..." srcfile)
        (with-output-to-buffer (buffer (buffer-size buffer))
          (format t "~&~%;; ~A - ~A~%"
                  (format-date-string "%Y-%m-%d %H:%M:%S")
                  srcfile)
          (handler-bind
              ((error (lambda (error)
                        (format t "~&* Error occured while compiling ~A:~%  ~A"
                                srcfile error))))
            (byte-compile-file srcfile))
          (message "Compiling ~A...done." srcfile))))
    ;; load if necessary
    (when (eql -lisp-load-on-save- :ask)
      (setf -lisp-load-on-save- (yes-or-no-p "load ~S?" srcfile)))
    (when -lisp-load-on-save-
      (cond ((file-exist-p bytefile) (load bytefile))
            ((file-exist-p srcfile)  (load srcfile))
            (t (error 'file-not-found :pathname srcfile))))))


;;;; electric commands

#| 設定例
(dolist (keymap (list ed::*lisp-mode-map*
                      ed::*lisp-interaction-mode-map*))
  (define-key keymap #\( 'lisp-electric-open-paren)
  (define-key keymap #\) 'lisp-electric-close-paren)
  (define-key keymap #\" 'lisp-electric-double-quote))
;|#

(export '(lisp-electric-open-paren
          lisp-electric-close-paren
          lisp-electric-double-quote))

(defvar *lisp-pair-chars-alist*
  '((#\( . #\)) (#\{ . #\}) (#\[ . #\])))

(defun lisp-electric-open-paren (&optional (arg 0))
  "開き括弧を挿入するついでにてきとーに閉じコッカも"
  (interactive "*p")
  (setq arg (lisp-number-of-universal-arguments))
  (let* ((open-char *last-command-char*)
         (close-char (cdr (assoc open-char *lisp-pair-chars-alist*))))
    (insert open-char)
    (unless (and (null (parse-point-syntax))
                 close-char)
      (return-from lisp-electric-open-paren))
    (save-excursion
      (let ((epoint (save-excursion
                      (when arg (forward-sexp arg t))
                      (point))))
        (while (up-list -1 t))
        (let ((p (point)))
          (unless (and (ignore-errors (goto-matched-parenthesis))
                       (ignore-errors (goto-matched-parenthesis))
                       (= (point) p))
            (goto-char epoint)
            (insert close-char)))
        t))))

(defun lisp-electric-close-paren (&optional (arg 1))
  "閉じコッカをてきとーに挿入したりしなかったり"
  (interactive "*p")
  (unless (eql *last-command-char* #\))
    (return-from lisp-electric-close-paren
      (if (interactive-p)
        (call-interactively 'self-insert-command)
        (insert *last-command-char*))))
  (case (lisp-number-of-universal-arguments)
    (1 (let ((beg (save-excursion
                    (while (up-list -1 t))
                    (point))))
         (while (save-excursion
                  (goto-char beg)
                  (not (ignore-errors (goto-matched-parenthesis))))
           (insert *last-command-char*)))
       t)
    (t (if (and (eql (following-char) *last-command-char*)
                (lisp-toplevel-paren-balanced-p))
         (forward-char arg)
         (insert *last-command-char* arg)))))

(defun lisp-electric-double-quote ()
  "ダブルクォート（文字列の開始/終了）をてきとーに挿入したりしなかったり"
  (interactive "*")
  (cond ((and (eql (parse-point-syntax) :string)
              (eql (following-char) *last-command-char*)
              (not (syntax-escape-p (preceding-char))))
         (forward-char))
        (t
         (insert *last-command-char*)
         (save-excursion
           (let ((opoint (point)))
             (when (and (forward-paragraph)
                        (eql (parse-point-syntax) :string))
               (goto-char opoint)
               (insert *last-command-char*)))
           t))))


;;;; indentation

#| config example
(defconstant +original-calc-lisp-indent+ #'ed::calc-lisp-indent)
(setf (symbol-function 'ed::calc-lisp-indent) #'ed::calc-lisp-indent+)
|#


(defun calc-lisp-indent+ (opoint)
  (protect-match-data
    (let ((begin-paren (and lisp-indent-close-paren
                            (looking-at "[ \t]*)"))))
      (goto-bol)
      (when (eql (parse-point-syntax) :string)
        (back-to-indentation)
        (return-from calc-lisp-indent+ (current-column)))
      (when (and (looking-at "\\s(")
                 (forward-char -1))
        (skip-white-backward)
        (forward-char 1))
      (or (up-list -1 t)
          (return-from calc-lisp-indent+ 0))
      (cond (begin-paren
             (+ (current-column) lisp-paren-imaginary-offset))
            ((or (looking-at "#")
                 (and (not (looking-back "#'"))
                      (looking-back "'")))
             (+ (current-column) 1))
            (t
             (let ((package (or (find-package (lisp-point-package-name))
                                (and (stringp *buffer-package*)
                                     (find-package *buffer-package*))
                                *package*)))
               (when (save-excursion
                       (when (and (up-list -1 t)
                                  (looking-for "((")
                                  (up-list -1 t))
                         (forward-char 1)
                         (multiple-value-bind (symbol found)
                             (calc-lisp-indent-current-symbol package)
                           (when found (get symbol 'lisp-indent-flet)))))
                 (return-from calc-lisp-indent+
                   (+ (current-column) *lisp-body-indention*)))
               (let ((column (progn
                               (forward-char 1)
                               (current-column))))
                 (multiple-value-bind (symbol found pkg-marker-p)
                     (calc-lisp-indent-current-symbol package)
                   (when pkg-marker-p
                     (return-from calc-lisp-indent+ column))
                   ;; (get SYMBOL ed::lisp-indent-clauses) = N
                   ;; N番目以降の引数式は暗黙の progn を包む式と扱う、的な
                   (save-excursion
                     (when (and (up-list -1 t)
                                (forward-sexp -1 t)
                                (up-list -1 t)
                                (forward-char 1))
                       (multiple-value-bind (symbol-1 found-1)
                           (calc-lisp-indent-current-symbol package)
                         (when found-1
                           (let ((x (get symbol-1 'lisp-indent-clause)))
                             (when (and (numberp x)
                                        (>= (lisp-count-complete-forms opoint) (1- x)))
                               (return-from calc-lisp-indent+
                                 (+ (1- column) *lisp-body-indent*))))))))
                   (let ((method (when found
                                   (or (get symbol 'lisp-indent-hook)
                                       ;; マクロの &body に相当する場合について
                                       (let* ((args (cadr (macro-function symbol)))
                                              (before (when (find '&body args)
                                                        (subseq args 0 (position '&body args)))))
                                         (when before
                                           (while (find (car before) '(&whole &environment))
                                             (setq before (cddr before)))
                                           (length before)))))))
                     (cond ((numberp method)
                            (let ((count (lisp-count-complete-forms opoint)))
                              (+ (1- column)
                                 (* *lisp-body-indent*
                                    (if (< count method) 2 1)))))
                           (method
                            (+ column -1 *lisp-body-indention*))
                           (t
                            (skip-chars-forward " \t")
                            (if (or (eolp) (looking-for ";"))
                              (if *lisp-indent-offset*
                                (+ column *lisp-indent-offset*)
                                column)
                              (current-column)))))))))))))

(setf (get 'handler-case 'ed::lisp-indent-clause) 2)


;;; lisp-mode-misc.l ends here.