/[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.65 by trittweiler, Thu May 17 11:41:34 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)
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                (load binary-pathname :verbose t))
164                ;; so we can try to debug it.            ;; Fail as early as possible
165                (load source-pathname))            (serious-condition (c)
166              ))))))              (handle-loadtime-error c binary-pathname)))))))
167    
168  (defun user-init-file ()  #+(or cormanlisp ecl)
169    "Return the name of the user init file or nil."  (defun compile-files-if-needed-serially (files fasl-directory)
170    (probe-file (merge-pathnames (user-homedir-pathname)    "Corman Lisp and ECL have trouble with compiled files."
171                                 (make-pathname :name ".swank" :type "lisp"))))    (declare (ignore fasl-directory))
172      (dolist (file files)
173        (load file :verbose t)
174  (compile-files-if-needed-serially      (force-output)))
175    (append (list (make-swank-pathname "swank-backend"))  
176            *sysdep-pathnames*  (defun load-user-init-file ()
177            (list *swank-pathname*)))    "Load the user init file, return NIL if it does not exist."
178      (load (merge-pathnames (user-homedir-pathname)
179  (funcall (intern (string :warn-unimplemented-interfaces) :swank-backend))                           (make-pathname :name ".swank" :type "lisp"))
180            :if-does-not-exist nil))
181  (when (user-init-file)  
182    (load (user-init-file)))  (defun load-site-init-file (directory)
183      (load (make-pathname :name "site-init" :type "lisp"
184                           :defaults directory)
185            :if-does-not-exist nil))
186    
187    (defun swank-source-files (source-directory)
188      (mapcar (lambda (name)
189                (make-pathname :name name :type "lisp"
190                               :defaults source-directory))
191              `("swank-backend" ,@*sysdep-files* "swank")))
192    
193    (defvar *fasl-directory* (default-fasl-directory)
194      "The directory where fasl files should be placed.")
195    
196    (defun load-swank (&key
197                       (source-directory *source-directory*)
198                       (fasl-directory *fasl-directory*))
199      (compile-files-if-needed-serially (swank-source-files source-directory)
200                                        fasl-directory)
201      (set (read-from-string "swank::*swank-wire-protocol-version*")
202           (slime-version-string))
203      (funcall (intern (string :warn-unimplemented-interfaces) :swank-backend))
204      (load-site-init-file source-directory)
205      (load-user-init-file)
206      (funcall (intern (string :run-after-init-hook) :swank)))
207    
208    (load-swank)

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

  ViewVC Help
Powered by ViewVC 1.1.5