gistfile1.cl

(require "condition-restart")

(in-package :lisp)

;;;
;;; * Condition Definitions


(define-condition library-condition (condition)
  (name source-pathname compiled-pathname)
  (:report (lambda (c s)
             (format s "ライブラリ `~A' が..."
                     (library-condition-name c)))))

(define-condition library-not-compiled (library-condition)
  ()
  (:report (lambda (c s)
             (format s "ライブラリはコンパイルされていません: ~S"
                     (library-condition-name c)))))

(define-condition library-source-updated (library-condition)
  ()
  (:report (lambda (c s)
             (format s "ライブラリのソースが更新されてます: ~S"
                     (library-condition-source-pathname c)))))
;;;
;;; * load-library

(defun load-library-w/restarts
      (library-name &rest options &key no-suffix if-does-not-exist no-message)
  (let* ((src-pathname (if no-suffix
                           library-name
                         (find-load-path (ed:concat library-name ".l"))))
         (lc-pathname (ed:concat src-pathname "c")))
    (unless (file-exist-p src-pathname)
      (error 'file-not-found :pathname src-pathname))
    (apply #'si:*load-library
           (cond ((not (file-exist-p lc-pathname))
                  (restart-case
                      (signal 'library-not-compiled :name library-name
                              :source-pathname src-pathname)
                    (compile ()
                      :report "コンパイルしてロードする。"
                      (compile-file src-pathname)
                      lc-pathname)
                    (continue ()
                      :report "そのままロードする。"
                      src-pathname)))
                 ((> (file-write-time src-pathname)
                     (file-write-time lc-pathname))
                  (restart-case
                      (signal 'library-source-updated :name library-name
                              :source-pathname src-pathname
                              :compiled-pathname lc-pathname)
                    (recompile ()
                      :report "コンパイルし直してロードする。"
                      (compile-file src-pathname)
                      lc-pathname)
                    (use-source ()
                      :report "ソースファイルをロードする。"
                      src-pathname)
                    (use-compiled ()
                      :report "コンパイル済みファイルをそのままロードする。"
                      lc-pathname)))
                 (t
                  lc-pathname))
           :no-suffix t
           options)))


;;; !! WARNING: 標準関数上書き注意報

(defun load-library (filename &rest rest)
  (ed:interactive "sLoad library: ")
  (apply #'load-library-w/restarts filename rest))

(defun require (module-name &optional pathname)
  (setq module-name (string module-name))
  (unless (member module-name *modules* :test #'string=)
    (load-library-w/restarts (or pathname module-name))))

• si:*load-library 呼び出すのに cond 式から abs-pathname 渡しておいて :no-suffix つけてなかった
• :no-suffix で呼び出されたら find-load-path しないように
• src file が無かったときはふつーにエラー投げるように