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

Contents of /slime/swank-loader.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5