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

Contents of /slime/swank-loader.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.40 - (hide annotations)
Wed Mar 9 03:56:48 2005 UTC (9 years, 1 month ago) by pseibel
Branch: MAIN
Changes since 1.39: +2 -2 lines
Updating feature lists for FASL directory names computing code.
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.11 (cl:defpackage :swank-loader
12 jbielman 1.1 (:use :common-lisp))
13 heller 1.4
14 jbielman 1.1 (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 msimmons 1.33 (merge-pathnames (make-pathname :name name :type type)
19     (or *compile-file-pathname*
20     *load-pathname*
21     *default-pathname-defaults*)))
22 jbielman 1.1
23 heller 1.3 (defparameter *sysdep-pathnames*
24     (mapcar #'make-swank-pathname
25 heller 1.21 (append
26     '("nregex")
27     #+cmu '("swank-source-path-parser" "swank-cmucl")
28     #+sbcl '("swank-sbcl" "swank-source-path-parser" "swank-gray")
29 aruttenberg 1.34 #+openmcl '("metering" "swank-openmcl" "swank-gray")
30 heller 1.21 #+lispworks '("swank-lispworks" "swank-gray")
31     #+allegro '("swank-allegro" "swank-gray")
32     #+clisp '("xref" "metering" "swank-clisp" "swank-gray")
33 asimon 1.35 #+armedbear '("swank-abcl")
34 heller 1.21 )))
35 jbielman 1.1
36 pseibel 1.39 (defparameter *implementation-features*
37 pseibel 1.40 '(:allegro :sbcl :openmcl :cmu ::clisp :ccl :corman :armedbear :gcl))
38 pseibel 1.39
39     (defparameter *os-features*
40     '(:macosx :linux :windows :solaris :darwin :sunos :unix))
41    
42     (defparameter *architecture-features*
43 pseibel 1.40 '(:powerpc :ppc :x86 :x86-64 :i686 :sparc))
44 pseibel 1.39
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 heller 1.17
93 jbielman 1.1 (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 heller 1.17 (defun binary-pathname (source-pathname)
100 lgorrie 1.27 "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 pseibel 1.39 :directory
104     `(:relative ".slime" "fasl" ,(unique-directory-name))
105 lgorrie 1.27 :name (pathname-name cfp)
106     :type (pathname-type cfp))
107     (user-homedir-pathname))))
108 heller 1.17
109 heller 1.4 (defun compile-files-if-needed-serially (files)
110 jbielman 1.1 "Compile each file in FILES if the source is newer than
111     its corresponding binary, or the file preceding it was
112     recompiled."
113 heller 1.6 (with-compilation-unit ()
114     (let ((needs-recompile nil))
115     (dolist (source-pathname files)
116 heller 1.17 (let ((binary-pathname (binary-pathname source-pathname)))
117 heller 1.6 (handler-case
118     (progn
119     (when (or needs-recompile
120     (not (probe-file binary-pathname))
121     (file-newer-p source-pathname binary-pathname))
122 heller 1.17 (ensure-directories-exist binary-pathname)
123 heller 1.37 (compile-file source-pathname :output-file binary-pathname
124     :print nil :verbose t)
125 heller 1.6 (setq needs-recompile t))
126 heller 1.36 (load binary-pathname :verbose t))
127 heller 1.13 #+(or)
128 heller 1.6 (error ()
129     ;; If an error occurs compiling, load the source instead
130     ;; so we can try to debug it.
131 heller 1.13 (load source-pathname))
132     ))))))
133 jbielman 1.1
134 lgorrie 1.5 (compile-files-if-needed-serially
135 heller 1.18 (append (list (make-swank-pathname "swank-backend"))
136     *sysdep-pathnames*
137     (list *swank-pathname*)))
138 lgorrie 1.14
139 heller 1.18 (funcall (intern (string :warn-unimplemented-interfaces) :swank-backend))
140 heller 1.4
141 mbaringer 1.38 (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