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

Contents of /slime/swank-loader.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.89 - (show annotations)
Fri Jan 2 16:43:21 2009 UTC (5 years, 3 months ago) by trittweiler
Branch: MAIN
Changes since 1.88: +1 -0 lines
	* swank-loader.lisp (*contribs*): Add `swank-sbcl-exts'.
1 ;;;; -*- indent-tabs-mode: nil -*-
2 ;;;
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 ;; 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 ;; (make-package :swank-loader)
18 ;; (defparameter swank-loader::*fasl-directory* "/tmp/fasl/")
19 ;; (load ".../swank-loader.lisp")
20
21 (cl:defpackage :swank-loader
22 (:use :cl)
23 (:export :init
24 :dump-image
25 :*source-directory*
26 :*fasl-directory*))
27
28 (cl:in-package :swank-loader)
29
30 (defvar *source-directory*
31 (make-pathname :name nil :type nil
32 :defaults (or *load-pathname* *default-pathname-defaults*))
33 "The directory where to look for the source.")
34
35 (defparameter *sysdep-files*
36 #+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 #+openmcl '(metering swank-openmcl swank-gray)
41 #+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 #+ecl '(swank-source-path-parser swank-source-file-cache swank-ecl swank-gray))
47
48 (defparameter *implementation-features*
49 '(:allegro :lispworks :sbcl :openmcl :cmu :clisp :ccl :corman :cormanlisp
50 :armedbear :gcl :ecl :scl))
51
52 (defparameter *os-features*
53 '(:macosx :linux :windows :mswindows :win32 :solaris :darwin :sunos :hpux
54 :unix))
55
56 (defparameter *architecture-features*
57 '(:powerpc :ppc :x86 :x86-64 :amd64 :i686 :i586 :i486 :pc386 :iapx386
58 :sparc64 :sparc :hppa64 :hppa))
59
60 (defun lisp-version-string ()
61 #+(or openmcl cmu) (substitute-if #\_ (lambda (x) (find x " /"))
62 (lisp-implementation-version))
63 #+(or cormanlisp scl sbcl ecl) (lisp-implementation-version)
64 #+lispworks (lisp-implementation-version)
65 #+allegro (format nil
66 "~A~A~A"
67 excl::*common-lisp-version-number*
68 (if (eq 'h 'H) "A" "M") ; ANSI vs MoDeRn
69 (if (member :64bit *features*) "-64bit" ""))
70 #+clisp (let ((s (lisp-implementation-version)))
71 (subseq s 0 (position #\space s)))
72 #+armedbear (lisp-implementation-version))
73
74 (defun unique-dir-name ()
75 "Return a name that can be used as a directory name that is
76 unique to a Lisp implementation, Lisp implementation version,
77 operating system, and hardware architecture."
78 (flet ((first-of (features)
79 (loop for f in features
80 when (find f *features*) return it))
81 (maybe-warn (value fstring &rest args)
82 (cond (value)
83 (t (apply #'warn fstring args)
84 "unknown"))))
85 (let ((lisp (maybe-warn (first-of *implementation-features*)
86 "No implementation feature found in ~a."
87 *implementation-features*))
88 (os (maybe-warn (first-of *os-features*)
89 "No os feature found in ~a." *os-features*))
90 (arch (maybe-warn (first-of *architecture-features*)
91 "No architecture feature found in ~a."
92 *architecture-features*))
93 (version (maybe-warn (lisp-version-string)
94 "Don't know how to get Lisp ~
95 implementation version.")))
96 (format nil "~(~@{~a~^-~}~)" lisp version os arch))))
97
98 (defun file-newer-p (new-file old-file)
99 "Returns true if NEW-FILE is newer than OLD-FILE."
100 (> (file-write-date new-file) (file-write-date old-file)))
101
102 (defun slime-version-string ()
103 "Return a string identifying the SLIME version.
104 Return nil if nothing appropriate is available."
105 (with-open-file (s (merge-pathnames "ChangeLog" *source-directory*)
106 :if-does-not-exist nil)
107 (and s (symbol-name (read s)))))
108
109 (defun default-fasl-dir ()
110 (merge-pathnames
111 (make-pathname
112 :directory `(:relative ".slime" "fasl"
113 ,@(if (slime-version-string) (list (slime-version-string)))
114 ,(unique-dir-name)))
115 (user-homedir-pathname)))
116
117 (defun binary-pathname (src-pathname binary-dir)
118 "Return the pathname where SRC-PATHNAME's binary should be compiled."
119 (let ((cfp (compile-file-pathname src-pathname)))
120 (merge-pathnames (make-pathname :name (pathname-name cfp)
121 :type (pathname-type cfp))
122 binary-dir)))
123
124 (defun handle-loadtime-error (condition binary-pathname)
125 (pprint-logical-block (*error-output* () :per-line-prefix ";; ")
126 (format *error-output*
127 "~%Error while loading: ~A~%Condition: ~A~%Aborting.~%"
128 binary-pathname condition))
129 (when (equal (directory-namestring binary-pathname)
130 (directory-namestring (default-fasl-dir)))
131 (ignore-errors (delete-file binary-pathname)))
132 (abort))
133
134 (defun compile-files (files fasl-dir load)
135 "Compile each file in FILES if the source is newer than its
136 corresponding binary, or the file preceding it was recompiled.
137 If LOAD is true, load the fasl file."
138 (let ((needs-recompile nil))
139 (dolist (src files)
140 (let ((dest (binary-pathname src fasl-dir)))
141 (handler-case
142 (progn
143 (when (or needs-recompile
144 (not (probe-file dest))
145 (file-newer-p src dest))
146 ;; need a to recompile src-pathname, so we'll
147 ;; need to recompile everything after this too.
148 (setq needs-recompile t)
149 (ensure-directories-exist dest)
150 (compile-file src :output-file dest :print nil :verbose t))
151 (when load
152 (load dest :verbose t)))
153 ;; Fail as early as possible
154 (serious-condition (c)
155 (handle-loadtime-error c dest)))))))
156
157 #+(or cormanlisp ecl)
158 (defun compile-files (files fasl-dir load)
159 "Corman Lisp and ECL have trouble with compiled files."
160 (declare (ignore fasl-dir))
161 (when load
162 (dolist (file files)
163 (load file :verbose t)
164 (force-output))))
165
166 (defun load-user-init-file ()
167 "Load the user init file, return NIL if it does not exist."
168 (load (merge-pathnames (user-homedir-pathname)
169 (make-pathname :name ".swank" :type "lisp"))
170 :if-does-not-exist nil))
171
172 (defun load-site-init-file (dir)
173 (load (make-pathname :name "site-init" :type "lisp"
174 :defaults dir)
175 :if-does-not-exist nil))
176
177 (defun src-files (names src-dir)
178 (mapcar (lambda (name)
179 (make-pathname :name (string-downcase name) :type "lisp"
180 :defaults src-dir))
181 names))
182
183 (defvar *swank-files* `(swank-backend ,@*sysdep-files* swank))
184
185 (defvar *contribs* '(swank-c-p-c swank-arglists swank-fuzzy
186 swank-fancy-inspector
187 swank-presentations swank-presentation-streams
188 #+(or asdf sbcl) swank-asdf
189 swank-package-fu
190 swank-sbcl-exts
191 )
192 "List of names for contrib modules.")
193
194 (defvar *fasl-directory* (default-fasl-dir)
195 "The directory where fasl files should be placed.")
196
197 (defun append-dir (absolute name)
198 (merge-pathnames
199 (make-pathname :directory `(:relative ,name) :defaults absolute)
200 absolute))
201
202 (defun contrib-dir (base-dir)
203 (append-dir base-dir "contrib"))
204
205 (defun q (s) (read-from-string s))
206
207 (defun load-swank (&key (src-dir *source-directory*)
208 (fasl-dir *fasl-directory*))
209 (compile-files (src-files *swank-files* src-dir) fasl-dir t)
210 (funcall (q "swank::before-init")
211 (slime-version-string)
212 (list (contrib-dir fasl-dir)
213 (contrib-dir src-dir))))
214
215 (defun compile-contribs (&key (src-dir (contrib-dir *source-directory*))
216 (fasl-dir (contrib-dir *fasl-directory*))
217 load)
218 (compile-files (src-files *contribs* src-dir) fasl-dir load))
219
220 (defun loadup ()
221 (load-swank)
222 (compile-contribs :load t))
223
224 (defun setup ()
225 (load-site-init-file *source-directory*)
226 (load-user-init-file)
227 (eval `(pushnew 'compile-contribs ,(q "swank::*after-init-hook*")))
228 (funcall (q "swank::init")))
229
230 (defun init (&key delete reload load-contribs (setup t))
231 (when (and delete (find-package :swank))
232 (mapc #'delete-package '(:swank :swank-io-package :swank-backend)))
233 (cond ((or (not (find-package :swank)) reload)
234 (load-swank))
235 (t
236 (warn "Not reloading SWANK. Package already exists.")))
237 (when load-contribs
238 (compile-contribs :load t))
239 (when setup
240 (setup)))
241
242 (defun dump-image (filename)
243 (init :setup nil)
244 (funcall (q "swank-backend:save-image") filename))

  ViewVC Help
Powered by ViewVC 1.1.5