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

Contents of /slime/swank-loader.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.82 - (show annotations)
Mon Feb 25 17:17:56 2008 UTC (6 years, 1 month ago) by heller
Branch: MAIN
Changes since 1.81: +30 -28 lines
Make it easier to prepare core-files.

* swank-loader.lisp (init): Two new keyword args: :SETUP and
:LOAD-CONTRIBS.  :SETUP=nil can be used to suppress init hooks and
loading user init files.

* swank.asd: Call swank-loader:init with :SETUP=nil.

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

  ViewVC Help
Powered by ViewVC 1.1.5