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

Contents of /slime/swank-loader.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.79 - (hide annotations)
Sun Feb 17 08:17:24 2008 UTC (6 years, 2 months ago) by heller
Branch: MAIN
Changes since 1.78: +2 -3 lines
*** empty log message ***
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 heller 1.11 (cl:defpackage :swank-loader
22 heller 1.54 (:use :cl)
23 heller 1.62 (:export :load-swank
24 heller 1.78 :init
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.75 '()
38 heller 1.54 #+cmu '("swank-source-path-parser" "swank-source-file-cache" "swank-cmucl")
39     #+scl '("swank-source-path-parser" "swank-source-file-cache" "swank-scl")
40 trittweiler 1.65 #+sbcl '("swank-source-path-parser" "swank-source-file-cache"
41     "swank-sbcl" "swank-gray")
42 heller 1.54 #+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 mbaringer 1.76 #+(or openmcl cmu) (substitute-if #\_ (lambda (x) (find x " /"))
65 heller 1.52 (lisp-implementation-version))
66 mbaringer 1.76 #+(or cormanlisp scl sbcl ecl) (lisp-implementation-version)
67 heller 1.45 #+lispworks (lisp-implementation-version)
68 mkoeppe 1.61 #+allegro (format nil
69     "~A~A~A"
70     excl::*common-lisp-version-number*
71     (if (eq 'h 'H) "A" "M") ; ANSI vs MoDeRn
72     (if (member :64bit *features*) "-64bit" ""))
73 heller 1.45 #+clisp (let ((s (lisp-implementation-version)))
74     (subseq s 0 (position #\space s)))
75 mbaringer 1.76 #+armedbear (lisp-implementation-version))
76 heller 1.62
77 heller 1.78 (defun unique-dir-name ()
78 pseibel 1.39 "Return a name that can be used as a directory name that is
79     unique to a Lisp implementation, Lisp implementation version,
80     operating system, and hardware architecture."
81     (flet ((first-of (features)
82     (loop for f in features
83 heller 1.45 when (find f *features*) return it))
84     (maybe-warn (value fstring &rest args)
85     (cond (value)
86     (t (apply #'warn fstring args)
87     "unknown"))))
88     (let ((lisp (maybe-warn (first-of *implementation-features*)
89 heller 1.62 "No implementation feature found in ~a."
90 heller 1.45 *implementation-features*))
91     (os (maybe-warn (first-of *os-features*)
92     "No os feature found in ~a." *os-features*))
93     (arch (maybe-warn (first-of *architecture-features*)
94     "No architecture feature found in ~a."
95     *architecture-features*))
96     (version (maybe-warn (lisp-version-string)
97     "Don't know how to get Lisp ~
98     implementation version.")))
99     (format nil "~(~@{~a~^-~}~)" lisp version os arch))))
100 heller 1.17
101 jbielman 1.1 (defun file-newer-p (new-file old-file)
102     "Returns true if NEW-FILE is newer than OLD-FILE."
103     (> (file-write-date new-file) (file-write-date old-file)))
104    
105 heller 1.56 (defun slime-version-string ()
106     "Return a string identifying the SLIME version.
107     Return nil if nothing appropriate is available."
108 heller 1.63 (with-open-file (s (merge-pathnames "ChangeLog" *source-directory*)
109     :if-does-not-exist nil)
110     (and s (symbol-name (read s)))))
111 heller 1.56
112 heller 1.78 (defun default-fasl-dir ()
113 heller 1.57 (merge-pathnames
114 heller 1.62 (make-pathname
115     :directory `(:relative ".slime" "fasl"
116 heller 1.57 ,@(if (slime-version-string) (list (slime-version-string)))
117 heller 1.78 ,(unique-dir-name)))
118 heller 1.57 (user-homedir-pathname)))
119 heller 1.54
120 heller 1.78 (defun binary-pathname (src-pathname binary-dir)
121     "Return the pathname where SRC-PATHNAME's binary should be compiled."
122     (let ((cfp (compile-file-pathname src-pathname)))
123 heller 1.54 (merge-pathnames (make-pathname :name (pathname-name cfp)
124     :type (pathname-type cfp))
125 heller 1.78 binary-dir)))
126 heller 1.54
127 heller 1.62 (defun handle-loadtime-error (condition binary-pathname)
128 heller 1.64 (pprint-logical-block (*error-output* () :per-line-prefix ";; ")
129     (format *error-output*
130     "~%Error while loading: ~A~%Condition: ~A~%Aborting.~%"
131     binary-pathname condition))
132 heller 1.62 (when (equal (directory-namestring binary-pathname)
133 heller 1.78 (directory-namestring (default-fasl-dir)))
134 heller 1.62 (ignore-errors (delete-file binary-pathname)))
135     (abort))
136    
137 heller 1.78 (defun compile-files (files fasl-dir load)
138 heller 1.79 "Compile each file in FILES if the source is newer than its
139     corresponding binary, or the file preceding it was recompiled."
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 heller 1.78 (defun swank-src-files (src-dir)
186     (src-files `("swank-backend" ,@*sysdep-files* "swank")
187     src-dir))
188 heller 1.54
189 heller 1.78 (defvar *fasl-directory* (default-fasl-dir)
190 heller 1.55 "The directory where fasl files should be placed.")
191    
192 heller 1.70 (defvar *contribs* '(swank-c-p-c swank-arglists swank-fuzzy
193     swank-fancy-inspector
194 heller 1.71 swank-presentations swank-presentation-streams
195 trittweiler 1.72 #+(or asdf sbcl) swank-asdf
196 heller 1.71 )
197 heller 1.66 "List of names for contrib modules.")
198    
199     (defun append-dir (absolute name)
200     (merge-pathnames
201     (make-pathname :directory `(:relative ,name) :defaults absolute)
202     absolute))
203    
204 heller 1.78 (defun contrib-dir (base-dir)
205     (append-dir base-dir "contrib"))
206 heller 1.66
207 heller 1.78 (defun load-swank (&key (src-dir *source-directory*)
208     (fasl-dir *fasl-directory*))
209     (compile-files (swank-src-files src-dir) fasl-dir t))
210    
211     (defun compile-contribs (&key (src-dir (contrib-dir *source-directory*))
212     (fasl-dir (contrib-dir *fasl-directory*)))
213     (compile-files (src-files *contribs* src-dir) fasl-dir nil))
214    
215     (defun setup ()
216     (flet ((q (s) (read-from-string s)))
217     (load-site-init-file *source-directory*)
218     (load-user-init-file)
219     (eval `(pushnew 'compile-contribs ,(q "swank::*after-init-hook*")))
220     (funcall (q "swank::setup")
221     (slime-version-string)
222     (list (contrib-dir *fasl-directory*)
223     (contrib-dir *source-directory*)))))
224    
225     (defun init (&key delete reload)
226     (when (and delete (find-package :swank))
227     (mapc #'delete-package '(:swank :swank-io-package :swank-backend)))
228     (when (or (not (find-package :swank)) reload)
229     (load-swank))
230     (setup))

  ViewVC Help
Powered by ViewVC 1.1.5