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

Contents of /slime/swank-loader.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.117 - (hide 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 heller 1.81 ;;;; -*- indent-tabs-mode: nil -*-
2 jbielman 1.1 ;;;
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 heller 1.55 ;; If you want customize the source- or fasl-directory you can set
12     ;; swank-loader:*source-directory* resp. swank-loader:*fasl-directory*
13 heller 1.114 ;; before loading this files.
14 heller 1.55 ;; E.g.:
15     ;;
16     ;; (load ".../swank-loader.lisp")
17 heller 1.114 ;; (setq swank-loader::*fasl-directory* "/tmp/fasl/")
18     ;; (swank-loader:init)
19 heller 1.55
20 heller 1.11 (cl:defpackage :swank-loader
21 heller 1.54 (:use :cl)
22 heller 1.82 (:export :init
23 heller 1.87 :dump-image
24 heller 1.55 :*source-directory*
25     :*fasl-directory*))
26 heller 1.4
27 heller 1.52 (cl:in-package :swank-loader)
28 jbielman 1.1
29 heller 1.62 (defvar *source-directory*
30     (make-pathname :name nil :type nil
31 heller 1.57 :defaults (or *load-pathname* *default-pathname-defaults*))
32 heller 1.56 "The directory where to look for the source.")
33    
34 heller 1.83 (defparameter *sysdep-files*
35 heller 1.82 #+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 heller 1.91 #+clozure '(metering swank-ccl swank-gray)
40 heller 1.82 #+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 trittweiler 1.99 #+ecl '(swank-source-path-parser swank-source-file-cache
46     swank-ecl swank-gray))
47 jbielman 1.1
48 pseibel 1.39 (defparameter *implementation-features*
49 heller 1.91 '(:allegro :lispworks :sbcl :clozure :cmu :clisp :ccl :corman :cormanlisp
50 dcrosher 1.53 :armedbear :gcl :ecl :scl))
51 pseibel 1.39
52     (defparameter *os-features*
53 dcrosher 1.53 '(:macosx :linux :windows :mswindows :win32 :solaris :darwin :sunos :hpux
54     :unix))
55 pseibel 1.39
56     (defparameter *architecture-features*
57 heller 1.106 '(:powerpc :ppc :x86 :x86-64 :x86_64 :amd64 :i686 :i586 :i486 :pc386 :iapx386
58 sboukarev 1.109 :sparc64 :sparc :hppa64 :hppa :arm
59 mevenson 1.105 :pentium3 :pentium4
60     :java-1.4 :java-1.5 :java-1.6 :java-1.7))
61 pseibel 1.39
62 sboukarev 1.103 (defun q (s) (read-from-string s))
63    
64 trittweiler 1.101 #+ecl
65     (defun ecl-version-string ()
66 sboukarev 1.103 (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 trittweiler 1.101
73 heller 1.45 (defun lisp-version-string ()
74 heller 1.91 #+(or clozure cmu) (substitute-if #\_ (lambda (x) (find x " /"))
75     (lisp-implementation-version))
76 sboukarev 1.115 #+(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 heller 1.45 #+lispworks (lisp-implementation-version)
82 sboukarev 1.116 #+allegro (format nil "~@{~a~}"
83 mkoeppe 1.61 excl::*common-lisp-version-number*
84     (if (eq 'h 'H) "A" "M") ; ANSI vs MoDeRn
85 sboukarev 1.116 (if (member :smp *features*) "s" "")
86 heller 1.92 (if (member :64bit *features*) "-64bit" "")
87     (excl:ics-target-case
88     (:-ics "")
89     (:+ics "-ics")))
90 heller 1.45 #+clisp (let ((s (lisp-implementation-version)))
91     (subseq s 0 (position #\space s)))
92 trittweiler 1.101 #+armedbear (lisp-implementation-version)
93     #+ecl (ecl-version-string) )
94 heller 1.62
95 heller 1.78 (defun unique-dir-name ()
96 pseibel 1.39 "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 heller 1.45 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 heller 1.62 "No implementation feature found in ~a."
108 heller 1.45 *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 heller 1.17
119 jbielman 1.1 (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 heller 1.56 (defun slime-version-string ()
124     "Return a string identifying the SLIME version.
125     Return nil if nothing appropriate is available."
126 heller 1.63 (with-open-file (s (merge-pathnames "ChangeLog" *source-directory*)
127     :if-does-not-exist nil)
128     (and s (symbol-name (read s)))))
129 heller 1.56
130 heller 1.78 (defun default-fasl-dir ()
131 heller 1.110 (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 heller 1.54
138 trittweiler 1.100 (defvar *fasl-directory* (default-fasl-dir)
139     "The directory where fasl files should be placed.")
140    
141 heller 1.78 (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 heller 1.54 (merge-pathnames (make-pathname :name (pathname-name cfp)
145     :type (pathname-type cfp))
146 heller 1.78 binary-dir)))
147 heller 1.54
148 trittweiler 1.100 (defun handle-swank-load-error (condition context pathname)
149     (fresh-line *error-output*)
150 heller 1.64 (pprint-logical-block (*error-output* () :per-line-prefix ";; ")
151     (format *error-output*
152 trittweiler 1.100 "~%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 heller 1.62 (abort))
158    
159 heller 1.117 (defun compile-files (files fasl-dir load quiet)
160 heller 1.79 "Compile each file in FILES if the source is newer than its
161 heller 1.80 corresponding binary, or the file preceding it was recompiled.
162     If LOAD is true, load the fasl file."
163 trittweiler 1.100 (let ((needs-recompile nil)
164     (state :unknown))
165 heller 1.78 (dolist (src files)
166     (let ((dest (binary-pathname src fasl-dir)))
167 heller 1.64 (handler-case
168     (progn
169     (when (or needs-recompile
170 heller 1.78 (not (probe-file dest))
171     (file-newer-p src dest))
172 trittweiler 1.100 (ensure-directories-exist dest)
173     ;; need to recompile SRC, so we'll need to recompile
174     ;; everything after this too.
175 heller 1.64 (setq needs-recompile t)
176 trittweiler 1.100 (setq state :compile)
177 heller 1.117 (or (compile-file src :output-file dest :print nil
178     :verbose (not quiet))
179 trittweiler 1.100 ;; An implementation may not necessarily signal a
180     ;; condition itself when COMPILE-FILE fails (e.g. ECL)
181     (error "COMPILE-FILE returned NIL.")))
182 heller 1.66 (when load
183 trittweiler 1.100 (setq state :load)
184 heller 1.117 (load dest :verbose (not quiet))))
185 heller 1.64 ;; Fail as early as possible
186     (serious-condition (c)
187 trittweiler 1.100 (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 jbielman 1.1
192 trittweiler 1.99 #+(or cormanlisp)
193 heller 1.117 (defun compile-files (files fasl-dir load quiet)
194 trittweiler 1.99 "Corman Lisp has trouble with compiled files."
195 heller 1.78 (declare (ignore fasl-dir))
196 trittweiler 1.74 (when load
197     (dolist (file files)
198 heller 1.117 (load file :verbose (not quiet)
199     (force-output)))))
200 ewiborg 1.49
201 mbaringer 1.38 (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 heller 1.78 (defun load-site-init-file (dir)
208 mbaringer 1.38 (load (make-pathname :name "site-init" :type "lisp"
209 heller 1.78 :defaults dir)
210 mbaringer 1.38 :if-does-not-exist nil))
211    
212 heller 1.78 (defun src-files (names src-dir)
213 heller 1.54 (mapcar (lambda (name)
214 heller 1.66 (make-pathname :name (string-downcase name) :type "lisp"
215     :defaults src-dir))
216     names))
217    
218 trittweiler 1.99 (defvar *swank-files*
219     `(swank-backend ,@*sysdep-files* swank-match swank-rpc swank))
220 heller 1.55
221 trittweiler 1.99 (defvar *contribs*
222 heller 1.113 '(swank-util swank-repl
223 heller 1.111 swank-c-p-c swank-arglists swank-fuzzy
224 trittweiler 1.99 swank-fancy-inspector
225     swank-presentations swank-presentation-streams
226     #+(or asdf sbcl ecl) swank-asdf
227     swank-package-fu
228     swank-hyperdoc
229 heller 1.104 #+sbcl swank-sbcl-exts
230 heller 1.112 swank-mrepl
231 trittweiler 1.99 )
232 heller 1.66 "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 heller 1.78 (defun contrib-dir (base-dir)
240     (append-dir base-dir "contrib"))
241 heller 1.66
242 heller 1.78 (defun load-swank (&key (src-dir *source-directory*)
243 heller 1.117 (fasl-dir *fasl-directory*)
244     quiet)
245     (compile-files (src-files *swank-files* src-dir) fasl-dir t quiet)
246 heller 1.84 (funcall (q "swank::before-init")
247     (slime-version-string)
248     (list (contrib-dir fasl-dir)
249     (contrib-dir src-dir))))
250 heller 1.78
251 heller 1.114 (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 heller 1.78 (defun compile-contribs (&key (src-dir (contrib-dir *source-directory*))
260 heller 1.114 (fasl-dir (contrib-dir *fasl-directory*))
261     (swank-src-dir *source-directory*)
262 heller 1.117 load quiet)
263 heller 1.114 (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 heller 1.117 (compile-files contrib-src-files fasl-dir load quiet)))
268 heller 1.114
269 heller 1.82 (defun loadup ()
270     (load-swank)
271     (compile-contribs :load t))
272 heller 1.78
273     (defun setup ()
274 heller 1.84 (load-site-init-file *source-directory*)
275     (load-user-init-file)
276 sboukarev 1.94 (when (#-clisp probe-file
277     #+clisp ext:probe-directory
278     (contrib-dir *source-directory*))
279 heller 1.93 (eval `(pushnew 'compile-contribs ,(q "swank::*after-init-hook*"))))
280 heller 1.84 (funcall (q "swank::init")))
281 heller 1.78
282 heller 1.117 (defun init (&key delete reload load-contribs (setup t)
283     (quiet (not *load-verbose*)))
284 heller 1.90 "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 heller 1.78 (when (and delete (find-package :swank))
291     (mapc #'delete-package '(:swank :swank-io-package :swank-backend)))
292 heller 1.81 (cond ((or (not (find-package :swank)) reload)
293 heller 1.117 (load-swank :quiet quiet))
294     (t
295 heller 1.81 (warn "Not reloading SWANK. Package already exists.")))
296 heller 1.82 (when load-contribs
297 heller 1.117 (compile-contribs :load t :quiet quiet))
298 heller 1.82 (when setup
299     (setup)))
300 heller 1.88
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