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

Contents of /slime/swank-loader.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.47 - (hide annotations)
Mon Apr 18 04:42:50 2005 UTC (9 years ago) by pseibel
Branch: MAIN
CVS Tags: SLIME-1-2, SLIME-1-2-1
Changes since 1.46: +3 -1 lines
Added GCL and ECL features to swank-loader.lisp
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 heller 1.45 #+cmu '("swank-source-path-parser" "swank-source-file-cache"
28     "swank-cmucl")
29     #+sbcl '("swank-sbcl" "swank-source-path-parser"
30     "swank-source-file-cache" "swank-gray")
31 aruttenberg 1.34 #+openmcl '("metering" "swank-openmcl" "swank-gray")
32 heller 1.21 #+lispworks '("swank-lispworks" "swank-gray")
33     #+allegro '("swank-allegro" "swank-gray")
34     #+clisp '("xref" "metering" "swank-clisp" "swank-gray")
35 asimon 1.35 #+armedbear '("swank-abcl")
36 heller 1.21 )))
37 jbielman 1.1
38 pseibel 1.39 (defparameter *implementation-features*
39 pseibel 1.47 '(:allegro :lispworks :sbcl :openmcl :cmu :clisp :ccl :corman :armedbear :gcl :ecl))
40 pseibel 1.39
41     (defparameter *os-features*
42 eweitz 1.46 '(:macosx :linux :windows :mswindows :win32 :solaris :darwin :sunos :unix))
43 pseibel 1.39
44     (defparameter *architecture-features*
45 eweitz 1.46 '(:powerpc :ppc :x86 :x86-64 :i686 :pc386 :iapx386 :sparc))
46 pseibel 1.39
47 heller 1.45 (defun lisp-version-string ()
48     #+cmu (substitute #\- #\/ (lisp-implementation-version))
49     #+sbcl (lisp-implementation-version)
50 pseibel 1.47 #+ecl (lisp-implementation-version)
51     #+gcl (let ((s (lisp-implementation-version))) (subseq s 4))
52 heller 1.45 #+openmcl (format nil "~d.~d"
53     ccl::*openmcl-major-version*
54     ccl::*openmcl-minor-version*)
55     #+lispworks (lisp-implementation-version)
56     #+allegro excl::*common-lisp-version-number*
57     #+clisp (let ((s (lisp-implementation-version)))
58     (subseq s 0 (position #\space s)))
59     #+armedbear (lisp-implementation-version))
60    
61 pseibel 1.39 (defun unique-directory-name ()
62     "Return a name that can be used as a directory name that is
63     unique to a Lisp implementation, Lisp implementation version,
64     operating system, and hardware architecture."
65     (flet ((first-of (features)
66     (loop for f in features
67 heller 1.45 when (find f *features*) return it))
68     (maybe-warn (value fstring &rest args)
69     (cond (value)
70     (t (apply #'warn fstring args)
71     "unknown"))))
72     (let ((lisp (maybe-warn (first-of *implementation-features*)
73     "No implementation feature found in ~a."
74     *implementation-features*))
75     (os (maybe-warn (first-of *os-features*)
76     "No os feature found in ~a." *os-features*))
77     (arch (maybe-warn (first-of *architecture-features*)
78     "No architecture feature found in ~a."
79     *architecture-features*))
80     (version (maybe-warn (lisp-version-string)
81     "Don't know how to get Lisp ~
82     implementation version.")))
83     (format nil "~(~@{~a~^-~}~)" lisp version os arch))))
84 heller 1.17
85 jbielman 1.1 (defparameter *swank-pathname* (make-swank-pathname "swank"))
86    
87     (defun file-newer-p (new-file old-file)
88     "Returns true if NEW-FILE is newer than OLD-FILE."
89     (> (file-write-date new-file) (file-write-date old-file)))
90    
91 heller 1.17 (defun binary-pathname (source-pathname)
92 lgorrie 1.27 "Return the pathname where SOURCE-PATHNAME's binary should be compiled."
93     (let ((cfp (compile-file-pathname source-pathname)))
94     (merge-pathnames (make-pathname
95 pseibel 1.39 :directory
96     `(:relative ".slime" "fasl" ,(unique-directory-name))
97 lgorrie 1.27 :name (pathname-name cfp)
98     :type (pathname-type cfp))
99     (user-homedir-pathname))))
100 heller 1.17
101 heller 1.4 (defun compile-files-if-needed-serially (files)
102 jbielman 1.1 "Compile each file in FILES if the source is newer than
103     its corresponding binary, or the file preceding it was
104     recompiled."
105 heller 1.6 (with-compilation-unit ()
106     (let ((needs-recompile nil))
107     (dolist (source-pathname files)
108 heller 1.17 (let ((binary-pathname (binary-pathname source-pathname)))
109 heller 1.6 (handler-case
110     (progn
111     (when (or needs-recompile
112     (not (probe-file binary-pathname))
113     (file-newer-p source-pathname binary-pathname))
114 heller 1.17 (ensure-directories-exist binary-pathname)
115 heller 1.37 (compile-file source-pathname :output-file binary-pathname
116     :print nil :verbose t)
117 heller 1.6 (setq needs-recompile t))
118 heller 1.36 (load binary-pathname :verbose t))
119 heller 1.13 #+(or)
120 heller 1.6 (error ()
121     ;; If an error occurs compiling, load the source instead
122     ;; so we can try to debug it.
123 heller 1.13 (load source-pathname))
124     ))))))
125 jbielman 1.1
126 lgorrie 1.5 (compile-files-if-needed-serially
127 heller 1.18 (append (list (make-swank-pathname "swank-backend"))
128     *sysdep-pathnames*
129     (list *swank-pathname*)))
130 lgorrie 1.14
131 heller 1.18 (funcall (intern (string :warn-unimplemented-interfaces) :swank-backend))
132 heller 1.4
133 mbaringer 1.38 (defun load-user-init-file ()
134     "Load the user init file, return NIL if it does not exist."
135     (load (merge-pathnames (user-homedir-pathname)
136     (make-pathname :name ".swank" :type "lisp"))
137     :if-does-not-exist nil))
138     (export 'load-user-init-file)
139    
140     (defun load-site-init-file ()
141     (load (make-pathname :name "site-init" :type "lisp"
142     :defaults *load-truename*)
143     :if-does-not-exist nil))
144    
145     (or (load-site-init-file)
146     (load-user-init-file))
147    

  ViewVC Help
Powered by ViewVC 1.1.5