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

Contents of /slime/swank-loader.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.36 - (show annotations)
Sun Oct 3 12:10:48 2004 UTC (9 years, 6 months ago) by heller
Branch: MAIN
CVS Tags: SLIME-1-1, MULTIBYTE-ENCODING
Changes since 1.35: +1 -1 lines
(compile-files-if-needed-serially): Load verbosely.
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 (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-cmucl")
28 #+sbcl '("swank-sbcl" "swank-source-path-parser" "swank-gray")
29 #+openmcl '("metering" "swank-openmcl" "swank-gray")
30 #+lispworks '("swank-lispworks" "swank-gray")
31 #+allegro '("swank-allegro" "swank-gray")
32 #+clisp '("xref" "metering" "swank-clisp" "swank-gray")
33 #+armedbear '("swank-abcl")
34 )))
35
36 (defparameter *lisp-name*
37 #+cmu (format nil "cmu-~A"
38 (substitute #\- #\/ (lisp-implementation-version)))
39 #+sbcl (format nil "sbcl-~A" (lisp-implementation-version))
40 #+openmcl "openmcl"
41 #+lispworks (format nil "lispworks-~A" (lisp-implementation-version))
42 #+allegro (format nil "allegro-~A" excl::*common-lisp-version-number*)
43 #+clisp (format nil "clisp-~A" (let ((s (lisp-implementation-version)))
44 (subseq s 0 (position #\space s))))
45 #+armedbear "abcl"
46 )
47
48 (defparameter *swank-pathname* (make-swank-pathname "swank"))
49
50 (defun file-newer-p (new-file old-file)
51 "Returns true if NEW-FILE is newer than OLD-FILE."
52 (> (file-write-date new-file) (file-write-date old-file)))
53
54 (defun binary-pathname (source-pathname)
55 "Return the pathname where SOURCE-PATHNAME's binary should be compiled."
56 (let ((cfp (compile-file-pathname source-pathname)))
57 (merge-pathnames (make-pathname
58 :directory `(:relative ".slime" "fasl" ,*lisp-name*)
59 :name (pathname-name cfp)
60 :type (pathname-type cfp))
61 (user-homedir-pathname))))
62
63 (defun compile-files-if-needed-serially (files)
64 "Compile each file in FILES if the source is newer than
65 its corresponding binary, or the file preceding it was
66 recompiled."
67 (with-compilation-unit ()
68 (let ((needs-recompile nil))
69 (dolist (source-pathname files)
70 (let ((binary-pathname (binary-pathname source-pathname)))
71 (handler-case
72 (progn
73 (when (or needs-recompile
74 (not (probe-file binary-pathname))
75 (file-newer-p source-pathname binary-pathname))
76 (format t "~&;; Compiling ~A...~%" source-pathname)
77 (ensure-directories-exist binary-pathname)
78 (compile-file source-pathname :output-file binary-pathname)
79 (setq needs-recompile t))
80 (load binary-pathname :verbose t))
81 #+(or)
82 (error ()
83 ;; If an error occurs compiling, load the source instead
84 ;; so we can try to debug it.
85 (load source-pathname))
86 ))))))
87
88 (defun user-init-file ()
89 "Return the name of the user init file or nil."
90 (probe-file (merge-pathnames (user-homedir-pathname)
91 (make-pathname :name ".swank" :type "lisp"))))
92
93
94 (compile-files-if-needed-serially
95 (append (list (make-swank-pathname "swank-backend"))
96 *sysdep-pathnames*
97 (list *swank-pathname*)))
98
99 (funcall (intern (string :warn-unimplemented-interfaces) :swank-backend))
100
101 (when (user-init-file)
102 (load (user-init-file)))
103

  ViewVC Help
Powered by ViewVC 1.1.5