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

Contents of /slime/swank-loader.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.102 - (hide 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 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 sboukarev 1.102 #+#.(cl:if (cl:and
65     (cl:find-package :ext)
66     (cl:find-symbol "LISP-IMPLEMENTATION-VCS-ID" :ext)) '(:and) '(:or))
67 trittweiler 1.101 (format nil "~A-~A"
68     (lisp-implementation-version)
69     (subseq (ext:lisp-implementation-vcs-id) 0 8))
70 sboukarev 1.102 #-#.(cl:if (cl:and
71     (cl:find-package :ext)
72     (cl:find-symbol "LISP-IMPLEMENTATION-VCS-ID" :ext)) '(:and) '(:or))
73 trittweiler 1.101 (lisp-implementation-version))
74    
75 heller 1.45 (defun lisp-version-string ()
76 heller 1.91 #+(or clozure cmu) (substitute-if #\_ (lambda (x) (find x " /"))
77     (lisp-implementation-version))
78 trittweiler 1.101 #+(or cormanlisp scl sbcl) (lisp-implementation-version)
79 heller 1.45 #+lispworks (lisp-implementation-version)
80 heller 1.92 #+allegro (format nil "~A~A~A~A"
81 mkoeppe 1.61 excl::*common-lisp-version-number*
82     (if (eq 'h 'H) "A" "M") ; ANSI vs MoDeRn
83 heller 1.92 (if (member :64bit *features*) "-64bit" "")
84     (excl:ics-target-case
85     (:-ics "")
86     (:+ics "-ics")))
87 heller 1.45 #+clisp (let ((s (lisp-implementation-version)))
88     (subseq s 0 (position #\space s)))
89 trittweiler 1.101 #+armedbear (lisp-implementation-version)
90     #+ecl (ecl-version-string) )
91 heller 1.62
92 heller 1.78 (defun unique-dir-name ()
93 pseibel 1.39 "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 heller 1.45 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 heller 1.62 "No implementation feature found in ~a."
105 heller 1.45 *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 heller 1.17
116 jbielman 1.1 (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 heller 1.56 (defun slime-version-string ()
121     "Return a string identifying the SLIME version.
122     Return nil if nothing appropriate is available."
123 heller 1.63 (with-open-file (s (merge-pathnames "ChangeLog" *source-directory*)
124     :if-does-not-exist nil)
125     (and s (symbol-name (read s)))))
126 heller 1.56
127 heller 1.78 (defun default-fasl-dir ()
128 heller 1.57 (merge-pathnames
129 heller 1.62 (make-pathname
130     :directory `(:relative ".slime" "fasl"
131 heller 1.57 ,@(if (slime-version-string) (list (slime-version-string)))
132 heller 1.78 ,(unique-dir-name)))
133 heller 1.57 (user-homedir-pathname)))
134 heller 1.54
135 trittweiler 1.100 (defvar *fasl-directory* (default-fasl-dir)
136     "The directory where fasl files should be placed.")
137    
138 heller 1.78 (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 heller 1.54 (merge-pathnames (make-pathname :name (pathname-name cfp)
142     :type (pathname-type cfp))
143 heller 1.78 binary-dir)))
144 heller 1.54
145 trittweiler 1.100 (defun handle-swank-load-error (condition context pathname)
146     (fresh-line *error-output*)
147 heller 1.64 (pprint-logical-block (*error-output* () :per-line-prefix ";; ")
148     (format *error-output*
149 trittweiler 1.100 "~%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 heller 1.62 (abort))
155    
156 heller 1.78 (defun compile-files (files fasl-dir load)
157 heller 1.79 "Compile each file in FILES if the source is newer than its
158 heller 1.80 corresponding binary, or the file preceding it was recompiled.
159     If LOAD is true, load the fasl file."
160 trittweiler 1.100 (let ((needs-recompile nil)
161     (state :unknown))
162 heller 1.78 (dolist (src files)
163     (let ((dest (binary-pathname src fasl-dir)))
164 heller 1.64 (handler-case
165     (progn
166     (when (or needs-recompile
167 heller 1.78 (not (probe-file dest))
168     (file-newer-p src dest))
169 trittweiler 1.100 (ensure-directories-exist dest)
170     ;; need to recompile SRC, so we'll need to recompile
171     ;; everything after this too.
172 heller 1.64 (setq needs-recompile t)
173 trittweiler 1.100 (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 heller 1.66 (when load
179 trittweiler 1.100 (setq state :load)
180 heller 1.78 (load dest :verbose t)))
181 heller 1.64 ;; Fail as early as possible
182     (serious-condition (c)
183 trittweiler 1.100 (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 jbielman 1.1
188 trittweiler 1.99 #+(or cormanlisp)
189 heller 1.78 (defun compile-files (files fasl-dir load)
190 trittweiler 1.99 "Corman Lisp has trouble with compiled files."
191 heller 1.78 (declare (ignore fasl-dir))
192 trittweiler 1.74 (when load
193     (dolist (file files)
194     (load file :verbose t)
195     (force-output))))
196 ewiborg 1.49
197 mbaringer 1.38 (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 heller 1.78 (defun load-site-init-file (dir)
204 mbaringer 1.38 (load (make-pathname :name "site-init" :type "lisp"
205 heller 1.78 :defaults dir)
206 mbaringer 1.38 :if-does-not-exist nil))
207    
208 heller 1.78 (defun src-files (names src-dir)
209 heller 1.54 (mapcar (lambda (name)
210 heller 1.66 (make-pathname :name (string-downcase name) :type "lisp"
211     :defaults src-dir))
212     names))
213    
214 trittweiler 1.99 (defvar *swank-files*
215     `(swank-backend ,@*sysdep-files* swank-match swank-rpc swank))
216 heller 1.55
217 trittweiler 1.99 (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 heller 1.66 "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 heller 1.78 (defun contrib-dir (base-dir)
234     (append-dir base-dir "contrib"))
235 heller 1.66
236 heller 1.84 (defun q (s) (read-from-string s))
237    
238 heller 1.78 (defun load-swank (&key (src-dir *source-directory*)
239 trittweiler 1.100 (fasl-dir *fasl-directory*))
240 heller 1.84 (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 heller 1.78
246     (defun compile-contribs (&key (src-dir (contrib-dir *source-directory*))
247 heller 1.82 (fasl-dir (contrib-dir *fasl-directory*))
248     load)
249     (compile-files (src-files *contribs* src-dir) fasl-dir load))
250 heller 1.84
251 heller 1.82 (defun loadup ()
252     (load-swank)
253     (compile-contribs :load t))
254 heller 1.78
255     (defun setup ()
256 heller 1.84 (load-site-init-file *source-directory*)
257     (load-user-init-file)
258 sboukarev 1.94 (when (#-clisp probe-file
259     #+clisp ext:probe-directory
260     (contrib-dir *source-directory*))
261 heller 1.93 (eval `(pushnew 'compile-contribs ,(q "swank::*after-init-hook*"))))
262 heller 1.84 (funcall (q "swank::init")))
263 heller 1.78
264 heller 1.82 (defun init (&key delete reload load-contribs (setup t))
265 heller 1.90 "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 heller 1.78 (when (and delete (find-package :swank))
272     (mapc #'delete-package '(:swank :swank-io-package :swank-backend)))
273 heller 1.81 (cond ((or (not (find-package :swank)) reload)
274     (load-swank))
275     (t
276     (warn "Not reloading SWANK. Package already exists.")))
277 heller 1.82 (when load-contribs
278     (compile-contribs :load t))
279     (when setup
280     (setup)))
281 heller 1.88
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