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

Contents of /slime/swank-loader.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.95 - (hide annotations)
Sat Oct 31 22:13:55 2009 UTC (4 years, 5 months ago) by trittweiler
Branch: MAIN
Changes since 1.94: +1 -1 lines
	* slime.el (slime-inside-string-p, slime-inside-comment-p)
	(slime-inside-string-or-comment-p): New.

	* swank-match.lisp: New file. Contains very simple pattern matcher
	from the CMU AI archive.

	* swank-loader.lisp: Compile swank-match.lisp.

	* swank.lisp: Make SWANK package use new SWANK-MATCH package.

	* slime-autodoc.el, swank-arglists.lisp: Large parts were
	rewritten. Autodoc is now able to highlight &key parameters, and
	parameters in nested arglists.

	* slime-parse.el, slime-c-p-c.el, slime-highlighting-edits.el:
	Adapted to changes.
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 trittweiler 1.95 (defvar *swank-files* `(swank-backend ,@*sysdep-files* swank-match swank))
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.89 swank-sbcl-exts
193 heller 1.71 )
194 heller 1.66 "List of names for contrib modules.")
195    
196 heller 1.82 (defvar *fasl-directory* (default-fasl-dir)
197     "The directory where fasl files should be placed.")
198    
199 heller 1.66 (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.84 (defun q (s) (read-from-string s))
208    
209 heller 1.78 (defun load-swank (&key (src-dir *source-directory*)
210     (fasl-dir *fasl-directory*))
211 heller 1.84 (compile-files (src-files *swank-files* src-dir) fasl-dir t)
212     (funcall (q "swank::before-init")
213     (slime-version-string)
214     (list (contrib-dir fasl-dir)
215     (contrib-dir src-dir))))
216 heller 1.78
217     (defun compile-contribs (&key (src-dir (contrib-dir *source-directory*))
218 heller 1.82 (fasl-dir (contrib-dir *fasl-directory*))
219     load)
220     (compile-files (src-files *contribs* src-dir) fasl-dir load))
221 heller 1.84
222 heller 1.82 (defun loadup ()
223     (load-swank)
224     (compile-contribs :load t))
225 heller 1.78
226     (defun setup ()
227 heller 1.84 (load-site-init-file *source-directory*)
228     (load-user-init-file)
229 sboukarev 1.94 (when (#-clisp probe-file
230     #+clisp ext:probe-directory
231     (contrib-dir *source-directory*))
232 heller 1.93 (eval `(pushnew 'compile-contribs ,(q "swank::*after-init-hook*"))))
233 heller 1.84 (funcall (q "swank::init")))
234 heller 1.78
235 heller 1.82 (defun init (&key delete reload load-contribs (setup t))
236 heller 1.90 "Load SWANK and initialize some global variables.
237     If DELETE is true, delete any existing SWANK packages.
238     If RELOAD is true, reload SWANK, even if the SWANK package already exists.
239     If LOAD-CONTRIBS is true, load all contribs
240     If SETUP is true, load user init files and initialize some
241     global variabes in SWANK."
242 heller 1.78 (when (and delete (find-package :swank))
243     (mapc #'delete-package '(:swank :swank-io-package :swank-backend)))
244 heller 1.81 (cond ((or (not (find-package :swank)) reload)
245     (load-swank))
246     (t
247     (warn "Not reloading SWANK. Package already exists.")))
248 heller 1.82 (when load-contribs
249     (compile-contribs :load t))
250     (when setup
251     (setup)))
252 heller 1.88
253     (defun dump-image (filename)
254     (init :setup nil)
255     (funcall (q "swank-backend:save-image") filename))

  ViewVC Help
Powered by ViewVC 1.1.5