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

Diff of /slime/swank-loader.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.77 by mbaringer, Mon Feb 4 12:15:27 2008 UTC revision 1.78 by heller, Sat Feb 16 19:26:22 2008 UTC
# Line 18  Line 18 
18  ;;   (defparameter swank-loader::*fasl-directory* "/tmp/fasl/")  ;;   (defparameter swank-loader::*fasl-directory* "/tmp/fasl/")
19  ;;   (load ".../swank-loader.lisp")  ;;   (load ".../swank-loader.lisp")
20    
 (eval-when (:compile-toplevel :load-toplevel :execute)  
   (when (find-package :swank)  
     (delete-package :swank)  
     (delete-package :swank-io-package)  
     (delete-package :swank-backend)))  
   
21  (cl:defpackage :swank-loader  (cl:defpackage :swank-loader
22    (:use :cl)    (:use :cl)
23    (:export :load-swank    (:export :load-swank
24               :init
25             :*source-directory*             :*source-directory*
26             :*fasl-directory*))             :*fasl-directory*))
27    
# Line 79  Line 74 
74                  (subseq s 0 (position #\space s)))                  (subseq s 0 (position #\space s)))
75    #+armedbear (lisp-implementation-version))    #+armedbear (lisp-implementation-version))
76    
77  (defun unique-directory-name ()  (defun unique-dir-name ()
78    "Return a name that can be used as a directory name that is    "Return a name that can be used as a directory name that is
79  unique to a Lisp implementation, Lisp implementation version,  unique to a Lisp implementation, Lisp implementation version,
80  operating system, and hardware architecture."  operating system, and hardware architecture."
# Line 114  Return nil if nothing appropriate is ava Line 109  Return nil if nothing appropriate is ava
109                       :if-does-not-exist nil)                       :if-does-not-exist nil)
110      (and s (symbol-name (read s)))))      (and s (symbol-name (read s)))))
111    
112  (defun default-fasl-directory ()  (defun default-fasl-dir ()
113    (merge-pathnames    (merge-pathnames
114     (make-pathname     (make-pathname
115      :directory `(:relative ".slime" "fasl"      :directory `(:relative ".slime" "fasl"
116                   ,@(if (slime-version-string) (list (slime-version-string)))                   ,@(if (slime-version-string) (list (slime-version-string)))
117                   ,(unique-directory-name)))                   ,(unique-dir-name)))
118     (user-homedir-pathname)))     (user-homedir-pathname)))
119    
120  (defun binary-pathname (source-pathname binary-directory)  (defun binary-pathname (src-pathname binary-dir)
121    "Return the pathname where SOURCE-PATHNAME's binary should be compiled."    "Return the pathname where SRC-PATHNAME's binary should be compiled."
122    (let ((cfp (compile-file-pathname source-pathname)))    (let ((cfp (compile-file-pathname src-pathname)))
123      (merge-pathnames (make-pathname :name (pathname-name cfp)      (merge-pathnames (make-pathname :name (pathname-name cfp)
124                                      :type (pathname-type cfp))                                      :type (pathname-type cfp))
125                       binary-directory)))                       binary-dir)))
126    
127  (defun handle-loadtime-error (condition binary-pathname)  (defun handle-loadtime-error (condition binary-pathname)
128    (pprint-logical-block (*error-output* () :per-line-prefix ";; ")    (pprint-logical-block (*error-output* () :per-line-prefix ";; ")
# Line 135  Return nil if nothing appropriate is ava Line 130  Return nil if nothing appropriate is ava
130              "~%Error while loading: ~A~%Condition: ~A~%Aborting.~%"              "~%Error while loading: ~A~%Condition: ~A~%Aborting.~%"
131              binary-pathname condition))              binary-pathname condition))
132    (when (equal (directory-namestring binary-pathname)    (when (equal (directory-namestring binary-pathname)
133                 (directory-namestring (default-fasl-directory)))                 (directory-namestring (default-fasl-dir)))
134      (ignore-errors (delete-file binary-pathname)))      (ignore-errors (delete-file binary-pathname)))
135    (abort))    (abort))
136    
137  (defun compile-files-if-needed-serially (files fasl-directory load)  (defun compile-files (files fasl-dir load)
138    "Compile each file in FILES if the source is newer than    "Compile each file in FILES if the source is newer than
139  its corresponding binary, or the file preceding it was  its corresponding binary, or the file preceding it was
140  recompiled."  recompiled."
141    (let ((needs-recompile nil))    (let ((needs-recompile nil))
142      (dolist (source-pathname files)      (dolist (src files)
143        (let ((binary-pathname (binary-pathname source-pathname        (let ((dest (binary-pathname src fasl-dir)))
                                               fasl-directory)))  
144          (handler-case          (handler-case
145              (progn              (progn
146                (when (or needs-recompile                (when (or needs-recompile
147                          (not (probe-file binary-pathname))                          (not (probe-file dest))
148                          (file-newer-p source-pathname binary-pathname))                          (file-newer-p src dest))
149                  ;; need a to recompile source-pathname, so we'll                  ;; need a to recompile src-pathname, so we'll
150                  ;; need to recompile everything after this too.                  ;; need to recompile everything after this too.
151                  (setq needs-recompile t)                  (setq needs-recompile t)
152                  (ensure-directories-exist binary-pathname)                  (ensure-directories-exist dest)
153                  (compile-file source-pathname :output-file binary-pathname                  (compile-file src :output-file dest :print nil :verbose t))
                               :print nil  
                               :verbose t))  
154                (when load                (when load
155                  (load binary-pathname :verbose t)))                  (load dest :verbose t)))
156            ;; Fail as early as possible            ;; Fail as early as possible
157            (serious-condition (c)            (serious-condition (c)
158              (handle-loadtime-error c binary-pathname)))))))              (handle-loadtime-error c dest)))))))
159    
160  #+(or cormanlisp ecl)  #+(or cormanlisp ecl)
161  (defun compile-files-if-needed-serially (files fasl-directory load)  (defun compile-files (files fasl-dir load)
162    "Corman Lisp and ECL have trouble with compiled files."    "Corman Lisp and ECL have trouble with compiled files."
163    (declare (ignore fasl-directory))    (declare (ignore fasl-dir))
164    (when load    (when load
165      (dolist (file files)      (dolist (file files)
166        (load file :verbose t)        (load file :verbose t)
# Line 180  recompiled." Line 172  recompiled."
172                           (make-pathname :name ".swank" :type "lisp"))                           (make-pathname :name ".swank" :type "lisp"))
173          :if-does-not-exist nil))          :if-does-not-exist nil))
174    
175  (defun load-site-init-file (directory)  (defun load-site-init-file (dir)
176    (load (make-pathname :name "site-init" :type "lisp"    (load (make-pathname :name "site-init" :type "lisp"
177                         :defaults directory)                         :defaults dir)
178          :if-does-not-exist nil))          :if-does-not-exist nil))
179    
180  (defun source-files (names src-dir)  (defun src-files (names src-dir)
181    (mapcar (lambda (name)    (mapcar (lambda (name)
182              (make-pathname :name (string-downcase name) :type "lisp"              (make-pathname :name (string-downcase name) :type "lisp"
183                             :defaults src-dir))                             :defaults src-dir))
184            names))            names))
185    
186  (defun swank-source-files (src-dir)  (defun swank-src-files (src-dir)
187    (source-files `("swank-backend" ,@*sysdep-files* "swank")    (src-files `("swank-backend" ,@*sysdep-files* "swank")
188                  src-dir))               src-dir))
189    
190  (defvar *fasl-directory* (default-fasl-directory)  (defvar *fasl-directory* (default-fasl-dir)
191    "The directory where fasl files should be placed.")    "The directory where fasl files should be placed.")
192    
193  (defvar *contribs* '(swank-c-p-c swank-arglists swank-fuzzy  (defvar *contribs* '(swank-c-p-c swank-arglists swank-fuzzy
# Line 210  recompiled." Line 202  recompiled."
202     (make-pathname :directory `(:relative ,name) :defaults absolute)     (make-pathname :directory `(:relative ,name) :defaults absolute)
203     absolute))     absolute))
204    
205  (defun contrib-src-dir (src-dir)  (defun contrib-dir (base-dir)
206    (append-dir src-dir "contrib"))    (append-dir base-dir "contrib"))
   
 (defun contrib-source-files (src-dir)  
   (source-files *contribs* (contrib-src-dir src-dir)))  
