/[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.88 by heller, Sun Aug 17 08:31:17 2008 UTC
# Line 1  Line 1 
1  ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-  ;;;; -*- indent-tabs-mode: nil -*-
2  ;;;  ;;;
3  ;;; swank-loader.lisp --- Compile and load the Slime backend.  ;;; swank-loader.lisp --- Compile and load the Slime backend.
4  ;;;  ;;;
# 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    
21  (defun make-swank-pathname (name &optional (type "lisp"))  (cl:defpackage :swank-loader
22    "Return a pathname with name component NAME in the Slime directory."    (:use :cl)
23    (merge-pathnames (make-pathname :name name :type type)    (:export :init
24                     (or *compile-file-pathname*             :dump-image
25                         *load-pathname*             :*source-directory*
26                         *default-pathname-defaults*)))             :*fasl-directory*))
27    
28  (defparameter *sysdep-pathnames*  (cl:in-package :swank-loader)
29    (mapcar #'make-swank-pathname  
30            (append  (defvar *source-directory*
31             '("nregex")    (make-pathname :name nil :type nil
32             #+cmu '("swank-source-path-parser" "swank-cmucl")                   :defaults (or *load-pathname* *default-pathname-defaults*))
33             #+sbcl '("swank-sbcl" "swank-source-path-parser" "swank-gray")    "The directory where to look for the source.")
34             #+openmcl '("metering" "swank-openmcl" "swank-gray")  
35             #+lispworks '("swank-lispworks" "swank-gray")  (defparameter *sysdep-files*
36             #+allegro '("swank-allegro" "swank-gray")    #+cmu '(swank-source-path-parser swank-source-file-cache swank-cmucl)
37             #+clisp '("xref" "metering" "swank-clisp" "swank-gray")    #+scl '(swank-source-path-parser swank-source-file-cache swank-scl)
38             #+armedbear '("swank-abcl")    #+sbcl '(swank-source-path-parser swank-source-file-cache
39             )))             swank-sbcl swank-gray)
40      #+openmcl '(metering swank-openmcl swank-gray)
41  (defparameter *lisp-name*    #+lispworks '(swank-lispworks swank-gray)
42    #+cmu       (format nil "cmu-~A"    #+allegro '(swank-allegro swank-gray)
43                        (substitute #\- #\/ (lisp-implementation-version)))    #+clisp '(xref metering swank-clisp swank-gray)
44    #+sbcl      (format nil "sbcl-~A" (lisp-implementation-version))    #+armedbear '(swank-abcl)
45    #+openmcl   "openmcl"    #+cormanlisp '(swank-corman swank-gray)
46    #+lispworks (format nil "lispworks-~A" (lisp-implementation-version))    #+ecl '(swank-source-path-parser swank-source-file-cache swank-ecl swank-gray))
47    #+allegro   (format nil "allegro-~A" excl::*common-lisp-version-number*)  
48    #+clisp     (format nil "clisp-~A" (let ((s (lisp-implementation-version)))  (defparameter *implementation-features*
49                                         (subseq s 0 (position #\space s))))    '(:allegro :lispworks :sbcl :openmcl :cmu :clisp :ccl :corman :cormanlisp
50    #+armedbear "abcl"      :armedbear :gcl :ecl :scl))
51    )  
52    (defparameter *os-features*
53  (defparameter *swank-pathname* (make-swank-pathname "swank"))    '(:macosx :linux :windows :mswindows :win32 :solaris :darwin :sunos :hpux
54        :unix))
55    
56    (defparameter *architecture-features*
57      '(:powerpc :ppc :x86 :x86-64 :amd64 :i686 :i586 :i486 :pc386 :iapx386
58        :sparc64 :sparc :hppa64 :hppa))
59    
60    (defun lisp-version-string ()
61      #+(or openmcl cmu)       (substitute-if #\_ (lambda (x) (find x " /"))
62                                 (lisp-implementation-version))
63      #+(or cormanlisp scl sbcl ecl)       (lisp-implementation-version)
64      #+lispworks (lisp-implementation-version)
65      #+allegro   (format nil
66                          "~A~A~A"
67                          excl::*common-lisp-version-number*
68                          (if (eq 'h 'H) "A" "M")     ; ANSI vs MoDeRn
69                          (if (member :64bit *features*) "-64bit" ""))
70      #+clisp     (let ((s (lisp-implementation-version)))
71                    (subseq s 0 (position #\space s)))
72      #+armedbear (lisp-implementation-version))
73    
74    (defun unique-dir-name ()
75      "Return a name that can be used as a directory name that is
76    unique to a Lisp implementation, Lisp implementation version,
77    operating system, and hardware architecture."
78      (flet ((first-of (features)
79               (loop for f in features
80                     when (find f *features*) return it))
81             (maybe-warn (value fstring &rest args)
82               (cond (value)
83                     (t (apply #'warn fstring args)
84                        "unknown"))))
85        (let ((lisp (maybe-warn (first-of *implementation-features*)
86                                "No implementation feature found in ~a."
87                                *implementation-features*))
88              (os   (maybe-warn (first-of *os-features*)
89                                "No os feature found in ~a." *os-features*))
90              (arch (maybe-warn (first-of *architecture-features*)
91                                "No architecture feature found in ~a."
92                                *architecture-features*))
93              (version (maybe-warn (lisp-version-string)
94                                   "Don't know how to get Lisp ~
95                                    implementation version.")))
96          (format nil "~(~@{~a~^-~}~)" lisp version os arch))))
97    
98  (defun file-newer-p (new-file old-file)  (defun file-newer-p (new-file old-file)
99    "Returns true if NEW-FILE is newer than OLD-FILE."    "Returns true if NEW-FILE is newer than OLD-FILE."
100    (> (file-write-date new-file) (file-write-date old-file)))    (> (file-write-date new-file) (file-write-date old-file)))
101    
102  (defun binary-pathname (source-pathname)  (defun slime-version-string ()
103    "Return the pathname where SOURCE-PATHNAME's binary should be compiled."    "Return a string identifying the SLIME version.
104    (let ((cfp (compile-file-pathname source-pathname)))  Return nil if nothing appropriate is available."
105      (merge-pathnames (make-pathname    (with-open-file (s (merge-pathnames "ChangeLog" *source-directory*)
106                        :directory `(:relative ".slime" "fasl" ,*lisp-name*)                       :if-does-not-exist nil)
107                        :name (pathname-name cfp)      (and s (symbol-name (read s)))))
108                        :type (pathname-type cfp))  
109                       (user-homedir-pathname))))  (defun default-fasl-dir ()
110      (merge-pathnames
111  (defun compile-files-if-needed-serially (files)     (make-pathname
112    "Compile each file in FILES if the source is newer than      :directory `(:relative ".slime" "fasl"
113  its corresponding binary, or the file preceding it was                   ,@(if (slime-version-string) (list (slime-version-string)))
114  recompiled."                   ,(unique-dir-name)))
115    (with-compilation-unit ()     (user-homedir-pathname)))
116      (let ((needs-recompile nil))  
117        (dolist (source-pathname files)  (defun binary-pathname (src-pathname binary-dir)
118          (let ((binary-pathname (binary-pathname source-pathname)))    "Return the pathname where SRC-PATHNAME's binary should be compiled."
119            (handler-case    (let ((cfp (compile-file-pathname src-pathname)))
120                (progn      (merge-pathnames (make-pathname :name (pathname-name cfp)
121                  (when (or needs-recompile                                      :type (pathname-type cfp))
122                            (not (probe-file binary-pathname))                       binary-dir)))
123                            (file-newer-p source-pathname binary-pathname))  
124                    (format t "~&;; Compiling ~A...~%" source-pathname)  (defun handle-loadtime-error (condition binary-pathname)
125                    (ensure-directories-exist binary-pathname)    (pprint-logical-block (*error-output* () :per-line-prefix ";; ")
126                    (compile-file source-pathname :output-file binary-pathname)      (format *error-output*
127                    (setq needs-recompile t))              "~%Error while loading: ~A~%Condition: ~A~%Aborting.~%"
128                  (load binary-pathname))              binary-pathname condition))
129              #+(or)    (when (equal (directory-namestring binary-pathname)
130              (error ()                 (directory-namestring (default-fasl-dir)))
131                ;; If an error occurs compiling, load the source instead      (ignore-errors (delete-file binary-pathname)))
132                ;; so we can try to debug it.    (abort))
133                (load source-pathname))  
134              ))))))  (defun compile-files (files fasl-dir load)
135      "Compile each file in FILES if the source is newer than its
136  (defun user-init-file ()  corresponding binary, or the file preceding it was recompiled.
137    "Return the name of the user init file or nil."  If LOAD is true, load the fasl file."
138    (probe-file (merge-pathnames (user-homedir-pathname)    (let ((needs-recompile nil))
139                                 (make-pathname :name ".swank" :type "lisp"))))      (dolist (src files)
140          (let ((dest (binary-pathname src fasl-dir)))
141            (handler-case
142  (compile-files-if-needed-serially              (progn
143    (append (list (make-swank-pathname "swank-backend"))                (when (or needs-recompile
144            *sysdep-pathnames*                          (not (probe-file dest))
145            (list *swank-pathname*)))                          (file-newer-p src dest))
146                    ;; need a to recompile src-pathname, so we'll
147  (funcall (intern (string :warn-unimplemented-interfaces) :swank-backend))                  ;; need to recompile everything after this too.
148                    (setq needs-recompile t)
149  (when (user-init-file)                  (ensure-directories-exist dest)
150    (load (user-init-file)))                  (compile-file src :output-file dest :print nil :verbose t))
151                  (when load
152                    (load dest :verbose t)))
153              ;; Fail as early as possible
154              (serious-condition (c)
155                (handle-loadtime-error c dest)))))))
156    
157    #+(or cormanlisp ecl)
158    (defun compile-files (files fasl-dir load)
159      "Corman Lisp and ECL have trouble with compiled files."
160      (declare (ignore fasl-dir))
161      (when load
162        (dolist (file files)
163          (load file :verbose t)
164          (force-output))))
165    
166    (defun load-user-init-file ()
167      "Load the user init file, return NIL if it does not exist."
168      (load (merge-pathnames (user-homedir-pathname)
169                             (make-pathname :name ".swank" :type "lisp"))
170            :if-does-not-exist nil))
171    
172    (defun load-site-init-file (dir)
173      (load (make-pathname :name "site-init" :type "lisp"
174                           :defaults dir)
175            :if-does-not-exist nil))
176    
177    (defun src-files (names src-dir)
178      (mapcar (lambda (name)
179                (make-pathname :name (string-downcase name) :type "lisp"
180                               :defaults src-dir))
181              names))
182    
183    (defvar *swank-files* `(swank-backend ,@*sysdep-files* swank))
184    
185    (defvar *contribs* '(swank-c-p-c swank-arglists swank-fuzzy
186                         swank-fancy-inspector
187                         swank-presentations swank-presentation-streams
188                         #+(or asdf sbcl) swank-asdf
189                         swank-package-fu
190                         )
191      "List of names for contrib modules.")
192    
193    (defvar *fasl-directory* (default-fasl-dir)
194      "The directory where fasl files should be placed.")
195    
196    (defun append-dir (absolute name)
197      (merge-pathnames
198       (make-pathname :directory `(:relative ,name) :defaults absolute)
199       absolute))
200    
201    (defun contrib-dir (base-dir)
202      (append-dir base-dir "contrib"))
203    
204    (defun q (s) (read-from-string s))
205    
206    (defun load-swank (&key (src-dir *source-directory*)
207                       (fasl-dir *fasl-directory*))
208      (compile-files (src-files *swank-files* src-dir) fasl-dir t)
209      (funcall (q "swank::before-init")
210               (slime-version-string)
211               (list (contrib-dir fasl-dir)
212                     (contrib-dir src-dir))))
213    
214    (defun compile-contribs (&key (src-dir (contrib-dir *source-directory*))
215                             (fasl-dir (contrib-dir *fasl-directory*))
216                             load)
217      (compile-files (src-files *contribs* src-dir) fasl-dir load))
218    
219    (defun loadup ()
220      (load-swank)
221      (compile-contribs :load t))
222    
223    (defun setup ()
224      (load-site-init-file *source-directory*)
225      (load-user-init-file)
226      (eval `(pushnew 'compile-contribs ,(q "swank::*after-init-hook*")))
227      (funcall (q "swank::init")))
228    
229    (defun init (&key delete reload load-contribs (setup t))
230      (when (and delete (find-package :swank))
231        (mapc #'delete-package '(:swank :swank-io-package :swank-backend)))
232      (cond ((or (not (find-package :swank)) reload)
233             (load-swank))
234            (t
235             (warn "Not reloading SWANK.  Package already exists.")))
236      (when load-contribs
237        (compile-contribs :load t))
238      (when setup
239        (setup)))
240    
241    (defun dump-image (filename)
242      (init :setup nil)
243      (funcall (q "swank-backend:save-image") filename))

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

  ViewVC Help
Powered by ViewVC 1.1.5