/[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.35 by asimon, Sun Sep 26 17:09:13 2004 UTC revision 1.74 by trittweiler, Mon Oct 22 09:34:04 2007 UTC
# Line 8  Line 8 
8  ;;; are disclaimed.  ;;; are disclaimed.
9  ;;;  ;;;
10    
11  (cl:defpackage :swank-loader  ;; If you want customize the source- or fasl-directory you can set
12    (:use :common-lisp))  ;; swank-loader:*source-directory* resp. swank-loader:*fasl-directory*
13    ;; before loading this files. (you also need to create the
14  (in-package :swank-loader)  ;; 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  (defun make-swank-pathname (name &optional (type "lisp"))  (cl:defpackage :swank-loader
22    "Return a pathname with name component NAME in the Slime directory."    (:use :cl)
23    (merge-pathnames (make-pathname :name name :type type)    (:export :load-swank
24                     (or *compile-file-pathname*             :*source-directory*
25                         *load-pathname*             :*fasl-directory*))
26                         *default-pathname-defaults*)))  
27    (cl:in-package :swank-loader)
28  (defparameter *sysdep-pathnames*  
29    (mapcar #'make-swank-pathname  (defvar *source-directory*
30            (append    (make-pathname :name nil :type nil
31             '("nregex")                   :defaults (or *load-pathname* *default-pathname-defaults*))
32             #+cmu '("swank-source-path-parser" "swank-cmucl")    "The directory where to look for the source.")
33             #+sbcl '("swank-sbcl" "swank-source-path-parser" "swank-gray")  
34             #+openmcl '("metering" "swank-openmcl" "swank-gray")  (defparameter *sysdep-files*
35             #+lispworks '("swank-lispworks" "swank-gray")    (append
36             #+allegro '("swank-allegro" "swank-gray")     '("nregex")
37             #+clisp '("xref" "metering" "swank-clisp" "swank-gray")     #+cmu '("swank-source-path-parser" "swank-source-file-cache" "swank-cmucl")
38             #+armedbear '("swank-abcl")     #+scl '("swank-source-path-parser" "swank-source-file-cache" "swank-scl")
39             )))     #+sbcl '("swank-source-path-parser" "swank-source-file-cache"
40                "swank-sbcl" "swank-gray")
41  (defparameter *lisp-name*     #+openmcl '("metering" "swank-openmcl" "swank-gray")
42    #+cmu       (format nil "cmu-~A"     #+lispworks '("swank-lispworks" "swank-gray")
43                        (substitute #\- #\/ (lisp-implementation-version)))     #+allegro '("swank-allegro" "swank-gray")
44    #+sbcl      (format nil "sbcl-~A" (lisp-implementation-version))     #+clisp '("xref" "metering" "swank-clisp" "swank-gray")
45    #+openmcl   "openmcl"     #+armedbear '("swank-abcl")
46    #+lispworks (format nil "lispworks-~A" (lisp-implementation-version))     #+cormanlisp '("swank-corman" "swank-gray")
47    #+allegro   (format nil "allegro-~A" excl::*common-lisp-version-number*)     #+ecl '("swank-ecl" "swank-gray")
48    #+clisp     (format nil "clisp-~A" (let ((s (lisp-implementation-version)))     ))
49                                         (subseq s 0 (position #\space s))))  
50    #+armedbear "abcl"  (defparameter *implementation-features*
51    )    '(:allegro :lispworks :sbcl :openmcl :cmu :clisp :ccl :corman :cormanlisp
52        :armedbear :gcl :ecl :scl))
53  (defparameter *swank-pathname* (make-swank-pathname "swank"))  
54    (defparameter *os-features*
55      '(:macosx :linux :windows :mswindows :win32 :solaris :darwin :sunos :hpux
56        :unix))
57    
58    (defparameter *architecture-features*
59      '(:powerpc :ppc :x86 :x86-64 :amd64 :i686 :i586 :i486 :pc386 :iapx386
60        :sparc64 :sparc :hppa64 :hppa))
61    
62    (defun lisp-version-string ()
63      #+cmu       (substitute-if #\_ (lambda (x) (find x " /"))
64                                 (lisp-implementation-version))
65      #+scl       (lisp-implementation-version)
66      #+sbcl      (lisp-implementation-version)
67      #+ecl       (lisp-implementation-version)
68      #+openmcl   (format nil "~d.~d"
69                          ccl::*openmcl-major-version*
70                          ccl::*openmcl-minor-version*)
71      #+lispworks (lisp-implementation-version)
72      #+allegro   (format nil
73                          "~A~A~A"
74                          excl::*common-lisp-version-number*
75                          (if (eq 'h 'H) "A" "M")     ; ANSI vs MoDeRn
76                          (if (member :64bit *features*) "-64bit" ""))
77      #+clisp     (let ((s (lisp-implementation-version)))
78                    (subseq s 0 (position #\space s)))
79      #+armedbear (lisp-implementation-version)
80      #+cormanlisp (lisp-implementation-version))
81    
82    (defun unique-directory-name ()
83      "Return a name that can be used as a directory name that is
84    unique to a Lisp implementation, Lisp implementation version,
85    operating system, and hardware architecture."
86      (flet ((first-of (features)
87               (loop for f in features
88                     when (find f *features*) return it))
89             (maybe-warn (value fstring &rest args)
90               (cond (value)
91                     (t (apply #'warn fstring args)
92                        "unknown"))))
93        (let ((lisp (maybe-warn (first-of *implementation-features*)
94                                "No implementation feature found in ~a."
95                                *implementation-features*))
96              (os   (maybe-warn (first-of *os-features*)
97                                "No os feature found in ~a." *os-features*))
98              (arch (maybe-warn (first-of *architecture-features*)
99                                "No architecture feature found in ~a."
100                                *architecture-features*))
101              (version (maybe-warn (lisp-version-string)
102                                   "Don't know how to get Lisp ~
103                                    implementation version.")))
104          (format nil "~(~@{~a~^-~}~)" lisp version os arch))))
105    
106  (defun file-newer-p (new-file old-file)  (defun file-newer-p (new-file old-file)
107    "Returns true if NEW-FILE is newer than OLD-FILE."    "Returns true if NEW-FILE is newer than OLD-FILE."
108    (> (file-write-date new-file) (file-write-date old-file)))    (> (file-write-date new-file) (file-write-date old-file)))
109    
110  (defun binary-pathname (source-pathname)  (defun slime-version-string ()
111      "Return a string identifying the SLIME version.
112    Return nil if nothing appropriate is available."
113      (with-open-file (s (merge-pathnames "ChangeLog" *source-directory*)
114                         :if-does-not-exist nil)
115        (and s (symbol-name (read s)))))
116    
117    (defun default-fasl-directory ()
118      (merge-pathnames
119       (make-pathname
120        :directory `(:relative ".slime" "fasl"
121                     ,@(if (slime-version-string) (list (slime-version-string)))
122                     ,(unique-directory-name)))
123       (user-homedir-pathname)))
124    
125    (defun binary-pathname (source-pathname binary-directory)
126    "Return the pathname where SOURCE-PATHNAME's binary should be compiled."    "Return the pathname where SOURCE-PATHNAME's binary should be compiled."
127    (let ((cfp (compile-file-pathname source-pathname)))    (let ((cfp (compile-file-pathname source-pathname)))
128      (merge-pathnames (make-pathname      (merge-pathnames (make-pathname :name (pathname-name cfp)
129                        :directory `(:relative ".slime" "fasl" ,*lisp-name*)                                      :type (pathname-type cfp))
130                        :name (pathname-name cfp)                       binary-directory)))
131                        :type (pathname-type cfp))  
132                       (user-homedir-pathname))))  (defun handle-loadtime-error (condition binary-pathname)
133      (pprint-logical-block (*error-output* () :per-line-prefix ";; ")
134        (format *error-output*
135                "~%Error while loading: ~A~%Condition: ~A~%Aborting.~%"
136                binary-pathname condition))
137      (when (equal (directory-namestring binary-pathname)
138                   (directory-namestring (default-fasl-directory)))
139        (ignore-errors (delete-file binary-pathname)))
140      (abort))
141    
142  (defun compile-files-if-needed-serially (files)  (defun compile-files-if-needed-serially (files fasl-directory load)
143    "Compile each file in FILES if the source is newer than    "Compile each file in FILES if the source is newer than
144  its corresponding binary, or the file preceding it was  its corresponding binary, or the file preceding it was
145  recompiled."  recompiled."
146    (with-compilation-unit ()    (let ((needs-recompile nil))
147      (let ((needs-recompile nil))      (dolist (source-pathname files)
148        (dolist (source-pathname files)        (let ((binary-pathname (binary-pathname source-pathname
149          (let ((binary-pathname (binary-pathname source-pathname)))                                                fasl-directory)))
150            (handler-case          (handler-case
151                (progn              (progn
152                  (when (or needs-recompile                (when (or needs-recompile
153                            (not (probe-file binary-pathname))                          (not (probe-file binary-pathname))
154                            (file-newer-p source-pathname binary-pathname))                          (file-newer-p source-pathname binary-pathname))
155                    (format t "~&;; Compiling ~A...~%" source-pathname)                  ;; need a to recompile source-pathname, so we'll
156                    (ensure-directories-exist binary-pathname)                  ;; need to recompile everything after this too.
157                    (compile-file source-pathname :output-file binary-pathname)                  (setq needs-recompile t)
158                    (setq needs-recompile t))                  (ensure-directories-exist binary-pathname)
159                  (load binary-pathname))                  (compile-file source-pathname :output-file binary-pathname
160              #+(or)                                :print nil
161              (error ()                                :verbose t))
162                ;; If an error occurs compiling, load the source instead                (when load
163                ;; so we can try to debug it.                  (load binary-pathname :verbose t)))
164                (load source-pathname))            ;; Fail as early as possible
165              ))))))            (serious-condition (c)
166                (handle-loadtime-error c binary-pathname)))))))
167  (defun user-init-file ()  
168    "Return the name of the user init file or nil."  #+(or cormanlisp ecl)
169    (probe-file (merge-pathnames (user-homedir-pathname)  (defun compile-files-if-needed-serially (files fasl-directory load)
170                                 (make-pathname :name ".swank" :type "lisp"))))    "Corman Lisp and ECL have trouble with compiled files."
171      (declare (ignore fasl-directory))
172      (when load
173  (compile-files-if-needed-serially      (dolist (file files)
174    (append (list (make-swank-pathname "swank-backend"))        (load file :verbose t)
175            *sysdep-pathnames*        (force-output))))
176            (list *swank-pathname*)))  
177    (defun load-user-init-file ()
178  (funcall (intern (string :warn-unimplemented-interfaces) :swank-backend))    "Load the user init file, return NIL if it does not exist."
179      (load (merge-pathnames (user-homedir-pathname)
180  (when (user-init-file)                           (make-pathname :name ".swank" :type "lisp"))
181    (load (user-init-file)))          :if-does-not-exist nil))
182    
183    (defun load-site-init-file (directory)
184      (load (make-pathname :name "site-init" :type "lisp"
185                           :defaults directory)
186            :if-does-not-exist nil))
187    
188    (defun source-files (names src-dir)
189      (mapcar (lambda (name)
190                (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    
198    (defvar *fasl-directory* (default-fasl-directory)
199      "The directory where fasl files should be placed.")
200    
201    (defvar *contribs* '(swank-c-p-c swank-arglists swank-fuzzy
202                         swank-fancy-inspector
203                         swank-presentations swank-presentation-streams
204                         #+(or asdf sbcl) swank-asdf
205                         )
206      "List of names for contrib modules.")
207    
208    (defun append-dir (absolute name)
209      (merge-pathnames
210       (make-pathname :directory `(:relative ,name) :defaults absolute)
211       absolute))
212    
213    (defun contrib-src-dir (src-dir)
214      (append-dir src-dir "contrib"))
215    
216    (defun contrib-source-files (src-dir)
217      (source-files *contribs* (contrib-src-dir src-dir)))
218    
219    (defun load-swank (&key
220                       (source-directory *source-directory*)
221                       (fasl-directory *fasl-directory*)
222                       (contrib-fasl-directory
223                        (append-dir fasl-directory "contrib")))
224      (compile-files-if-needed-serially (swank-source-files source-directory)
225                                        fasl-directory t)
226      (compile-files-if-needed-serially (contrib-source-files source-directory)
227                                        contrib-fasl-directory nil))
228    
229    (load-swank)
230    
231    (setq swank::*swank-wire-protocol-version* (slime-version-string))
232    (setq swank::*load-path*
233          (append swank::*load-path* (list (contrib-src-dir *source-directory*))))
234    (swank-backend::warn-unimplemented-interfaces)
235    (load-site-init-file *source-directory*)
236    (load-user-init-file)
237    (swank:run-after-init-hook)

Legend:
Removed from v.1.35  
changed lines
  Added in v.1.74

  ViewVC Help
Powered by ViewVC 1.1.5