/[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.35 by asimon, Sun Sep 26 17:09:13 2004 UTC revision 1.43 by lgorrie, Sat Mar 12 01:49:48 2005 UTC
# Line 24  Line 24 
24    (mapcar #'make-swank-pathname    (mapcar #'make-swank-pathname
25            (append            (append
26             '("nregex")             '("nregex")
27             #+cmu '("swank-source-path-parser" "swank-cmucl")             #+cmu '("swank-source-path-parser"  "swank-source-file-cache" "swank-cmucl")
28             #+sbcl '("swank-sbcl" "swank-source-path-parser" "swank-gray")             #+sbcl '("swank-sbcl" "swank-source-path-parser" "swank-source-file-cache" "swank-gray")
29             #+openmcl '("metering" "swank-openmcl" "swank-gray")             #+openmcl '("metering" "swank-openmcl" "swank-gray")
30             #+lispworks '("swank-lispworks" "swank-gray")             #+lispworks '("swank-lispworks" "swank-gray")
31             #+allegro '("swank-allegro" "swank-gray")             #+allegro '("swank-allegro" "swank-gray")
# Line 33  Line 33 
33             #+armedbear '("swank-abcl")             #+armedbear '("swank-abcl")
34             )))             )))
35    
36  (defparameter *lisp-name*  (defparameter *implementation-features*
37    #+cmu       (format nil "cmu-~A"    '(:allegro :sbcl :openmcl :cmu :clisp :ccl :corman :armedbear :gcl))
38                        (substitute #\- #\/ (lisp-implementation-version)))  
39    #+sbcl      (format nil "sbcl-~A" (lisp-implementation-version))  (defparameter *os-features*
40    #+openmcl   "openmcl"    '(:macosx :linux :windows :solaris :darwin :sunos :unix))
41    #+lispworks (format nil "lispworks-~A" (lisp-implementation-version))  
42    #+allegro   (format nil "allegro-~A" excl::*common-lisp-version-number*)  (defparameter *architecture-features*
43    #+clisp     (format nil "clisp-~A" (let ((s (lisp-implementation-version)))    '(:powerpc :ppc :x86 :x86-64 :i686 :pc386 :sparc))
44                                         (subseq s 0 (position #\space s))))  
45    #+armedbear "abcl"  (defun unique-directory-name ()
46    )    "Return a name that can be used as a directory name that is
47    unique to a Lisp implementation, Lisp implementation version,
48    operating system, and hardware architecture."
49      (flet ((first-of (features)
50               (loop for f in features
51                  when (find f *features*) return it)))
52        (let ((lisp         (first-of *implementation-features*))
53              (os           (first-of *os-features*))
54              (architecture (first-of *architecture-features*))
55              (version
56               (block nil
57                 #+cmu
58                 (return (substitute #\- #\/ (lisp-implementation-version)))
59                 #+sbcl
60                 (return (lisp-implementation-version))
61                 #+gcl
62                 (let ((s (lisp-implementation-version))) (subseq s 4))
63                 #+openmcl
64                 (return (format nil "~d.~d"
65                                 ccl::*openmcl-major-version*
66                                 ccl::*openmcl-minor-version*))
67                 #+lispworks
68                 (return (lisp-implementation-version))
69                 #+allegro
70                 (return excl::*common-lisp-version-number*)
71                 #+clisp
72                 (return (let ((s (lisp-implementation-version)))
73                           (subseq s 0 (position #\space s))))
74                 #+armedbear
75                 (return "unknown")
76    
77                 (warn "Don't know how to get Lisp implementation version.")
78                 (return "unknown"))))
79    
80          (unless lisp
81            (warn "No implementation feature found in ~a."
82                  *implementation-features*)
83            (setf lisp "unknown"))
84          (unless os
85            (warn "No os feature found in ~a." *os-features*)
86            (setf os "unknown"))
87          (unless architecture
88            (warn "No architecture feature found in ~a."
89                  *architecture-features*)
90            (setf architecture "unknown"))
91    
92          (format nil "~(~@{~a~^-~}~)" lisp version os architecture))))
93    
94  (defparameter *swank-pathname* (make-swank-pathname "swank"))  (defparameter *swank-pathname* (make-swank-pathname "swank"))
95    
# Line 55  Line 101 
101    "Return the pathname where SOURCE-PATHNAME's binary should be compiled."    "Return the pathname where SOURCE-PATHNAME's binary should be compiled."
102    (let ((cfp (compile-file-pathname source-pathname)))    (let ((cfp (compile-file-pathname source-pathname)))
103      (merge-pathnames (make-pathname      (merge-pathnames (make-pathname
104                        :directory `(:relative ".slime" "fasl" ,*lisp-name*)                        :directory
105                          `(:relative ".slime" "fasl" ,(unique-directory-name))
106                        :name (pathname-name cfp)                        :name (pathname-name cfp)
107                        :type (pathname-type cfp))                        :type (pathname-type cfp))
108                       (user-homedir-pathname))))                       (user-homedir-pathname))))
# Line 73  recompiled." Line 120  recompiled."
120                  (when (or needs-recompile                  (when (or needs-recompile
121                            (not (probe-file binary-pathname))                            (not (probe-file binary-pathname))
122                            (file-newer-p source-pathname binary-pathname))                            (file-newer-p source-pathname binary-pathname))
                   (format t "~&;; Compiling ~A...~%" source-pathname)  
123                    (ensure-directories-exist binary-pathname)                    (ensure-directories-exist binary-pathname)
124                    (compile-file source-pathname :output-file binary-pathname)                    (compile-file source-pathname :output-file binary-pathname
125                                    :print nil :verbose t)
126                    (setq needs-recompile t))                    (setq needs-recompile t))
127                  (load binary-pathname))                  (load binary-pathname :verbose t))
128              #+(or)              #+(or)
129              (error ()              (error ()
130                ;; If an error occurs compiling, load the source instead                ;; If an error occurs compiling, load the source instead
# Line 85  recompiled." Line 132  recompiled."
132                (load source-pathname))                (load source-pathname))
133              ))))))              ))))))
134    
 (defun user-init-file ()  
   "Return the name of the user init file or nil."  
   (probe-file (merge-pathnames (user-homedir-pathname)  
                                (make-pathname :name ".swank" :type "lisp"))))  
   
   
135  (compile-files-if-needed-serially  (compile-files-if-needed-serially
136    (append (list (make-swank-pathname "swank-backend"))    (append (list (make-swank-pathname "swank-backend"))
137            *sysdep-pathnames*            *sysdep-pathnames*
# Line 98  recompiled." Line 139  recompiled."
139    
140  (funcall (intern (string :warn-unimplemented-interfaces) :swank-backend))  (funcall (intern (string :warn-unimplemented-interfaces) :swank-backend))
141    
142  (when (user-init-file)  (defun load-user-init-file ()
143    (load (user-init-file)))    "Load the user init file, return NIL if it does not exist."
144      (load (merge-pathnames (user-homedir-pathname)
145                             (make-pathname :name ".swank" :type "lisp"))
146            :if-does-not-exist nil))
147    (export 'load-user-init-file)
148    
149    (defun load-site-init-file ()
150      (load (make-pathname :name "site-init" :type "lisp"
151                           :defaults *load-truename*)
152            :if-does-not-exist nil))
153    
154    (or (load-site-init-file)
155        (load-user-init-file))
156    

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

  ViewVC Help
Powered by ViewVC 1.1.5