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

Contents of /slime/swank-loader.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.98 - (show annotations)
Tue Jan 19 19:41:00 2010 UTC (4 years, 2 months ago) by tnorderhaug
Branch: MAIN
Changes since 1.97: +1 -1 lines
New swank-rpc package
Use swank-rpc in swank package.
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 #+clozure '(metering swank-ccl 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 :clozure :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 clozure 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 "~A~A~A~A"
66 excl::*common-lisp-version-number*
67 (if (eq 'h 'H) "A" "M") ; ANSI vs MoDeRn
68 (if (member :64bit *features*) "-64bit" "")
69 (excl:ics-target-case
70 (:-ics "")
71 (:+ics "-ics")))
72 #+clisp (let ((s (lisp-implementation-version)))
73 (subseq s 0 (position #\space s)))
74 #+armedbear (lisp-implementation-version))
75
76 (defun unique-dir-name ()
77 "Return a name that can be used as a directory name that is
78 unique to a Lisp implementation, Lisp implementation version,
79 operating system, and hardware architecture."
80 (flet ((first-of (features)
81 (loop for f in features
82 when (find f *features*) return it))
83 (maybe-warn (value fstring &rest args)
84 (cond (value)
85 (t (apply #'warn fstring args)
86 "unknown"))))
87 (let ((lisp (maybe-warn (first-of *implementation-features*)
88 "No implementation feature found in ~a."
89 *implementation-features*))
90 (os (maybe-warn (first-of *os-features*)
91 "No os feature found in ~a." *os-features*))
92 (arch (maybe-warn (first-of *architecture-features*)
93 "No architecture feature found in ~a."
94 *architecture-features*))
95 (version (maybe-warn (lisp-version-string)
96 "Don't know how to get Lisp ~
97 implementation version.")))
98 (format nil "~(~@{~a~^-~}~)" lisp version os arch))))
99
100 (defun file-newer-p (new-file old-file)
101 "Returns true if NEW-FILE is newer than OLD-FILE."
102 (> (file-write-date new-file) (file-write-date old-file)))
103
104 (defun slime-version-string ()
105 "Return a string identifying the SLIME version.
106 Return nil if nothing appropriate is available."
107 (with-open-file (s (merge-pathnames "ChangeLog" *source-directory*)
108 :if-does-not-exist nil)
109 (and s (symbol-name (read s)))))
110
111 (defun default-fasl-dir ()
112 (merge-pathnames
113 (make-pathname
114 :directory `(:relative ".slime" "fasl"
115 ,@(if (slime-version-string) (list (slime-version-string)))
116 ,(unique-dir-name)))
117 (user-homedir-pathname)))
118
119 (defun binary-pathname (src-pathname binary-dir)
120 "Return the pathname where SRC-PATHNAME's binary should be compiled."
121 (let ((cfp (compile-file-pathname src-pathname)))
122 (merge-pathnames (make-pathname :name (pathname-name cfp)
123 :type (pathname-type cfp))
124 binary-dir)))
125
126 (defun handle-loadtime-error (condition binary-pathname)
127 (pprint-logical-block (*error-output* () :per-line-prefix ";; ")
128 (format *error-output*
129 "~%Error while loading: ~A~%Condition: ~A~%Aborting.~%"
130 binary-pathname condition))
131 (when (equal (directory-namestring binary-pathname)
132 (directory-namestring (default-fasl-dir)))
133 (ignore-errors (delete-file binary-pathname)))
134 (abort))
135
136 (defun compile-files (files fasl-dir load)
137 "Compile each file in FILES if the source is newer than its
138 corresponding binary, or the file preceding it was recompiled.
139 If LOAD is true, load the fasl file."
140 (let ((needs-recompile nil))
141 (dolist (src files)
142 (let ((dest (binary-pathname src fasl-dir)))
143 (handler-case
144 (progn
145 (when (or needs-recompile
146 (not (probe-file dest))
147 (file-newer-p src dest))
148 ;; need a to recompile src-pathname, so we'll
149 ;; need to recompile everything after this too.
150 (setq needs-recompile t)
151 (ensure-directories-exist dest)
152 (compile-file src :output-file dest :print nil :verbose t))
153 (when load
154 (load dest :verbose t)))
155 ;; Fail as early as possible
156 (serious-condition (c)
157 (handle-loadtime-error c dest)))))))
158
159 #+(or cormanlisp ecl)
160 (defun compile-files (files fasl-dir load)
161 "Corman Lisp and ECL have trouble with compiled files."
162 (declare (ignore fasl-dir))
163 (when load
164 (dolist (file files)
165 (load file :verbose t)
166 (force-output))))
167
168 (defun load-user-init-file ()
169 "Load the user init file, return NIL if it does not exist."
170 (load (merge-pathnames (user-homedir-pathname)
171 (make-pathname :name ".swank" :type "lisp"))
172 :if-does-not-exist nil))
173
174 (defun load-site-init-file (dir)
175 (load (make-pathname :name "site-init" :type "lisp"
176 :defaults dir)
177 :if-does-not-exist nil))
178
179 (defun src-files (names src-dir)
180 (mapcar (lambda (name)
181 (make-pathname :name (string-downcase name) :type "lisp"
182 :defaults src-dir))
183 names))
184
185 (defvar *swank-files* `(swank-backend ,@*sysdep-files* swank-match swank-rpc swank))
186
187 (defvar *contribs* '(swank-c-p-c swank-arglists swank-fuzzy
188 swank-fancy-inspector
189 swank-presentations swank-presentation-streams
190 #+(or asdf sbcl) swank-asdf
191 swank-package-fu
192 swank-hyperdoc
193 swank-sbcl-exts
194 )
195 "List of names for contrib modules.")
196
197 (defvar *fasl-directory* (default-fasl-dir)
198 "The directory where fasl files should be placed.")
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 q (s) (read-from-string s))
209
210 (defun load-swank (&key (src-dir *source-directory*)
211 (fasl-dir *fasl-directory*))
212 (compile-files (src-files *swank-files* src-dir) fasl-dir t)
213 (funcall (q "swank::before-init")
214 (slime-version-string)
215 (list (contrib-dir fasl-dir)
216 (contrib-dir src-dir))))
217
218 (defun compile-contribs (&key (src-dir (contrib-dir *source-directory*))
219 (fasl-dir (contrib-dir *fasl-directory*))
220 load)
221 (compile-files (src-files *contribs* src-dir) fasl-dir load))
222
223 (defun loadup ()
224 (load-swank)
225 (compile-contribs :load t))
226
227 (defun setup ()
228 (load-site-init-file *source-directory*)
229 (load-user-init-file)
230 (when (#-clisp probe-file
231 #+clisp ext:probe-directory
232 (contrib-dir *source-directory*))
233 (eval `(pushnew 'compile-contribs ,(q "swank::*after-init-hook*"))))
234 (funcall (q "swank::init")))
235
236 (defun init (&key delete reload load-contribs (setup t))
237 "Load SWANK and initialize some global variables.
238 If DELETE is true, delete any existing SWANK packages.
239 If RELOAD is true, reload SWANK, even if the SWANK package already exists.
240 If LOAD-CONTRIBS is true, load all contribs
241 If SETUP is true, load user init files and initialize some
242 global variabes in SWANK."
243 (when (and delete (find-package :swank))
244 (mapc #'delete-package '(:swank :swank-io-package :swank-backend)))
245 (cond ((or (not (find-package :swank)) reload)
246 (load-swank))
247 (t
248 (warn "Not reloading SWANK. Package already exists.")))
249 (when load-contribs
250 (compile-contribs :load t))
251 (when setup
252 (setup)))
253
254 (defun dump-image (filename)
255 (init :setup nil)
256 (funcall (q "swank-backend:save-image") filename))

  ViewVC Help
Powered by ViewVC 1.1.5