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

Contents of /slime/swank-loader.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5