/[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.91 by heller, Sun Jul 26 08:00:40 2009 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 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 :clozure :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 clozure 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                         swank-sbcl-exts
191                         )
192      "List of names for contrib modules.")
193    
194    (defvar *fasl-directory* (default-fasl-dir)
195      "The directory where fasl files should be placed.")
196    
197    (defun append-dir (absolute name)
198      (merge-pathnames
199       (make-pathname :directory `(:relative ,name) :defaults absolute)
200       absolute))
201    
202    (defun contrib-dir (base-dir)
203      (append-dir base-dir "contrib"))
204    
205    (defun q (s) (read-from-string s))
206    
207    (defun load-swank (&key (src-dir *source-directory*)
208                       (fasl-dir *fasl-directory*))
209      (compile-files (src-files *swank-files* src-dir) fasl-dir t)
210      (funcall (q "swank::before-init")
211               (slime-version-string)
212               (list (contrib-dir fasl-dir)
213                     (contrib-dir src-dir))))
214    
215    (defun compile-contribs (&key (src-dir (contrib-dir *source-directory*))
216                             (fasl-dir (contrib-dir *fasl-directory*))
217                             load)
218      (compile-files (src-files *contribs* src-dir) fasl-dir load))
219    
220    (defun loadup ()
221      (load-swank)
222      (compile-contribs :load t))
223    
224    (defun setup ()
225      (load-site-init-file *source-directory*)
226      (load-user-init-file)
227      (eval `(pushnew 'compile-contribs ,(q "swank::*after-init-hook*")))
228      (funcall (q "swank::init")))
229    
230    (defun init (&key delete reload load-contribs (setup t))
231      "Load SWANK and initialize some global variables.
232    If DELETE is true, delete any existing SWANK packages.
233    If RELOAD is true, reload SWANK, even if the SWANK package already exists.
234    If LOAD-CONTRIBS is true, load all contribs
235    If SETUP is true, load user init files and initialize some
236    global variabes in SWANK."
237      (when (and delete (find-package :swank))
238        (mapc #'delete-package '(:swank :swank-io-package :swank-backend)))
239      (cond ((or (not (find-package :swank)) reload)
240             (load-swank))
241            (t
242             (warn "Not reloading SWANK.  Package already exists.")))
243      (when load-contribs
244        (compile-contribs :load t))
245      (when setup
246        (setup)))
247    
248    (defun dump-image (filename)
249      (init :setup nil)
250      (funcall (q "swank-backend:save-image") filename))

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

  ViewVC Help
Powered by ViewVC 1.1.5