/[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.57 by heller, Sat Feb 25 14:57:21 2006 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-sbcl" "swank-source-path-parser"
41                "swank-source-file-cache" "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   excl::*common-lisp-version-number*
74      #+clisp     (let ((s (lisp-implementation-version)))
75                    (subseq s 0 (position #\space s)))
76      #+armedbear (lisp-implementation-version)
77      #+cormanlisp (lisp-implementation-version))
78    
79    (defun unique-directory-name ()
80      "Return a name that can be used as a directory name that is
81    unique to a Lisp implementation, Lisp implementation version,
82    operating system, and hardware architecture."
83      (flet ((first-of (features)
84               (loop for f in features
85                     when (find f *features*) return it))
86             (maybe-warn (value fstring &rest args)
87               (cond (value)
88                     (t (apply #'warn fstring args)
89                        "unknown"))))
90        (let ((lisp (maybe-warn (first-of *implementation-features*)
91                                "No implementation feature found in ~a."
92                                *implementation-features*))
93              (os   (maybe-warn (first-of *os-features*)
94                                "No os feature found in ~a." *os-features*))
95              (arch (maybe-warn (first-of *architecture-features*)
96                                "No architecture feature found in ~a."
97                                *architecture-features*))
98              (version (maybe-warn (lisp-version-string)
99                                   "Don't know how to get Lisp ~
100                                    implementation version.")))
101          (format nil "~(~@{~a~^-~}~)" lisp version os arch))))
102    
103  (defun file-newer-p (new-file old-file)  (defun file-newer-p (new-file old-file)
104    "Returns true if NEW-FILE is newer than OLD-FILE."    "Returns true if NEW-FILE is newer than OLD-FILE."
105    (> (file-write-date new-file) (file-write-date old-file)))    (> (file-write-date new-file) (file-write-date old-file)))
106    
107  (defun binary-pathname (source-pathname)  ;; Currently just use the modification time of the ChangeLog.  We
108    ;; could also try to use one of those CVS keywords.
109    (defun slime-version-string ()
110      "Return a string identifying the SLIME version.
111    Return nil if nothing appropriate is available."
112      (let* ((changelog (merge-pathnames "ChangeLog" *source-directory*))
113             (date (file-write-date changelog)))
114        (cond (date (multiple-value-bind (_s _m _h date month year)
115                        (decode-universal-time date)
116                      (declare (ignore _s _m _h))
117                      (format nil "~D-~2,'0D-~2,'0D" year month date)))
118              (t nil))))
119    
120    (defun default-fasl-directory ()
121      (merge-pathnames
122       (make-pathname
123        :directory `(:relative ".slime" "fasl"
124                     ,@(if (slime-version-string) (list (slime-version-string)))
125                     ,(unique-directory-name)))
126       (user-homedir-pathname)))
127    
128    (defun binary-pathname (source-pathname binary-directory)
129    "Return the pathname where SOURCE-PATHNAME's binary should be compiled."    "Return the pathname where SOURCE-PATHNAME's binary should be compiled."
130    (let ((cfp (compile-file-pathname source-pathname)))    (let ((cfp (compile-file-pathname source-pathname)))
131      (merge-pathnames (make-pathname      (merge-pathnames (make-pathname :name (pathname-name cfp)
132                        :directory `(:relative ".slime" "fasl" ,*lisp-name*)                                      :type (pathname-type cfp))
133                        :name (pathname-name cfp)                       binary-directory)))
                       :type (pathname-type cfp))  
                      (user-homedir-pathname))))  
134    
135  (defun compile-files-if-needed-serially (files)  (defun compile-files-if-needed-serially (files fasl-directory)
136    "Compile each file in FILES if the source is newer than    "Compile each file in FILES if the source is newer than
137  its corresponding binary, or the file preceding it was  its corresponding binary, or the file preceding it was
138  recompiled."  recompiled."
139    (with-compilation-unit ()    (with-compilation-unit ()
140      (let ((needs-recompile nil))      (let ((needs-recompile nil))
141        (dolist (source-pathname files)        (dolist (source-pathname files)
142          (let ((binary-pathname (binary-pathname source-pathname)))          (let ((binary-pathname (binary-pathname source-pathname
143                                                    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 binary-pathname))
148                            (file-newer-p source-pathname binary-pathname))                            (file-newer-p source-pathname binary-pathname))
                   (format t "~&;; Compiling ~A...~%" source-pathname)  
149                    (ensure-directories-exist binary-pathname)                    (ensure-directories-exist binary-pathname)
150                    (compile-file source-pathname :output-file binary-pathname)                    (compile-file source-pathname :output-file binary-pathname
151                                    :print nil :verbose t)
152                    (setq needs-recompile t))                    (setq needs-recompile t))
153                  (load binary-pathname))                  (load binary-pathname :verbose t))
154              #+(or)              #+(or)
155              (error ()              (error ()
156                ;; If an error occurs compiling, load the source instead                ;; If an error occurs compiling, load the source instead
# Line 85  recompiled." Line 158  recompiled."
158                (load source-pathname))                (load source-pathname))
159              ))))))              ))))))
160    
161  (defun user-init-file ()  #+(or cormanlisp ecl)
162    "Return the name of the user init file or nil."  (defun compile-files-if-needed-serially (files fasl-directory)
163    (probe-file (merge-pathnames (user-homedir-pathname)    "Corman Lisp and ECL have trouble with compiled files."
164                                 (make-pathname :name ".swank" :type "lisp"))))    (declare (ignore fasl-directory))
165      (dolist (file files)
166        (load file :verbose t)
167  (compile-files-if-needed-serially      (force-output)))
168    (append (list (make-swank-pathname "swank-backend"))  
169            *sysdep-pathnames*  (defun load-user-init-file ()
170            (list *swank-pathname*)))    "Load the user init file, return NIL if it does not exist."
171      (load (merge-pathnames (user-homedir-pathname)
172  (funcall (intern (string :warn-unimplemented-interfaces) :swank-backend))                           (make-pathname :name ".swank" :type "lisp"))
173            :if-does-not-exist nil))
174  (when (user-init-file)  
175    (load (user-init-file)))  (defun load-site-init-file (directory)
176      (load (make-pathname :name "site-init" :type "lisp"
177                           :directory (pathname-directory directory))
178            :if-does-not-exist nil))
179    
180    (defun swank-source-files (source-directory)
181      (mapcar (lambda (name)
182                (make-pathname :name name :type "lisp"
183                               :directory (pathname-directory source-directory)))
184              `("swank-backend" ,@*sysdep-files* "swank")))
185    
186    (defvar *fasl-directory* (default-fasl-directory)
187      "The directory where fasl files should be placed.")
188    
189    (defun load-swank (&key
190                       (source-directory *source-directory*)
191                       (fasl-directory *fasl-directory*))
192      (compile-files-if-needed-serially (swank-source-files source-directory)
193                                        fasl-directory)
194      (funcall (intern (string :warn-unimplemented-interfaces) :swank-backend))
195      (load-site-init-file source-directory)
196      (load-user-init-file))
197    
198    (load-swank)

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

  ViewVC Help
Powered by ViewVC 1.1.5