207    
208  (defun load-swank (&key  (defun load-swank (&key (src-dir *source-directory*)
209                     (source-directory *source-directory*)                     (fasl-dir *fasl-directory*))
210                     (fasl-directory *fasl-directory*)    (compile-files (swank-src-files src-dir) fasl-dir t))
211                     (contrib-fasl-directory  
212                      (append-dir fasl-directory "contrib")))  (defun compile-contribs (&key (src-dir (contrib-dir *source-directory*))
213    (compile-files-if-needed-serially (swank-source-files source-directory)                           (fasl-dir (contrib-dir *fasl-directory*)))
214                                      fasl-directory t)    (compile-files (src-files *contribs* src-dir) fasl-dir nil))
215    (compile-files-if-needed-serially (contrib-source-files source-directory)  
216                                      contrib-fasl-directory nil))  (defun setup ()
217      (flet ((q (s) (read-from-string s)))
218  (load-swank)      (load-site-init-file *source-directory*)
219        (load-user-init-file)
220  (setq swank::*swank-wire-protocol-version* (slime-version-string))      (eval `(pushnew 'compile-contribs ,(q "swank::*after-init-hook*")))
221  (setq swank::*load-path*      (funcall (q "swank::setup")
222        (append swank::*load-path* (list (contrib-src-dir *source-directory*))))               (slime-version-string)
223  (swank-backend::warn-unimplemented-interfaces)               (list (contrib-dir *fasl-directory*)
224  (load-site-init-file *source-directory*)                     (contrib-dir *source-directory*)))))
225  (load-user-init-file)  
226  (swank:run-after-init-hook)  (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))

Legend:
Removed from v.1.77  
changed lines
  Added in v.1.78

  ViewVC Help
Powered by ViewVC 1.1.5