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

Contents of /slime/swank-loader.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.27 - (show annotations)
Thu Jun 17 16:04:52 2004 UTC (9 years, 10 months ago) by lgorrie
Branch: MAIN
Changes since 1.26: +9 -3 lines
(binary-pathname): Place fasl files under ~/.slime/fasl/ (or _slime in
win32) instead of the SLIME installation directory. The installation
directory can now be read-only.
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 :common-lisp))
13
14 (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 name
19 (make-pathname
20 :type type
21 :device
22 (pathname-device
23 (or *compile-file-pathname* *load-pathname*
24 *default-pathname-defaults*))
25 :directory
26 (pathname-directory
27 (or *compile-file-pathname* *load-pathname*
28 *default-pathname-defaults*)))))
29
30 (defparameter *sysdep-pathnames*
31 (mapcar #'make-swank-pathname
32 (append
33 '("nregex")
34 #+cmu '("swank-source-path-parser" "swank-cmucl")
35 #+sbcl '("swank-sbcl" "swank-source-path-parser" "swank-gray")
36 #+openmcl '("swank-openmcl" "swank-gray")
37 #+lispworks '("swank-lispworks" "swank-gray")
38 #+allegro '("swank-allegro" "swank-gray")
39 #+clisp '("xref" "metering" "swank-clisp" "swank-gray")
40 #+armedbear '("swank-abcl" "swank-gray")
41 )))
42
43 (defparameter *lisp-name*
44 #+cmu (format nil "cmu-~A" (lisp-implementation-version))
45 #+sbcl (format nil "sbcl-~A" (lisp-implementation-version))
46 #+openmcl "openmcl"
47 #+lispworks "lispworks"
48 #+allegro "allegro"
49 #+clisp (format nil "clisp-~A" (let ((s (lisp-implementation-version)))
50 (subseq s 0 (position #\space s))))
51 #+armedbear "abcl"
52 )
53
54 (defparameter *swank-pathname* (make-swank-pathname "swank"))
55
56 (defun file-newer-p (new-file old-file)
57 "Returns true if NEW-FILE is newer than OLD-FILE."
58 (> (file-write-date new-file) (file-write-date old-file)))
59
60 (defun binary-pathname (source-pathname)
61 "Return the pathname where SOURCE-PATHNAME's binary should be compiled."
62 (let ((cfp (compile-file-pathname source-pathname)))
63 (merge-pathnames (make-pathname
64 :directory `(:relative #-mswindows ".slime"
65 #+mswindows "_slime"
66 "fasl" ,*lisp-name*)
67 :name (pathname-name cfp)
68 :type (pathname-type cfp))
69 (user-homedir-pathname))))
70
71 (defun compile-files-if-needed-serially (files)
72 "Compile each file in FILES if the source is newer than
73 its corresponding binary, or the file preceding it was
74 recompiled."
75 (with-compilation-unit ()
76 (let ((needs-recompile nil))
77 (dolist (source-pathname files)
78 (let ((binary-pathname (binary-pathname source-pathname)))
79 (handler-case
80 (progn
81 (when (or needs-recompile
82 (not (probe-file binary-pathname))
83 (file-newer-p source-pathname binary-pathname))
84 (format t "~&;; Compiling ~A...~%" source-pathname)
85 (ensure-directories-exist binary-pathname)
86 (compile-file source-pathname :output-file binary-pathname)
87 (setq needs-recompile t))
88 (load binary-pathname))
89 #+(or)
90 (error ()
91 ;; If an error occurs compiling, load the source instead
92 ;; so we can try to debug it.
93 (load source-pathname))
94 ))))))
95
96 (defun user-init-file ()
97 "Return the name of the user init file or nil."
98 (probe-file
99 (merge-pathnames (user-homedir-pathname)
100 #-mswindows (make-pathname :name ".swank" :type "lisp")
101 #+mswindows (make-pathname :name "_swank" :type "lsp"))))
102
103
104 (compile-files-if-needed-serially
105 (append (list (make-swank-pathname "swank-backend"))
106 *sysdep-pathnames*
107 (list *swank-pathname*)))
108
109 (funcall (intern (string :warn-unimplemented-interfaces) :swank-backend))
110
111 (when (user-init-file)
112 (load (user-init-file)))
113

  ViewVC Help
Powered by ViewVC 1.1.5