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

Contents of /slime/swank-loader.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.23 - (hide annotations)
Wed Apr 28 22:21:10 2004 UTC (9 years, 11 months ago) by heller
Branch: MAIN
CVS Tags: SLIME-0-14, SLIME-0-13
Changes since 1.22: +2 -1 lines
(*lisp-name*): Add versioning support for CLISP.
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     )))
41 jbielman 1.1
42 heller 1.17 (defparameter *lisp-name*
43 lgorrie 1.22 #+cmu (format nil "cmu-~A" (lisp-implementation-version))
44     #+sbcl (format nil "sbcl-~A" (lisp-implementation-version))
45     #+openmcl "openmcl"
46 heller 1.17 #+lispworks "lispworks"
47 lgorrie 1.22 #+allegro "allegro"
48 heller 1.23 #+clisp (format nil "clisp-~A" (let ((s (lisp-implementation-version)))
49     (subseq s 0 (position #\space s))))
50 heller 1.21 )
51 heller 1.17
52 jbielman 1.1 (defparameter *swank-pathname* (make-swank-pathname "swank"))
53    
54     (defun file-newer-p (new-file old-file)
55     "Returns true if NEW-FILE is newer than OLD-FILE."
56     (> (file-write-date new-file) (file-write-date old-file)))
57    
58 heller 1.17 (defun binary-pathname (source-pathname)
59     (merge-pathnames
60     (make-pathname :directory `(:relative "fasl" ,*lisp-name*))
61     (merge-pathnames (compile-file-pathname source-pathname))))
62    
63 heller 1.4 (defun compile-files-if-needed-serially (files)
64 jbielman 1.1 "Compile each file in FILES if the source is newer than
65     its corresponding binary, or the file preceding it was
66     recompiled."
67 heller 1.6 (with-compilation-unit ()
68     (let ((needs-recompile nil))
69     (dolist (source-pathname files)
70 heller 1.17 (let ((binary-pathname (binary-pathname source-pathname)))
71 heller 1.6 (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 heller 1.17 (ensure-directories-exist binary-pathname)
78     (compile-file source-pathname :output-file binary-pathname)
79 heller 1.6 (setq needs-recompile t))
80     (load binary-pathname))
81 heller 1.13 #+(or)
82 heller 1.6 (error ()
83     ;; If an error occurs compiling, load the source instead
84     ;; so we can try to debug it.
85 heller 1.13 (load source-pathname))
86     ))))))
87 jbielman 1.1
88 heller 1.4 (defun user-init-file ()
89 heller 1.6 "Return the name of the user init file or nil."
90 heller 1.12 (probe-file
91     (merge-pathnames (user-homedir-pathname)
92     #-mswindows (make-pathname :name ".swank" :type "lisp")
93     #+mswindows (make-pathname :name "_swank" :type "lsp"))))
94 heller 1.4
95 lgorrie 1.5 (compile-files-if-needed-serially
96 heller 1.18 (append (list (make-swank-pathname "swank-backend"))
97     *sysdep-pathnames*
98     (list *swank-pathname*)))
99 lgorrie 1.14
100 heller 1.18 (funcall (intern (string :warn-unimplemented-interfaces) :swank-backend))
101 heller 1.4
102     (when (user-init-file)
103     (load (user-init-file)))
104 jbielman 1.1

  ViewVC Help
Powered by ViewVC 1.1.5