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

Contents of /slime/swank-loader.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.78 - (show annotations)
Sat Feb 16 19:26:22 2008 UTC (6 years, 2 months ago) by heller
Branch: MAIN
Changes since 1.77: +54 -60 lines
Split loading and initialization (again).

* swank-loader.lisp (init): New.  Delete old packages only if
explicitly requested.  Also, if the swank package already exists
don't load swank again.
(setup): New function.

* swank.lisp (setup): New function.  Moved over here from
swank-loader.lisp.

* slime.el (slime-init-command): Call swank-loader:init.


In the REPL, mark the trailing newline also as input.

* slime.el (slime-repl-send-input): Mark the newline with
the 'slime-repl-old-input property.
(slime-repl-grab-old-input): Strip the newline.
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 ;; 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 ;; (make-package :swank-loader)
18 ;; (defparameter swank-loader::*fasl-directory* "/tmp/fasl/")
19 ;; (load ".../swank-loader.lisp")
20
21 (cl:defpackage :swank-loader
22 (:use :cl)
23 (:export :load-swank
24 :init
25 :*source-directory*
26 :*fasl-directory*))
27
28 (cl:in-package :swank-loader)
29
30 (defvar *source-directory*
31 (make-pathname :name nil :type nil
32 :defaults (or *load-pathname* *default-pathname-defaults*))
33 "The directory where to look for the source.")
34
35 (defparameter *sysdep-files*
36 (append
37 '()
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-source-path-parser" "swank-source-file-cache"
41 "swank-sbcl" "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
51 (defparameter *implementation-features*
52 '(:allegro :lispworks :sbcl :openmcl :cmu :clisp :ccl :corman :cormanlisp
53 :armedbear :gcl :ecl :scl))
54
55 (defparameter *os-features*
56 '(:macosx :linux :windows :mswindows :win32 :solaris :darwin :sunos :hpux
57 :unix))
58
59 (defparameter *architecture-features*
60 '(:powerpc :ppc :x86 :x86-64 :amd64 :i686 :i586 :i486 :pc386 :iapx386
61 :sparc64 :sparc :hppa64 :hppa))
62
63 (defun lisp-version-string ()
64 #+(or openmcl cmu) (substitute-if #\_ (lambda (x) (find x " /"))
65 (lisp-implementation-version))
66 #+(or cormanlisp scl sbcl ecl) (lisp-implementation-version)
67 #+lispworks (lisp-implementation-version)
68 #+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 #+clisp (let ((s (lisp-implementation-version)))
74 (subseq s 0 (position #\space s)))
75 #+armedbear (lisp-implementation-version))
76
77 (defun unique-dir-name ()
78 "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 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 "No implementation feature found in ~a."
90 *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
101 (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 (defun slime-version-string ()
106 "Return a string identifying the SLIME version.
107 Return nil if nothing appropriate is available."
108 (with-open-file (s (merge-pathnames "ChangeLog" *source-directory*)
109 :if-does-not-exist nil)
110 (and s (symbol-name (read s)))))
111
112 (defun default-fasl-dir ()
113 (merge-pathnames
114 (make-pathname
115 :directory `(:relative ".slime" "fasl"
116 ,@(if (slime-version-string) (list (slime-version-string)))
117 ,(unique-dir-name)))
118 (user-homedir-pathname)))
119
120 (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 (merge-pathnames (make-pathname :name (pathname-name cfp)
124 :type (pathname-type cfp))
125 binary-dir)))
126
127 (defun handle-loadtime-error (condition binary-pathname)
128 (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 (when (equal (directory-namestring binary-pathname)
133 (directory-namestring (default-fasl-dir)))
134 (ignore-errors (delete-file binary-pathname)))
135 (abort))
136
137 (defun compile-files (files fasl-dir load)
138 "Compile each file in FILES if the source is newer than
139 its corresponding binary, or the file preceding it was
140 recompiled."
141 (let ((needs-recompile nil))
142 (dolist (src files)
143 (let ((dest (binary-pathname src fasl-dir)))
144 (handler-case
145 (progn
146 (when (or needs-recompile
147 (not (probe-file dest))
148 (file-newer-p src dest))
149 ;; need a to recompile src-pathname, so we'll
150 ;; need to recompile everything after this too.
151 (setq needs-recompile t)
152 (ensure-directories-exist dest)
153 (compile-file src :output-file dest :print nil :verbose t))
154 (when load
155 (load dest :verbose t)))
156 ;; Fail as early as possible
157 (serious-condition (c)
158 (handle-loadtime-error c dest)))))))
159
160 #+(or cormanlisp ecl)
161 (defun compile-files (files fasl-dir load)
162 "Corman Lisp and ECL have trouble with compiled files."
163 (declare (ignore fasl-dir))
164 (when load
165 (dolist (file files)
166 (load file :verbose t)
167 (force-output))))
168
169 (defun load-user-init-file ()
170 "Load the user init file, return NIL if it does not exist."
171 (load (merge-pathnames (user-homedir-pathname)
172 (make-pathname :name ".swank" :type "lisp"))
173 :if-does-not-exist nil))
174
175 (defun load-site-init-file (dir)
176 (load (make-pathname :name "site-init" :type "lisp"
177 :defaults dir)
178 :if-does-not-exist nil))
179
180 (defun src-files (names src-dir)
181 (mapcar (lambda (name)
182 (make-pathname :name (string-downcase name) :type "lisp"
183 :defaults src-dir))
184 names))
185
186 (defun swank-src-files (src-dir)
187 (src-files `("swank-backend" ,@*sysdep-files* "swank")
188 src-dir))
189
190 (defvar *fasl-directory* (default-fasl-dir)
191 "The directory where fasl files should be placed.")
192
193 (defvar *contribs* '(swank-c-p-c swank-arglists swank-fuzzy
194 swank-fancy-inspector
195 swank-presentations swank-presentation-streams
196 #+(or asdf sbcl) swank-asdf
197 )
198 "List of names for contrib modules.")
199
200 (defun append-dir (absolute name)
201 (merge-pathnames
202 (make-pathname :directory `(:relative ,name) :defaults absolute)
203 absolute))
204
205 (defun contrib-dir (base-dir)
206 (append-dir base-dir "contrib"))
207
208 (defun load-swank (&key (src-dir *source-directory*)
209 (fasl-dir *fasl-directory*))
210 (compile-files (swank-src-files src-dir) fasl-dir t))
211
212 (defun compile-contribs (&key (src-dir (contrib-dir *source-directory*))
213 (fasl-dir (contrib-dir *fasl-directory*)))
214 (compile-files (src-files *contribs* src-dir) fasl-dir nil))
215
216 (defun setup ()
217 (flet ((q (s) (read-from-string s)))
218 (load-site-init-file *source-directory*)
219 (load-user-init-file)
220 (eval `(pushnew 'compile-contribs ,(q "swank::*after-init-hook*")))
221 (funcall (q "swank::setup")
222 (slime-version-string)
223 (list (contrib-dir *fasl-directory*)
224 (contrib-dir *source-directory*)))))
225
226 (defun init (&key delete reload)
227 (when (and delete (find-package :swank))
228 (mapc #'delete-package '(:swank :swank-io-package :swank-backend)))
229 (when (or (not (find-package :swank)) reload)
230 (load-swank))
231 (setup))

  ViewVC Help
Powered by ViewVC 1.1.5