← Back to branch summary

~ubuntu-branches/ubuntu/trusty/slime/trusty

« back to all changes in this revision

Viewing changes to swank-loader.lisp

  • Committer: Bazaar Package Importer
  • Author(s): Peter Van Eynde
  • Date: 2006-12-05 10:35:50 UTC
  • mfrom: (1.1.2 upstream)
  • Revision ID: james.westby@ubuntu.com-20061205103550-qh2ij11czkh5x7ns
Tags: 1:20061201-2
Fix stupid merge error that I missed. 

Show diffs side-by-side

added added

removed removed

Lines of Context:
swank-loader.lisp
21
21
 
22
22
(cl:defpackage :swank-loader
23
23
  (:use :cl)
24
 
  (:export :load-swank 
 
24
  (:export :load-swank
25
25
           :*source-directory*
26
26
           :*fasl-directory*))
27
27
 
28
28
(cl:in-package :swank-loader)
29
29
 
30
 
(defvar *source-directory* 
31
 
  (make-pathname :name nil :type nil 
 
30
(defvar *source-directory*
 
31
  (make-pathname :name nil :type nil
32
32
                 :defaults (or *load-pathname* *default-pathname-defaults*))
33
33
  "The directory where to look for the source.")
34
34
 
35
35
(defparameter *sysdep-files*
36
 
  (append 
 
36
  (append
37
37
   '("nregex")
38
38
   #+cmu '("swank-source-path-parser" "swank-source-file-cache" "swank-cmucl")
39
39
   #+scl '("swank-source-path-parser" "swank-source-file-cache" "swank-scl")
49
49
   ))
50
50
 
51
51
(defparameter *implementation-features*
52
 
  '(:allegro :lispworks :sbcl :openmcl :cmu :clisp :ccl :corman :cormanlisp 
 
52
  '(:allegro :lispworks :sbcl :openmcl :cmu :clisp :ccl :corman :cormanlisp
53
53
    :armedbear :gcl :ecl :scl))
54
54
 
55
55
(defparameter *os-features*
67
67
  #+sbcl      (lisp-implementation-version)
68
68
  #+ecl       (lisp-implementation-version)
69
69
  #+openmcl   (format nil "~d.~d"
70
 
                      ccl::*openmcl-major-version* 
 
70
                      ccl::*openmcl-major-version*
71
71
                      ccl::*openmcl-minor-version*)
72
72
  #+lispworks (lisp-implementation-version)
73
 
  #+allegro   (concatenate 'string (if (eq 'h 'H) "A" "M")     ; ANSI vs MoDeRn
74
 
                           excl::*common-lisp-version-number*)
 
73
  #+allegro   (format nil
 
74
                      "~A~A~A"
 
75
                      excl::*common-lisp-version-number*
 
76
                      (if (eq 'h 'H) "A" "M")     ; ANSI vs MoDeRn
 
77
                      (if (member :64bit *features*) "-64bit" ""))
75
78
  #+clisp     (let ((s (lisp-implementation-version)))
76
79
                (subseq s 0 (position #\space s)))
77
80
  #+armedbear (lisp-implementation-version)
78
81
  #+cormanlisp (lisp-implementation-version))
79
 
  
 
82
 
80
83
(defun unique-directory-name ()
81
84
  "Return a name that can be used as a directory name that is
82
85
unique to a Lisp implementation, Lisp implementation version,
89
92
                 (t (apply #'warn fstring args)
90
93
                    "unknown"))))
91
94
    (let ((lisp (maybe-warn (first-of *implementation-features*)
92
 
                            "No implementation feature found in ~a." 
 
95
                            "No implementation feature found in ~a."
93
96
                            *implementation-features*))
94
97
          (os   (maybe-warn (first-of *os-features*)
95
98
                            "No os feature found in ~a." *os-features*))
105
108
  "Returns true if NEW-FILE is newer than OLD-FILE."
106
109
  (> (file-write-date new-file) (file-write-date old-file)))
107
110
 
108
 
;; Currently just use the modification time of the ChangeLog.  We
109
 
;; could also try to use one of those CVS keywords.
110
111
(defun slime-version-string ()
111
112
  "Return a string identifying the SLIME version.
112
113
Return nil if nothing appropriate is available."
113
 
  (let* ((changelog "/usr/share/doc/cl-swank/changelog")
114
 
         (date (file-write-date changelog)))
115
 
    (cond (date (multiple-value-bind (_s _m _h date month year)
116
 
                    (decode-universal-time date)
117
 
                  (declare (ignore _s _m _h))
118
 
                  (format nil "~D-~2,'0D-~2,'0D" year month date)))
119
 
          (t nil))))
 
114
  (with-open-file (s "/usr/share/doc/cl-swank/changelog" 
 
115
                     :if-does-not-exist nil)
 
116
    (and s (symbol-name (read s)))))
120
117
 
121
118
(defun default-fasl-directory ()
122
119
  (merge-pathnames
123
 
   (make-pathname  
124
 
    :directory `(:relative ".slime" "fasl" 
 
120
   (make-pathname
 
121
    :directory `(:relative ".slime" "fasl"
125
122
                 ,@(if (slime-version-string) (list (slime-version-string)))
126
123
                 ,(unique-directory-name)))
127
124
   (user-homedir-pathname)))
137
134
                                    :type (pathname-type cfp))
138
135
           (clc:calculate-fasl-root))))
