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

Contents of /slime/swank-loader.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.65.2.1 - (hide annotations)
Sun Aug 19 11:19:32 2007 UTC (6 years, 8 months ago) by heller
Branch: contrib
Changes since 1.65: +28 -8 lines
Add a contrib directory and move fuzzy completion code to that directory.

* contrib: New directory.

* swank.lisp (swank-require): New function to load contrib code.
(*find-module*, module-filename, *load-path*, merged-directory)
(find-module, module-canditates): New. Pathname acrobatics for
swank-require.

* swank-loader.lisp: Compile (but don't load) contribs.
(*contribs*, contrib-source-files): New.

* contrib/slime-fuzzy.el: New file.
(slime-fuzzy-init): New function.  Load CL code on startup.

* contrib/swank-fuzzy.lisp: New file. Common Lisp code for fuzzy
completion.
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    
22 heller 1.11 (cl:defpackage :swank-loader
23 heller 1.54 (:use :cl)
24 heller 1.62 (:export :load-swank
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.54 '("nregex")
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 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 heller 1.52 #+cmu (substitute-if #\_ (lambda (x) (find x " /"))
65     (lisp-implementation-version))
66 dcrosher 1.53 #+scl (lisp-implementation-version)
67 heller 1.45 #+sbcl (lisp-implementation-version)
68 pseibel 1.47 #+ecl (lisp-implementation-version)
69 heller 1.45 #+openmcl (format nil "~d.~d"
70 heller 1.62 ccl::*openmcl-major-version*
71 heller 1.45 ccl::*openmcl-minor-version*)
72     #+lispworks (lisp-implementation-version)
73 mkoeppe 1.61 #+allegro (format nil
74     "~A~A~A"
75     excl::*common-lisp-version-number*
76     (if (eq 'h 'H) "A" "M") ; ANSI vs MoDeRn
77     (if (member :64bit *features*) "-64bit" ""))
78 heller 1.45 #+clisp (let ((s (lisp-implementation-version)))
79     (subseq s 0 (position #\space s)))
80 heller 1.48 #+armedbear (lisp-implementation-version)
81     #+cormanlisp (lisp-implementation-version))
82 heller 1.62
83 pseibel 1.39 (defun unique-directory-name ()
84     "Return a name that can be used as a directory name that is
85     unique to a Lisp implementation, Lisp implementation version,
86     operating system, and hardware architecture."
87     (flet ((first-of (features)
88     (loop for f in features
89 heller 1.45 when (find f *features*) return it))
90     (maybe-warn (value fstring &rest args)
91     (cond (value)
92     (t (apply #'warn fstring args)
93     "unknown"))))
94     (let ((lisp (maybe-warn (first-of *implementation-features*)
95 heller 1.62 "No implementation feature found in ~a."
96 heller 1.45 *implementation-features*))
97     (os (maybe-warn (first-of *os-features*)
98     "No os feature found in ~a." *os-features*))
99     (arch (maybe-warn (first-of *architecture-features*)
100     "No architecture feature found in ~a."
101     *architecture-features*))
102     (version (maybe-warn (lisp-version-string)
103     "Don't know how to get Lisp ~
104     implementation version.")))
105     (format nil "~(~@{~a~^-~}~)" lisp version os arch))))
106 heller 1.17
107 jbielman 1.1 (defun file-newer-p (new-file old-file)
108     "Returns true if NEW-FILE is newer than OLD-FILE."
109     (> (file-write-date new-file) (file-write-date old-file)))
110    
111 heller 1.56 (defun slime-version-string ()
112     "Return a string identifying the SLIME version.
113     Return nil if nothing appropriate is available."
114 heller 1.63 (with-open-file (s (merge-pathnames "ChangeLog" *source-directory*)
115     :if-does-not-exist nil)
116     (and s (symbol-name (read s)))))
117 heller 1.56
118 heller 1.54 (defun default-fasl-directory ()
119 heller 1.57 (merge-pathnames
120 heller 1.62 (make-pathname
121     :directory `(:relative ".slime" "fasl"
122 heller 1.57 ,@(if (slime-version-string) (list (slime-version-string)))
123     ,(unique-directory-name)))
124     (user-homedir-pathname)))
125 heller 1.54
126     (defun binary-pathname (source-pathname binary-directory)
127 lgorrie 1.27 "Return the pathname where SOURCE-PATHNAME's binary should be compiled."
128     (let ((cfp (compile-file-pathname source-pathname)))
129 heller 1.54 (merge-pathnames (make-pathname :name (pathname-name cfp)
130     :type (pathname-type cfp))
131     binary-directory)))
132    
133 heller 1.62 (defun handle-loadtime-error (condition binary-pathname)
134 heller 1.64 (pprint-logical-block (*error-output* () :per-line-prefix ";; ")
135     (format *error-output*
136     "~%Error while loading: ~A~%Condition: ~A~%Aborting.~%"
137     binary-pathname condition))
138 heller 1.62 (when (equal (directory-namestring binary-pathname)
139     (directory-namestring (default-fasl-directory)))
140     (ignore-errors (delete-file binary-pathname)))
141     (abort))
142    
143 heller 1.65.2.1 (defun compile-files-if-needed-serially (files fasl-directory load)
144 jbielman 1.1 "Compile each file in FILES if the source is newer than
145 heller 1.62 its corresponding binary, or the file preceding it was
146 jbielman 1.1 recompiled."
147 heller 1.64 (let ((needs-recompile nil))
148     (dolist (source-pathname files)
149     (let ((binary-pathname (binary-pathname source-pathname
150     fasl-directory)))
151     (handler-case
152     (progn
153     (when (or needs-recompile
154     (not (probe-file binary-pathname))
155     (file-newer-p source-pathname binary-pathname))
156     ;; need a to recompile source-pathname, so we'll
157     ;; need to recompile everything after this too.
158     (setq needs-recompile t)
159     (ensure-directories-exist binary-pathname)
160     (compile-file source-pathname :output-file binary-pathname
161     :print nil
162     :verbose t))
163 heller 1.65.2.1 (when load
164     (load binary-pathname :verbose t)))
165 heller 1.64 ;; Fail as early as possible
166     (serious-condition (c)
167     (handle-loadtime-error c binary-pathname)))))))
168 jbielman 1.1
169 jgarcia 1.51 #+(or cormanlisp ecl)
170 heller 1.54 (defun compile-files-if-needed-serially (files fasl-directory)
171 jgarcia 1.51 "Corman Lisp and ECL have trouble with compiled files."
172 heller 1.54 (declare (ignore fasl-directory))
173 ewiborg 1.49 (dolist (file files)
174 heller 1.50 (load file :verbose t)
175     (force-output)))
176 ewiborg 1.49
177 mbaringer 1.38 (defun load-user-init-file ()
178     "Load the user init file, return NIL if it does not exist."
179     (load (merge-pathnames (user-homedir-pathname)
180     (make-pathname :name ".swank" :type "lisp"))
181     :if-does-not-exist nil))
182    
183 heller 1.54 (defun load-site-init-file (directory)
184 mbaringer 1.38 (load (make-pathname :name "site-init" :type "lisp"
185 msimmons 1.59 :defaults directory)
186 mbaringer 1.38 :if-does-not-exist nil))
187    
188 heller 1.65.2.1 (defun source-files (names src-dir)
189 heller 1.54 (mapcar (lambda (name)
190 heller 1.65.2.1 (make-pathname :name (string-downcase name) :type "lisp"
191     :defaults src-dir))
192     names))
193    
194     (defun swank-source-files (src-dir)
195     (source-files `("swank-backend" ,@*sysdep-files* "swank")
196     src-dir))
197 heller 1.54
198 heller 1.57 (defvar *fasl-directory* (default-fasl-directory)
199 heller 1.55 "The directory where fasl files should be placed.")
200    
201 heller 1.65.2.1 (defvar *contribs* '(swank-fuzzy)
202     "List of names for contrib modules.")
203    
204     (defun append-dir (absolute name)
205     (merge-pathnames
206     (make-pathname :directory `(:relative ,name) :defaults absolute)
207     absolute))
208    
209     (defun contrib-source-files (src-dir)
210     (source-files *contribs* (append-dir src-dir "contrib")))
211    
212 heller 1.62 (defun load-swank (&key
213 heller 1.55 (source-directory *source-directory*)
214 heller 1.65.2.1 (fasl-directory *fasl-directory*)
215     (contrib-fasl-directory
216     (append-dir fasl-directory "contrib")))
217 heller 1.62 (compile-files-if-needed-serially (swank-source-files source-directory)
218 heller 1.65.2.1 fasl-directory t)
219     (compile-files-if-needed-serially (contrib-source-files source-directory)
220     contrib-fasl-directory nil)
221 heller 1.63 (set (read-from-string "swank::*swank-wire-protocol-version*")
222     (slime-version-string))
223 heller 1.54 (funcall (intern (string :warn-unimplemented-interfaces) :swank-backend))
224     (load-site-init-file source-directory)
225 heller 1.62 (load-user-init-file)
226     (funcall (intern (string :run-after-init-hook) :swank)))
227 heller 1.55
228 heller 1.62 (load-swank)

  ViewVC Help
Powered by ViewVC 1.1.5