/[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.16 by wjenkner, Thu Feb 5 05:57:04 2004 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  (cl:defpackage :swank-loader  (cl:defpackage :swank-loader
12    (:use :common-lisp))    (:use :common-lisp))
# Line 17  Line 15 
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-source-path-parser" "swank-cmucl")            (append
26            #+sbcl '("swank-sbcl" "swank-source-path-parser" "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            #+allegro '("swank-allegro" "swank-gray")             #+openmcl '("metering" "swank-openmcl" "swank-gray")
30            #+clisp '("xref" "metering" "swank-clisp" "swank-gray")             #+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 41  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 48  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)              #+(or)
# Line 67  recompiled." Line 87  recompiled."
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    (probe-file    (probe-file (merge-pathnames (user-homedir-pathname)
91     (merge-pathnames (user-homedir-pathname)                                 (make-pathname :name ".swank" :type "lisp"))))
                     #-mswindows (make-pathname :name ".swank" :type "lisp")  
                     #+mswindows (make-pathname :name "_swank" :type "lsp"))))  
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))  (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.16  
changed lines
  Added in v.1.35

  ViewVC Help
Powered by ViewVC 1.1.5