/[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.6 by heller, Thu Nov 27 00:38:08 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            #+lispworks '("swank-lispworks" "swank-gray")             #+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 39  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 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)  (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
# Line 46  recompiled." Line 67  recompiled."
67    (with-compilation-unit ()    (with-compilation-unit ()
68      (let ((needs-recompile nil))      (let ((needs-recompile nil))
69        (dolist (source-pathname files)        (dolist (source-pathname files)
70          (let ((binary-pathname (compile-file-pathname source-pathname)))          (let ((binary-pathname (binary-pathname source-pathname)))
71            (handler-case            (handler-case
72                (progn                (progn
73                  (when (or needs-recompile                  (when (or needs-recompile
74                            (not (probe-file binary-pathname))                            (not (probe-file binary-pathname))
75                            (file-newer-p source-pathname binary-pathname))                            (file-newer-p source-pathname binary-pathname))
76                    (format t "~&;; Compiling ~A...~%" source-pathname)                    (format t "~&;; Compiling ~A...~%" source-pathname)
77                    (compile-file source-pathname)                    (ensure-directories-exist binary-pathname)
78                      (compile-file source-pathname :output-file binary-pathname)
79                    (setq needs-recompile t))                    (setq needs-recompile t))
80                  (load binary-pathname))                  (load binary-pathname))
81                #+(or)
82              (error ()              (error ()
83                ;; If an error occurs compiling, load the source instead                ;; If an error occurs compiling, load the source instead
84                ;; so we can try to debug it.                ;; so we can try to debug it.
85                (load source-pathname))))))))                (load source-pathname))
86                ))))))
87    
88  (defun user-init-file ()  (defun user-init-file ()
89    "Return the name of the user init file or nil."    "Return the name of the user init file or nil."
90    (let ((filename (format nil "~A/.swank.lisp"    (probe-file (merge-pathnames (user-homedir-pathname)
91                            (namestring (user-homedir-pathname)))))                                 (make-pathname :name ".swank" :type "lisp"))))
     (cond ((probe-file filename) filename)  
           (t nil))))  
92    
93    
94  (compile-files-if-needed-serially  (compile-files-if-needed-serially
95   (list* (make-swank-pathname "swank-backend") *swank-pathname*    (append (list (make-swank-pathname "swank-backend"))
96          *sysdep-pathnames*))            *sysdep-pathnames*
97              (list *swank-pathname*)))
98    
99    (funcall (intern (string :warn-unimplemented-interfaces) :swank-backend))
100    
101  (when (user-init-file)  (when (user-init-file)
102    (load (user-init-file)))    (load (user-init-file)))

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

  ViewVC Help
Powered by ViewVC 1.1.5