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

Contents of /slime/swank-loader.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.87 - (hide annotations)
Tue Aug 12 17:54:44 2008 UTC (5 years, 8 months ago) by heller
Branch: MAIN
Changes since 1.86: +5 -0 lines
Add a dump-image function to the loader.

* swank-loader.lisp (dump-image): New.

* swank-backend.lisp (save-image): New interface.

* swank-cmucl.lisp, swank-clisp.lisp, swank-sbcl.lisp
(save-image): Implemented.
1 heller 1.81 ;;;; -*- indent-tabs-mode: nil -*-
2 jbielman 1.1 ;;;
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.82 (:export :init
24 heller 1.87 :dump-image
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.83 (defparameter *sysdep-files*
36 heller 1.82 #+cmu '(swank-source-path-parser swank-source-file-cache swank-cmucl)
37     #+scl '(swank-source-path-parser swank-source-file-cache swank-scl)
38     #+sbcl '(swank-source-path-parser swank-source-file-cache
39     swank-sbcl swank-gray)
40     #+openmcl '(metering swank-openmcl swank-gray)
41     #+lispworks '(swank-lispworks swank-gray)
42     #+allegro '(swank-allegro swank-gray)
43     #+clisp '(xref metering swank-clisp swank-gray)
44     #+armedbear '(swank-abcl)
45     #+cormanlisp '(swank-corman swank-gray)
46 gcarncross 1.85 #+ecl '(swank-source-path-parser swank-source-file-cache swank-ecl swank-gray))
47 jbielman 1.1
48 pseibel 1.39 (defparameter *implementation-features*
49 heller 1.62 '(:allegro :lispworks :sbcl :openmcl :cmu :clisp :ccl :corman :cormanlisp
50 dcrosher 1.53 :armedbear :gcl :ecl :scl))
51 pseibel 1.39
52     (defparameter *os-features*
53 dcrosher 1.53 '(:macosx :linux :windows :mswindows :win32 :solaris :darwin :sunos :hpux
54     :unix))
55 pseibel 1.39
56     (defparameter *architecture-features*
57 dcrosher 1.53 '(:powerpc :ppc :x86 :x86-64 :amd64 :i686 :i586 :i486 :pc386 :iapx386
58     :sparc64 :sparc :hppa64 :hppa))
59 pseibel 1.39
60 heller 1.45 (defun lisp-version-string ()
61 mbaringer 1.76 #+(or openmcl cmu) (substitute-if #\_ (lambda (x) (find x " /"))
62 heller 1.52 (lisp-implementation-version))
63 mbaringer 1.76 #+(or cormanlisp scl sbcl ecl) (lisp-implementation-version)
64 heller 1.45 #+lispworks (lisp-implementation-version)
65 mkoeppe 1.61 #+allegro (format nil
66     "~A~A~A"
67     excl::*common-lisp-version-number*
68     (if (eq 'h 'H) "A" "M") ; ANSI vs MoDeRn
69     (if (member :64bit *features*) "-64bit" ""))
70 heller 1.45 #+clisp (let ((s (lisp-implementation-version)))
71     (subseq s 0 (position #\space s)))
72 mbaringer 1.76 #+armedbear (lisp-implementation-version))
73 heller 1.62
74 heller 1.78 (defun unique-dir-name ()
75 pseibel 1.39 "Return a name that can be used as a directory name that is
76     unique to a Lisp implementation, Lisp implementation version,
77     operating system, and hardware architecture."
78     (flet ((first-of (features)
79     (loop for f in features
80 heller 1.45 when (find f *features*) return it))
81     (maybe-warn (value fstring &rest args)
82     (cond (value)
83     (t (apply #'warn fstring args)
84     "unknown"))))
85     (let ((lisp (maybe-warn (first-of *implementation-features*)
86 heller 1.62 "No implementation feature found in ~a."
87 heller 1.45 *implementation-features*))
88     (os (maybe-warn (first-of *os-features*)
89     "No os feature found in ~a." *os-features*))
90     (arch (maybe-warn (first-of *architecture-features*)
91     "No architecture feature found in ~a."
92     *architecture-features*))
93     (version (maybe-warn (lisp-version-string)
94     "Don't know how to get Lisp ~
95     implementation version.")))
96     (format nil "~(~@{~a~^-~}~)" lisp version os arch))))
97 heller 1.17
98 jbielman 1.1 (defun file-newer-p (new-file old-file)
99     "Returns true if NEW-FILE is newer than OLD-FILE."
100     (> (file-write-date new-file) (file-write-date old-file)))
101    
102 heller 1.56 (defun slime-version-string ()
103     "Return a string identifying the SLIME version.
104     Return nil if nothing appropriate is available."
105 heller 1.63 (with-open-file (s (merge-pathnames "ChangeLog" *source-directory*)
106     :if-does-not-exist nil)
107     (and s (symbol-name (read s)))))
108 heller 1.56
109 heller 1.78 (defun default-fasl-dir ()
110 heller 1.57 (merge-pathnames
111 heller 1.62 (make-pathname
112     :directory `(:relative ".slime" "fasl"
113 heller 1.57 ,@(if (slime-version-string) (list (slime-version-string)))
114 heller 1.78 ,(unique-dir-name)))
115 heller 1.57 (user-homedir-pathname)))
116 heller 1.54
117 heller 1.78 (defun binary-pathname (src-pathname binary-dir)
118     "Return the pathname where SRC-PATHNAME's binary should be compiled."
119     (let ((cfp (compile-file-pathname src-pathname)))
120 heller 1.54 (merge-pathnames (make-pathname :name (pathname-name cfp)
121     :type (pathname-type cfp))
122 heller 1.78 binary-dir)))
123 heller 1.54
124 heller 1.62 (defun handle-loadtime-error (condition binary-pathname)
125 heller 1.64 (pprint-logical-block (*error-output* () :per-line-prefix ";; ")
126     (format *error-output*
127     "~%Error while loading: ~A~%Condition: ~A~%Aborting.~%"
128     binary-pathname condition))
129 heller 1.62 (when (equal (directory-namestring binary-pathname)
130 heller 1.78 (directory-namestring (default-fasl-dir)))
131 heller 1.62 (ignore-errors (delete-file binary-pathname)))
132     (abort))
133    
134 heller 1.78 (defun compile-files (files fasl-dir load)
135 heller 1.79 "Compile each file in FILES if the source is newer than its
136 heller 1.80 corresponding binary, or the file preceding it was recompiled.
137     If LOAD is true, load the fasl file."
138 heller 1.64 (let ((needs-recompile nil))
139 heller 1.78 (dolist (src files)
140     (let ((dest (binary-pathname src fasl-dir)))
141 heller 1.64 (handler-case
142     (progn
143     (when (or needs-recompile
144 heller 1.78 (not (probe-file dest))
145     (file-newer-p src dest))
146     ;; need a to recompile src-pathname, so we'll
147 heller 1.64 ;; need to recompile everything after this too.
148     (setq needs-recompile t)
149 heller 1.78 (ensure-directories-exist dest)
150     (compile-file src :output-file dest :print nil :verbose t))
151 heller 1.66 (when load
152 heller 1.78 (load dest :verbose t)))
153 heller 1.64 ;; Fail as early as possible
154     (serious-condition (c)
155 heller 1.78 (handle-loadtime-error c dest)))))))
156 jbielman 1.1
157 jgarcia 1.51 #+(or cormanlisp ecl)
158 heller 1.78 (defun compile-files (files fasl-dir load)
159 jgarcia 1.51 "Corman Lisp and ECL have trouble with compiled files."
160 heller 1.78 (declare (ignore fasl-dir))
161 trittweiler 1.74 (when load
162     (dolist (file files)
163     (load file :verbose t)
164     (force-output))))
165 ewiborg 1.49
166 mbaringer 1.38 (defun load-user-init-file ()
167     "Load the user init file, return NIL if it does not exist."
168     (load (merge-pathnames (user-homedir-pathname)
169     (make-pathname :name ".swank" :type "lisp"))
170     :if-does-not-exist nil))
171    
172 heller 1.78 (defun load-site-init-file (dir)
173 mbaringer 1.38 (load (make-pathname :name "site-init" :type "lisp"
174 heller 1.78 :defaults dir)
175 mbaringer 1.38 :if-does-not-exist nil))
176    
177 heller 1.78 (defun src-files (names src-dir)
178 heller 1.54 (mapcar (lambda (name)
179 heller 1.66 (make-pathname :name (string-downcase name) :type "lisp"
180     :defaults src-dir))
181     names))
182    
183 heller 1.82 (defvar *swank-files* `(swank-backend ,@*sysdep-files* swank))
184 heller 1.55
185 heller 1.70 (defvar *contribs* '(swank-c-p-c swank-arglists swank-fuzzy
186     swank-fancy-inspector
187 heller 1.71 swank-presentations swank-presentation-streams
188 trittweiler 1.72 #+(or asdf sbcl) swank-asdf
189 trittweiler 1.86 swank-package-fu
190 heller 1.71 )
191 heller 1.66 "List of names for contrib modules.")
192    
193 heller 1.82 (defvar *fasl-directory* (default-fasl-dir)
194     "The directory where fasl files should be placed.")
195    
196 heller 1.66 (defun append-dir (absolute name)
197     (merge-pathnames
198     (make-pathname :directory `(:relative ,name) :defaults absolute)
199     absolute))
200    
201 heller 1.78 (defun contrib-dir (base-dir)
202     (append-dir base-dir "contrib"))
203 heller 1.66
204 heller 1.84 (defun q (s) (read-from-string s))
205    
206 heller 1.78 (defun load-swank (&key (src-dir *source-directory*)
207     (fasl-dir *fasl-directory*))
208 heller 1.84 (compile-files (src-files *swank-files* src-dir) fasl-dir t)
209     (funcall (q "swank::before-init")
210     (slime-version-string)
211     (list (contrib-dir fasl-dir)
212     (contrib-dir src-dir))))
213 heller 1.78
214     (defun compile-contribs (&key (src-dir (contrib-dir *source-directory*))
215 heller 1.82 (fasl-dir (contrib-dir *fasl-directory*))
216     load)
217     (compile-files (src-files *contribs* src-dir) fasl-dir load))
218 heller 1.84
219 heller 1.82 (defun loadup ()
220     (load-swank)
221     (compile-contribs :load t))
222 heller 1.78
223     (defun setup ()
224 heller 1.84 (load-site-init-file *source-directory*)
225     (load-user-init-file)
226     (eval `(pushnew 'compile-contribs ,(q "swank::*after-init-hook*")))
227     (funcall (q "swank::init")))
228 heller 1.78
229 heller 1.87 (defun dump-image (filename)
230     (init :setup nil)
231     (funcall (q "swank-backend:save-image") filename))
232    
233 heller 1.82 (defun init (&key delete reload load-contribs (setup t))
234 heller 1.78 (when (and delete (find-package :swank))
235     (mapc #'delete-package '(:swank :swank-io-package :swank-backend)))
236 heller 1.81 (cond ((or (not (find-package :swank)) reload)
237     (load-swank))
238     (t
239     (warn "Not reloading SWANK. Package already exists.")))
240 heller 1.82 (when load-contribs
241     (compile-contribs :load t))
242     (when setup
243     (setup)))

  ViewVC Help
Powered by ViewVC 1.1.5