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

Contents of /slime/swank-loader.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.62 - (show annotations)
Mon Oct 16 19:59:33 2006 UTC (7 years, 6 months ago) by heller
Branch: MAIN
Changes since 1.61: +42 -35 lines
Abort on compile-time or load-time errors.
Don't try to load the source-file if COMPILE-FILE's 3rd return
value is true (it's true even for warnings).
(handle-loadtime-error): New function.

Run the after-init-hook.
1 ;;;; -*- Mode: lisp; 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
22 (cl:defpackage :swank-loader
23 (:use :cl)
24 (:export :load-swank
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 '("nregex")
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-sbcl" "swank-source-path-parser"
41 "swank-source-file-cache" "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 #+cmu (substitute-if #\_ (lambda (x) (find x " /"))
65 (lisp-implementation-version))
66 #+scl (lisp-implementation-version)
67 #+sbcl (lisp-implementation-version)
68 #+ecl (lisp-implementation-version)
69 #+openmcl (format nil "~d.~d"
70 ccl::*openmcl-major-version*
71 ccl::*openmcl-minor-version*)
72 #+lispworks (lisp-implementation-version)
73 #+allegro (format nil
74 "~A~A~A"
75 excl::*common-lisp-version-number*
76 (if (eq 'h 'H) "A" "M") ; ANSI vs MoDeRn
77 (if (member :64bit *features*) "-64bit" ""))
78 #+clisp (let ((s (lisp-implementation-version)))
79 (subseq s 0 (position #\space s)))
80 #+armedbear (lisp-implementation-version)
81 #+cormanlisp (lisp-implementation-version))
82
83 (defun unique-directory-name ()
84 "Return a name that can be used as a directory name that is
85 unique to a Lisp implementation, Lisp implementation version,
86 operating system, and hardware architecture."
87 (flet ((first-of (features)
88 (loop for f in features
89 when (find f *features*) return it))
90 (maybe-warn (value fstring &rest args)
91 (cond (value)
92 (t (apply #'warn fstring args)
93 "unknown"))))
94 (let ((lisp (maybe-warn (first-of *implementation-features*)
95 "No implementation feature found in ~a."
96 *implementation-features*))
97 (os (maybe-warn (first-of *os-features*)
98 "No os feature found in ~a." *os-features*))
99 (arch (maybe-warn (first-of *architecture-features*)
100 "No architecture feature found in ~a."
101 *architecture-features*))
102 (version (maybe-warn (lisp-version-string)
103 "Don't know how to get Lisp ~
104 implementation version.")))
105 (format nil "~(~@{~a~^-~}~)" lisp version os arch))))
106
107 (defun file-newer-p (new-file old-file)
108 "Returns true if NEW-FILE is newer than OLD-FILE."
109 (> (file-write-date new-file) (file-write-date old-file)))
110
111 ;; Currently just use the modification time of the ChangeLog. We
112 ;; could also try to use one of those CVS keywords.
113 (defun slime-version-string ()
114 "Return a string identifying the SLIME version.
115 Return nil if nothing appropriate is available."
116 (let* ((changelog (merge-pathnames "ChangeLog" *source-directory*))
117 (date (file-write-date changelog)))
118 (cond (date (multiple-value-bind (_s _m _h date month year)
119 (decode-universal-time date)
120 (declare (ignore _s _m _h))
121 (format nil "~D-~2,'0D-~2,'0D" year month date)))
122 (t nil))))
123
124 (defun default-fasl-directory ()
125 (merge-pathnames
126 (make-pathname
127 :directory `(:relative ".slime" "fasl"
128 ,@(if (slime-version-string) (list (slime-version-string)))
129 ,(unique-directory-name)))
130 (user-homedir-pathname)))
131
132 (defun binary-pathname (source-pathname binary-directory)
133 "Return the pathname where SOURCE-PATHNAME's binary should be compiled."
134 (let ((cfp (compile-file-pathname source-pathname)))
135 (merge-pathnames (make-pathname :name (pathname-name cfp)
136 :type (pathname-type cfp))
137 binary-directory)))
138
139
140 (defun handle-loadtime-error (condition binary-pathname)
141 (format *error-output*
142 "~%~<;; ~@;Error while loading: ~A~% Condition: ~A~%Aborting.~:>~%"
143 (list binary-pathname condition))
144 (when (equal (directory-namestring binary-pathname)
145 (directory-namestring (default-fasl-directory)))
146 (ignore-errors (delete-file binary-pathname)))
147 (abort))
148
149 (defun compile-files-if-needed-serially (files fasl-directory)
150 "Compile each file in FILES if the source is newer than
151 its corresponding binary, or the file preceding it was
152 recompiled."
153 (with-compilation-unit ()
154 (let ((needs-recompile nil))
155 (dolist (source-pathname files)
156 (let ((binary-pathname (binary-pathname source-pathname
157 fasl-directory)))
158 (handler-case
159 (progn
160 (when (or needs-recompile
161 (not (probe-file binary-pathname))
162 (file-newer-p source-pathname binary-pathname))
163 ;; need a to recompile source-pathname, so we'll
164 ;; need to recompile everything after this too.
165 (setq needs-recompile t)
166 (ensure-directories-exist binary-pathname)
167 (compile-file source-pathname :output-file binary-pathname
168 :print nil
169 :verbose t))
170 (load binary-pathname :verbose t))
171 ;; Fail as early as possible
172 (serious-condition (c)
173 (handle-loadtime-error c binary-pathname))))))))
174
175 #+(or cormanlisp ecl)
176 (defun compile-files-if-needed-serially (files fasl-directory)
177 "Corman Lisp and ECL have trouble with compiled files."
178 (declare (ignore fasl-directory))
179 (dolist (file files)
180 (load file :verbose t)
181 (force-output)))
182
183 (defun load-user-init-file ()
184 "Load the user init file, return NIL if it does not exist."
185 (load (merge-pathnames (user-homedir-pathname)
186 (make-pathname :name ".swank" :type "lisp"))
187 :if-does-not-exist nil))
188
189 (defun load-site-init-file (directory)
190 (load (make-pathname :name "site-init" :type "lisp"
191 :defaults directory)
192 :if-does-not-exist nil))
193
194 (defun swank-source-files (source-directory)
195 (mapcar (lambda (name)
196 (make-pathname :name name :type "lisp"
197 :defaults source-directory))
198 `("swank-backend" ,@*sysdep-files* "swank")))
199
200 (defvar *fasl-directory* (default-fasl-directory)
201 "The directory where fasl files should be placed.")
202
203 (defun load-swank (&key
204 (source-directory *source-directory*)
205 (fasl-directory *fasl-directory*))
206 (compile-files-if-needed-serially (swank-source-files source-directory)
207 fasl-directory)
208 (funcall (intern (string :warn-unimplemented-interfaces) :swank-backend))
209 (load-site-init-file source-directory)
210 (load-user-init-file)
211 (funcall (intern (string :run-after-init-hook) :swank)))
212
213 (load-swank)

  ViewVC Help
Powered by ViewVC 1.1.5