/[slime]/slime/swank-loader.lisp
ViewVC logotype

Contents of /slime/swank-loader.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.41 - (show annotations)
Wed Mar 9 21:34:28 2005 UTC (9 years, 1 month ago) by pseibel
Branch: MAIN
Changes since 1.40: +2 -2 lines
Adding missing features for unique-directory-name.
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2 ;;;
3 ;;; swank-loader.lisp --- Compile and load the Slime backend.
4 ;;;
5 ;;; Created 2003, James Bielman <jamesjb@jamesjb.com>
6 ;;;
7 ;;; This code has been placed in the Public Domain. All warranties
8 ;;; are disclaimed.
9 ;;;
10
11 (cl:defpackage :swank-loader
12 (:use :common-lisp))
13
14 (in-package :swank-loader)
15
16 (defun make-swank-pathname (name &optional (type "lisp"))
17 "Return a pathname with name component NAME in the Slime directory."
18 (merge-pathnames (make-pathname :name name :type type)
19 (or *compile-file-pathname*
20 *load-pathname*
21 *default-pathname-defaults*)))
22
23 (defparameter *sysdep-pathnames*
24 (mapcar #'make-swank-pathname
25 (append
26 '("nregex")
27 #+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 *implementation-features*
37 '(:allegro :sbcl :openmcl :cmu :clisp :ccl :corman :armedbear :gcl))
38
39 (defparameter *os-features*
40 '(:macosx :linux :windows :solaris :darwin :sunos :unix))
41
42 (defparameter *architecture-features*
43 '(:powerpc :ppc :x86 :x86-64 :i686 :pc386 :sparc))
44
45 (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 (error "Don't know how to get Lisp implementation version."))))
78
79 (unless lisp
80 (warn "No implementation feature found in ~a."
81 *implementation-features*)
82 (setf lisp "unknown"))
83 (unless os
84 (warn "No os feature found in ~a." *os-features*)
85 (setf os "unknown"))
86 (unless architecture
87 (warn "No architecture feature found in ~a."
88 *architecture-features*)
89 (setf architecture "unknown"))
90
91 (format nil "~(~@{~a~^-~}~)" lisp version os architecture))))
92
93 (defparameter *swank-pathname* (make-swank-pathname "swank"))
94
95 (defun file-newer-p (new-file old-file)
96 "Returns true if NEW-FILE is newer than OLD-FILE."
97 (> (file-write-date new-file) (file-write-date old-file)))
98
99 (defun binary-pathname (source-pathname)
100 "Return the pathname where SOURCE-PATHNAME's binary should be compiled."
101 (let ((cfp (compile-file-pathname source-pathname)))
102 (merge-pathnames (make-pathname
103 :directory
104 `(:relative ".slime" "fasl" ,(unique-directory-name))
105 :name (pathname-name cfp)
106 :type (pathname-type cfp))
107 (user-homedir-pathname))))
108
109 (defun compile-files-if-needed-serially (files)
110 "Compile each file in FILES if the source is newer than
111 its corresponding binary, or the file preceding it was
112 recompiled."
113 (with-compilation-unit ()
114 (let ((needs-recompile nil))
115 (dolist (source-pathname files)
116 (let ((binary-pathname (binary-pathname source-pathname)))
117 (handler-case
118 (progn
119 (when (or needs-recompile
120 (not (probe-file binary-pathname))
121 (file-newer-p source-pathname binary-pathname))
122 (ensure-directories-exist binary-pathname)
123 (compile-file source-pathname :output-file binary-pathname
124 :print nil :verbose t)
125 (setq needs-recompile t))
126 (load binary-pathname :verbose t))
127 #+(or)
128 (error ()
129 ;; If an error occurs compiling, load the source instead
130 ;; so we can try to debug it.
131 (load source-pathname))
132 ))))))
133
134 (compile-files-if-needed-serially
135 (append (list (make-swank-pathname "swank-backend"))
136 *sysdep-pathnames*
137 (list *swank-pathname*)))
138
139 (funcall (intern (string :warn-unimplemented-interfaces) :swank-backend))
140
141 (defun load-user-init-file ()
142 "Load the user init file, return NIL if it does not exist."
143 (load (merge-pathnames (user-homedir-pathname)
144 (make-pathname :name ".swank" :type "lisp"))
145 :if-does-not-exist nil))
146 (export 'load-user-init-file)
147
148 (defun load-site-init-file ()
149 (load (make-pathname :name "site-init" :type "lisp"
150 :defaults *load-truename*)
151 :if-does-not-exist nil))
152
153 (or (load-site-init-file)
154 (load-user-init-file))
155

  ViewVC Help
Powered by ViewVC 1.1.5