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

Contents of /slime/swank-loader.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.53 - (show annotations)
Fri Oct 14 18:11:16 2005 UTC (8 years, 6 months ago) by dcrosher
Branch: MAIN
Changes since 1.52: +8 -3 lines
Support for Scieneer Common Lisp:
 o *sysdep-pathnames*: swank-scl.
 o *implementation-features*: add :scl.
 o *os-features*: add :hpux.
 o *architecture-features*: add :amd64, :i686, :i486, :sparc64, :sparc,
   :hppa64, and :hppa.
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 (cl:defpackage :swank-loader
12 (:use :cl))
13
14 (cl: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 (merge-pathnames (make-pathname :name name :type type)
19 (or *compile-file-pathname*
20 *load-pathname*
21 *default-pathname-defaults*)))
22
23 (defparameter *sysdep-pathnames*
24 (mapcar #'make-swank-pathname
25 (append
26 '("nregex")
27 #+cmu '("swank-source-path-parser" "swank-source-file-cache"
28 "swank-cmucl")
29 #+scl '("swank-source-path-parser" "swank-source-file-cache"
30 "swank-scl")
31 #+sbcl '("swank-sbcl" "swank-source-path-parser"
32 "swank-source-file-cache" "swank-gray")
33 #+openmcl '("metering" "swank-openmcl" "swank-gray")
34 #+lispworks '("swank-lispworks" "swank-gray")
35 #+allegro '("swank-allegro" "swank-gray")
36 #+clisp '("xref" "metering" "swank-clisp" "swank-gray")
37 #+armedbear '("swank-abcl")
38 #+cormanlisp '("swank-corman" "swank-gray")
39 #+ecl '("swank-ecl" "swank-gray")
40 )))
41
42 (defparameter *implementation-features*
43 '(:allegro :lispworks :sbcl :openmcl :cmu :clisp :ccl :corman :cormanlisp
44 :armedbear :gcl :ecl :scl))
45
46 (defparameter *os-features*
47 '(:macosx :linux :windows :mswindows :win32 :solaris :darwin :sunos :hpux
48 :unix))
49
50 (defparameter *architecture-features*
51 '(:powerpc :ppc :x86 :x86-64 :amd64 :i686 :i586 :i486 :pc386 :iapx386
52 :sparc64 :sparc :hppa64 :hppa))
53
54 (defun lisp-version-string ()
55 #+cmu (substitute-if #\_ (lambda (x) (find x " /"))
56 (lisp-implementation-version))
57 #+scl (lisp-implementation-version)
58 #+sbcl (lisp-implementation-version)
59 #+ecl (lisp-implementation-version)
60 #+openmcl (format nil "~d.~d"
61 ccl::*openmcl-major-version*
62 ccl::*openmcl-minor-version*)
63 #+lispworks (lisp-implementation-version)
64 #+allegro excl::*common-lisp-version-number*
65 #+clisp (let ((s (lisp-implementation-version)))
66 (subseq s 0 (position #\space s)))
67 #+armedbear (lisp-implementation-version)
68 #+cormanlisp (lisp-implementation-version))
69
70 (defun unique-directory-name ()
71 "Return a name that can be used as a directory name that is
72 unique to a Lisp implementation, Lisp implementation version,
73 operating system, and hardware architecture."
74 (flet ((first-of (features)
75 (loop for f in features
76 when (find f *features*) return it))
77 (maybe-warn (value fstring &rest args)
78 (cond (value)
79 (t (apply #'warn fstring args)
80 "unknown"))))
81 (let ((lisp (maybe-warn (first-of *implementation-features*)
82 "No implementation feature found in ~a."
83 *implementation-features*))
84 (os (maybe-warn (first-of *os-features*)
85 "No os feature found in ~a." *os-features*))
86 (arch (maybe-warn (first-of *architecture-features*)
87 "No architecture feature found in ~a."
88 *architecture-features*))
89 (version (maybe-warn (lisp-version-string)
90 "Don't know how to get Lisp ~
91 implementation version.")))
92 (format nil "~(~@{~a~^-~}~)" lisp version os arch))))
93
94 (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 (defun binary-pathname (source-pathname)
101 "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 :directory
105 `(:relative ".slime" "fasl" ,(unique-directory-name))
106 :name (pathname-name cfp)
107 :type (pathname-type cfp))
108 (user-homedir-pathname))))
109
110 (defun compile-files-if-needed-serially (files)
111 "Compile each file in FILES if the source is newer than
112 its corresponding binary, or the file preceding it was
113 recompiled."
114 (with-compilation-unit ()
115 (let ((needs-recompile nil))
116 (dolist (source-pathname files)
117 (let ((binary-pathname (binary-pathname source-pathname)))
118 (handler-case
119 (progn
120 (when (or needs-recompile
121 (not (probe-file binary-pathname))
122 (file-newer-p source-pathname binary-pathname))
123 (ensure-directories-exist binary-pathname)
124 (compile-file source-pathname :output-file binary-pathname
125 :print nil :verbose t)
126 (setq needs-recompile t))
127 (load binary-pathname :verbose t))
128 #+(or)
129 (error ()
130 ;; If an error occurs compiling, load the source instead
131 ;; so we can try to debug it.
132 (load source-pathname))
133 ))))))
134
135 #+(or cormanlisp ecl)
136 (defun compile-files-if-needed-serially (files)
137 "Corman Lisp and ECL have trouble with compiled files."
138 (dolist (file files)
139 (load file :verbose t)
140 (force-output)))
141
142 (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
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 (compile-files-if-needed-serially
154 (append (list (make-swank-pathname "swank-backend"))
155 *sysdep-pathnames*
156 (list *swank-pathname*)))
157
158 (funcall (intern (string :warn-unimplemented-interfaces) :swank-backend))
159
160 (load-site-init-file)
161 (load-user-init-file)

  ViewVC Help
Powered by ViewVC 1.1.5