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

Contents of /slime/swank-loader.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.31 - (hide annotations)
Mon Jul 12 10:36:31 2004 UTC (9 years, 9 months ago) by lgorrie
Branch: MAIN
CVS Tags: SLIME-1-0-BETA
Changes since 1.30: +2 -3 lines
*** empty log message ***
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.21 (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 heller 1.24 #+armedbear '("swank-abcl" "swank-gray")
41 heller 1.21 )))
42 jbielman 1.1
43 heller 1.17 (defparameter *lisp-name*
44 lgorrie 1.22 #+cmu (format nil "cmu-~A" (lisp-implementation-version))
45     #+sbcl (format nil "sbcl-~A" (lisp-implementation-version))
46     #+openmcl "openmcl"
47 lgorrie 1.29 #+lispworks (format nil "lispworks-~A" (lisp-implementation-version))
48 lgorrie 1.30 #+allegro (format nil "allegro-~A" excl::*common-lisp-version-number*)
49 heller 1.23 #+clisp (format nil "clisp-~A" (let ((s (lisp-implementation-version)))
50     (subseq s 0 (position #\space s))))
51 heller 1.24 #+armedbear "abcl"
52 heller 1.21 )
53 heller 1.17
54 jbielman 1.1 (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 heller 1.17 (defun binary-pathname (source-pathname)
61 lgorrie 1.27 "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 lgorrie 1.28 :directory `(:relative
65     ".slime" "fasl" ,*lisp-name*)
66 lgorrie 1.27 :name (pathname-name cfp)
67     :type (pathname-type cfp))
68     (user-homedir-pathname))))
69 heller 1.17
70 heller 1.4 (defun compile-files-if-needed-serially (files)
71 jbielman 1.1 "Compile each file in FILES if the source is newer than
72     its corresponding binary, or the file preceding it was
73     recompiled."
74 heller 1.6 (with-compilation-unit ()
75     (let ((needs-recompile nil))
76     (dolist (source-pathname files)
77 heller 1.17 (let ((binary-pathname (binary-pathname source-pathname)))
78 heller 1.6 (handler-case
79     (progn
80     (when (or needs-recompile
81     (not (probe-file binary-pathname))
82     (file-newer-p source-pathname binary-pathname))
83     (format t "~&;; Compiling ~A...~%" source-pathname)
84 heller 1.17 (ensure-directories-exist binary-pathname)
85     (compile-file source-pathname :output-file binary-pathname)
86 heller 1.6 (setq needs-recompile t))
87     (load binary-pathname))
88 heller 1.13 #+(or)
89 heller 1.6 (error ()
90     ;; If an error occurs compiling, load the source instead
91     ;; so we can try to debug it.
92 heller 1.13 (load source-pathname))
93     ))))))
94 jbielman 1.1
95 heller 1.4 (defun user-init-file ()
96 heller 1.6 "Return the name of the user init file or nil."
97 lgorrie 1.31 (probe-file (merge-pathnames (user-homedir-pathname)
98     (make-pathname :name ".swank" :type "lisp"))))
99 heller 1.4
100 heller 1.24
101 lgorrie 1.5 (compile-files-if-needed-serially
102 heller 1.18 (append (list (make-swank-pathname "swank-backend"))
103     *sysdep-pathnames*
104     (list *swank-pathname*)))
105 lgorrie 1.14
106 heller 1.18 (funcall (intern (string :warn-unimplemented-interfaces) :swank-backend))
107 heller 1.4
108     (when (user-init-file)
109     (load (user-init-file)))
110 jbielman 1.1

  ViewVC Help
Powered by ViewVC 1.1.5