;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; swank-loader.lisp --- Compile and load the Slime backend. ;;; ;;; Created 2003, James Bielman ;;; ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; ;; If you want customize the source- or fasl-directory you can set ;; swank-loader:*source-directory* resp. swank-loader:*fasl-directory* ;; before loading this files. (you also need to create the ;; swank-loader package.) ;; E.g.: ;; ;; (make-package :swank-laoder) ;; (defparameter swank-loader::*fasl-directory* "/tmp/fasl/") ;; (load ".../swank-loader.lisp") (cl:defpackage :swank-loader (:use :cl) (:export :load-swank :*source-directory* :*fasl-directory*)) (cl:in-package :swank-loader) (defvar *source-directory* (let ((p (or *load-pathname* *default-pathname-defaults*))) (if p (directory-namestring p))) "The directory where to look for the source.") (defparameter *sysdep-files* (append '("nregex") #+cmu '("swank-source-path-parser" "swank-source-file-cache" "swank-cmucl") #+scl '("swank-source-path-parser" "swank-source-file-cache" "swank-scl") #+sbcl '("swank-sbcl" "swank-source-path-parser" "swank-source-file-cache" "swank-gray") #+openmcl '("metering" "swank-openmcl" "swank-gray") #+lispworks '("swank-lispworks" "swank-gray") #+allegro '("swank-allegro" "swank-gray") #+clisp '("xref" "metering" "swank-clisp" "swank-gray") #+armedbear '("swank-abcl") #+cormanlisp '("swank-corman" "swank-gray") #+ecl '("swank-ecl" "swank-gray") )) (defparameter *implementation-features* '(:allegro :lispworks :sbcl :openmcl :cmu :clisp :ccl :corman :cormanlisp :armedbear :gcl :ecl :scl)) (defparameter *os-features* '(:macosx :linux :windows :mswindows :win32 :solaris :darwin :sunos :hpux :unix)) (defparameter *architecture-features* '(:powerpc :ppc :x86 :x86-64 :amd64 :i686 :i586 :i486 :pc386 :iapx386 :sparc64 :sparc :hppa64 :hppa)) (defun lisp-version-string () #+cmu (substitute-if #\_ (lambda (x) (find x " /")) (lisp-implementation-version)) #+scl (lisp-implementation-version) #+sbcl (lisp-implementation-version) #+ecl (lisp-implementation-version) #+openmcl (format nil "~d.~d" ccl::*openmcl-major-version* ccl::*openmcl-minor-version*) #+lispworks (lisp-implementation-version) #+allegro excl::*common-lisp-version-number* #+clisp (let ((s (lisp-implementation-version))) (subseq s 0 (position #\space s))) #+armedbear (lisp-implementation-version) #+cormanlisp (lisp-implementation-version)) (defun unique-directory-name () "Return a name that can be used as a directory name that is unique to a Lisp implementation, Lisp implementation version, operating system, and hardware architecture." (flet ((first-of (features) (loop for f in features when (find f *features*) return it)) (maybe-warn (value fstring &rest args) (cond (value) (t (apply #'warn fstring args) "unknown")))) (let ((lisp (maybe-warn (first-of *implementation-features*) "No implementation feature found in ~a." *implementation-features*)) (os (maybe-warn (first-of *os-features*) "No os feature found in ~a." *os-features*)) (arch (maybe-warn (first-of *architecture-features*) "No architecture feature found in ~a." *architecture-features*)) (version (maybe-warn (lisp-version-string) "Don't know how to get Lisp ~ implementation version."))) (format nil "~(~@{~a~^-~}~)" lisp version os arch)))) (defun file-newer-p (new-file old-file) "Returns true if NEW-FILE is newer than OLD-FILE." (> (file-write-date new-file) (file-write-date old-file))) ;; Currently just use the modification time of the ChangeLog. We ;; could also try to use one of those CVS keywords. (defun slime-version-string () "Return a string identifying the SLIME version. Return nil if nothing appropriate is available." (let* ((changelog (merge-pathnames "ChangeLog" *source-directory*)) (date (file-write-date changelog))) (cond (date (multiple-value-bind (_s _m _h date month year) (decode-universal-time date) (declare (ignore _s _m _h)) (format nil "~D-~2,'0D-~2,'0D" year month date))) (t nil)))) (defun default-fasl-directory () (directory-namestring (merge-pathnames (make-pathname :directory `(:relative ".slime" "fasl" ,@(if (slime-version-string) (list (slime-version-string))) ,(unique-directory-name))) (user-homedir-pathname)))) (defun binary-pathname (source-pathname binary-directory) "Return the pathname where SOURCE-PATHNAME's binary should be compiled." (let ((cfp (compile-file-pathname source-pathname))) (merge-pathnames (make-pathname :name (pathname-name cfp) :type (pathname-type cfp)) binary-directory))) (defun compile-files-if-needed-serially (files fasl-directory) "Compile each file in FILES if the source is newer than its corresponding binary, or the file preceding it was recompiled." (with-compilation-unit () (let ((needs-recompile nil)) (dolist (source-pathname files) (let ((binary-pathname (binary-pathname source-pathname fasl-directory))) (handler-case (progn (when (or needs-recompile (not (probe-file binary-pathname)) (file-newer-p source-pathname binary-pathname)) (ensure-directories-exist binary-pathname) (compile-file source-pathname :output-file binary-pathname :print nil :verbose t) (setq needs-recompile t)) (load binary-pathname :verbose t)) #+(or) (error () ;; If an error occurs compiling, load the source instead ;; so we can try to debug it. (load source-pathname)) )))))) #+(or cormanlisp ecl) (defun compile-files-if-needed-serially (files fasl-directory) "Corman Lisp and ECL have trouble with compiled files." (declare (ignore fasl-directory)) (dolist (file files) (load file :verbose t) (force-output))) (defun load-user-init-file () "Load the user init file, return NIL if it does not exist." (load (merge-pathnames (user-homedir-pathname) (make-pathname :name ".swank" :type "lisp")) :if-does-not-exist nil)) (defun load-site-init-file (directory) (load (make-pathname :name "site-init" :type "lisp" :directory (pathname-directory directory)) :if-does-not-exist nil)) (defun swank-source-files (source-directory) (mapcar (lambda (name) (make-pathname :name name :type "lisp" :directory (pathname-directory source-directory))) `("swank-backend" ,@*sysdep-files* "swank"))) (defvar *fasl-directory* (directory-namestring (default-fasl-directory)) "The directory where fasl files should be placed.") (defun load-swank (&key (source-directory *source-directory*) (fasl-directory *fasl-directory*)) (compile-files-if-needed-serially (swank-source-files source-directory) fasl-directory) (funcall (intern (string :warn-unimplemented-interfaces) :swank-backend)) (load-site-init-file source-directory) (load-user-init-file)) (load-swank)