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

Contents of /slime/swank-loader.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5