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

Contents of /slime/swank-loader.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.103 - (hide annotations)
Fri Feb 26 21:02:59 2010 UTC (4 years, 1 month ago) by sboukarev
Branch: MAIN
Changes since 1.102: +8 -12 lines
* swank-loader.lisp (ecl-version-string): Check length of
the result of ext:lisp-implementation-vcs-id before doing subseq.
On CVS it returns "unknown".
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 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 trittweiler 1.101 #+(or cormanlisp scl sbcl) (lisp-implementation-version)
77 heller 1.45 #+lispworks (lisp-implementation-version)
78 heller 1.92 #+allegro (format nil "~A~A~A~A"
79 mkoeppe 1.61 excl::*common-lisp-version-number*
80     (if (eq 'h 'H) "A" "M") ; ANSI vs MoDeRn
81 heller 1.92 (if (member :64bit *features*) "-64bit" "")
82     (excl:ics-target-case
83     (:-ics "")
84     (:+ics "-ics")))
85 heller 1.45 #+clisp (let ((s (lisp-implementation-version)))
86     (subseq s 0 (position #\space s)))
87 trittweiler 1.101 #+armedbear (lisp-implementation-version)
88     #+ecl (ecl-version-string) )
89 heller 1.62
90 heller 1.78 (defun unique-dir-name ()
91 pseibel 1.39 "Return a name that can be used as a directory name that is
92     unique to a Lisp implementation, Lisp implementation version,
93     operating system, and hardware architecture."
94     (flet ((first-of (features)
95     (loop for f in features
96 heller 1.45 when (find f *features*) return it))
97     (maybe-warn (value fstring &rest args)
98     (cond (value)
99     (t (apply #'warn fstring args)
100     "unknown"))))
101     (let ((lisp (maybe-warn (first-of *implementation-features*)
102 heller 1.62 "No implementation feature found in ~a."
103 heller 1.45 *implementation-features*))
104     (os (maybe-warn (first-of *os-features*)
105     "No os feature found in ~a." *os-features*))
106     (arch (maybe-warn (first-of *architecture-features*)
107     "No architecture feature found in ~a."
108     *architecture-features*))
109     (version (maybe-warn (lisp-version-string)
110     "Don't know how to get Lisp ~
111     implementation version.")))
112     (format nil "~(~@{~a~^-~}~)" lisp version os arch))))
113 heller 1.17
114 jbielman 1.1 (defun file-newer-p (new-file old-file)
115     "Returns true if NEW-FILE is newer than OLD-FILE."
116     (> (file-write-date new-file) (file-write-date old-file)))
117    
118 heller 1.56 (defun slime-version-string ()
119     "Return a string identifying the SLIME version.
120     Return nil if nothing appropriate is available."
121 heller 1.63 (with-open-file (s (merge-pathnames "ChangeLog" *source-directory*)
122     :if-does-not-exist nil)
123     (and s (symbol-name (read s)))))
124 heller 1.56
125 heller 1.78 (defun default-fasl-dir ()
126 heller 1.57 (merge-pathnames
127 heller 1.62 (make-pathname
128     :directory `(:relative ".slime" "fasl"
129 heller 1.57 ,@(if (slime-version-string) (list (slime-version-string)))
130 heller 1.78 ,(unique-dir-name)))
131 heller 1.57 (user-homedir-pathname)))
132 heller 1.54
133 trittweiler 1.100 (defvar *fasl-directory* (default-fasl-dir)
134     "The directory where fasl files should be placed.")
135    
136 heller 1.78 (defun binary-pathname (src-pathname binary-dir)
137     "Return the pathname where SRC-PATHNAME's binary should be compiled."
138     (let ((cfp (compile-file-pathname src-pathname)))
139 heller 1.54 (merge-pathnames (make-pathname :name (pathname-name cfp)
140     :type (pathname-type cfp))
141 heller 1.78 binary-dir)))
142 heller 1.54
143 trittweiler 1.100 (defun handle-swank-load-error (condition context pathname)
144     (fresh-line *error-output*)
145 heller 1.64 (pprint-logical-block (*error-output* () :per-line-prefix ";; ")
146     (format *error-output*
147 trittweiler 1.100 "~%Error while ~A ~A:~% ~A~%Aborting.~%"
148     context pathname condition))
149     (when (equal (directory-namestring pathname)
150     (directory-namestring *fasl-directory*))
151     (ignore-errors (delete-file pathname)))
152 heller 1.62 (abort))
153    
154 heller 1.78 (defun compile-files (files fasl-dir load)
155 heller 1.79 "Compile each file in FILES if the source is newer than its
156 heller 1.80 corresponding binary, or the file preceding it was recompiled.
157     If LOAD is true, load the fasl file."
158 trittweiler 1.100 (let ((needs-recompile nil)
159     (state :unknown))
160 heller 1.78 (dolist (src files)
161     (let ((dest (binary-pathname src fasl-dir)))
162 heller 1.64 (handler-case
163     (progn
164     (when (or needs-recompile
165 heller 1.78 (not (probe-file dest))
166     (file-newer-p src dest))
167 trittweiler 1.100 (ensure-directories-exist dest)
168     ;; need to recompile SRC, so we'll need to recompile
169     ;; everything after this too.
170 heller 1.64 (setq needs-recompile t)
171 trittweiler 1.100 (setq state :compile)
172     (or (compile-file src :output-file dest :print nil :verbose t)
173     ;; An implementation may not necessarily signal a
174     ;; condition itself when COMPILE-FILE fails (e.g. ECL)
175     (error "COMPILE-FILE returned NIL.")))
176 heller 1.66 (when load
177 trittweiler 1.100 (setq state :load)
178 heller 1.78 (load dest :verbose t)))
179 heller 1.64 ;; Fail as early as possible
180     (serious-condition (c)
181 trittweiler 1.100 (ecase state
182     (:compile (handle-swank-load-error c "compiling" src))
183     (:load (handle-swank-load-error c "loading" dest))
184     (:unknown (handle-swank-load-error c "???ing" src)))))))))
185 jbielman 1.1
186 trittweiler 1.99 #+(or cormanlisp)
187 heller 1.78 (defun compile-files (files fasl-dir load)
188 trittweiler 1.99 "Corman Lisp has trouble with compiled files."
189 heller 1.78 (declare (ignore fasl-dir))
190 trittweiler 1.74 (when load
191     (dolist (file files)
192     (load file :verbose t)
193     (force-output))))
194 ewiborg 1.49
195 mbaringer 1.38 (defun load-user-init-file ()
196     "Load the user init file, return NIL if it does not exist."
197     (load (merge-pathnames (user-homedir-pathname)
198     (make-pathname :name ".swank" :type "lisp"))
199     :if-does-not-exist nil))
200    
201 heller 1.78 (defun load-site-init-file (dir)
202 mbaringer 1.38 (load (make-pathname :name "site-init" :type "lisp"
203 heller 1.78 :defaults dir)
204 mbaringer 1.38 :if-does-not-exist nil))
205    
206 heller 1.78 (defun src-files (names src-dir)
207 heller 1.54 (mapcar (lambda (name)
208 heller 1.66 (make-pathname :name (string-downcase name) :type "lisp"
209     :defaults src-dir))
210     names))
211    
212 trittweiler 1.99 (defvar *swank-files*
213     `(swank-backend ,@*sysdep-files* swank-match swank-rpc swank))
214 heller 1.55
215 trittweiler 1.99 (defvar *contribs*
216     '(swank-c-p-c swank-arglists swank-fuzzy
217     swank-fancy-inspector
218     swank-presentations swank-presentation-streams
219     #+(or asdf sbcl ecl) swank-asdf
220     swank-package-fu
221     swank-hyperdoc
222     swank-sbcl-exts
223     )
224 heller 1.66 "List of names for contrib modules.")
225    
226     (defun append-dir (absolute name)
227     (merge-pathnames
228     (make-pathname :directory `(:relative ,name) :defaults absolute)
229     absolute))
230    
231 heller 1.78 (defun contrib-dir (base-dir)
232     (append-dir base-dir "contrib"))
233 heller 1.66
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