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

Contents of /slime/swank-loader.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.97 - (hide annotations)
Mon Jan 18 23:20:34 2010 UTC (4 years, 3 months ago) by tnorderhaug
Branch: MAIN
Changes since 1.96: +1 -1 lines
Refactorizing RPC layer into new module.
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 heller 1.91 #+clozure '(metering swank-ccl swank-gray)
41 heller 1.82 #+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.91 '(:allegro :lispworks :sbcl :clozure :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 heller 1.91 #+(or clozure cmu) (substitute-if #\_ (lambda (x) (find x " /"))
62     (lisp-implementation-version))
63 mbaringer 1.76 #+(or cormanlisp scl sbcl ecl) (lisp-implementation-version)
64 heller 1.45 #+lispworks (lisp-implementation-version)
65 heller 1.92 #+allegro (format nil "~A~A~A~A"
66 mkoeppe 1.61 excl::*common-lisp-version-number*
67     (if (eq 'h 'H) "A" "M") ; ANSI vs MoDeRn
68 heller 1.92 (if (member :64bit *features*) "-64bit" "")
69     (excl:ics-target-case
70     (:-ics "")
71     (:+ics "-ics")))
72 heller 1.45 #+clisp (let ((s (lisp-implementation-version)))
73     (subseq s 0 (position #\space s)))
74 mbaringer 1.76 #+armedbear (lisp-implementation-version))
75 heller 1.62
76 heller 1.78 (defun unique-dir-name ()
77 pseibel 1.39 "Return a name that can be used as a directory name that is
78     unique to a Lisp implementation, Lisp implementation version,
79     operating system, and hardware architecture."
80     (flet ((first-of (features)
81     (loop for f in features
82 heller 1.45 when (find f *features*) return it))
83     (maybe-warn (value fstring &rest args)
84     (cond (value)
85     (t (apply #'warn fstring args)
86     "unknown"))))
87     (let ((lisp (maybe-warn (first-of *implementation-features*)
88 heller 1.62 "No implementation feature found in ~a."
89 heller 1.45 *implementation-features*))
90     (os (maybe-warn (first-of *os-features*)
91     "No os feature found in ~a." *os-features*))
92     (arch (maybe-warn (first-of *architecture-features*)
93     "No architecture feature found in ~a."
94     *architecture-features*))
95     (version (maybe-warn (lisp-version-string)
96     "Don't know how to get Lisp ~
97     implementation version.")))
98     (format nil "~(~@{~a~^-~}~)" lisp version os arch))))
99 heller 1.17
100 jbielman 1.1 (defun file-newer-p (new-file old-file)
101     "Returns true if NEW-FILE is newer than OLD-FILE."
102     (> (file-write-date new-file) (file-write-date old-file)))
103    
104 heller 1.56 (defun slime-version-string ()
105     "Return a string identifying the SLIME version.
106     Return nil if nothing appropriate is available."
107 heller 1.63 (with-open-file (s (merge-pathnames "ChangeLog" *source-directory*)
108     :if-does-not-exist nil)
109     (and s (symbol-name (read s)))))
110 heller 1.56
111 heller 1.78 (defun default-fasl-dir ()
112 heller 1.57 (merge-pathnames
113 heller 1.62 (make-pathname
114     :directory `(:relative ".slime" "fasl"
115 heller 1.57 ,@(if (slime-version-string) (list (slime-version-string)))
116 heller 1.78 ,(unique-dir-name)))
117 heller 1.57 (user-homedir-pathname)))
118 heller 1.54
119 heller 1.78 (defun binary-pathname (src-pathname binary-dir)
120     "Return the pathname where SRC-PATHNAME's binary should be compiled."
121     (let ((cfp (compile-file-pathname src-pathname)))
122 heller 1.54 (merge-pathnames (make-pathname :name (pathname-name cfp)
123     :type (pathname-type cfp))
124 heller 1.78 binary-dir)))
125 heller 1.54
126 heller 1.62 (defun handle-loadtime-error (condition binary-pathname)
127 heller 1.64 (pprint-logical-block (*error-output* () :per-line-prefix ";; ")
128     (format *error-output*
129     "~%Error while loading: ~A~%Condition: ~A~%Aborting.~%"
130     binary-pathname condition))
131 heller 1.62 (when (equal (directory-namestring binary-pathname)
132 heller 1.78 (directory-namestring (default-fasl-dir)))
133 heller 1.62 (ignore-errors (delete-file binary-pathname)))
134     (abort))
135    
136 heller 1.78 (defun compile-files (files fasl-dir load)
137 heller 1.79 "Compile each file in FILES if the source is newer than its
138 heller 1.80 corresponding binary, or the file preceding it was recompiled.
139     If LOAD is true, load the fasl file."
140 heller 1.64 (let ((needs-recompile nil))
141 heller 1.78 (dolist (src files)
142     (let ((dest (binary-pathname src fasl-dir)))
143 heller 1.64 (handler-case
144     (progn
145     (when (or needs-recompile
146 heller 1.78 (not (probe-file dest))
147     (file-newer-p src dest))
148     ;; need a to recompile src-pathname, so we'll
149 heller 1.64 ;; need to recompile everything after this too.
150     (setq needs-recompile t)
151 heller 1.78 (ensure-directories-exist dest)
152     (compile-file src :output-file dest :print nil :verbose t))
153 heller 1.66 (when load
154 heller 1.78 (load dest :verbose t)))
155 heller 1.64 ;; Fail as early as possible
156     (serious-condition (c)
157 heller 1.78 (handle-loadtime-error c dest)))))))
158 jbielman 1.1
159 jgarcia 1.51 #+(or cormanlisp ecl)
160 heller 1.78 (defun compile-files (files fasl-dir load)
161 jgarcia 1.51 "Corman Lisp and ECL have trouble with compiled files."
162 heller 1.78 (declare (ignore fasl-dir))
163 trittweiler 1.74 (when load
164     (dolist (file files)
165     (load file :verbose t)
166     (force-output))))
167 ewiborg 1.49
168 mbaringer 1.38 (defun load-user-init-file ()
169     "Load the user init file, return NIL if it does not exist."
170     (load (merge-pathnames (user-homedir-pathname)
171     (make-pathname :name ".swank" :type "lisp"))
172     :if-does-not-exist nil))
173    
174 heller 1.78 (defun load-site-init-file (dir)
175 mbaringer 1.38 (load (make-pathname :name "site-init" :type "lisp"
176 heller 1.78 :defaults dir)
177 mbaringer 1.38 :if-does-not-exist nil))
178    
179 heller 1.78 (defun src-files (names src-dir)
180 heller 1.54 (mapcar (lambda (name)
181 heller 1.66 (make-pathname :name (string-downcase name) :type "lisp"
182     :defaults src-dir))
183     names))
184    
185 tnorderhaug 1.97 (defvar *swank-files* `(swank-backend ,@*sysdep-files* swank-match swank swank-rpc))
186 heller 1.55
187 heller 1.70 (defvar *contribs* '(swank-c-p-c swank-arglists swank-fuzzy
188     swank-fancy-inspector
189 heller 1.71 swank-presentations swank-presentation-streams
190 trittweiler 1.72 #+(or asdf sbcl) swank-asdf
191 trittweiler 1.86 swank-package-fu
192 trittweiler 1.96 swank-hyperdoc
193 trittweiler 1.89 swank-sbcl-exts
194 heller 1.71 )
195 heller 1.66 "List of names for contrib modules.")
196    
197 heller 1.82 (defvar *fasl-directory* (default-fasl-dir)
198     "The directory where fasl files should be placed.")
199    
200 heller 1.66 (defun append-dir (absolute name)
201     (merge-pathnames
202     (make-pathname :directory `(:relative ,name) :defaults absolute)
203     absolute))
204    
205 heller 1.78 (defun contrib-dir (base-dir)
206     (append-dir base-dir "contrib"))
207 heller 1.66
208 heller 1.84 (defun q (s) (read-from-string s))
209    
210 heller 1.78 (defun load-swank (&key (src-dir *source-directory*)
211     (fasl-dir *fasl-directory*))
212 heller 1.84 (compile-files (src-files *swank-files* src-dir) fasl-dir t)
213     (funcall (q "swank::before-init")
214     (slime-version-string)
215     (list (contrib-dir fasl-dir)
216     (contrib-dir src-dir))))
217 heller 1.78
218     (defun compile-contribs (&key (src-dir (contrib-dir *source-directory*))
219 heller 1.82 (fasl-dir (contrib-dir *fasl-directory*))
220     load)
221     (compile-files (src-files *contribs* src-dir) fasl-dir load))
222 heller 1.84
223 heller 1.82 (defun loadup ()
224     (load-swank)
225     (compile-contribs :load t))
226 heller 1.78
227     (defun setup ()
228 heller 1.84 (load-site-init-file *source-directory*)
229     (load-user-init-file)
230 sboukarev 1.94 (when (#-clisp probe-file
231     #+clisp ext:probe-directory
232     (contrib-dir *source-directory*))
233 heller 1.93 (eval `(pushnew 'compile-contribs ,(q "swank::*after-init-hook*"))))
234 heller 1.84 (funcall (q "swank::init")))
235 heller 1.78
236 heller 1.82 (defun init (&key delete reload load-contribs (setup t))
237 heller 1.90 "Load SWANK and initialize some global variables.
238     If DELETE is true, delete any existing SWANK packages.
239     If RELOAD is true, reload SWANK, even if the SWANK package already exists.
240     If LOAD-CONTRIBS is true, load all contribs
241     If SETUP is true, load user init files and initialize some
242     global variabes in SWANK."
243 heller 1.78 (when (and delete (find-package :swank))
244     (mapc #'delete-package '(:swank :swank-io-package :swank-backend)))
245 heller 1.81 (cond ((or (not (find-package :swank)) reload)
246     (load-swank))
247     (t
248     (warn "Not reloading SWANK. Package already exists.")))
249 heller 1.82 (when load-contribs
250     (compile-contribs :load t))
251     (when setup
252     (setup)))
253 heller 1.88
254     (defun dump-image (filename)
255     (init :setup nil)
256     (funcall (q "swank-backend:save-image") filename))

  ViewVC Help
Powered by ViewVC 1.1.5