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

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

  ViewVC Help
Powered by ViewVC 1.1.5