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

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

  ViewVC Help
Powered by ViewVC 1.1.5