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

Contents of /slime/swank-loader.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.55 - (hide 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 jbielman 1.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 heller 1.55 ;; 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 heller 1.11 (cl:defpackage :swank-loader
23 heller 1.54 (:use :cl)
24 heller 1.55 (:export :load-swank
25     :*source-directory*
26     :*fasl-directory*))
27 heller 1.4
28 heller 1.52 (cl:in-package :swank-loader)
29 jbielman 1.1
30 heller 1.54 (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 jbielman 1.1
46 pseibel 1.39 (defparameter *implementation-features*
47 heller 1.52 '(:allegro :lispworks :sbcl :openmcl :cmu :clisp :ccl :corman :cormanlisp
48 dcrosher 1.53 :armedbear :gcl :ecl :scl))
49 pseibel 1.39
50     (defparameter *os-features*
51 dcrosher 1.53 '(:macosx :linux :windows :mswindows :win32 :solaris :darwin :sunos :hpux
52     :unix))
53 pseibel 1.39
54     (defparameter *architecture-features*
55 dcrosher 1.53 '(:powerpc :ppc :x86 :x86-64 :amd64 :i686 :i586 :i486 :pc386 :iapx386
56     :sparc64 :sparc :hppa64 :hppa))
57 pseibel 1.39
58 heller 1.45 (defun lisp-version-string ()
59 heller 1.52 #+cmu (substitute-if #\_ (lambda (x) (find x " /"))
60     (lisp-implementation-version))
61 dcrosher 1.53 #+scl (lisp-implementation-version)
62 heller 1.45 #+sbcl (lisp-implementation-version)
63 pseibel 1.47 #+ecl (lisp-implementation-version)
64 heller 1.45 #+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 heller 1.48 #+armedbear (lisp-implementation-version)
72     #+cormanlisp (lisp-implementation-version))
73 heller 1.45
74 pseibel 1.39 (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 heller 1.45 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 heller 1.17
98 jbielman 1.1 (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 heller 1.54 (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 lgorrie 1.27 "Return the pathname where SOURCE-PATHNAME's binary should be compiled."
110     (let ((cfp (compile-file-pathname source-pathname)))
111 heller 1.54 (merge-pathnames (make-pathname :name (pathname-name cfp)
112     :type (pathname-type cfp))
113     binary-directory)))
114    
115 heller 1.17
116 heller 1.54 (defun compile-files-if-needed-serially (files fasl-directory)
117 jbielman 1.1 "Compile each file in FILES if the source is newer than
118     its corresponding binary, or the file preceding it was
119     recompiled."
120 heller 1.6 (with-compilation-unit ()
121     (let ((needs-recompile nil))
122     (dolist (source-pathname files)
123 heller 1.54 (let ((binary-pathname (binary-pathname source-pathname
124     fasl-directory)))
125 heller 1.6 (handler-case
126     (progn
127     (when (or needs-recompile
128     (not (probe-file binary-pathname))
129     (file-newer-p source-pathname binary-pathname))
130 heller 1.17 (ensure-directories-exist binary-pathname)
131 heller 1.37 (compile-file source-pathname :output-file binary-pathname
132     :print nil :verbose t)
133 heller 1.6 (setq needs-recompile t))
134 heller 1.36 (load binary-pathname :verbose t))
135 heller 1.13 #+(or)
136 heller 1.6 (error ()
137     ;; If an error occurs compiling, load the source instead
138     ;; so we can try to debug it.
139 heller 1.13 (load source-pathname))
140     ))))))
141 jbielman 1.1
142 jgarcia 1.51 #+(or cormanlisp ecl)
143 heller 1.54 (defun compile-files-if-needed-serially (files fasl-directory)
144 jgarcia 1.51 "Corman Lisp and ECL have trouble with compiled files."
145 heller 1.54 (declare (ignore fasl-directory))
146 ewiborg 1.49 (dolist (file files)
147 heller 1.50 (load file :verbose t)
148     (force-output)))
149 ewiborg 1.49
150 mbaringer 1.38 (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 heller 1.54 (defun load-site-init-file (directory)
157 mbaringer 1.38 (load (make-pathname :name "site-init" :type "lisp"
158 heller 1.54 :defaults directory)
159 mbaringer 1.38 :if-does-not-exist nil))
160    
161 heller 1.54 (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 heller 1.55 (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 heller 1.54 (defun load-swank (&key
175 heller 1.55 (source-directory *source-directory*)
176     (fasl-directory *fasl-directory*))
177 heller 1.54 (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 heller 1.55
183     (load-swank)

  ViewVC Help
Powered by ViewVC 1.1.5