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

Contents of /slime/swank-loader.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5