/[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.50 by heller, Sun Jul 3 15:40:23 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"
28             #+sbcl '("swank-sbcl" "swank-source-path-parser" "swank-gray")                     "swank-cmucl")
29               #+sbcl '("swank-sbcl" "swank-source-path-parser"
30                        "swank-source-file-cache" "swank-gray")
31             #+openmcl '("metering" "swank-openmcl" "swank-gray")             #+openmcl '("metering" "swank-openmcl" "swank-gray")
32             #+lispworks '("swank-lispworks" "swank-gray")             #+lispworks '("swank-lispworks" "swank-gray")
33             #+allegro '("swank-allegro" "swank-gray")             #+allegro '("swank-allegro" "swank-gray")
34             #+clisp '("xref" "metering" "swank-clisp" "swank-gray")             #+clisp '("xref" "metering" "swank-clisp" "swank-gray")
35             #+armedbear '("swank-abcl")             #+armedbear '("swank-abcl")
36               #+cormanlisp '("swank-corman" "swank-gray")
37             )))             )))
38    
39  (defparameter *lisp-name*  (defparameter *implementation-features*
40    #+cmu       (format nil "cmu-~A"    '(:allegro :lispworks :sbcl :openmcl :cmu :clisp :ccl :corman :cormanlisp :armedbear :gcl :ecl))
41                        (substitute #\- #\/ (lisp-implementation-version)))  
42    #+sbcl      (format nil "sbcl-~A" (lisp-implementation-version))  (defparameter *os-features*
43    #+openmcl   "openmcl"    '(:macosx :linux :windows :mswindows :win32 :solaris :darwin :sunos :unix))
44    #+lispworks (format nil "lispworks-~A" (lisp-implementation-version))  
45    #+allegro   (format nil "allegro-~A" excl::*common-lisp-version-number*)  (defparameter *architecture-features*
46    #+clisp     (format nil "clisp-~A" (let ((s (lisp-implementation-version)))    '(:powerpc :ppc :x86 :x86-64 :i686 :pc386 :iapx386 :sparc))
47                                         (subseq s 0 (position #\space s))))  
48    #+armedbear "abcl"  (defun lisp-version-string ()
49    )    #+cmu       (substitute #\- #\/ (lisp-implementation-version))
50      #+sbcl      (lisp-implementation-version)
51      #+ecl       (lisp-implementation-version)
52      #+gcl       (let ((s (lisp-implementation-version))) (subseq s 4))
53      #+openmcl   (format nil "~d.~d"
54                          ccl::*openmcl-major-version*
55                          ccl::*openmcl-minor-version*)
56      #+lispworks (lisp-implementation-version)
57      #+allegro   excl::*common-lisp-version-number*
58      #+clisp     (let ((s (lisp-implementation-version)))
59                    (subseq s 0 (position #\space s)))
60      #+armedbear (lisp-implementation-version)
61      #+cormanlisp (lisp-implementation-version))
62    
63    (defun unique-directory-name ()
64      "Return a name that can be used as a directory name that is
65    unique to a Lisp implementation, Lisp implementation version,
66    operating system, and hardware architecture."
67      (flet ((first-of (features)
68               (loop for f in features
69                     when (find f *features*) return it))
70             (maybe-warn (value fstring &rest args)
71               (cond (value)
72                     (t (apply #'warn fstring args)
73                        "unknown"))))
74        (let ((lisp (maybe-warn (first-of *implementation-features*)
75                                "No implementation feature found in ~a."
76                                *implementation-features*))
77              (os   (maybe-warn (first-of *os-features*)
78                                "No os feature found in ~a." *os-features*))
79              (arch (maybe-warn (first-of *architecture-features*)
80                                "No architecture feature found in ~a."
81                                *architecture-features*))
82              (version (maybe-warn (lisp-version-string)
83                                   "Don't know how to get Lisp ~
84                                    implementation version.")))
85          (format nil "~(~@{~a~^-~}~)" lisp version os arch))))
86    
87  (defparameter *swank-pathname* (make-swank-pathname "swank"))  (defparameter *swank-pathname* (make-swank-pathname "swank"))
88    
# Line 55  Line 94 
94    "Return the pathname where SOURCE-PATHNAME's binary should be compiled."    "Return the pathname where SOURCE-PATHNAME's binary should be compiled."
95    (let ((cfp (compile-file-pathname source-pathname)))    (let ((cfp (compile-file-pathname source-pathname)))
96      (merge-pathnames (make-pathname      (merge-pathnames (make-pathname
97                        :directory `(:relative ".slime" "fasl" ,*lisp-name*)                        :directory
98                          `(:relative ".slime" "fasl" ,(unique-directory-name))
99                        :name (pathname-name cfp)                        :name (pathname-name cfp)
100                        :type (pathname-type cfp))                        :type (pathname-type cfp))
101                       (user-homedir-pathname))))                       (user-homedir-pathname))))
# Line 73  recompiled." Line 113  recompiled."
113                  (when (or needs-recompile                  (when (or needs-recompile
114                            (not (probe-file binary-pathname))                            (not (probe-file binary-pathname))
115                            (file-newer-p source-pathname binary-pathname))                            (file-newer-p source-pathname binary-pathname))
                   (format t "~&;; Compiling ~A...~%" source-pathname)  
116                    (ensure-directories-exist binary-pathname)                    (ensure-directories-exist binary-pathname)
117                    (compile-file source-pathname :output-file binary-pathname)                    (compile-file source-pathname :output-file binary-pathname
118                                    :print nil :verbose t)
119                    (setq needs-recompile t))                    (setq needs-recompile t))
120                  (load binary-pathname))                  (load binary-pathname :verbose t))
121              #+(or)              #+(or)
122              (error ()              (error ()
123                ;; If an error occurs compiling, load the source instead                ;; If an error occurs compiling, load the source instead
# Line 85  recompiled." Line 125  recompiled."
125                (load source-pathname))                (load source-pathname))
126              ))))))              ))))))
127    
128  (defun user-init-file ()  #+cormanlisp
129    "Return the name of the user init file or nil."  (defun compile-files-if-needed-serially (files)
130    (probe-file (merge-pathnames (user-homedir-pathname)    "Corman Lisp has trouble with compiled files."
131                                 (make-pathname :name ".swank" :type "lisp"))))    (dolist (file files)
132        (load file :verbose t)
133        (force-output)))
134    
   
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.50

  ViewVC Help
Powered by ViewVC 1.1.5