/[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.99 by trittweiler, Tue Feb 16 11:28:19 2010 UTC revision 1.100 by trittweiler, Sat Feb 20 18:20:46 2010 UTC
# Line 56  Line 56 
56    
57  (defparameter *architecture-features*  (defparameter *architecture-features*
58    '(:powerpc :ppc :x86 :x86-64 :amd64 :i686 :i586 :i486 :pc386 :iapx386    '(:powerpc :ppc :x86 :x86-64 :amd64 :i686 :i586 :i486 :pc386 :iapx386
59      :sparc64 :sparc :hppa64 :hppa))      :sparc64 :sparc :hppa64 :hppa
60        :pentium3 :pentium4))
61    
62  (defun lisp-version-string ()  (defun lisp-version-string ()
63    #+(or clozure cmu) (substitute-if #\_ (lambda (x) (find x " /"))    #+(or clozure cmu) (substitute-if #\_ (lambda (x) (find x " /"))
# Line 117  Return nil if nothing appropriate is ava Line 118  Return nil if nothing appropriate is ava
118                   ,(unique-dir-name)))                   ,(unique-dir-name)))
119     (user-homedir-pathname)))     (user-homedir-pathname)))
120    
121    (defvar *fasl-directory* (default-fasl-dir)
122      "The directory where fasl files should be placed.")
123    
124  (defun binary-pathname (src-pathname binary-dir)  (defun binary-pathname (src-pathname binary-dir)
125    "Return the pathname where SRC-PATHNAME's binary should be compiled."    "Return the pathname where SRC-PATHNAME's binary should be compiled."
126    (let ((cfp (compile-file-pathname src-pathname)))    (let ((cfp (compile-file-pathname src-pathname)))
# Line 124  Return nil if nothing appropriate is ava Line 128  Return nil if nothing appropriate is ava
128                                      :type (pathname-type cfp))                                      :type (pathname-type cfp))
129                       binary-dir)))                       binary-dir)))
130    
131  (defun handle-loadtime-error (condition binary-pathname)  (defun handle-swank-load-error (condition context pathname)
132      (fresh-line *error-output*)
133    (pprint-logical-block (*error-output* () :per-line-prefix ";; ")    (pprint-logical-block (*error-output* () :per-line-prefix ";; ")
134      (format *error-output*      (format *error-output*
135              "~%Error while loading: ~A~%Condition: ~A~%Aborting.~%"              "~%Error while ~A ~A:~%  ~A~%Aborting.~%"
136              binary-pathname condition))              context pathname condition))
137    (when (equal (directory-namestring binary-pathname)    (when (equal (directory-namestring pathname)
138                 (directory-namestring (default-fasl-dir)))                 (directory-namestring *fasl-directory*))
139      (ignore-errors (delete-file binary-pathname)))      (ignore-errors (delete-file pathname)))
140    (abort))    (abort))
141    
142  (defun compile-files (files fasl-dir load)  (defun compile-files (files fasl-dir load)
143    "Compile each file in FILES if the source is newer than its    "Compile each file in FILES if the source is newer than its
144  corresponding binary, or the file preceding it was recompiled.  corresponding binary, or the file preceding it was recompiled.
145  If LOAD is true, load the fasl file."  If LOAD is true, load the fasl file."
146    (let ((needs-recompile nil))    (let ((needs-recompile nil)
147            (state :unknown))
148      (dolist (src files)      (dolist (src files)
149        (let ((dest (binary-pathname src fasl-dir)))        (let ((dest (binary-pathname src fasl-dir)))
150          (handler-case          (handler-case
# Line 146  If LOAD is true, load the fasl file." Line 152  If LOAD is true, load the fasl file."
152                (when (or needs-recompile                (when (or needs-recompile
153                          (not (probe-file dest))                          (not (probe-file dest))
154                          (file-newer-p src dest))                          (file-newer-p src dest))
                 ;; need a to recompile src-pathname, so we'll  
                 ;; need to recompile everything after this too.  
                 (setq needs-recompile t)  
155                  (ensure-directories-exist dest)                  (ensure-directories-exist dest)
156                  (compile-file src :output-file dest :print nil :verbose t))                  ;; need to recompile SRC, so we'll need to recompile
157                    ;; everything after this too.
158                    (setq needs-recompile t)
159                    (setq state :compile)
160                    (or (compile-file src :output-file dest :print nil :verbose t)
161                        ;; An implementation may not necessarily signal a
162                        ;; condition itself when COMPILE-FILE fails (e.g. ECL)
163                        (error "COMPILE-FILE returned NIL.")))
164                (when load                (when load
165                    (setq state :load)
166                  (load dest :verbose t)))                  (load dest :verbose t)))
167            ;; Fail as early as possible            ;; Fail as early as possible
168            (serious-condition (c)            (serious-condition (c)
169              (handle-loadtime-error c dest)))))))              (ecase state
170                  (:compile (handle-swank-load-error c "compiling" src))
171                  (:load    (handle-swank-load-error c "loading" dest))
172                  (:unknown (handle-swank-load-error c "???ing" src)))))))))
173    
174  #+(or cormanlisp)  #+(or cormanlisp)
175  (defun compile-files (files fasl-dir load)  (defun compile-files (files fasl-dir load)
# Line 197  If LOAD is true, load the fasl file." Line 211  If LOAD is true, load the fasl file."
211      )      )
212    "List of names for contrib modules.")    "List of names for contrib modules.")
213    
 (defvar *fasl-directory* (default-fasl-dir)  
   "The directory where fasl files should be placed.")  
   
214  (defun append-dir (absolute name)  (defun append-dir (absolute name)
215    (merge-pathnames    (merge-pathnames
216     (make-pathname :directory `(:relative ,name) :defaults absolute)     (make-pathname :directory `(:relative ,name) :defaults absolute)
# Line 211  If LOAD is true, load the fasl file." Line 222  If LOAD is true, load the fasl file."
222  (defun q (s) (read-from-string s))  (defun q (s) (read-from-string s))
223    
224  (defun load-swank (&key (src-dir *source-directory*)  (defun load-swank (&key (src-dir *source-directory*)
225                     (fasl-dir *fasl-directory*))                          (fasl-dir *fasl-directory*))
226    (compile-files (src-files *swank-files* src-dir) fasl-dir t)    (compile-files (src-files *swank-files* src-dir) fasl-dir t)
227    (funcall (q "swank::before-init")    (funcall (q "swank::before-init")
228             (slime-version-string)             (slime-version-string)

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

  ViewVC Help
Powered by ViewVC 1.1.5