/[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.17.2.1 by heller, Tue Mar 9 09:00:23 2004 UTC revision 1.117 by heller, Sat Jan 5 08:50:12 2013 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 7  Line 7 
7  ;;; This code has been placed in the Public Domain.  All warranties  ;;; This code has been placed in the Public Domain.  All warranties
8  ;;; are disclaimed.  ;;; are disclaimed.
9  ;;;  ;;;
 ;;;   $Id$  
 ;;;  
   
 (cl:defpackage :swank-loader  
   (:use :common-lisp))  
10    
11  (in-package :swank-loader)  ;; If you want customize the source- or fasl-directory you can set
12    ;; swank-loader:*source-directory* resp. swank-loader:*fasl-directory*
13    ;; before loading this files.
14    ;; E.g.:
15    ;;
16    ;;   (load ".../swank-loader.lisp")
17    ;;   (setq swank-loader::*fasl-directory* "/tmp/fasl/")
18    ;;   (swank-loader:init)
19    
20  (defun make-swank-pathname (name &optional (type "lisp"))  (cl:defpackage :swank-loader
21    "Return a pathname with name component NAME in the Slime directory."    (:use :cl)
22    (merge-pathnames name    (:export :init
23                     (make-pathname             :dump-image
24                      :type type             :*source-directory*
25                      :directory             :*fasl-directory*))
26                      (pathname-directory  
27                       (or *compile-file-pathname* *load-pathname*  (cl:in-package :swank-loader)
28                           *default-pathname-defaults*)))))  
29    (defvar *source-directory*
30  (defparameter *sysdep-pathnames*    (make-pathname :name nil :type nil
31    (mapcar #'make-swank-pathname                   :defaults (or *load-pathname* *default-pathname-defaults*))
32            #+cmu '("swank-source-path-parser" "swank-cmucl")    "The directory where to look for the source.")
33            #+sbcl '("swank-sbcl" "swank-source-path-parser" "swank-gray")  
34            #+openmcl '("swank-openmcl" "swank-gray")  (defparameter *sysdep-files*
35            #+lispworks '("swank-lispworks" "swank-gray")    #+cmu '(swank-source-path-parser swank-source-file-cache swank-cmucl)
36            #+allegro '("swank-allegro" "swank-gray")    #+scl '(swank-source-path-parser swank-source-file-cache swank-scl)
37            #+clisp '("xref" "metering" "swank-clisp" "swank-gray")    #+sbcl '(swank-source-path-parser swank-source-file-cache
38            ))             swank-sbcl swank-gray)
39      #+clozure '(metering swank-ccl swank-gray)
40  (defparameter *lisp-name*    #+lispworks '(swank-lispworks swank-gray)
41    #+cmu "cmu"    #+allegro '(swank-allegro swank-gray)
42    #+sbcl "sbcl"    #+clisp '(xref metering swank-clisp swank-gray)
43    #+openmcl "openmcl"    #+armedbear '(swank-abcl)
44    #+lispworks "lispworks"    #+cormanlisp '(swank-corman swank-gray)
45    #+allegro "allegro"    #+ecl '(swank-source-path-parser swank-source-file-cache
46    #+clisp "clisp")            swank-ecl swank-gray))
47    
48  (defparameter *swank-pathname* (make-swank-pathname "swank"))  (defparameter *implementation-features*
49      '(:allegro :lispworks :sbcl :clozure :cmu :clisp :ccl :corman :cormanlisp
50        :armedbear :gcl :ecl :scl))
51    
52    (defparameter *os-features*
53      '(:macosx :linux :windows :mswindows :win32 :solaris :darwin :sunos :hpux
54        :unix))
55    
56    (defparameter *architecture-features*
57      '(:powerpc :ppc :x86 :x86-64 :x86_64 :amd64 :i686 :i586 :i486 :pc386 :iapx386
58        :sparc64 :sparc :hppa64 :hppa :arm
59        :pentium3 :pentium4
60        :java-1.4 :java-1.5 :java-1.6 :java-1.7))
61    
62    (defun q (s) (read-from-string s))
63    
64    #+ecl
65    (defun ecl-version-string ()
66      (format nil "~A~@[-~A~]"
67              (lisp-implementation-version)
68              (when (find-symbol "LISP-IMPLEMENTATION-VCS-ID" :ext)
69                (let ((vcs-id (funcall (q "ext:lisp-implementation-vcs-id"))))
70                  (when (>= (length vcs-id) 8)
71                    (subseq vcs-id 0 8))))))
72    
73    (defun lisp-version-string ()
74      #+(or clozure cmu) (substitute-if #\_ (lambda (x) (find x " /"))
75                                        (lisp-implementation-version))
76      #+(or cormanlisp scl) (lisp-implementation-version)
77      #+sbcl (format nil "~a~:[~;-no-threads~]"
78                     (lisp-implementation-version)
79                     #+sb-thread nil
80                     #-sb-thread t)
81      #+lispworks (lisp-implementation-version)
82      #+allegro   (format nil "~@{~a~}"
83                          excl::*common-lisp-version-number*
84                          (if (eq 'h 'H) "A" "M")     ; ANSI vs MoDeRn
85                          (if (member :smp *features*) "s" "")
86                          (if (member :64bit *features*) "-64bit" "")
87                          (excl:ics-target-case
88                           (:-ics "")
89                           (:+ics "-ics")))
90      #+clisp     (let ((s (lisp-implementation-version)))
91                    (subseq s 0 (position #\space s)))
92      #+armedbear (lisp-implementation-version)
93      #+ecl (ecl-version-string) )
94    
95    (defun unique-dir-name ()
96      "Return a name that can be used as a directory name that is
97    unique to a Lisp implementation, Lisp implementation version,
98    operating system, and hardware architecture."
99      (flet ((first-of (features)
100               (loop for f in features
101                     when (find f *features*) return it))
102             (maybe-warn (value fstring &rest args)
103               (cond (value)
104                     (t (apply #'warn fstring args)
105                        "unknown"))))
106        (let ((lisp (maybe-warn (first-of *implementation-features*)
107                                "No implementation feature found in ~a."
108                                *implementation-features*))
109              (os   (maybe-warn (first-of *os-features*)
110                                "No os feature found in ~a." *os-features*))
111              (arch (maybe-warn (first-of *architecture-features*)
112                                "No architecture feature found in ~a."
113                                *architecture-features*))
114              (version (maybe-warn (lisp-version-string)
115                                   "Don't know how to get Lisp ~
116                                    implementation version.")))
117          (format nil "~(~@{~a~^-~}~)" lisp version os arch))))
118    
119  (defun file-newer-p (new-file old-file)  (defun file-newer-p (new-file old-file)
120    "Returns true if NEW-FILE is newer than OLD-FILE."    "Returns true if NEW-FILE is newer than OLD-FILE."
121    (> (file-write-date new-file) (file-write-date old-file)))    (> (file-write-date new-file) (file-write-date old-file)))
122    
123  (defun binary-pathname (source-pathname)  (defun slime-version-string ()
124    (merge-pathnames    "Return a string identifying the SLIME version.
125     (make-pathname :directory `(:relative "fasl" ,*lisp-name*))  Return nil if nothing appropriate is available."
126     (merge-pathnames (compile-file-pathname source-pathname))))    (with-open-file (s (merge-pathnames "ChangeLog" *source-directory*)
127                         :if-does-not-exist nil)
128  (defun compile-files-if-needed-serially (files)      (and s (symbol-name (read s)))))
   "Compile each file in FILES if the source is newer than  
 its corresponding binary, or the file preceding it was  
 recompiled."  
   (with-compilation-unit ()  
     (let ((needs-recompile nil))  
       (dolist (source-pathname files)  
         (let ((binary-pathname (binary-pathname source-pathname)))  
           (handler-case  
               (progn  
                 (when (or needs-recompile  
                           (not (probe-file binary-pathname))  
                           (file-newer-p source-pathname binary-pathname))  
                   (format t "~&;; Compiling ~A...~%" source-pathname)  
                   (ensure-directories-exist binary-pathname)  
                   (compile-file source-pathname :output-file binary-pathname)  
                   (setq needs-recompile t))  
                 (load binary-pathname))  
             #+(or)  
             (error ()  
               ;; If an error occurs compiling, load the source instead  
               ;; so we can try to debug it.  
               (load source-pathname))  
             ))))))  
   
 (defun user-init-file ()  
   "Return the name of the user init file or nil."  
   (probe-file  
    (merge-pathnames (user-homedir-pathname)  
                     #-mswindows (make-pathname :name ".swank" :type "lisp")  
                     #+mswindows (make-pathname :name "_swank" :type "lsp"))))  
   
 (compile-files-if-needed-serially  
   (append (list (make-swank-pathname "swank-backend"))  
           *sysdep-pathnames*  
           (list *swank-pathname*)))  
   
 (funcall (intern (string :warn-unimplemented-interfaces) :swank-backend))  
   
 (when (user-init-file)  
   (load (user-init-file)))  
129    
130    (defun default-fasl-dir ()
131      (merge-pathnames
132       (make-pathname
133        :directory `(:relative ".slime" "fasl"
134                     ,@(if (slime-version-string) (list (slime-version-string)))
135                     ,(unique-dir-name)))
136       (user-homedir-pathname)))
137    
138    (defvar *fasl-directory* (default-fasl-dir)
139      "The directory where fasl files should be placed.")
140    
141    (defun binary-pathname (src-pathname binary-dir)
142      "Return the pathname where SRC-PATHNAME's binary should be compiled."
143      (let ((cfp (compile-file-pathname src-pathname)))
144        (merge-pathnames (make-pathname :name (pathname-name cfp)
145                                        :type (pathname-type cfp))
146                         binary-dir)))
147    
148    (defun handle-swank-load-error (condition context pathname)
149      (fresh-line *error-output*)
150      (pprint-logical-block (*error-output* () :per-line-prefix ";; ")
151        (format *error-output*
152                "~%Error while ~A ~A:~%  ~A~%Aborting.~%"
153                context pathname condition))
154      (when (equal (directory-namestring pathname)
155                   (directory-namestring *fasl-directory*))
156        (ignore-errors (delete-file pathname)))
157      (abort))
158    
159    (defun compile-files (files fasl-dir load quiet)
160      "Compile each file in FILES if the source is newer than its
161    corresponding binary, or the file preceding it was recompiled.
162    If LOAD is true, load the fasl file."
163      (let ((needs-recompile nil)
164            (state :unknown))
165        (dolist (src files)
166          (let ((dest (binary-pathname src fasl-dir)))
167            (handler-case
168                (progn
169                  (when (or needs-recompile
170                            (not (probe-file dest))
171                            (file-newer-p src dest))
172                    (ensure-directories-exist dest)
173                    ;; need to recompile SRC, so we'll need to recompile
174                    ;; everything after this too.
175                    (setq needs-recompile t)
176                    (setq state :compile)
177                    (or (compile-file src :output-file dest :print nil
178                                      :verbose (not quiet))
179                        ;; An implementation may not necessarily signal a
180                        ;; condition itself when COMPILE-FILE fails (e.g. ECL)
181                        (error "COMPILE-FILE returned NIL.")))
182                  (when load
183                    (setq state :load)
184                    (load dest :verbose (not quiet))))
185              ;; Fail as early as possible
186              (serious-condition (c)
187                (ecase state
188                  (:compile (handle-swank-load-error c "compiling" src))
189                  (:load    (handle-swank-load-error c "loading" dest))
190                  (:unknown (handle-swank-load-error c "???ing" src)))))))))
191    
192    #+(or cormanlisp)
193    (defun compile-files (files fasl-dir load quiet)
194      "Corman Lisp has trouble with compiled files."
195      (declare (ignore fasl-dir))
196      (when load
197        (dolist (file files)
198          (load file :verbose (not quiet)
199          (force-output)))))
200    
201    (defun load-user-init-file ()
202      "Load the user init file, return NIL if it does not exist."
203      (load (merge-pathnames (user-homedir-pathname)
204                             (make-pathname :name ".swank" :type "lisp"))
205            :if-does-not-exist nil))
206    
207    (defun load-site-init-file (dir)
208      (load (make-pathname :name "site-init" :type "lisp"
209                           :defaults dir)
210            :if-does-not-exist nil))
211    
212    (defun src-files (names src-dir)
213      (mapcar (lambda (name)
214                (make-pathname :name (string-downcase name) :type "lisp"
215                               :defaults src-dir))
216              names))
217    
218    (defvar *swank-files*
219      `(swank-backend ,@*sysdep-files* swank-match swank-rpc swank))
220    
221    (defvar *contribs*
222      '(swank-util swank-repl
223        swank-c-p-c swank-arglists swank-fuzzy
224        swank-fancy-inspector
225        swank-presentations swank-presentation-streams
226        #+(or asdf sbcl ecl) swank-asdf
227        swank-package-fu
228        swank-hyperdoc
229        #+sbcl swank-sbcl-exts
230        swank-mrepl
231        )
232      "List of names for contrib modules.")
233    
234    (defun append-dir (absolute name)
235      (merge-pathnames
236       (make-pathname :directory `(:relative ,name) :defaults absolute)
237       absolute))
238    
239    (defun contrib-dir (base-dir)
240      (append-dir base-dir "contrib"))
241    
242    (defun load-swank (&key (src-dir *source-directory*)
243                         (fasl-dir *fasl-directory*)
244                         quiet)
245      (compile-files (src-files *swank-files* src-dir) fasl-dir t quiet)
246      (funcall (q "swank::before-init")
247               (slime-version-string)
248               (list (contrib-dir fasl-dir)
249                     (contrib-dir src-dir))))
250    
251    (defun delete-stale-contrib-fasl-files (swank-files contrib-files fasl-dir)
252      (let ((newest (reduce #'max (mapcar #'file-write-date swank-files))))
253        (dolist (src contrib-files)
254          (let ((fasl (binary-pathname src fasl-dir)))
255            (when (and (probe-file fasl)
256                       (<= (file-write-date fasl) newest))
257              (delete-file fasl))))))
258    
259    (defun compile-contribs (&key (src-dir (contrib-dir *source-directory*))
260                               (fasl-dir (contrib-dir *fasl-directory*))
261                               (swank-src-dir *source-directory*)
262                               load quiet)
263      (let* ((swank-src-files (src-files *swank-files* swank-src-dir))
264             (contrib-src-files (src-files *contribs* src-dir)))
265        (delete-stale-contrib-fasl-files swank-src-files contrib-src-files
266                                         fasl-dir)
267        (compile-files contrib-src-files fasl-dir load quiet)))
268    
269    (defun loadup ()
270      (load-swank)
271      (compile-contribs :load t))
272    
273    (defun setup ()
274      (load-site-init-file *source-directory*)
275      (load-user-init-file)
276      (when (#-clisp probe-file
277             #+clisp ext:probe-directory
278             (contrib-dir *source-directory*))
279        (eval `(pushnew 'compile-contribs ,(q "swank::*after-init-hook*"))))
280      (funcall (q "swank::init")))
281    
282    (defun init (&key delete reload load-contribs (setup t)
283                   (quiet (not *load-verbose*)))
284      "Load SWANK and initialize some global variables.
285    If DELETE is true, delete any existing SWANK packages.
286    If RELOAD is true, reload SWANK, even if the SWANK package already exists.
287    If LOAD-CONTRIBS is true, load all contribs
288    If SETUP is true, load user init files and initialize some
289    global variabes in SWANK."
290      (when (and delete (find-package :swank))
291        (mapc #'delete-package '(:swank :swank-io-package :swank-backend)))
292      (cond ((or (not (find-package :swank)) reload)
293             (load-swank :quiet quiet))
294            (t
295             (warn "Not reloading SWANK.  Package already exists.")))
296      (when load-contribs
297        (compile-contribs :load t :quiet quiet))
298      (when setup
299        (setup)))
300    
301    (defun dump-image (filename)
302      (init :setup nil)
303      (funcall (q "swank-backend:save-image") filename))

Legend:
Removed from v.1.17.2.1  
changed lines
  Added in v.1.117

  ViewVC Help
Powered by ViewVC 1.1.5