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

Contents of /slime/swank-loader.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.81 - (show annotations)
Wed Feb 20 22:10:38 2008 UTC (6 years, 2 months ago) by heller
Branch: MAIN
Changes since 1.80: +5 -3 lines
Emit a warning if the SWANK package already exists.

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

  ViewVC Help
Powered by ViewVC 1.1.5