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

Contents of /slime/swank-loader.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.20 - (hide annotations)
Fri Mar 19 21:07:35 2004 UTC (10 years, 1 month ago) by lgorrie
Branch: MAIN
Changes since 1.19: +4 -0 lines
Take into account `pathname-device' when deriving paths. A fix for
Windows.
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     (merge-pathnames name
19     (make-pathname
20     :type type
21 lgorrie 1.20 :device
22     (pathname-device
23     (or *compile-file-pathname* *load-pathname*
24     *default-pathname-defaults*))
25 jbielman 1.1 :directory
26     (pathname-directory
27     (or *compile-file-pathname* *load-pathname*
28     *default-pathname-defaults*)))))
29    
30 heller 1.3 (defparameter *sysdep-pathnames*
31     (mapcar #'make-swank-pathname
32 heller 1.9 #+cmu '("swank-source-path-parser" "swank-cmucl")
33 dbarlow 1.8 #+sbcl '("swank-sbcl" "swank-source-path-parser" "swank-gray")
34 heller 1.6 #+openmcl '("swank-openmcl" "swank-gray")
35     #+lispworks '("swank-lispworks" "swank-gray")
36 heller 1.7 #+allegro '("swank-allegro" "swank-gray")
37 wjenkner 1.16 #+clisp '("xref" "metering" "swank-clisp" "swank-gray")
38 heller 1.6 ))
39 jbielman 1.1
40 heller 1.17 (defparameter *lisp-name*
41     #+cmu "cmu"
42     #+sbcl "sbcl"
43     #+openmcl "openmcl"
44     #+lispworks "lispworks"
45     #+allegro "allegro"
46     #+clisp "clisp")
47    
48 jbielman 1.1 (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 heller 1.17 (defun binary-pathname (source-pathname)
55     (merge-pathnames
56     (make-pathname :directory `(:relative "fasl" ,*lisp-name*))
57     (merge-pathnames (compile-file-pathname source-pathname))))
58    
59 heller 1.4 (defun compile-files-if-needed-serially (files)
60 jbielman 1.1 "Compile each file in FILES if the source is newer than
61     its corresponding binary, or the file preceding it was
62     recompiled."
63 heller 1.6 (with-compilation-unit ()
64     (let ((needs-recompile nil))
65     (dolist (source-pathname files)
66 heller 1.17 (let ((binary-pathname (binary-pathname source-pathname)))
67 heller 1.6 (handler-case
68     (progn
69     (when (or needs-recompile
70     (not (probe-file binary-pathname))
71     (file-newer-p source-pathname binary-pathname))
72     (format t "~&;; Compiling ~A...~%" source-pathname)
73 heller 1.17 (ensure-directories-exist binary-pathname)
74     (compile-file source-pathname :output-file binary-pathname)
75 heller 1.6 (setq needs-recompile t))
76     (load binary-pathname))
77 heller 1.13 #+(or)
78 heller 1.6 (error ()
79     ;; If an error occurs compiling, load the source instead
80     ;; so we can try to debug it.
81 heller 1.13 (load source-pathname))
82     ))))))
83 jbielman 1.1
84 heller 1.4 (defun user-init-file ()
85 heller 1.6 "Return the name of the user init file or nil."
86 heller 1.12 (probe-file
87     (merge-pathnames (user-homedir-pathname)
88     #-mswindows (make-pathname :name ".swank" :type "lisp")
89     #+mswindows (make-pathname :name "_swank" :type "lsp"))))
90 heller 1.4
91 lgorrie 1.5 (compile-files-if-needed-serially
92 heller 1.18 (append (list (make-swank-pathname "swank-backend"))
93     *sysdep-pathnames*
94     (list *swank-pathname*)))
95 lgorrie 1.14
96 heller 1.18 (funcall (intern (string :warn-unimplemented-interfaces) :swank-backend))
97 heller 1.4
98     (when (user-init-file)
99     (load (user-init-file)))
100 jbielman 1.1

  ViewVC Help
Powered by ViewVC 1.1.5