/[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.54 by heller, Tue Jan 17 20:29:58 2006 UTC
# Line 9  Line 9 
9  ;;;  ;;;
10    
11  (cl:defpackage :swank-loader  (cl:defpackage :swank-loader
12    (:use :common-lisp))    (:use :cl)
13      (:export :load-swank))
14    
15  (in-package :swank-loader)  (cl:in-package :swank-loader)
16    
17  (defun make-swank-pathname (name &optional (type "lisp"))  (defparameter *sysdep-files*
18    "Return a pathname with name component NAME in the Slime directory."    (append
19    (merge-pathnames (make-pathname :name name :type type)     '("nregex")
20                     (or *compile-file-pathname*     #+cmu '("swank-source-path-parser" "swank-source-file-cache" "swank-cmucl")
21                         *load-pathname*     #+scl '("swank-source-path-parser" "swank-source-file-cache" "swank-scl")
22                         *default-pathname-defaults*)))     #+sbcl '("swank-sbcl" "swank-source-path-parser"
23                "swank-source-file-cache" "swank-gray")
24  (defparameter *sysdep-pathnames*     #+openmcl '("metering" "swank-openmcl" "swank-gray")
25    (mapcar #'make-swank-pathname     #+lispworks '("swank-lispworks" "swank-gray")
26            (append     #+allegro '("swank-allegro" "swank-gray")
27             '("nregex")     #+clisp '("xref" "metering" "swank-clisp" "swank-gray")
28             #+cmu '("swank-source-path-parser" "swank-cmucl")     #+armedbear '("swank-abcl")
29             #+sbcl '("swank-sbcl" "swank-source-path-parser" "swank-gray")     #+cormanlisp '("swank-corman" "swank-gray")
30             #+openmcl '("metering" "swank-openmcl" "swank-gray")     #+ecl '("swank-ecl" "swank-gray")
31             #+lispworks '("swank-lispworks" "swank-gray")     ))
32             #+allegro '("swank-allegro" "swank-gray")  
33             #+clisp '("xref" "metering" "swank-clisp" "swank-gray")  (defparameter *implementation-features*
34             #+armedbear '("swank-abcl")    '(:allegro :lispworks :sbcl :openmcl :cmu :clisp :ccl :corman :cormanlisp
35             )))      :armedbear :gcl :ecl :scl))
36    
37  (defparameter *lisp-name*  (defparameter *os-features*
38    #+cmu       (format nil "cmu-~A"    '(:macosx :linux :windows :mswindows :win32 :solaris :darwin :sunos :hpux
39                        (substitute #\- #\/ (lisp-implementation-version)))      :unix))
40    #+sbcl      (format nil "sbcl-~A" (lisp-implementation-version))  
41    #+openmcl   "openmcl"  (defparameter *architecture-features*
42    #+lispworks (format nil "lispworks-~A" (lisp-implementation-version))    '(:powerpc :ppc :x86 :x86-64 :amd64 :i686 :i586 :i486 :pc386 :iapx386
43    #+allegro   (format nil "allegro-~A" excl::*common-lisp-version-number*)      :sparc64 :sparc :hppa64 :hppa))
44    #+clisp     (format nil "clisp-~A" (let ((s (lisp-implementation-version)))  
45                                         (subseq s 0 (position #\space s))))  (defun lisp-version-string ()
46    #+armedbear "abcl"    #+cmu       (substitute-if #\_ (lambda (x) (find x " /"))
47    )                               (lisp-implementation-version))
48      #+scl       (lisp-implementation-version)
49  (defparameter *swank-pathname* (make-swank-pathname "swank"))    #+sbcl      (lisp-implementation-version)
50      #+ecl       (lisp-implementation-version)
51      #+openmcl   (format nil "~d.~d"
52                          ccl::*openmcl-major-version*
53                          ccl::*openmcl-minor-version*)
54      #+lispworks (lisp-implementation-version)
55      #+allegro   excl::*common-lisp-version-number*
56      #+clisp     (let ((s (lisp-implementation-version)))
57                    (subseq s 0 (position #\space s)))
58      #+armedbear (lisp-implementation-version)
59      #+cormanlisp (lisp-implementation-version))
60    
61    (defun unique-directory-name ()
62      "Return a name that can be used as a directory name that is
63    unique to a Lisp implementation, Lisp implementation version,
64    operating system, and hardware architecture."
65      (flet ((first-of (features)
66               (loop for f in features
67                     when (find f *features*) return it))
68             (maybe-warn (value fstring &rest args)
69               (cond (value)
70                     (t (apply #'warn fstring args)
71                        "unknown"))))
72        (let ((lisp (maybe-warn (first-of *implementation-features*)
73                                "No implementation feature found in ~a."
74                                *implementation-features*))
75              (os   (maybe-warn (first-of *os-features*)
76                                "No os feature found in ~a." *os-features*))
77              (arch (maybe-warn (first-of *architecture-features*)
78                                "No architecture feature found in ~a."
79                                *architecture-features*))
80              (version (maybe-warn (lisp-version-string)
81                                   "Don't know how to get Lisp ~
82                                    implementation version.")))
83          (format nil "~(~@{~a~^-~}~)" lisp version os arch))))
84    
85  (defun file-newer-p (new-file old-file)  (defun file-newer-p (new-file old-file)
86    "Returns true if NEW-FILE is newer than OLD-FILE."    "Returns true if NEW-FILE is newer than OLD-FILE."
87    (> (file-write-date new-file) (file-write-date old-file)))    (> (file-write-date new-file) (file-write-date old-file)))
88    
89  (defun binary-pathname (source-pathname)  (defun default-fasl-directory ()
90      (merge-pathnames
91       (make-pathname
92        :directory `(:relative ".slime" "fasl" ,(unique-directory-name)))
93       (user-homedir-pathname)))
94    
95    (defun binary-pathname (source-pathname binary-directory)
96    "Return the pathname where SOURCE-PATHNAME's binary should be compiled."    "Return the pathname where SOURCE-PATHNAME's binary should be compiled."
97    (let ((cfp (compile-file-pathname source-pathname)))    (let ((cfp (compile-file-pathname source-pathname)))
98      (merge-pathnames (make-pathname      (merge-pathnames (make-pathname :name (pathname-name cfp)
99                        :directory `(:relative ".slime" "fasl" ,*lisp-name*)                                      :type (pathname-type cfp))
100                        :name (pathname-name cfp)                       binary-directory)))
101                        :type (pathname-type cfp))  
                      (user-homedir-pathname))))  
102    
103  (defun compile-files-if-needed-serially (files)  (defun compile-files-if-needed-serially (files fasl-directory)
104    "Compile each file in FILES if the source is newer than    "Compile each file in FILES if the source is newer than
105  its corresponding binary, or the file preceding it was  its corresponding binary, or the file preceding it was
106  recompiled."  recompiled."
107    (with-compilation-unit ()    (with-compilation-unit ()
108      (let ((needs-recompile nil))      (let ((needs-recompile nil))
109        (dolist (source-pathname files)        (dolist (source-pathname files)
110          (let ((binary-pathname (binary-pathname source-pathname)))          (let ((binary-pathname (binary-pathname source-pathname
111                                                    fasl-directory)))
112            (handler-case            (handler-case
113                (progn                (progn
114                  (when (or needs-recompile                  (when (or needs-recompile
115                            (not (probe-file binary-pathname))                            (not (probe-file binary-pathname))
116                            (file-newer-p source-pathname binary-pathname))                            (file-newer-p source-pathname binary-pathname))
                   (format t "~&;; Compiling ~A...~%" source-pathname)  
117                    (ensure-directories-exist binary-pathname)                    (ensure-directories-exist binary-pathname)
118                    (compile-file source-pathname :output-file binary-pathname)                    (compile-file source-pathname :output-file binary-pathname
119                                    :print nil :verbose t)
120                    (setq needs-recompile t))                    (setq needs-recompile t))
121                  (load binary-pathname))                  (load binary-pathname :verbose t))
122              #+(or)              #+(or)
123              (error ()              (error ()
124                ;; If an error occurs compiling, load the source instead                ;; If an error occurs compiling, load the source instead
# Line 85  recompiled." Line 126  recompiled."
126                (load source-pathname))                (load source-pathname))
127              ))))))              ))))))
128    
129  (defun user-init-file ()  #+(or cormanlisp ecl)
130    "Return the name of the user init file or nil."  (defun compile-files-if-needed-serially (files fasl-directory)
131    (probe-file (merge-pathnames (user-homedir-pathname)    "Corman Lisp and ECL have trouble with compiled files."
132                                 (make-pathname :name ".swank" :type "lisp"))))    (declare (ignore fasl-directory))
133      (dolist (file files)
134        (load file :verbose t)
135  (compile-files-if-needed-serially      (force-output)))
136    (append (list (make-swank-pathname "swank-backend"))  
137            *sysdep-pathnames*  (defun load-user-init-file ()
138            (list *swank-pathname*)))    "Load the user init file, return NIL if it does not exist."
139      (load (merge-pathnames (user-homedir-pathname)
140  (funcall (intern (string :warn-unimplemented-interfaces) :swank-backend))                           (make-pathname :name ".swank" :type "lisp"))
141            :if-does-not-exist nil))
142  (when (user-init-file)  
143    (load (user-init-file)))  (defun load-site-init-file (directory)
144      (load (make-pathname :name "site-init" :type "lisp"
145                           :defaults directory)
146            :if-does-not-exist nil))
147    
148    (defun swank-source-files (source-directory)
149      (mapcar (lambda (name)
150                (merge-pathnames (make-pathname :name name :type "lisp")
151                                 source-directory))
152              `("swank-backend" ,@*sysdep-files* "swank")))
153    
154    (defun load-swank (&key
155                       (fasl-directory (default-fasl-directory))
156                       (source-directory #.(or *compile-file-pathname*
157                                               *load-pathname*
158                                               *default-pathname-defaults*)))
159      (compile-files-if-needed-serially (swank-source-files source-directory)
160                                        fasl-directory)
161      (funcall (intern (string :warn-unimplemented-interfaces) :swank-backend))
162      (load-site-init-file source-directory)
163      (load-user-init-file))

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

  ViewVC Help
Powered by ViewVC 1.1.5