139
136
 
 
137
 
 
138
(defun handle-loadtime-error (condition binary-pathname)
 
139
  (format *error-output*
 
140
          "~%~<;; ~@;Error while loading: ~A~%  Condition: ~A~%Aborting.~:>~%"
 
141
          (list binary-pathname condition))
 
142
  (when (equal (directory-namestring binary-pathname)
 
143
               (directory-namestring (default-fasl-directory)))
 
144
    (ignore-errors (delete-file binary-pathname)))
 
145
  (abort))
 
146
 
140
147
(defun compile-files-if-needed-serially (files fasl-directory)
141
148
  "Compile each file in FILES if the source is newer than
142
 
its corresponding binary, or the file preceding it was 
 
149
its corresponding binary, or the file preceding it was
143
150
recompiled."
144
151
  (with-compilation-unit ()
145
152
    (let ((needs-recompile nil))
151
158
                (when (or needs-recompile
152
159
                          (not (probe-file binary-pathname))
153
160
                          (file-newer-p source-pathname binary-pathname))
 
161
                  ;; need a to recompile source-pathname, so we'll
 
162
                  ;; need to recompile everything after this too.
 
163
                  (setq needs-recompile t)
154
164
                  (ensure-directories-exist binary-pathname)
155
165
                  (compile-file source-pathname :output-file binary-pathname
156
 
                                :print nil :verbose t)
157
 
                  (setq needs-recompile t))
 
166
                                :print nil
 
167
                                :verbose t))
158
168
                (load binary-pathname :verbose t))
159
 
            #+(or)
160
 
            (error ()
161
 
              ;; If an error occurs compiling, load the source instead
162
 
              ;; so we can try to debug it.
163
 
              (load source-pathname))
164
 
            ))))))
 
169
            ;; Fail as early as possible
 
170
            (serious-condition (c)
 
171
              (handle-loadtime-error c binary-pathname))))))))
165
172
 
166
173
#+(or cormanlisp ecl)
167
174
(defun compile-files-if-needed-serially (files fasl-directory)
191
198
(defvar *fasl-directory* (default-fasl-directory)
192
199
  "The directory where fasl files should be placed.")
193
200
 
194
 
(defun load-swank (&key 
 
201
(defun load-swank (&key
195
202
                   (source-directory *source-directory*)
196
203
                   (fasl-directory *fasl-directory*))
197
 
  (compile-files-if-needed-serially (swank-source-files source-directory) 
 
204
  (compile-files-if-needed-serially (swank-source-files source-directory)
198
205
                                    fasl-directory)
 
206
  (set (read-from-string "swank::*swank-wire-protocol-version*")
 
207
       (slime-version-string))
199
208
  (funcall (intern (string :warn-unimplemented-interfaces) :swank-backend))
200
209
  (load-site-init-file source-directory)
201
 
  (load-user-init-file))
 
210
  (load-user-init-file)
 
211
  (funcall (intern (string :run-after-init-hook) :swank)))
202
212
 
203
213
(load-swank)