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

Contents of /slime/swank-loader.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.62 - (hide 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 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 ;; 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 heller 1.54 (defun default-fasl-directory ()
125 heller 1.57 (merge-pathnames
126 heller 1.62 (make-pathname
127     :directory `(:relative ".slime" "fasl"
128 heller 1.57 ,@(if (slime-version-string) (list (slime-version-string)))
129     ,(unique-directory-name)))
130     (user-homedir-pathname)))
131 heller 1.54
132     (defun binary-pathname (source-pathname binary-directory)
133 lgorrie 1.27 "Return the pathname where SOURCE-PATHNAME's binary should be compiled."
134     (let ((cfp (compile-file-pathname source-pathname)))
135 heller 1.54 (merge-pathnames (make-pathname :name (pathname-name cfp)
136     :type (pathname-type cfp))
137     binary-directory)))
138    
139 heller 1.62
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 heller 1.54 (defun compile-files-if-needed-serially (files fasl-directory)
150 jbielman 1.1 "Compile each file in FILES if the source is newer than
151 heller 1.62 its corresponding binary, or the file preceding it was
152 jbielman 1.1 recompiled."
153 heller 1.6 (with-compilation-unit ()
154     (let ((needs-recompile nil))
155     (dolist (source-pathname files)
156 heller 1.54 (let ((binary-pathname (binary-pathname source-pathname
157     fasl-directory)))
158 heller 1.62 (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 jbielman 1.1
175 jgarcia 1.51 #+(or cormanlisp ecl)
176 heller 1.54 (defun compile-files-if-needed-serially (files fasl-directory)
177 jgarcia 1.51 "Corman Lisp and ECL have trouble with compiled files."
178 heller 1.54 (declare (ignore fasl-directory))
179 ewiborg 1.49 (dolist (file files)
180 heller 1.50 (load file :verbose t)
181     (force-output)))
182 ewiborg 1.49
183 mbaringer 1.38 (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 heller 1.54 (defun load-site-init-file (directory)
190 mbaringer 1.38 (load (make-pathname :name "site-init" :type "lisp"
191 msimmons 1.59 :defaults directory)
192 mbaringer 1.38 :if-does-not-exist nil))
193    
194 heller 1.54 (defun swank-source-files (source-directory)
195     (mapcar (lambda (name)
196 heller 1.56 (make-pathname :name name :type "lisp"
197 msimmons 1.59 :defaults source-directory))
198 heller 1.54 `("swank-backend" ,@*sysdep-files* "swank")))
199    
200 heller 1.57 (defvar *fasl-directory* (default-fasl-directory)
201 heller 1.55 "The directory where fasl files should be placed.")
202    
203 heller 1.62 (defun load-swank (&key
204 heller 1.55 (source-directory *source-directory*)
205     (fasl-directory *fasl-directory*))
206 heller 1.62 (compile-files-if-needed-serially (swank-source-files source-directory)
207 heller 1.54 fasl-directory)
208     (funcall (intern (string :warn-unimplemented-interfaces) :swank-backend))
209     (load-site-init-file source-directory)
210 heller 1.62 (load-user-init-file)
211     (funcall (intern (string :run-after-init-hook) :swank)))
212 heller 1.55
213 heller 1.62 (load-swank)

  ViewVC Help
Powered by ViewVC 1.1.5