/[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.3 by heller, Sun Nov 16 18:10:25 2003 UTC revision 1.35 by asimon, Sun Sep 26 17:09:13 2004 UTC
# 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$  
 ;;;  
10    
11  (defpackage :swank-loader  (cl:defpackage :swank-loader
12    (:use :common-lisp))    (:use :common-lisp))
13    
14  (in-package :swank-loader)  (in-package :swank-loader)
15    
16  (defun make-swank-pathname (name &optional (type "lisp"))  (defun make-swank-pathname (name &optional (type "lisp"))
17    "Return a pathname with name component NAME in the Slime directory."    "Return a pathname with name component NAME in the Slime directory."
18    (merge-pathnames name    (merge-pathnames (make-pathname :name name :type type)
19                     (make-pathname                     (or *compile-file-pathname*
20                      :type type                         *load-pathname*
21                      :directory                         *default-pathname-defaults*)))
                     (pathname-directory  
                      (or *compile-file-pathname* *load-pathname*  
                          *default-pathname-defaults*)))))  
22    
23  (defparameter *sysdep-pathnames*  (defparameter *sysdep-pathnames*
24    (mapcar #'make-swank-pathname    (mapcar #'make-swank-pathname
25             #+cmu '("swank-cmucl")            (append
26             #+sbcl '("swank-sbcl" "swank-gray")             '("nregex")
27             #+openmcl '("swank-openmcl" "swank-gray")))             #+cmu '("swank-source-path-parser" "swank-cmucl")
28               #+sbcl '("swank-sbcl" "swank-source-path-parser" "swank-gray")
29               #+openmcl '("metering" "swank-openmcl" "swank-gray")
30               #+lispworks '("swank-lispworks" "swank-gray")
31               #+allegro '("swank-allegro" "swank-gray")
32               #+clisp '("xref" "metering" "swank-clisp" "swank-gray")
33               #+armedbear '("swank-abcl")
34               )))
35    
36    (defparameter *lisp-name*
37      #+cmu       (format nil "cmu-~A"
38                          (substitute #\- #\/ (lisp-implementation-version)))
39      #+sbcl      (format nil "sbcl-~A" (lisp-implementation-version))
40      #+openmcl   "openmcl"
41      #+lispworks (format nil "lispworks-~A" (lisp-implementation-version))
42      #+allegro   (format nil "allegro-~A" excl::*common-lisp-version-number*)
43      #+clisp     (format nil "clisp-~A" (let ((s (lisp-implementation-version)))
44                                           (subseq s 0 (position #\space s))))
45      #+armedbear "abcl"
46      )
47    
48  (defparameter *swank-pathname* (make-swank-pathname "swank"))  (defparameter *swank-pathname* (make-swank-pathname "swank"))
49    
# Line 36  Line 51 
51    "Returns true if NEW-FILE is newer than OLD-FILE."    "Returns true if NEW-FILE is newer than OLD-FILE."
52    (> (file-write-date new-file) (file-write-date old-file)))    (> (file-write-date new-file) (file-write-date old-file)))
53    
54  (defun compile-files-if-needed-serially (&rest files)  (defun binary-pathname (source-pathname)
55      "Return the pathname where SOURCE-PATHNAME's binary should be compiled."
56      (let ((cfp (compile-file-pathname source-pathname)))
57        (merge-pathnames (make-pathname
58                          :directory `(:relative ".slime" "fasl" ,*lisp-name*)
59                          :name (pathname-name cfp)
60                          :type (pathname-type cfp))
61                         (user-homedir-pathname))))
62    
63    (defun compile-files-if-needed-serially (files)
64    "Compile each file in FILES if the source is newer than    "Compile each file in FILES if the source is newer than
65  its corresponding binary, or the file preceding it was  its corresponding binary, or the file preceding it was
66  recompiled."  recompiled."
67    (let ((needs-recompile nil))    (with-compilation-unit ()
68      (dolist (source-pathname files)      (let ((needs-recompile nil))
69        (let ((binary-pathname (compile-file-pathname source-pathname)))        (dolist (source-pathname files)
70          (handler-case          (let ((binary-pathname (binary-pathname source-pathname)))
71              (progn            (handler-case
72                (when (or needs-recompile                (progn
73                          (not (probe-file binary-pathname))                  (when (or needs-recompile
74                          (file-newer-p source-pathname binary-pathname))                            (not (probe-file binary-pathname))
75                  (format t "~&;; Compiling ~A...~%" source-pathname)                            (file-newer-p source-pathname binary-pathname))
76                  (compile-file source-pathname)                    (format t "~&;; Compiling ~A...~%" source-pathname)
77                  (setq needs-recompile t))                    (ensure-directories-exist binary-pathname)
78                (load binary-pathname))                    (compile-file source-pathname :output-file binary-pathname)
79            (error ()                    (setq needs-recompile t))
80              ;; If an error occurs compiling, load the source instead                  (load binary-pathname))
81              ;; so we can try to debug it.              #+(or)
82              (load source-pathname)))))))              (error ()
83                  ;; If an error occurs compiling, load the source instead
84                  ;; so we can try to debug it.
85                  (load source-pathname))
86                ))))))
87    
88    (defun user-init-file ()
89      "Return the name of the user init file or nil."
90      (probe-file (merge-pathnames (user-homedir-pathname)
91                                   (make-pathname :name ".swank" :type "lisp"))))
92    
93    
94    (compile-files-if-needed-serially
95      (append (list (make-swank-pathname "swank-backend"))
96              *sysdep-pathnames*
97              (list *swank-pathname*)))
98    
99    (funcall (intern (string :warn-unimplemented-interfaces) :swank-backend))
100    
101  (apply #'compile-files-if-needed-serially *swank-pathname* *sysdep-pathnames*)  (when (user-init-file)
102      (load (user-init-file)))
103    

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

  ViewVC Help
Powered by ViewVC 1.1.5