swank-loader.lisp 11.1 KB
Newer Older
1
;;;; -*- indent-tabs-mode: nil -*-
James Bielman's avatar
James Bielman committed
2 3 4 5 6 7 8 9 10
;;;
;;; swank-loader.lisp --- Compile and load the Slime backend.
;;;
;;; Created 2003, James Bielman <jamesjb@jamesjb.com>
;;;
;;; This code has been placed in the Public Domain.  All warranties
;;; are disclaimed.
;;;

11 12
;; If you want customize the source- or fasl-directory you can set
;; swank-loader:*source-directory* resp. swank-loader:*fasl-directory*
13
;; before loading this files. 
14 15 16
;; E.g.:
;;
;;   (load ".../swank-loader.lisp")
17 18
;;   (setq swank-loader::*fasl-directory* "/tmp/fasl/")
;;   (swank-loader:init)
19

Helmut Eller's avatar
Helmut Eller committed
20
(cl:defpackage :swank-loader
21
  (:use :cl)
22
  (:export :init
23
           :dump-image
24 25
           :*source-directory*
           :*fasl-directory*))
26

27
(cl:in-package :swank-loader)
James Bielman's avatar
James Bielman committed
28

29 30
(defvar *source-directory*
  (make-pathname :name nil :type nil
31
                 :defaults (or *load-pathname* *default-pathname-defaults*))
32 33
  "The directory where to look for the source.")

Helmut Eller's avatar
Helmut Eller committed
34
(defparameter *sysdep-files*
35 36 37 38
  #+cmu '(swank-source-path-parser swank-source-file-cache swank-cmucl)
  #+scl '(swank-source-path-parser swank-source-file-cache swank-scl)
  #+sbcl '(swank-source-path-parser swank-source-file-cache
           swank-sbcl swank-gray)
39
  #+clozure '(metering swank-ccl swank-gray)
40 41 42 43 44
  #+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)
45 46
  #+ecl '(swank-source-path-parser swank-source-file-cache
          swank-ecl swank-gray))
James Bielman's avatar
James Bielman committed
47

48
(defparameter *implementation-features*
49
  '(:allegro :lispworks :sbcl :clozure :cmu :clisp :ccl :corman :cormanlisp
50
    :armedbear :gcl :ecl :scl))
51 52

(defparameter *os-features*
53 54
  '(:macosx :linux :windows :mswindows :win32 :solaris :darwin :sunos :hpux
    :unix))
55 56

(defparameter *architecture-features*
57
  '(:powerpc :ppc :x86 :x86-64 :x86_64 :amd64 :i686 :i586 :i486 :pc386 :iapx386
58
    :sparc64 :sparc :hppa64 :hppa :arm
59 60
    :pentium3 :pentium4
    :java-1.4 :java-1.5 :java-1.6 :java-1.7))
61

62 63
(defun q (s) (read-from-string s))

64 65
#+ecl
(defun ecl-version-string ()
66 67 68 69 70 71
  (format nil "~A~@[-~A~]"
          (lisp-implementation-version)
          (when (find-symbol "LISP-IMPLEMENTATION-VCS-ID" :ext)
            (let ((vcs-id (funcall (q "ext:lisp-implementation-vcs-id"))))
              (when (>= (length vcs-id) 8)
                (subseq vcs-id 0 8))))))
72

73
(defun lisp-version-string ()
74 75
  #+(or clozure cmu) (substitute-if #\_ (lambda (x) (find x " /"))
                                    (lisp-implementation-version))
76 77 78 79 80
  #+(or cormanlisp scl) (lisp-implementation-version)
  #+sbcl (format nil "~a~:[~;-no-threads~]"
                 (lisp-implementation-version)
                 #+sb-thread nil
                 #-sb-thread t)
81
  #+lispworks (lisp-implementation-version)
82
  #+allegro   (format nil "~A~A~A~A"
83 84
                      excl::*common-lisp-version-number*
                      (if (eq 'h 'H) "A" "M")     ; ANSI vs MoDeRn
85 86 87 88
                      (if (member :64bit *features*) "-64bit" "")
                      (excl:ics-target-case
                       (:-ics "")
                       (:+ics "-ics")))
