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

Contents of /slime/swank-loader.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5