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

Contents of /slime/swank-loader.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.73 - (hide annotations)
Fri Sep 14 12:41:28 2007 UTC (6 years, 7 months ago) by heller
Branch: MAIN
Changes since 1.72: +0 -1 lines
Make ASDF:LOAD-OP (and SBCL REQUIRE) happy with swank.asd

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

  ViewVC Help
Powered by ViewVC 1.1.5