89 90
  #+clisp     (let ((s (lisp-implementation-version)))
                (subseq s 0 (position #\space s)))
91 92
  #+armedbear (lisp-implementation-version)
  #+ecl (ecl-version-string) )
93

94
(defun unique-dir-name ()
95 96 97 98 99
  "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
100 101 102 103 104 105
                 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*)
106
                            "No implementation feature found in ~a."
107 108 109 110 111 112 113 114 115 116
                            *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))))
117

James Bielman's avatar
James Bielman committed
118 119 120 121
(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)))

122 123 124
(defun slime-version-string ()
  "Return a string identifying the SLIME version.
Return nil if nothing appropriate is available."
125 126 127
  (with-open-file (s (merge-pathnames "ChangeLog" *source-directory*)
                     :if-does-not-exist nil)
    (and s (symbol-name (read s)))))
128

129
(defun default-fasl-dir ()
130 131 132 133 134 135
  (merge-pathnames
   (make-pathname
    :directory `(:relative ".slime" "fasl"
                 ,@(if (slime-version-string) (list (slime-version-string)))
                 ,(unique-dir-name)))
   (user-homedir-pathname)))
136

137 138 139
(defvar *fasl-directory* (default-fasl-dir)
  "The directory where fasl files should be placed.")

140 141 142
(defun binary-pathname (src-pathname binary-dir)
  "Return the pathname where SRC-PATHNAME's binary should be compiled."
  (let ((cfp (compile-file-pathname src-pathname)))
143 144
    (merge-pathnames (make-pathname :name (pathname-name cfp)
                                    :type (pathname-type cfp))
145
                     binary-dir)))
146

147 148
(defun handle-swank-load-error (condition context pathname)
  (fresh-line *error-output*)
149 150
  (pprint-logical-block (*error-output* () :per-line-prefix ";; ")
    (format *error-output*
151 152 153 154 155
            "~%Error while ~A ~A:~%  ~A~%Aborting.~%"
            context pathname condition))
  (when (equal (directory-namestring pathname)
               (directory-namestring *fasl-directory*))
    (ignore-errors (delete-file pathname)))
156 157
  (abort))

158
(defun compile-files (files fasl-dir load)
Helmut Eller's avatar
Helmut Eller committed
159
  "Compile each file in FILES if the source is newer than its
Helmut Eller's avatar
Helmut Eller committed
160 161
corresponding binary, or the file preceding it was recompiled.
If LOAD is true, load the fasl file."
162 163
  (let ((needs-recompile nil)
        (state :unknown))
164 165
    (dolist (src files)
      (let ((dest (binary-pathname src fasl-dir)))
166 167 168
        (handler-case
            (progn
              (when (or needs-recompile
169 170 171
                        (not (probe-file dest))
                        (file-newer-p src dest))
                (ensure-directories-exist dest)
172 173 174 175 176 177 178 179
                ;; need to recompile SRC, so we'll need to recompile
                ;; everything after this too.
                (setq needs-recompile t)
                (setq state :compile)
                (or (compile-file src :output-file dest :print nil :verbose t)
                    ;; An implementation may not necessarily signal a
                    ;; condition itself when COMPILE-FILE fails (e.g. ECL)
                    (error "COMPILE-FILE returned NIL.")))
Helmut Eller's avatar
Helmut Eller committed
180
              (when load
181
                (setq state :load)
182
                (load dest :verbose t)))
183 184
          ;; Fail as early as possible
          (serious-condition (c)
185 186 187 188
            (ecase state
              (:compile (handle-swank-load-error c "compiling" src))
              (:load    (handle-swank-load-error c "loading" dest))
              (:unknown (handle-swank-load-error c "???ing" src)))))))))
James Bielman's avatar
James Bielman committed
189

190
#+(or cormanlisp)
191
(defun compile-files (files fasl-dir load)
192
  "Corman Lisp has trouble with compiled files."
193
  (declare (ignore fasl-dir))
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
194 195 196 197
  (when load
    (dolist (file files)
      (load file :verbose t)
      (force-output))))
198

199 200 201 202 203 204
(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))

205
(defun load-site-init-file (dir)
206
  (load (make-pathname :name "site-init" :type "lisp"
207
                       :defaults dir)
208 209
        :if-does-not-exist nil))

210
(defun src-files (names src-dir)
211
  (mapcar (lambda (name)
Helmut Eller's avatar
Helmut Eller committed
212 213 214 215
            (make-pathname :name (string-downcase name) :type "lisp"
                           :defaults src-dir))
          names))

216 217 218 219
(defvar *swank-files*
  `(swank-backend ,@*sysdep-files* swank-match swank-rpc swank))

(defvar *contribs*
220
  '(swank-util swank-repl
221
    swank-c-p-c swank-arglists swank-fuzzy
222 223 224 225 226
    swank-fancy-inspector
    swank-presentations swank-presentation-streams
    #+(or asdf sbcl ecl) swank-asdf
    swank-package-fu
    swank-hyperdoc
227
    #+sbcl swank-sbcl-exts
228
    swank-mrepl
229
    )
Helmut Eller's avatar
Helmut Eller committed
230 231 232 233 234 235 236
  "List of names for contrib modules.")

(defun append-dir (absolute name)
  (merge-pathnames 
   (make-pathname :directory `(:relative ,name) :defaults absolute)
   absolute))

237 238 239 240
(defun contrib-dir (base-dir)
  (append-dir base-dir "contrib"))

(defun load-swank (&key (src-dir *source-directory*)
241
                        (fasl-dir *fasl-directory*))
242 243 244 245 246
  (compile-files (src-files *swank-files* src-dir) fasl-dir t)
  (funcall (q "swank::before-init")
           (slime-version-string)
           (list (contrib-dir fasl-dir)
                 (contrib-dir src-dir))))
247

248 249 250 251 252 253 254 255
(defun delete-stale-contrib-fasl-files (swank-files contrib-files fasl-dir)
  (let ((newest (reduce #'max (mapcar #'file-write-date swank-files))))
    (dolist (src contrib-files)
      (let ((fasl (binary-pathname src fasl-dir)))
        (when (and (probe-file fasl)
                   (<= (file-write-date fasl) newest))
          (delete-file fasl))))))

256
(defun compile-contribs (&key (src-dir (contrib-dir *source-directory*))
257 258 259 260 261 262 263 264 265
                           (fasl-dir (contrib-dir *fasl-directory*))
                           (swank-src-dir *source-directory*)
                           load)
  (let* ((swank-src-files (src-files *swank-files* swank-src-dir))
         (contrib-src-files (src-files *contribs* src-dir)))
    (delete-stale-contrib-fasl-files swank-src-files contrib-src-files 
                                     fasl-dir)
    (compile-files contrib-src-files fasl-dir load)))

266 267 268
(defun loadup ()
  (load-swank)
  (compile-contribs :load t))
269 270

(defun setup ()
271 272
  (load-site-init-file *source-directory*)
  (load-user-init-file)
273 274 275
  (when (#-clisp probe-file
         #+clisp ext:probe-directory        
         (contrib-dir *source-directory*))
276
    (eval `(pushnew 'compile-contribs ,(q "swank::*after-init-hook*"))))
277
  (funcall (q "swank::init")))
278

279
(defun init (&key delete reload load-contribs (setup t))
280 281 282 283 284 285
  "Load SWANK and initialize some global variables.
If DELETE is true, delete any existing SWANK packages.
If RELOAD is true, reload SWANK, even if the SWANK package already exists.
If LOAD-CONTRIBS is true, load all contribs
If SETUP is true, load user init files and initialize some
global variabes in SWANK."
286 287
  (when (and delete (find-package :swank))
    (mapc #'delete-package '(:swank :swank-io-package :swank-backend)))
288 289 290 291
  (cond ((or (not (find-package :swank)) reload)
         (load-swank))
        (t 
         (warn "Not reloading SWANK.  Package already exists.")))
292 293 294 295
  (when load-contribs
    (compile-contribs :load t))
  (when setup
    (setup)))
296 297 298 299

(defun dump-image (filename)
  (init :setup nil)
  (funcall (q "swank-backend:save-image") filename))