/[slime]/slime/swank-loader.lisp
ViewVC logotype

Diff of /slime/swank-loader.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.35 by asimon, Sun Sep 26 17:09:13 2004 UTC revision 1.117 by heller, Sat Jan 5 08:50:12 2013 UTC
# Line 1  Line 1 
1  ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-  ;;;; -*- indent-tabs-mode: nil -*-
2  ;;;  ;;;
3  ;;; swank-loader.lisp --- Compile and load the Slime backend.  ;;; swank-loader.lisp --- Compile and load the Slime backend.
4  ;;;  ;;;
# Line 8  Line 8 
8  ;;; are disclaimed.  ;;; are disclaimed.
9  ;;;  ;;;
10    
11  (cl:defpackage :swank-loader  ;; If you want customize the source- or fasl-directory you can set
12    (:use :common-lisp))  ;; swank-loader:*source-directory* resp. swank-loader:*fasl-directory*
13    ;; before loading this files.
14  (in-package :swank-loader)  ;; E.g.:
15    ;;
16    ;;   (load ".../swank-loader.lisp")
17    ;;   (setq swank-loader::*fasl-directory* "/tmp/fasl/")
18    ;;   (swank-loader:init)
19    
20  (defun make-swank-pathname (name &optional (type "lisp"))  (cl:defpackage :swank-loader
21    "Return a pathname with name component NAME in the Slime directory."    (:use :cl)
22    (merge-pathnames (make-pathname :name name :type type)    (:export :init
23                     (or *compile-file-pathname*             :dump-image
24                         *load-pathname*             :*source-directory*
25                         *default-pathname-defaults*)))             :*fasl-directory*))
26    
27  (defparameter *sysdep-pathnames*  (cl:in-package :swank-loader)
28    (mapcar #'make-swank-pathname  
29            (append  (defvar *source-directory*
30             '("nregex")    (make-pathname :name nil :type nil
31             #+cmu '("swank-source-path-parser" "swank-cmucl")                   :defaults (or *load-pathname* *default-pathname-defaults*))
32             #+sbcl '("swank-sbcl" "swank-source-path-parser" "swank-gray")    "The directory where to look for the source.")
33             #+openmcl '("metering" "swank-openmcl" "swank-gray")  
34             #+lispworks '("swank-lispworks" "swank-gray")  (defparameter *sysdep-files*
35             #+allegro '("swank-allegro" "swank-gray")    #+cmu '(swank-source-path-parser swank-source-file-cache swank-cmucl)
36             #+clisp '("xref" "metering" "swank-clisp" "swank-gray")    #+scl '(swank-source-path-parser swank-source-file-cache swank-scl)
37             #+armedbear '("swank-abcl")    #+sbcl '(swank-source-path-parser swank-source-file-cache
38             )))             swank-sbcl swank-gray)
39      #+clozure '(metering swank-ccl swank-gray)
40  (defparameter *lisp-name*    #+lispworks '(swank-lispworks swank-gray)
41    #+cmu       (format nil "cmu-~A"    #+allegro '(swank-allegro swank-gray)
42                        (substitute #\- #\/ (lisp-implementation-version)))    #+clisp '(xref metering swank-clisp swank-gray)
43    #+sbcl      (format nil "sbcl-~A" (lisp-implementation-version))    #+armedbear '(swank-abcl)
44    #+openmcl   "openmcl"    #+cormanlisp '(swank-corman swank-gray)
45    #+lispworks (format nil "lispworks-~A" (lisp-implementation-version))    #+ecl '(swank-source-path-parser swank-source-file-cache
46    #+allegro   (format nil "allegro-~A" excl::*common-lisp-version-number*)            swank-ecl swank-gray))
47    #+clisp     (format nil "clisp-~A" (let ((s (lisp-implementation-version)))  
48                                         (subseq s 0 (position #\space s))))  (defparameter *implementation-features*
49    #+armedbear "abcl"    '(:allegro :lispworks :sbcl :clozure :cmu :clisp :ccl :corman :cormanlisp
50    )      :armedbear :gcl :ecl :scl))
51    
52  (defparameter *swank-pathname* (make-swank-pathname "swank"))  (defparameter *os-features*
53      '(:macosx :linux :windows :mswindows :win32 :solaris :darwin :sunos :hpux
54        :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        :pentium3 :pentium4
60        :java-1.4 :java-1.5 :java-1.6 :java-1.7))
61    
62    (defun q (s) (read-from-string s))
63    
64    #+ecl
65    (defun ecl-version-string ()
66      (format nil "~A~@[-~A~]"
67              (lisp-implementation-version)
68              (when (find-symbol "LISP-IMPLEMENTATION-VCS-ID" :ext)
69                (let ((vcs-id (funcall (q "ext:lisp-implementation-vcs-id"))))
70                  (when (>= (length vcs-id) 8)
71                    (subseq vcs-id 0 8))))))
72    
73    (defun lisp-version-string ()
74      #+(or clozure cmu) (substitute-if #\_ (lambda (x) (find x " /"))
75                                        (lisp-implementation-version))
76      #+(or cormanlisp scl) (lisp-implementation-version)
77      #+sbcl (format nil "~a~:[~;-no-threads~]"
78                     (lisp-implementation-version)
79                     #+sb-thread nil
80                     #-sb-thread t)
81      #+lispworks (lisp-implementation-version)
82      #+allegro   (format nil "~@{~a~}"
83                          excl::*common-lisp-version-number*
84                          (if (eq 'h 'H) "A" "M")     ; ANSI vs MoDeRn
85                          (if (member :smp *features*) "s" "")
86                          (if (member :64bit *features*) "-64bit" "")
87                          (excl:ics-target-case
88                           (:-ics "")
89                           (:+ics "-ics")))
90      #+clisp     (let ((s (lisp-implementation-version)))
91                    (subseq s 0 (position #\space s)))
92      #+armedbear (lisp-implementation-version)
93      #+ecl (ecl-version-string) )
94    
95    (defun unique-dir-name ()
96      "Return a name that can be used as a directory name that is
97    unique to a Lisp implementation, Lisp implementation version,
98    operating system, and hardware architecture."
99      (flet ((first-of (features)
100               (loop for f in features
101                     when (find f *features*) return it))
102             (maybe-warn (value fstring &rest args)
103               (cond (value)
104                     (t (apply #'warn fstring args)
105                        "unknown"))))
106        (let ((lisp (maybe-warn (first-of *implementation-features*)
107                                "No implementation feature found in ~a."
108                                *implementation-features*))
109              (os   (maybe-warn (first-of *os-features*)
110                                "No os feature found in ~a." *os-features*))
111              (arch (maybe-warn (first-of *architecture-features*)
112                                "No architecture feature found in ~a."
113                                *architecture-features*))
114              (version (maybe-warn (lisp-version-string)
115                                   "Don't know how to get Lisp ~
116                                    implementation version.")))
117          (format nil "~(~@{~a~^-~}~)" lisp version os arch))))
118    
119  (defun file-newer-p (new-file old-file)  (defun file-newer-p (new-file old-file)
120    "Returns true if NEW-FILE is newer than OLD-FILE."    "Returns true if NEW-FILE is newer than OLD-FILE."
121    (> (file-write-date new-file) (file-write-date old-file)))    (> (file-write-date new-file) (file-write-date old-file)))
122    
123  (defun binary-pathname (source-pathname)  (defun slime-version-string ()
124    "Return the pathname where SOURCE-PATHNAME's binary should be compiled."    "Return a string identifying the SLIME version.
125    (let ((cfp (compile-file-pathname source-pathname)))  Return nil if nothing appropriate is available."
126      (merge-pathnames (make-pathname    (with-open-file (s (merge-pathnames "ChangeLog" *source-directory*)
127                        :directory `(:relative ".slime" "fasl" ,*lisp-name*)                       :if-does-not-exist nil)
128                        :name (pathname-name cfp)      (and s (symbol-name (read s)))))
129                        :type (pathname-type cfp))  
130                       (user-homedir-pathname))))  (defun default-fasl-dir ()
131      (merge-pathnames
132  (defun compile-files-if-needed-serially (files)     (make-pathname
133    "Compile each file in FILES if the source is newer than      :directory `(:relative ".slime" "fasl"
134  its corresponding binary, or the file preceding it was                   ,@(if (slime-version-string) (list (slime-version-string)))
135  recompiled."                   ,(unique-dir-name)))
136    (with-compilation-unit ()     (user-homedir-pathname)))
137      (let ((needs-recompile nil))  
138        (dolist (source-pathname files)  (defvar *fasl-directory* (default-fasl-dir)
139          (let ((binary-pathname (binary-pathname source-pathname)))    "The directory where fasl files should be placed.")
140            (handler-case  
141                (progn  (defun binary-pathname (src-pathname binary-dir)
142                  (when (or needs-recompile    "Return the pathname where SRC-PATHNAME's binary should be compiled."
143                            (not (probe-file binary-pathname))    (let ((cfp (compile-file-pathname src-pathname)))
144                            (file-newer-p source-pathname binary-pathname))      (merge-pathnames (make-pathname :name (pathname-name cfp)
145                    (format t "~&;; Compiling ~A...~%" source-pathname)                                      :type (pathname-type cfp))
146                    (ensure-directories-exist binary-pathname)                       binary-dir)))
147                    (compile-file source-pathname :output-file binary-pathname)  
148                    (setq needs-recompile t))  (defun handle-swank-load-error (condition context pathname)
149                  (load binary-pathname))    (fresh-line *error-output*)
150              #+(or)    (pprint-logical-block (*error-output* () :per-line-prefix ";; ")
151              (error ()      (format *error-output*
152                ;; If an error occurs compiling, load the source instead              "~%Error while ~A ~A:~%  ~A~%Aborting.~%"
153                ;; so we can try to debug it.              context pathname condition))
154                (load source-pathname))    (when (equal (directory-namestring pathname)
155              ))))))                 (directory-namestring *fasl-directory*))
156        (ignore-errors (delete-file pathname)))
157  (defun user-init-file ()    (abort))
158    "Return the name of the user init file or nil."  
159    (probe-file (merge-pathnames (user-homedir-pathname)  (defun compile-files (files fasl-dir load quiet)
160                                 (make-pathname :name ".swank" :type "lisp"))))    "Compile each file in FILES if the source is newer than its
161    corresponding binary, or the file preceding it was recompiled.
162    If LOAD is true, load the fasl file."
163  (compile-files-if-needed-serially    (let ((needs-recompile nil)
164    (append (list (make-swank-pathname "swank-backend"))          (state :unknown))
165            *sysdep-pathnames*      (dolist (src files)
166            (list *swank-pathname*)))        (let ((dest (binary-pathname src fasl-dir)))
167            (handler-case
168  (funcall (intern (string :warn-unimplemented-interfaces) :swank-backend))              (progn
169                  (when (or needs-recompile
170  (when (user-init-file)                          (not (probe-file dest))
171    (load (user-init-file)))                          (file-newer-p src dest))
172                    (ensure-directories-exist dest)
173                    ;; need to recompile SRC, so we'll need to recompile
174                    ;; everything after this too.
175                    (setq needs-recompile t)
176                    (setq state :compile)
177                    (or (compile-file src :output-file dest :print nil
178                                      :verbose (not quiet))
179                        ;; An implementation may not necessarily signal a
180                        ;; condition itself when COMPILE-FILE fails (e.g. ECL)
181                        (error "COMPILE-FILE returned NIL.")))
182                  (when load
183                    (setq state :load)
184                    (load dest :verbose (not quiet))))
185              ;; Fail as early as possible
186              (serious-condition (c)
187                (ecase state
188                  (:compile (handle-swank-load-error c "compiling" src))
189                  (:load    (handle-swank-load-error c "loading" dest))
190                  (:unknown (handle-swank-load-error c "???ing" src)))))))))
191    
192    #+(or cormanlisp)
193    (defun compile-files (files fasl-dir load quiet)
194      "Corman Lisp has trouble with compiled files."
195      (declare (ignore fasl-dir))
196      (when load
197        (dolist (file files)
198          (load file :verbose (not quiet)
199          (force-output)))))
200    
201    (defun load-user-init-file ()
202      "Load the user init file, return NIL if it does not exist."
203      (load (merge-pathnames (user-homedir-pathname)
204                             (make-pathname :name ".swank" :type "lisp"))
205            :if-does-not-exist nil))
206    
207    (defun load-site-init-file (dir)
208      (load (make-pathname :name "site-init" :type "lisp"
209                           :defaults dir)
210            :if-does-not-exist nil))
211    
212    (defun src-files (names src-dir)
213      (mapcar (lambda (name)
214                (make-pathname :name (string-downcase name) :type "lisp"
215                               :defaults src-dir))
216              names))
217    
218    (defvar *swank-files*
219      `(swank-backend ,@*sysdep-files* swank-match swank-rpc swank))
220    
221    (defvar *contribs*
222      '(swank-util swank-repl
223        swank-c-p-c swank-arglists swank-fuzzy
224        swank-fancy-inspector
225        swank-presentations swank-presentation-streams
226        #+(or asdf sbcl ecl) swank-asdf
227        swank-package-fu
228        swank-hyperdoc
229        #+sbcl swank-sbcl-exts
230        swank-mrepl
231        )
232      "List of names for contrib modules.")
233    
234    (defun append-dir (absolute name)
235      (merge-pathnames
236       (make-pathname :directory `(:relative ,name) :defaults absolute)
237       absolute))
238    
239    (defun contrib-dir (base-dir)
240      (append-dir base-dir "contrib"))
241    
242    (defun load-swank (&key (src-dir *source-directory*)
243                         (fasl-dir *fasl-directory*)
244                         quiet)
245      (compile-files (src-files *swank-files* src-dir) fasl-dir t quiet)
246      (funcall (q "swank::before-init")
247               (slime-version-string)
248               (list (contrib-dir fasl-dir)
249                     (contrib-dir src-dir))))
250    
251    (defun delete-stale-contrib-fasl-files (swank-files contrib-files fasl-dir)
252      (let ((newest (reduce #'max (mapcar #'file-write-date swank-files))))
253        (dolist (src contrib-files)
254          (let ((fasl (binary-pathname src fasl-dir)))
255            (when (and (probe-file fasl)
256                       (<= (file-write-date fasl) newest))
257              (delete-file fasl))))))
258    
259    (defun compile-contribs (&key (src-dir (contrib-dir *source-directory*))
260                               (fasl-dir (contrib-dir *fasl-directory*))
261                               (swank-src-dir *source-directory*)
262                               load quiet)
263      (let* ((swank-src-files (src-files *swank-files* swank-src-dir))
264             (contrib-src-files (src-files *contribs* src-dir)))
265        (delete-stale-contrib-fasl-files swank-src-files contrib-src-files
266                                         fasl-dir)
267        (compile-files contrib-src-files fasl-dir load quiet)))
268    
269    (defun loadup ()
270      (load-swank)
271      (compile-contribs :load t))
272    
273    (defun setup ()
274      (load-site-init-file *source-directory*)
275      (load-user-init-file)
276      (when (#-clisp probe-file
277             #+clisp ext:probe-directory
278             (contrib-dir *source-directory*))
279        (eval `(pushnew 'compile-contribs ,(q "swank::*after-init-hook*"))))
280      (funcall (q "swank::init")))
281    
282    (defun init (&key delete reload load-contribs (setup t)
283                   (quiet (not *load-verbose*)))
284      "Load SWANK and initialize some global variables.
285    If DELETE is true, delete any existing SWANK packages.
286    If RELOAD is true, reload SWANK, even if the SWANK package already exists.
287    If LOAD-CONTRIBS is true, load all contribs
288    If SETUP is true, load user init files and initialize some
289    global variabes in SWANK."
290      (when (and delete (find-package :swank))
291        (mapc #'delete-package '(:swank :swank-io-package :swank-backend)))
292      (cond ((or (not (find-package :swank)) reload)
293             (load-swank :quiet quiet))
294            (t
295             (warn "Not reloading SWANK.  Package already exists.")))
296      (when load-contribs
297        (compile-contribs :load t :quiet quiet))
298      (when setup
299        (setup)))
300    
301    (defun dump-image (filename)
302      (init :setup nil)
303      (funcall (q "swank-backend:save-image") filename))

Legend:
Removed from v.1.35  
changed lines
  Added in v.1.117

  ViewVC Help
Powered by ViewVC 1.1.5