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

Contents of /slime/swank-loader.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.55 - (show annotations)
Thu Jan 19 22:56:16 2006 UTC (8 years, 2 months ago) by heller
Branch: MAIN
Changes since 1.54: +25 -5 lines
Return to the previous loading strategy: load everything when
swank-loader is loaded.  It's just to convenient to give that up.  To
customize the fasl directories, the new variable
swank-loader:*fasl-directory* can be set before loading swank-loader.

* swank-loader.lisp (*fasl-directory*, *source-directory*): New variables.
 (load-swank): Call it during loading.
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 ;; If you want customize the source- or fasl-directory you can set
12 ;; swank-loader:*source-directory* resp. swank-loader:*fasl-directory*
13 ;; before loading this files. (you also need to create the
14 ;; swank-loader package.)
15 ;; E.g.:
16 ;;
17 ;; (make-package :swank-laoder)
18 ;; (defparameter swank-loader::*fasl-directory* "/tmp/fasl/")
19 ;; (load ".../swank-loader.lisp")
20
21
22 (cl:defpackage :swank-loader
23 (:use :cl)
24 (:export :load-swank
25 :*source-directory*
26 :*fasl-directory*))
27
28 (cl:in-package :swank-loader)
29
30 (defparameter *sysdep-files*
31 (append
32 '("nregex")
33 #+cmu '("swank-source-path-parser" "swank-source-file-cache" "swank-cmucl")
34 #+scl '("swank-source-path-parser" "swank-source-file-cache" "swank-scl")
35 #+sbcl '("swank-sbcl" "swank-source-path-parser"
36 "swank-source-file-cache" "swank-gray")
37 #+openmcl '("metering" "swank-openmcl" "swank-gray")
38 #+lispworks '("swank-lispworks" "swank-gray")
39 #+allegro '("swank-allegro" "swank-gray")
40 #+clisp '("xref" "metering" "swank-clisp" "swank-gray")
41 #+armedbear '("swank-abcl")
42 #+cormanlisp '("swank-corman" "swank-gray")
43 #+ecl '("swank-ecl" "swank-gray")
44 ))
45
46 (defparameter *implementation-features*
47 '(:allegro :lispworks :sbcl :openmcl :cmu :clisp :ccl :corman :cormanlisp
48 :armedbear :gcl :ecl :scl))
49
50 (defparameter *os-features*
51 '(:macosx :linux :windows :mswindows :win32 :solaris :darwin :sunos :hpux
52 :unix))
53
54 (defparameter *architecture-features*
55 '(:powerpc :ppc :x86 :x86-64 :amd64 :i686 :i586 :i486 :pc386 :iapx386
56 :sparc64 :sparc :hppa64 :hppa))
57
58 (defun lisp-version-string ()
59 #+cmu (substitute-if #\_ (lambda (x) (find x " /"))
60 (lisp-implementation-version))
61 #+scl (lisp-implementation-version)
62 #+sbcl (lisp-implementation-version)
63 #+ecl (lisp-implementation-version)
64 #+openmcl (format nil "~d.~d"
65 ccl::*openmcl-major-version*
66 ccl::*openmcl-minor-version*)
67 #+lispworks (lisp-implementation-version)
68 #+allegro excl::*common-lisp-version-number*
69 #+clisp (let ((s (lisp-implementation-version)))
70 (subseq s 0 (position #\space s)))
71 #+armedbear (lisp-implementation-version)
72 #+cormanlisp (lisp-implementation-version))
73
74 (defun unique-directory-name ()
75 "Return a name that can be used as a directory name that is
76 unique to a Lisp implementation, Lisp implementation version,
77 operating system, and hardware architecture."
78 (flet ((first-of (features)
79 (loop for f in features
80 when (find f *features*) return it))
81 (maybe-warn (value fstring &rest args)
82 (cond (value)
83 (t (apply #'warn fstring args)
84 "unknown"))))
85 (let ((lisp (maybe-warn (first-of *implementation-features*)
86 "No implementation feature found in ~a."
87 *implementation-features*))
88 (os (maybe-warn (first-of *os-features*)
89 "No os feature found in ~a." *os-features*))
90 (arch (maybe-warn (first-of *architecture-features*)
91 "No architecture feature found in ~a."
92 *architecture-features*))
93 (version (maybe-warn (lisp-version-string)
94 "Don't know how to get Lisp ~
95 implementation version.")))
96 (format nil "~(~@{~a~^-~}~)" lisp version os arch))))
97
98 (defun file-newer-p (new-file old-file)
99 "Returns true if NEW-FILE is newer than OLD-FILE."
100 (> (file-write-date new-file) (file-write-date old-file)))
101
102 (defun default-fasl-directory ()
103 (merge-pathnames
104 (make-pathname
105 :directory `(:relative ".slime" "fasl" ,(unique-directory-name)))
106 (user-homedir-pathname)))
107
108 (defun binary-pathname (source-pathname binary-directory)
109 "Return the pathname where SOURCE-PATHNAME's binary should be compiled."
110 (let ((cfp (compile-file-pathname source-pathname)))
111 (merge-pathnames (make-pathname :name (pathname-name cfp)
112 :type (pathname-type cfp))
113 binary-directory)))
114
115
116 (defun compile-files-if-needed-serially (files fasl-directory)
117 "Compile each file in FILES if the source is newer than
118 its corresponding binary, or the file preceding it was
119 recompiled."
120 (with-compilation-unit ()
121 (let ((needs-recompile nil))
122 (dolist (source-pathname files)
123 (let ((binary-pathname (binary-pathname source-pathname
124 fasl-directory)))
125 (handler-case
126 (progn
127 (when (or needs-recompile
128 (not (probe-file binary-pathname))
129 (file-newer-p source-pathname binary-pathname))
130 (ensure-directories-exist binary-pathname)
131 (compile-file source-pathname :output-file binary-pathname
132 :print nil :verbose t)
133 (setq needs-recompile t))
134 (load binary-pathname :verbose t))
135 #+(or)
136 (error ()
137 ;; If an error occurs compiling, load the source instead
138 ;; so we can try to debug it.
139 (load source-pathname))
140 ))))))
141
142 #+(or cormanlisp ecl)
143 (defun compile-files-if-needed-serially (files fasl-directory)
144 "Corman Lisp and ECL have trouble with compiled files."
145 (declare (ignore fasl-directory))
146 (dolist (file files)
147 (load file :verbose t)
148 (force-output)))
149
150 (defun load-user-init-file ()
151 "Load the user init file, return NIL if it does not exist."
152 (load (merge-pathnames (user-homedir-pathname)
153 (make-pathname :name ".swank" :type "lisp"))
154 :if-does-not-exist nil))
155
156 (defun load-site-init-file (directory)
157 (load (make-pathname :name "site-init" :type "lisp"
158 :defaults directory)
159 :if-does-not-exist nil))
160
161 (defun swank-source-files (source-directory)
162 (mapcar (lambda (name)
163 (merge-pathnames (make-pathname :name name :type "lisp")
164 source-directory))
165 `("swank-backend" ,@*sysdep-files* "swank")))
166
167 (defvar *source-directory* (or *load-pathname*
168 *default-pathname-defaults*)
169 "The directory where to look for the source.")
170
171 (defvar *fasl-directory* (default-fasl-directory)
172 "The directory where fasl files should be placed.")
173
174 (defun load-swank (&key
175 (source-directory *source-directory*)
176 (fasl-directory *fasl-directory*))
177 (compile-files-if-needed-serially (swank-source-files source-directory)
178 fasl-directory)
179 (funcall (intern (string :warn-unimplemented-interfaces) :swank-backend))
180 (load-site-init-file source-directory)
181 (load-user-init-file))
182
183 (load-swank)

  ViewVC Help
Powered by ViewVC 1.1.5