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

Contents of /slime/swank-loader.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.101 - (hide annotations)
Thu Feb 25 16:35:23 2010 UTC (4 years, 1 month ago) by trittweiler
Branch: MAIN
Changes since 1.100: +12 -2 lines
	* swank-loader.lisp (lisp-version-string): Add git-commit ids for
	ECL because individual commits do not guarantee fasl
	compatibility.
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     ;; before loading this files. (you also need to create the
14     ;; swank-loader package.)
15     ;; E.g.:
16     ;;
17 heller 1.57 ;; (make-package :swank-loader)
18 heller 1.55 ;; (defparameter swank-loader::*fasl-directory* "/tmp/fasl/")
19     ;; (load ".../swank-loader.lisp")
20    
21 heller 1.11 (cl:defpackage :swank-loader
22 heller 1.54 (:use :cl)
23 heller 1.82 (:export :init
24 heller 1.87 :dump-image
25 heller 1.55 :*source-directory*
26     :*fasl-directory*))
27 heller 1.4
28 heller 1.52 (cl:in-package :swank-loader)
29 jbielman 1.1
30 heller 1.62 (defvar *source-directory*
31     (make-pathname :name nil :type nil
32 heller 1.57 :defaults (or *load-pathname* *default-pathname-defaults*))
33 heller 1.56 "The directory where to look for the source.")
34    
35 heller 1.83 (defparameter *sysdep-files*
36 heller 1.82 #+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 heller 1.91 #+clozure '(metering swank-ccl swank-gray)
41 heller 1.82 #+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 trittweiler 1.99 #+ecl '(swank-source-path-parser swank-source-file-cache
47     swank-ecl swank-gray))
48 jbielman 1.1
49 pseibel 1.39 (defparameter *implementation-features*
50 heller 1.91 '(:allegro :lispworks :sbcl :clozure :cmu :clisp :ccl :corman :cormanlisp
51 dcrosher 1.53 :armedbear :gcl :ecl :scl))
52 pseibel 1.39
53     (defparameter *os-features*
54 dcrosher 1.53 '(:macosx :linux :windows :mswindows :win32 :solaris :darwin :sunos :hpux
55     :unix))
56 pseibel 1.39
57     (defparameter *architecture-features*
58 dcrosher 1.53 '(:powerpc :ppc :x86 :x86-64 :amd64 :i686 :i586 :i486 :pc386 :iapx386
59 trittweiler 1.100 :sparc64 :sparc :hppa64 :hppa
60     :pentium3 :pentium4))
61 pseibel 1.39
62 trittweiler 1.101 #+ecl
63     (defun ecl-version-string ()
64     #+#.(cl:if (cl:find-symbol "LISP-IMPLEMENTATION-VCS-ID" :ext) '(:and) '(:or))
65     (format nil "~A-~A"
66     (lisp-implementation-version)
67     (subseq (ext:lisp-implementation-vcs-id) 0 8))
68     #-#.(cl:if (cl:find-symbol "LISP-IMPLEMENTATION-VCS-ID" :ext) '(:and) '(:or))
69     (lisp-implementation-version))
70    
71 heller 1.45 (defun lisp-version-string ()
72 heller 1.91 #+(or clozure cmu) (substitute-if #\_ (lambda (x) (find x " /"))
73     (lisp-implementation-version))
74 trittweiler 1.101 #+(or cormanlisp scl sbcl) (lisp-implementation-version)
75 heller 1.45 #+lispworks (lisp-implementation-version)
76 heller 1.92 #+allegro (format nil "~A~A~A~A"
77 mkoeppe 1.61 excl::*common-lisp-version-number*
78     (if (eq 'h 'H) "A" "M") ; ANSI vs MoDeRn
79 heller 1.92 (if (member :64bit *features*) "-64bit" "")
80     (excl:ics-target-case
81     (:-ics "")
82     (:+ics "-ics")))
83 heller 1.45 #+clisp (let ((s (lisp-implementation-version)))
84     (subseq s 0 (position #\space s)))
85 trittweiler 1.101 #+armedbear (lisp-implementation-version)
86     #+ecl (ecl-version-string) )
87 heller 1.62
88 heller 1.78 (defun unique-dir-name ()
89 pseibel 1.39 "Return a name that can be used as a directory name that is
90     unique to a Lisp implementation, Lisp implementation version,
91     operating system, and hardware architecture."
92     (flet ((first-of (features)
93     (loop for f in features
94 heller 1.45 when (find f *features*) return it))
95     (maybe-warn (value fstring &rest args)
96     (cond (value)
97     (t (apply #'warn fstring args)
98     "unknown"))))
99     (let ((lisp (maybe-warn (first-of *implementation-features*)
100 heller 1.62 "No implementation feature found in ~a."
101 heller 1.45 *implementation-features*))
102     (os (maybe-warn (first-of *os-features*)
103     "No os feature found in ~a." *os-features*))
104     (arch (maybe-warn (first-of *architecture-features*)
105     "No architecture feature found in ~a."
106     *architecture-features*))
107     (version (maybe-warn (lisp-version-string)
108     "Don't know how to get Lisp ~
109     implementation version.")))
110     (format nil "~(~@{~a~^-~}~)" lisp version os arch))))
111 heller 1.17
112 jbielman 1.1 (defun file-newer-p (new-file old-file)
113     "Returns true if NEW-FILE is newer than OLD-FILE."
114     (> (file-write-date new-file) (file-write-date old-file)))
115    
116 heller 1.56 (defun slime-version-string ()
117     "Return a string identifying the SLIME version.
118     Return nil if nothing appropriate is available."
119 heller 1.63 (with-open-file (s (merge-pathnames "ChangeLog" *source-directory*)
120     :if-does-not-exist nil)
121     (and s (symbol-name (read s)))))
122 heller 1.56
123 heller 1.78 (defun default-fasl-dir ()
124 heller 1.57 (merge-pathnames
125 heller 1.62 (make-pathname
126     :directory `(:relative ".slime" "fasl"
127 heller 1.57 ,@(if (slime-version-string) (list (slime-version-string)))
128 heller 1.78 ,(unique-dir-name)))
129 heller 1.57 (user-homedir-pathname)))
130 heller 1.54
131 trittweiler 1.100 (defvar *fasl-directory* (default-fasl-dir)
132     "The directory where fasl files should be placed.")
133    
134 heller 1.78 (defun binary-pathname (src-pathname binary-dir)
135     "Return the pathname where SRC-PATHNAME's binary should be compiled."
136     (let ((cfp (compile-file-pathname src-pathname)))
137 heller 1.54 (merge-pathnames (make-pathname :name (pathname-name cfp)
138     :type (pathname-type cfp))
139 heller 1.78 binary-dir)))
140 heller 1.54
141 trittweiler 1.100 (defun handle-swank-load-error (condition context pathname)
142     (fresh-line *error-output*)
143 heller 1.64 (pprint-logical-block (*error-output* () :per-line-prefix ";; ")
144     (format *error-output*
145 trittweiler 1.100 "~%Error while ~A ~A:~% ~A~%Aborting.~%"
146     context pathname condition))
147     (when (equal (directory-namestring pathname)
148     (directory-namestring *fasl-directory*))
149     (ignore-errors (delete-file pathname)))
150 heller 1.62 (abort))
151    
152 heller 1.78 (defun compile-files (files fasl-dir load)
153 heller 1.79 "Compile each file in FILES if the source is newer than its
154 heller 1.80 corresponding binary, or the file preceding it was recompiled.
155     If LOAD is true, load the fasl file."
156 trittweiler 1.100 (let ((needs-recompile nil)
157     (state :unknown))
158 heller 1.78 (dolist (src files)
159     (let ((dest (binary-pathname src fasl-dir)))
160 heller 1.64 (handler-case
161     (progn
162     (when (or needs-recompile
163 heller 1.78 (not (probe-file dest))
164     (file-newer-p src dest))
165 trittweiler 1.100 (ensure-directories-exist dest)
166     ;; need to recompile SRC, so we'll need to recompile
167     ;; everything after this too.
168 heller 1.64 (setq needs-recompile t)
169 trittweiler 1.100 (setq state :compile)
170     (or (compile-file src :output-file dest :print nil :verbose t)
171     ;; An implementation may not necessarily signal a
172     ;; condition itself when COMPILE-FILE fails (e.g. ECL)
173     (error "COMPILE-FILE returned NIL.")))
174 heller 1.66 (when load
175 trittweiler 1.100 (setq state :load)
176 heller 1.78 (load dest :verbose t)))
177 heller 1.64 ;; Fail as early as possible
178     (serious-condition (c)
179 trittweiler 1.100 (ecase state
180     (:compile (handle-swank-load-error c "compiling" src))
181     (:load (handle-swank-load-error c "loading" dest))
182     (:unknown (handle-swank-load-error c "???ing" src)))))))))
183 jbielman 1.1
184 trittweiler 1.99 #+(or cormanlisp)
185 heller 1.78 (defun compile-files (files fasl-dir load)
186 trittweiler 1.99 "Corman Lisp has trouble with compiled files."
187 heller 1.78 (declare (ignore fasl-dir))
188 trittweiler 1.74 (when load
189     (dolist (file files)
190     (load file :verbose t)
191     (force-output))))
192 ewiborg 1.49
193 mbaringer 1.38 (defun load-user-init-file ()
194     "Load the user init file, return NIL if it does not exist."
195     (load (merge-pathnames (user-homedir-pathname)
196     (make-pathname :name ".swank" :type "lisp"))
197     :if-does-not-exist nil))
198    
199 heller 1.78 (defun load-site-init-file (dir)
200 mbaringer 1.38 (load (make-pathname :name "site-init" :type "lisp"
201 heller 1.78 :defaults dir)
202 mbaringer 1.38 :if-does-not-exist nil))
203    
204 heller 1.78 (defun src-files (names src-dir)
205 heller 1.54 (mapcar (lambda (name)
206 heller 1.66 (make-pathname :name (string-downcase name) :type "lisp"
207     :defaults src-dir))
208     names))
209    
210 trittweiler 1.99 (defvar *swank-files*
211     `(swank-backend ,@*sysdep-files* swank-match swank-rpc swank))
212 heller 1.55
213 trittweiler 1.99 (defvar *contribs*
214     '(swank-c-p-c swank-arglists swank-fuzzy
215     swank-fancy-inspector
216     swank-presentations swank-presentation-streams
217     #+(or asdf sbcl ecl) swank-asdf
218     swank-package-fu
219     swank-hyperdoc
220     swank-sbcl-exts
221     )
222 heller 1.66 "List of names for contrib modules.")
223    
224     (defun append-dir (absolute name)
225     (merge-pathnames
226     (make-pathname :directory `(:relative ,name) :defaults absolute)
227     absolute))
228    
229 heller 1.78 (defun contrib-dir (base-dir)
230     (append-dir base-dir "contrib"))
231 heller 1.66
232 heller 1.84 (defun q (s) (read-from-string s))
233    
234 heller 1.78 (defun load-swank (&key (src-dir *source-directory*)
235 trittweiler 1.100 (fasl-dir *fasl-directory*))
236 heller 1.84 (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 heller 1.78
242     (defun compile-contribs (&key (src-dir (contrib-dir *source-directory*))
243 heller 1.82 (fasl-dir (contrib-dir *fasl-directory*))
244     load)
245     (compile-files (src-files *contribs* src-dir) fasl-dir load))
246 heller 1.84
247 heller 1.82 (defun loadup ()
248     (load-swank)
249     (compile-contribs :load t))
250 heller 1.78
251     (defun setup ()
252 heller 1.84 (load-site-init-file *source-directory*)
253     (load-user-init-file)
254 sboukarev 1.94 (when (#-clisp probe-file
255     #+clisp ext:probe-directory
256     (contrib-dir *source-directory*))
257 heller 1.93 (eval `(pushnew 'compile-contribs ,(q "swank::*after-init-hook*"))))
258 heller 1.84 (funcall (q "swank::init")))
259 heller 1.78
260 heller 1.82 (defun init (&key delete reload load-contribs (setup t))
261 heller 1.90 "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 heller 1.78 (when (and delete (find-package :swank))
268     (mapc #'delete-package '(:swank :swank-io-package :swank-backend)))
269 heller 1.81 (cond ((or (not (find-package :swank)) reload)
270     (load-swank))
271     (t
272     (warn "Not reloading SWANK. Package already exists.")))
273 heller 1.82 (when load-contribs
274     (compile-contribs :load t))
275     (when setup
276     (setup)))
277 heller 1.88
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