/[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.72 by trittweiler, Tue Sep 11 19:30:53 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    
 (defun make-swank-pathname (name &optional (type "lisp"))  
   "Return a pathname with name component NAME in the Slime directory."  
   (merge-pathnames (make-pathname :name name :type type)  
                    (or *compile-file-pathname*  
                        *load-pathname*  
                        *default-pathname-defaults*)))  
   
 (defparameter *sysdep-pathnames*  
   (mapcar #'make-swank-pathname  
           (append  
            '("nregex")  
            #+cmu '("swank-source-path-parser" "swank-cmucl")  
            #+sbcl '("swank-sbcl" "swank-source-path-parser" "swank-gray")  
            #+openmcl '("metering" "swank-openmcl" "swank-gray")  
            #+lispworks '("swank-lispworks" "swank-gray")  
            #+allegro '("swank-allegro" "swank-gray")  
            #+clisp '("xref" "metering" "swank-clisp" "swank-gray")  
            #+armedbear '("swank-abcl")  
            )))  
   
 (defparameter *lisp-name*  
   #+cmu       (format nil "cmu-~A"  
                       (substitute #\- #\/ (lisp-implementation-version)))  
   #+sbcl      (format nil "sbcl-~A" (lisp-implementation-version))  
   #+openmcl   "openmcl"  
   #+lispworks (format nil "lispworks-~A" (lisp-implementation-version))  
   #+allegro   (format nil "allegro-~A" excl::*common-lisp-version-number*)  
   #+clisp     (format nil "clisp-~A" (let ((s (lisp-implementation-version)))  
                                        (subseq s 0 (position #\space s))))  
   #+armedbear "abcl"  
   )  
21    
22  (defparameter *swank-pathname* (make-swank-pathname "swank"))  (cl:defpackage :swank-loader
23      (:use :cl)
24      (:export :load-swank
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       '("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       #+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      #+cmu       (substitute-if #\_ (lambda (x) (find x " /"))
65                                 (lisp-implementation-version))
66      #+scl       (lisp-implementation-version)
67      #+sbcl      (lisp-implementation-version)
68      #+ecl       (lisp-implementation-version)
69      #+openmcl   (format nil "~d.~d"
70                          ccl::*openmcl-major-version*
71                          ccl::*openmcl-minor-version*)
72      #+lispworks (lisp-implementation-version)
73      #+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      #+clisp     (let ((s (lisp-implementation-version)))
79                    (subseq s 0 (position #\space s)))
80      #+armedbear (lisp-implementation-version)
81      #+cormanlisp (lisp-implementation-version))
82    
83    (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                     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                                "No implementation feature found in ~a."
96                                *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    
107  (defun file-newer-p (new-file old-file)  (defun file-newer-p (new-file old-file)
108    "Returns true if NEW-FILE is newer than OLD-FILE."    "Returns true if NEW-FILE is newer than OLD-FILE."
109    (> (file-write-date new-file) (file-write-date old-file)))    (> (file-write-date new-file) (file-write-date old-file)))
110    
111  (defun binary-pathname (source-pathname)  (defun slime-version-string ()
112      "Return a string identifying the SLIME version.
113    Return nil if nothing appropriate is available."
114      (with-open-file (s (merge-pathnames "ChangeLog" *source-directory*)
115                         :if-does-not-exist nil)
116        (and s (symbol-name (read s)))))
117    
118    (defun default-fasl-directory ()
119      (merge-pathnames
120       (make-pathname
121        :directory `(:relative ".slime" "fasl"
122                     ,@(if (slime-version-string) (list (slime-version-string)))
123                     ,(unique-directory-name)))
124       (user-homedir-pathname)))
125    
126    (defun binary-pathname (source-pathname binary-directory)
127    "Return the pathname where SOURCE-PATHNAME's binary should be compiled."    "Return the pathname where SOURCE-PATHNAME's binary should be compiled."
128    (let ((cfp (compile-file-pathname source-pathname)))    (let ((cfp (compile-file-pathname source-pathname)))
129      (merge-pathnames (make-pathname      (merge-pathnames (make-pathname :name (pathname-name cfp)
130                        :directory `(:relative ".slime" "fasl" ,*lisp-name*)                                      :type (pathname-type cfp))
131                        :name (pathname-name cfp)                       binary-directory)))
132                        :type (pathname-type cfp))  
133                       (user-homedir-pathname))))  (defun handle-loadtime-error (condition binary-pathname)
134      (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      (when (equal (directory-namestring binary-pathname)
139                   (directory-namestring (default-fasl-directory)))
140        (ignore-errors (delete-file binary-pathname)))
141      (abort))
142    
143  (defun compile-files-if-needed-serially (files)  (defun compile-files-if-needed-serially (files fasl-directory load)
144    "Compile each file in FILES if the source is newer than    "Compile each file in FILES if the source is newer than
145  its corresponding binary, or the file preceding it was  its corresponding binary, or the file preceding it was
146  recompiled."  recompiled."
147    (with-compilation-unit ()    (let ((needs-recompile nil))
148      (let ((needs-recompile nil))      (dolist (source-pathname files)
149        (dolist (source-pathname files)        (let ((binary-pathname (binary-pathname source-pathname
150          (let ((binary-pathname (binary-pathname source-pathname)))                                                fasl-directory)))
151            (handler-case          (handler-case
152                (progn              (progn
153                  (when (or needs-recompile                (when (or needs-recompile
154                            (not (probe-file binary-pathname))                          (not (probe-file binary-pathname))
155                            (file-newer-p source-pathname binary-pathname))                          (file-newer-p source-pathname binary-pathname))
156                    (format t "~&;; Compiling ~A...~%" source-pathname)                  ;; need a to recompile source-pathname, so we'll
157                    (ensure-directories-exist binary-pathname)                  ;; need to recompile everything after this too.
158                    (compile-file source-pathname :output-file binary-pathname)                  (setq needs-recompile t)
159                    (setq needs-recompile t))                  (ensure-directories-exist binary-pathname)
160                  (load binary-pathname))                  (compile-file source-pathname :output-file binary-pathname
161              #+(or)                                :print nil
162              (error ()                                :verbose t))
163                ;; If an error occurs compiling, load the source instead                (when load
164                ;; so we can try to debug it.                  (load binary-pathname :verbose t)))
165                (load source-pathname))            ;; Fail as early as possible
166              ))))))            (serious-condition (c)
167                (handle-loadtime-error c binary-pathname)))))))
168  (defun user-init-file ()  
169    "Return the name of the user init file or nil."  #+(or cormanlisp ecl)
170    (probe-file (merge-pathnames (user-homedir-pathname)  (defun compile-files-if-needed-serially (files fasl-directory)
171                                 (make-pathname :name ".swank" :type "lisp"))))    "Corman Lisp and ECL have trouble with compiled files."
172      (declare (ignore fasl-directory))
173      (dolist (file files)
174  (compile-files-if-needed-serially      (load file :verbose t)
175    (append (list (make-swank-pathname "swank-backend"))      (force-output)))
176            *sysdep-pathnames*  
177            (list *swank-pathname*)))  (defun load-user-init-file ()
178      "Load the user init file, return NIL if it does not exist."
179  (funcall (intern (string :warn-unimplemented-interfaces) :swank-backend))    (load (merge-pathnames (user-homedir-pathname)
180                             (make-pathname :name ".swank" :type "lisp"))
181  (when (user-init-file)          :if-does-not-exist nil))
182    (load (user-init-file)))  
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.72

  ViewVC Help
Powered by ViewVC 1.1.5