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

Contents of /slime/swank-loader.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.117 - (show annotations)
Sat Jan 5 08:50:12 2013 UTC (15 months, 1 week ago) by heller
Branch: MAIN
CVS Tags: HEAD
Changes since 1.116: +17 -14 lines
* swank-loader.lisp (init): Add a :quiet argument.
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.
14 ;; E.g.:
15 ;;
16 ;; (load ".../swank-loader.lisp")
17 ;; (setq swank-loader::*fasl-directory* "/tmp/fasl/")
18 ;; (swank-loader:init)
19
20 (cl:defpackage :swank-loader
21 (:use :cl)
22 (:export :init
23 :dump-image
24 :*source-directory*
25 :*fasl-directory*))
26
27 (cl:in-package :swank-loader)
28
29 (defvar *source-directory*
30 (make-pathname :name nil :type nil
31 :defaults (or *load-pathname* *default-pathname-defaults*))
32 "The directory where to look for the source.")
33
34 (defparameter *sysdep-files*
35 #+cmu '(swank-source-path-parser swank-source-file-cache swank-cmucl)
36 #+scl '(swank-source-path-parser swank-source-file-cache swank-scl)
37 #+sbcl '(swank-source-path-parser swank-source-file-cache
38 swank-sbcl swank-gray)
39 #+clozure '(metering swank-ccl swank-gray)
40 #+lispworks '(swank-lispworks swank-gray)
41 #+allegro '(swank-allegro swank-gray)
42 #+clisp '(xref metering swank-clisp swank-gray)
43 #+armedbear '(swank-abcl)
44 #+cormanlisp '(swank-corman swank-gray)
45 #+ecl '(swank-source-path-parser swank-source-file-cache
46 swank-ecl swank-gray))
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 '(: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)
120 "Returns true if NEW-FILE is newer than OLD-FILE."
121 (> (file-write-date new-file) (file-write-date old-file)))
122
123 (defun slime-version-string ()
124 "Return a string identifying the SLIME version.
125 Return nil if nothing appropriate is available."
126 (with-open-file (s (merge-pathnames "ChangeLog" *source-directory*)
127 :if-does-not-exist nil)
128 (and s (symbol-name (read s)))))
129
130 (defun default-fasl-dir ()
131 (merge-pathnames
132 (make-pathname
133 :directory `(:relative ".slime" "fasl"
134 ,@(if (slime-version-string) (list (slime-version-string)))
135 ,(unique-dir-name)))
136 (user-homedir-pathname)))
137
138 (defvar *fasl-directory* (default-fasl-dir)
139 "The directory where fasl files should be placed.")
140
141 (defun binary-pathname (src-pathname binary-dir)
142 "Return the pathname where SRC-PATHNAME's binary should be compiled."
143 (let ((cfp (compile-file-pathname src-pathname)))
144 (merge-pathnames (make-pathname :name (pathname-name cfp)
145 :type (pathname-type cfp))
146 binary-dir)))
147
148 (defun handle-swank-load-error (condition context pathname)
149 (fresh-line *error-output*)
150 (pprint-logical-block (*error-output* () :per-line-prefix ";; ")
151 (format *error-output*
152 "~%Error while ~A ~A:~% ~A~%Aborting.~%"
153 context pathname condition))
154 (when (equal (directory-namestring pathname)
155 (directory-namestring *fasl-directory*))
156 (ignore-errors (delete-file pathname)))
157 (abort))
158
159 (defun compile-files (files fasl-dir load quiet)
160 "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 (let ((needs-recompile nil)
164 (state :unknown))
165 (dolist (src files)
166 (let ((dest (binary-pathname src fasl-dir)))
167 (handler-case
168 (progn
169 (when (or needs-recompile
170 (not (probe-file dest))
171 (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))

  ViewVC Help
Powered by ViewVC 1.1.5