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

Contents of /slime/swank-loader.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.17 - (hide annotations)
Wed Feb 18 07:31:59 2004 UTC (10 years, 2 months ago) by heller
Branch: MAIN
CVS Tags: SLIME-0-11
Branch point for: package-split
Changes since 1.16: +17 -3 lines
Place the fasl files of different implementations in different
directories.  Patch by Peter Seibel.
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 heller 1.17 ;;; $Id: swank-loader.lisp,v 1.17 2004/02/18 07:31:59 heller Exp $
11 jbielman 1.1 ;;;
12    
13 heller 1.11 (cl:defpackage :swank-loader
14 jbielman 1.1 (:use :common-lisp))
15 heller 1.4
16 jbielman 1.1 (in-package :swank-loader)
17    
18     (defun make-swank-pathname (name &optional (type "lisp"))
19     "Return a pathname with name component NAME in the Slime directory."
20     (merge-pathnames name
21     (make-pathname
22     :type type
23     :directory
24     (pathname-directory
25     (or *compile-file-pathname* *load-pathname*
26     *default-pathname-defaults*)))))
27    
28 heller 1.3 (defparameter *sysdep-pathnames*
29     (mapcar #'make-swank-pathname
30 heller 1.9 #+cmu '("swank-source-path-parser" "swank-cmucl")
31 dbarlow 1.8 #+sbcl '("swank-sbcl" "swank-source-path-parser" "swank-gray")
32 heller 1.6 #+openmcl '("swank-openmcl" "swank-gray")
33     #+lispworks '("swank-lispworks" "swank-gray")
34 heller 1.7 #+allegro '("swank-allegro" "swank-gray")
35 wjenkner 1.16 #+clisp '("xref" "metering" "swank-clisp" "swank-gray")
36 heller 1.6 ))
37 jbielman 1.1
38 heller 1.17 (defparameter *lisp-name*
39     #+cmu "cmu"
40     #+sbcl "sbcl"
41     #+openmcl "openmcl"
42     #+lispworks "lispworks"
43     #+allegro "allegro"
44     #+clisp "clisp")
45    
46 jbielman 1.1 (defparameter *swank-pathname* (make-swank-pathname "swank"))
47    
48     (defun file-newer-p (new-file old-file)
49     "Returns true if NEW-FILE is newer than OLD-FILE."
50     (> (file-write-date new-file) (file-write-date old-file)))
51    
52 heller 1.17 (defun binary-pathname (source-pathname)
53     (merge-pathnames
54     (make-pathname :directory `(:relative "fasl" ,*lisp-name*))
55     (merge-pathnames (compile-file-pathname source-pathname))))
56    
57 heller 1.4 (defun compile-files-if-needed-serially (files)
58 jbielman 1.1 "Compile each file in FILES if the source is newer than
59     its corresponding binary, or the file preceding it was
60     recompiled."
61 heller 1.6 (with-compilation-unit ()
62     (let ((needs-recompile nil))
63     (dolist (source-pathname files)
64 heller 1.17 (let ((binary-pathname (binary-pathname source-pathname)))
65 heller 1.6 (handler-case
66     (progn
67     (when (or needs-recompile
68     (not (probe-file binary-pathname))
69     (file-newer-p source-pathname binary-pathname))
70     (format t "~&;; Compiling ~A...~%" source-pathname)
71 heller 1.17 (ensure-directories-exist binary-pathname)
72     (compile-file source-pathname :output-file binary-pathname)
73 heller 1.6 (setq needs-recompile t))
74     (load binary-pathname))
75 heller 1.13 #+(or)
76 heller 1.6 (error ()
77     ;; If an error occurs compiling, load the source instead
78     ;; so we can try to debug it.
79 heller 1.13 (load source-pathname))
80     ))))))
81 jbielman 1.1
82 heller 1.4 (defun user-init-file ()
83 heller 1.6 "Return the name of the user init file or nil."
84 heller 1.12 (probe-file
85     (merge-pathnames (user-homedir-pathname)
86     #-mswindows (make-pathname :name ".swank" :type "lisp")
87     #+mswindows (make-pathname :name "_swank" :type "lsp"))))
88 heller 1.4
89 lgorrie 1.5 (compile-files-if-needed-serially
90 heller 1.13 (list* (make-swank-pathname "swank-backend") *swank-pathname*
91     *sysdep-pathnames*))
92 lgorrie 1.14
93 heller 1.15 (funcall (intern (string :warn-unimplemented-interfaces) :swank))
94 heller 1.4
95     (when (user-init-file)
96     (load (user-init-file)))
97 jbielman 1.1

  ViewVC Help
Powered by ViewVC 1.1.5