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

Contents of /slime/swank-loader.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.43 - (hide annotations)
Sat Mar 12 01:49:48 2005 UTC (9 years, 1 month ago) by lgorrie
Branch: MAIN
Changes since 1.42: +2 -2 lines
Updated for swank-source-file-cache.lisp (CMUCL & SBCL)
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 lgorrie 1.43 #+cmu '("swank-source-path-parser" "swank-source-file-cache" "swank-cmucl")
28     #+sbcl '("swank-sbcl" "swank-source-path-parser" "swank-source-file-cache" "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.41 '(: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.41 '(:powerpc :ppc :x86 :x86-64 :i686 :pc386 :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 pseibel 1.42 (warn "Don't know how to get Lisp implementation version.")
78     (return "unknown"))))
79 pseibel 1.39
80     (unless lisp
81     (warn "No implementation feature found in ~a."
82     *implementation-features*)
83     (setf lisp "unknown"))
84     (unless os
85     (warn "No os feature found in ~a." *os-features*)
86     (setf os "unknown"))
87     (unless architecture
88     (warn "No architecture feature found in ~a."
89     *architecture-features*)
90     (setf architecture "unknown"))
91    
92     (format nil "~(~@{~a~^-~}~)" lisp version os architecture))))
93 heller 1.17
94 jbielman 1.1 (defparameter *swank-pathname* (make-swank-pathname "swank"))
95    
96     (defun file-newer-p (new-file old-file)
97     "Returns true if NEW-FILE is newer than OLD-FILE."
98     (> (file-write-date new-file) (file-write-date old-file)))
99    
100 heller 1.17 (defun binary-pathname (source-pathname)
101 lgorrie 1.27 "Return the pathname where SOURCE-PATHNAME's binary should be compiled."
102     (let ((cfp (compile-file-pathname source-pathname)))
103     (merge-pathnames (make-pathname
104 pseibel 1.39 :directory
105     `(:relative ".slime" "fasl" ,(unique-directory-name))
106 lgorrie 1.27 :name (pathname-name cfp)
107     :type (pathname-type cfp))
108     (user-homedir-pathname))))
109 heller 1.17
110 heller 1.4 (defun compile-files-if-needed-serially (files)
111 jbielman 1.1 "Compile each file in FILES if the source is newer than
112     its corresponding binary, or the file preceding it was
113     recompiled."
114 heller 1.6 (with-compilation-unit ()
115     (let ((needs-recompile nil))
116     (dolist (source-pathname files)
117 heller 1.17 (let ((binary-pathname (binary-pathname source-pathname)))
118 heller 1.6 (handler-case
119     (progn
120     (when (or needs-recompile
121     (not (probe-file binary-pathname))
122     (file-newer-p source-pathname binary-pathname))
123 heller 1.17 (ensure-directories-exist binary-pathname)
124 heller 1.37 (compile-file source-pathname :output-file binary-pathname
125     :print nil :verbose t)
126 heller 1.6 (setq needs-recompile t))
127 heller 1.36 (load binary-pathname :verbose t))
128 heller 1.13 #+(or)
129 heller 1.6 (error ()
130     ;; If an error occurs compiling, load the source instead
131     ;; so we can try to debug it.
132 heller 1.13 (load source-pathname))
133     ))))))
134 jbielman 1.1
135 lgorrie 1.5 (compile-files-if-needed-serially
136 heller 1.18 (append (list (make-swank-pathname "swank-backend"))
137     *sysdep-pathnames*
138     (list *swank-pathname*)))
139 lgorrie 1.14
140 heller 1.18 (funcall (intern (string :warn-unimplemented-interfaces) :swank-backend))
141 heller 1.4
142 mbaringer 1.38 (defun load-user-init-file ()
143     "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    

  ViewVC Help
Powered by ViewVC 1.1.5