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

Contents of /slime/swank-loader.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5