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

Contents of /slime/swank-loader.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.76 - (hide annotations)
Sun Feb 3 18:00:31 2008 UTC (6 years, 2 months ago) by mbaringer
Branch: MAIN
Changes since 1.75: +10 -9 lines
*** empty log message ***
1 jbielman 1.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 heller 1.55 ;; 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 heller 1.57 ;; (make-package :swank-loader)
18 heller 1.55 ;; (defparameter swank-loader::*fasl-directory* "/tmp/fasl/")
19     ;; (load ".../swank-loader.lisp")
20    
21 mbaringer 1.76 (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-loader)
26     (delete-package :swank-backend)))
27    
28 heller 1.11 (cl:defpackage :swank-loader
29 heller 1.54 (:use :cl)
30 heller 1.62 (:export :load-swank
31 heller 1.55 :*source-directory*
32     :*fasl-directory*))
33 heller 1.4
34 heller 1.52 (cl:in-package :swank-loader)
35 jbielman 1.1
36 heller 1.62 (defvar *source-directory*
37     (make-pathname :name nil :type nil
38 heller 1.57 :defaults (or *load-pathname* *default-pathname-defaults*))
39 heller 1.56 "The directory where to look for the source.")
40    
41 heller 1.54 (defparameter *sysdep-files*
42 heller 1.62 (append
43 heller 1.75 '()
44 heller 1.54 #+cmu '("swank-source-path-parser" "swank-source-file-cache" "swank-cmucl")
45     #+scl '("swank-source-path-parser" "swank-source-file-cache" "swank-scl")
46 trittweiler 1.65 #+sbcl '("swank-source-path-parser" "swank-source-file-cache"
47     "swank-sbcl" "swank-gray")
48 heller 1.54 #+openmcl '("metering" "swank-openmcl" "swank-gray")
49     #+lispworks '("swank-lispworks" "swank-gray")
50     #+allegro '("swank-allegro" "swank-gray")
51     #+clisp '("xref" "metering" "swank-clisp" "swank-gray")
52     #+armedbear '("swank-abcl")
53     #+cormanlisp '("swank-corman" "swank-gray")
54     #+ecl '("swank-ecl" "swank-gray")
55     ))
56 jbielman 1.1
57 pseibel 1.39 (defparameter *implementation-features*
58 heller 1.62 '(:allegro :lispworks :sbcl :openmcl :cmu :clisp :ccl :corman :cormanlisp
59 dcrosher 1.53 :armedbear :gcl :ecl :scl))
60 pseibel 1.39
61     (defparameter *os-features*
62 dcrosher 1.53 '(:macosx :linux :windows :mswindows :win32 :solaris :darwin :sunos :hpux
63     :unix))
64 pseibel 1.39
65     (defparameter *architecture-features*
66 dcrosher 1.53 '(:powerpc :ppc :x86 :x86-64 :amd64 :i686 :i586 :i486 :pc386 :iapx386
67     :sparc64 :sparc :hppa64 :hppa))
68 pseibel 1.39
69 heller 1.45 (defun lisp-version-string ()
70 mbaringer 1.76 #+(or openmcl cmu) (substitute-if #\_ (lambda (x) (find x " /"))
71 heller 1.52 (lisp-implementation-version))
72 mbaringer 1.76 #+(or cormanlisp scl sbcl ecl) (lisp-implementation-version)
73 heller 1.45 #+lispworks (lisp-implementation-version)
74 mkoeppe 1.61 #+allegro (format nil
75     "~A~A~A"
76     excl::*common-lisp-version-number*
77     (if (eq 'h 'H) "A" "M") ; ANSI vs MoDeRn
78     (if (member :64bit *features*) "-64bit" ""))
79 heller 1.45 #+clisp (let ((s (lisp-implementation-version)))
80     (subseq s 0 (position #\space s)))
81 mbaringer 1.76 #+armedbear (lisp-implementation-version))
82 heller 1.62
83 pseibel 1.39 (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 heller 1.45 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 heller 1.62 "No implementation feature found in ~a."
96 heller 1.45 *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 heller 1.17
107 jbielman 1.1 (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 heller 1.56 (defun slime-version-string ()
112     "Return a string identifying the SLIME version.
113     Return nil if nothing appropriate is available."
114 heller 1.63 (with-open-file (s (merge-pathnames "ChangeLog" *source-directory*)
115     :if-does-not-exist nil)
116     (and s (symbol-name (read s)))))
117 heller 1.56
118 heller 1.54 (defun default-fasl-directory ()
119 heller 1.57 (merge-pathnames
120 heller 1.62 (make-pathname
121     :directory `(:relative ".slime" "fasl"
122 heller 1.57 ,@(if (slime-version-string) (list (slime-version-string)))
123     ,(unique-directory-name)))
124     (user-homedir-pathname)))
125 heller 1.54
126     (defun binary-pathname (source-pathname binary-directory)
127 lgorrie 1.27 "Return the pathname where SOURCE-PATHNAME's binary should be compiled."
128     (let ((cfp (compile-file-pathname source-pathname)))
129 heller 1.54 (merge-pathnames (make-pathname :name (pathname-name cfp)
130     :type (pathname-type cfp))
131     binary-directory)))
132    
133 heller 1.62 (defun handle-loadtime-error (condition binary-pathname)
134 heller 1.64 (pprint-logical-block (*error-output* () :per-line-prefix ";; ")
135     (format *error-output*
136     "~%Error while loading: ~A~%Condition: ~A~%Aborting.~%"
137     binary-pathname condition))
138 heller 1.62 (when (equal (directory-namestring binary-pathname)
139     (directory-namestring (default-fasl-directory)))
140     (ignore-errors (delete-file binary-pathname)))
141     (abort))
142    
143 heller 1.66 (defun compile-files-if-needed-serially (files fasl-directory load)
144 jbielman 1.1 "Compile each file in FILES if the source is newer than
145 heller 1.62 its corresponding binary, or the file preceding it was
146 jbielman 1.1 recompiled."
147 heller 1.64 (let ((needs-recompile nil))
148     (dolist (source-pathname files)
149     (let ((binary-pathname (binary-pathname source-pathname
150     fasl-directory)))
151     (handler-case
152     (progn
153     (when (or needs-recompile
154     (not (probe-file binary-pathname))
155     (file-newer-p source-pathname binary-pathname))
156     ;; need a to recompile source-pathname, so we'll
157     ;; need to recompile everything after this too.
158     (setq needs-recompile t)
159     (ensure-directories-exist binary-pathname)
160     (compile-file source-pathname :output-file binary-pathname
161     :print nil
162     :verbose t))
163 heller 1.66 (when load
164     (load binary-pathname :verbose t)))
165 heller 1.64 ;; Fail as early as possible
166     (serious-condition (c)
167     (handle-loadtime-error c binary-pathname)))))))
168 jbielman 1.1
169 jgarcia 1.51 #+(or cormanlisp ecl)
170 trittweiler 1.74 (defun compile-files-if-needed-serially (files fasl-directory load)
171 jgarcia 1.51 "Corman Lisp and ECL have trouble with compiled files."
172 heller 1.54 (declare (ignore fasl-directory))
173 trittweiler 1.74 (when load
174     (dolist (file files)
175     (load file :verbose t)
176     (force-output))))
177 ewiborg 1.49
178 mbaringer 1.38 (defun load-user-init-file ()
179     "Load the user init file, return NIL if it does not exist."
180     (load (merge-pathnames (user-homedir-pathname)
181     (make-pathname :name ".swank" :type "lisp"))
182     :if-does-not-exist nil))
183    
184 heller 1.54 (defun load-site-init-file (directory)
185 mbaringer 1.38 (load (make-pathname :name "site-init" :type "lisp"
186 msimmons 1.59 :defaults directory)
187 mbaringer 1.38 :if-does-not-exist nil))
188    
189 heller 1.66 (defun source-files (names src-dir)
190 heller 1.54 (mapcar (lambda (name)
191 heller 1.66 (make-pathname :name (string-downcase name) :type "lisp"
192     :defaults src-dir))
193     names))
194    
195     (defun swank-source-files (src-dir)
196     (source-files `("swank-backend" ,@*sysdep-files* "swank")
197     src-dir))
198 heller 1.54
199 heller 1.57 (defvar *fasl-directory* (default-fasl-directory)
200 heller 1.55 "The directory where fasl files should be placed.")
201    
202 heller 1.70 (defvar *contribs* '(swank-c-p-c swank-arglists swank-fuzzy
203     swank-fancy-inspector
204 heller 1.71 swank-presentations swank-presentation-streams
205 trittweiler 1.72 #+(or asdf sbcl) swank-asdf
206 heller 1.71 )
207 heller 1.66 "List of names for contrib modules.")
208    
209     (defun append-dir (absolute name)
210     (merge-pathnames
211     (make-pathname :directory `(:relative ,name) :defaults absolute)
212     absolute))
213    
214 heller 1.71 (defun contrib-src-dir (src-dir)
215     (append-dir src-dir "contrib"))
216    
217 heller 1.66 (defun contrib-source-files (src-dir)
218 heller 1.71 (source-files *contribs* (contrib-src-dir src-dir)))
219 heller 1.66
220 heller 1.62 (defun load-swank (&key
221 heller 1.55 (source-directory *source-directory*)
222 heller 1.66 (fasl-directory *fasl-directory*)
223     (contrib-fasl-directory
224     (append-dir fasl-directory "contrib")))
225 heller 1.62 (compile-files-if-needed-serially (swank-source-files source-directory)
226 heller 1.66 fasl-directory t)
227     (compile-files-if-needed-serially (contrib-source-files source-directory)
228 heller 1.71 contrib-fasl-directory nil))
229 heller 1.55
230 heller 1.62 (load-swank)
231 heller 1.71
232     (setq swank::*swank-wire-protocol-version* (slime-version-string))
233     (setq swank::*load-path*
234     (append swank::*load-path* (list (contrib-src-dir *source-directory*))))
235     (swank-backend::warn-unimplemented-interfaces)
236     (load-site-init-file *source-directory*)
237     (load-user-init-file)
238     (swank:run-after-init-hook)

  ViewVC Help
Powered by ViewVC 1.1.5