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

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

  ViewVC Help
Powered by ViewVC 1.1.5