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

Contents of /slime/swank-loader.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.64 - (hide annotations)
Fri Jan 12 15:23:48 2007 UTC (7 years, 3 months ago) by heller
Branch: MAIN
Changes since 1.63: +24 -25 lines
(compile-files-if-needed-serially): Don't wrap
everything in a compilation unit.  If we abort on load errors and
it is confusing to see compiler warnings after the abort message.

(handle-loadtime-error): CLISP's format implements ~< differently
as everybody else, so use a explicit pprint-logical-block instead.
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    
22 heller 1.11 (cl:defpackage :swank-loader
23 heller 1.54 (:use :cl)
24 heller 1.62 (:export :load-swank
25 heller 1.55 :*source-directory*
26     :*fasl-directory*))
27 heller 1.4
28 heller 1.52 (cl:in-package :swank-loader)
29 jbielman 1.1
30 heller 1.62 (defvar *source-directory*
31     (make-pathname :name nil :type nil
32 heller 1.57 :defaults (or *load-pathname* *default-pathname-defaults*))
33 heller 1.56 "The directory where to look for the source.")
34    
35 heller 1.54 (defparameter *sysdep-files*
36 heller 1.62 (append
37 heller 1.54 '("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 jbielman 1.1
51 pseibel 1.39 (defparameter *implementation-features*
52 heller 1.62 '(:allegro :lispworks :sbcl :openmcl :cmu :clisp :ccl :corman :cormanlisp
53 dcrosher 1.53 :armedbear :gcl :ecl :scl))
54 pseibel 1.39
55     (defparameter *os-features*
56 dcrosher 1.53 '(:macosx :linux :windows :mswindows :win32 :solaris :darwin :sunos :hpux
57     :unix))
58 pseibel 1.39
59     (defparameter *architecture-features*
60 dcrosher 1.53 '(:powerpc :ppc :x86 :x86-64 :amd64 :i686 :i586 :i486 :pc386 :iapx386
61     :sparc64 :sparc :hppa64 :hppa))
62 pseibel 1.39
63 heller 1.45 (defun lisp-version-string ()
64 heller 1.52 #+cmu (substitute-if #\_ (lambda (x) (find x " /"))
65     (lisp-implementation-version))
66 dcrosher 1.53 #+scl (lisp-implementation-version)
67 heller 1.45 #+sbcl (lisp-implementation-version)
68 pseibel 1.47 #+ecl (lisp-implementation-version)
69 heller 1.45 #+openmcl (format nil "~d.~d"
70 heller 1.62 ccl::*openmcl-major-version*
71 heller 1.45 ccl::*openmcl-minor-version*)
72     #+lispworks (lisp-implementation-version)
73 mkoeppe 1.61 #+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 heller 1.45 #+clisp (let ((s (lisp-implementation-version)))
79     (subseq s 0 (position #\space s)))
80 heller 1.48 #+armedbear (lisp-implementation-version)
81     #+cormanlisp (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.54 (defun compile-files-if-needed-serially (files fasl-directory)
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     (load binary-pathname :verbose t))
164     ;; 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.54 (defun swank-source-files (source-directory)
188     (mapcar (lambda (name)
189 heller 1.56 (make-pathname :name name :type "lisp"
190 msimmons 1.59 :defaults source-directory))
191 heller 1.54 `("swank-backend" ,@*sysdep-files* "swank")))
192    
193 heller 1.57 (defvar *fasl-directory* (default-fasl-directory)
194 heller 1.55 "The directory where fasl files should be placed.")
195    
196 heller 1.62 (defun load-swank (&key
197 heller 1.55 (source-directory *source-directory*)
198     (fasl-directory *fasl-directory*))
199 heller 1.62 (compile-files-if-needed-serially (swank-source-files source-directory)
200 heller 1.54 fasl-directory)
201 heller 1.63 (set (read-from-string "swank::*swank-wire-protocol-version*")
202     (slime-version-string))
203 heller 1.54 (funcall (intern (string :warn-unimplemented-interfaces) :swank-backend))
204     (load-site-init-file source-directory)
205 heller 1.62 (load-user-init-file)
206     (funcall (intern (string :run-after-init-hook) :swank)))
207 heller 1.55
208 heller 1.62 (load-swank)

  ViewVC Help
Powered by ViewVC 1.1.5