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

Contents of /slime/swank-loader.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.103 - (show annotations)
Fri Feb 26 21:02:59 2010 UTC (4 years, 1 month ago) by sboukarev
Branch: MAIN
Changes since 1.102: +8 -12 lines
* swank-loader.lisp (ecl-version-string): Check length of
the result of ext:lisp-implementation-vcs-id before doing subseq.
On CVS it returns "unknown".
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 :amd64 :i686 :i586 :i486 :pc386 :iapx386
59 :sparc64 :sparc :hppa64 :hppa
60 :pentium3 :pentium4))
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 sbcl) (lisp-implementation-version)
77 #+lispworks (lisp-implementation-version)
78 #+allegro (format nil "~A~A~A~A"
79 excl::*common-lisp-version-number*
80 (if (eq 'h 'H) "A" "M") ; ANSI vs MoDeRn
81 (if (member :64bit *features*) "-64bit" "")
82 (excl:ics-target-case
83 (:-ics "")
84 (:+ics "-ics")))
85 #+clisp (let ((s (lisp-implementation-version)))
86 (subseq s 0 (position #\space s)))
87 #+armedbear (lisp-implementation-version)
88 #+ecl (ecl-version-string) )
89
90 (defun unique-dir-name ()
91 "Return a name that can be used as a directory name that is
92 unique to a Lisp implementation, Lisp implementation version,
93 operating system, and hardware architecture."
94 (flet ((first-of (features)
95 (loop for f in features
96 when (find f *features*) return it))
97 (maybe-warn (value fstring &rest args)
98 (cond (value)
99 (t (apply #'warn fstring args)
100 "unknown"))))
101 (let ((lisp (maybe-warn (first-of *implementation-features*)
102 "No implementation feature found in ~a."
103 *implementation-features*))
104 (os (maybe-warn (first-of *os-features*)
105 "No os feature found in ~a." *os-features*))
106 (arch (maybe-warn (first-of *architecture-features*)
107 "No architecture feature found in ~a."
108 *architecture-features*))
109 (version (maybe-warn (lisp-version-string)
110 "Don't know how to get Lisp ~
111 implementation version.")))
112 (format nil "~(~@{~a~^-~}~)" lisp version os arch))))
113
114 (defun file-newer-p (new-file old-file)
115 "Returns true if NEW-FILE is newer than OLD-FILE."
116 (> (file-write-date new-file) (file-write-date old-file)))
117
118 (defun slime-version-string ()
119 "Return a string identifying the SLIME version.
120 Return nil if nothing appropriate is available."
121 (with-open-file (s (merge-pathnames "ChangeLog" *source-directory*)
122 :if-does-not-exist nil)
123 (and s (symbol-name (read s)))))
124
125 (defun default-fasl-dir ()
126 (merge-pathnames
127 (make-pathname
128 :directory `(:relative ".slime" "fasl"
129 ,@(if (slime-version-string) (list (slime-version-string)))
130 ,(unique-dir-name)))
131 (user-homedir-pathname)))
132
133 (defvar *fasl-directory* (default-fasl-dir)
134 "The directory where fasl files should be placed.")
135
136 (defun binary-pathname (src-pathname binary-dir)
137 "Return the pathname where SRC-PATHNAME's binary should be compiled."
138 (let ((cfp (compile-file-pathname src-pathname)))
139 (merge-pathnames (make-pathname :name (pathname-name cfp)
140 :type (pathname-type cfp))
141 binary-dir)))
142
143 (defun handle-swank-load-error (condition context pathname)
144 (fresh-line *error-output*)
145 (pprint-logical-block (*error-output* () :per-line-prefix ";; ")
146 (format *error-output*
147 "~%Error while ~A ~A:~% ~A~%Aborting.~%"
148 context pathname condition))
149 (when (equal (directory-namestring pathname)
150 (directory-namestring *fasl-directory*))
151 (ignore-errors (delete-file pathname)))
152 (abort))
153
154 (defun compile-files (files fasl-dir load)
155 "Compile each file in FILES if the source is newer than its
156 corresponding binary, or the file preceding it was recompiled.
157 If LOAD is true, load the fasl file."
158 (let ((needs-recompile nil)
159 (state :unknown))
160 (dolist (src files)
161 (let ((dest (binary-pathname src fasl-dir)))
162 (handler-case
163 (progn
164 (when (or needs-recompile
165 (not (probe-file dest))
166 (file-newer-p src dest))
167 (ensure-directories-exist dest)
168 ;; need to recompile SRC, so we'll need to recompile
169 ;; everything after this too.
170 (setq needs-recompile t)
171 (setq state :compile)
172 (or (compile-file src :output-file dest :print nil :verbose t)
173 ;; An implementation may not necessarily signal a
174 ;; condition itself when COMPILE-FILE fails (e.g. ECL)
175 (error "COMPILE-FILE returned NIL.")))
176 (when load
177 (setq state :load)
178 (load dest :verbose t)))
179 ;; Fail as early as possible
180 (serious-condition (c)
181 (ecase state
182 (:compile (handle-swank-load-error c "compiling" src))
183 (:load (handle-swank-load-error c "loading" dest))
184 (:unknown (handle-swank-load-error c "???ing" src)))))))))
185
186 #+(or cormanlisp)
187 (defun compile-files (files fasl-dir load)
188 "Corman Lisp has trouble with compiled files."
189 (declare (ignore fasl-dir))
190 (when load
191 (dolist (file files)
192 (load file :verbose t)
193 (force-output))))
194
195 (defun load-user-init-file ()
196 "Load the user init file, return NIL if it does not exist."
197 (load (merge-pathnames (user-homedir-pathname)
198 (make-pathname :name ".swank" :type "lisp"))
199 :if-does-not-exist nil))
200
201 (defun load-site-init-file (dir)
202 (load (make-pathname :name "site-init" :type "lisp"
203 :defaults dir)
204 :if-does-not-exist nil))
205
206 (defun src-files (names src-dir)
207 (mapcar (lambda (name)
208 (make-pathname :name (string-downcase name) :type "lisp"
209 :defaults src-dir))
210 names))
211
212 (defvar *swank-files*
213 `(swank-backend ,@*sysdep-files* swank-match swank-rpc swank))
214
215 (defvar *contribs*
216 '(swank-c-p-c swank-arglists swank-fuzzy
217 swank-fancy-inspector
218 swank-presentations swank-presentation-streams
219 #+(or asdf sbcl ecl) swank-asdf
220 swank-package-fu
221 swank-hyperdoc
222 swank-sbcl-exts
223 )
224 "List of names for contrib modules.")
225
226 (defun append-dir (absolute name)
227 (merge-pathnames
228 (make-pathname :directory `(:relative ,name) :defaults absolute)
229 absolute))
230
231 (defun contrib-dir (base-dir)
232 (append-dir base-dir "contrib"))
233
234 (defun load-swank (&key (src-dir *source-directory*)
235 (fasl-dir *fasl-directory*))
236 (compile-files (src-files *swank-files* src-dir) fasl-dir t)
237 (funcall (q "swank::before-init")
238 (slime-version-string)
239 (list (contrib-dir fasl-dir)
240 (contrib-dir src-dir))))
241
242 (defun compile-contribs (&key (src-dir (contrib-dir *source-directory*))
243 (fasl-dir (contrib-dir *fasl-directory*))
244 load)
245 (compile-files (src-files *contribs* src-dir) fasl-dir load))
246
247 (defun loadup ()
248 (load-swank)
249 (compile-contribs :load t))
250
251 (defun setup ()
252 (load-site-init-file *source-directory*)
253 (load-user-init-file)
254 (when (#-clisp probe-file
255 #+clisp ext:probe-directory
256 (contrib-dir *source-directory*))
257 (eval `(pushnew 'compile-contribs ,(q "swank::*after-init-hook*"))))
258 (funcall (q "swank::init")))
259
260 (defun init (&key delete reload load-contribs (setup t))
261 "Load SWANK and initialize some global variables.
262 If DELETE is true, delete any existing SWANK packages.
263 If RELOAD is true, reload SWANK, even if the SWANK package already exists.
264 If LOAD-CONTRIBS is true, load all contribs
265 If SETUP is true, load user init files and initialize some
266 global variabes in SWANK."
267 (when (and delete (find-package :swank))
268 (mapc #'delete-package '(:swank :swank-io-package :swank-backend)))
269 (cond ((or (not (find-package :swank)) reload)
270 (load-swank))
271 (t
272 (warn "Not reloading SWANK. Package already exists.")))
273 (when load-contribs
274 (compile-contribs :load t))
275 (when setup
276 (setup)))
277
278 (defun dump-image (filename)
279 (init :setup nil)
280 (funcall (q "swank-backend:save-image") filename))

  ViewVC Help
Powered by ViewVC 1.1.5