diff options
Diffstat (limited to 'vim/bundle/slimv/slime/swank-loader.lisp')
| -rw-r--r-- | vim/bundle/slimv/slime/swank-loader.lisp | 366 |
1 files changed, 366 insertions, 0 deletions
diff --git a/vim/bundle/slimv/slime/swank-loader.lisp b/vim/bundle/slimv/slime/swank-loader.lisp new file mode 100644 index 0000000..7bb81da --- /dev/null +++ b/vim/bundle/slimv/slime/swank-loader.lisp @@ -0,0 +1,366 @@ +;;;; -*- indent-tabs-mode: nil -*- +;;; +;;; swank-loader.lisp --- Compile and load the Slime backend. +;;; +;;; Created 2003, James Bielman <jamesjb@jamesjb.com> +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +;; If you want customize the source- or fasl-directory you can set +;; swank-loader:*source-directory* resp. swank-loader:*fasl-directory* +;; before loading this files. +;; E.g.: +;; +;; (load ".../swank-loader.lisp") +;; (setq swank-loader::*fasl-directory* "/tmp/fasl/") +;; (swank-loader:init) + +(cl:defpackage :swank-loader + (:use :cl) + (:export :init + :dump-image + :list-fasls + :*source-directory* + :*fasl-directory*)) + +(cl:in-package :swank-loader) + +(defvar *source-directory* + (make-pathname :name nil :type nil + :defaults (or *load-pathname* *default-pathname-defaults*)) + "The directory where to look for the source.") + +(defparameter *sysdep-files* + #+cmu '((swank source-path-parser) (swank source-file-cache) (swank cmucl) + (swank gray)) + #+scl '((swank source-path-parser) (swank source-file-cache) (swank scl) + (swank gray)) + #+sbcl '((swank source-path-parser) (swank source-file-cache) (swank sbcl) + (swank gray)) + #+clozure '(metering (swank ccl) (swank gray)) + #+lispworks '((swank lispworks) (swank gray)) + #+allegro '((swank allegro) (swank gray)) + #+clisp '(xref metering (swank clisp) (swank gray)) + #+armedbear '((swank abcl)) + #+cormanlisp '((swank corman) (swank gray)) + #+ecl '((swank ecl) (swank gray)) + #+clasp '((swank clasp) (swank gray)) + #+mkcl '((swank mkcl) (swank gray)) + ) + +(defparameter *implementation-features* + '(:allegro :lispworks :sbcl :clozure :cmu :clisp :ccl :corman :cormanlisp + :armedbear :gcl :ecl :scl :mkcl :clasp)) + +(defparameter *os-features* + '(:macosx :linux :windows :mswindows :win32 :solaris :darwin :sunos :hpux + :unix)) + +(defparameter *architecture-features* + '(:powerpc :ppc :x86 :x86-64 :x86_64 :amd64 :i686 :i586 :i486 :pc386 :iapx386 + :sparc64 :sparc :hppa64 :hppa :arm :armv5l :armv6l :armv7l :arm64 + :pentium3 :pentium4 + :mips :mipsel + :java-1.4 :java-1.5 :java-1.6 :java-1.7)) + +(defun q (s) (read-from-string s)) + +#+ecl +(defun ecl-version-string () + (format nil "~A~@[-~A~]" + (lisp-implementation-version) + (when (find-symbol "LISP-IMPLEMENTATION-VCS-ID" :ext) + (let ((vcs-id (funcall (q "ext:lisp-implementation-vcs-id")))) + (when (>= (length vcs-id) 8) + (subseq vcs-id 0 8)))))) + +#+clasp +(defun clasp-version-string () + (format nil "~A~@[-~A~]" + (lisp-implementation-version) + (core:lisp-implementation-id))) + +(defun lisp-version-string () + #+(or clozure cmu) (substitute-if #\_ (lambda (x) (find x " /")) + (lisp-implementation-version)) + #+(or cormanlisp scl mkcl) (lisp-implementation-version) + #+sbcl (format nil "~a~:[~;-no-threads~]" + (lisp-implementation-version) + #+sb-thread nil + #-sb-thread t) + #+lispworks (lisp-implementation-version) + #+allegro (format nil "~@{~a~}" + excl::*common-lisp-version-number* + (if (eq 'h 'H) "A" "M") ; ANSI vs MoDeRn + (if (member :smp *features*) "s" "") + (if (member :64bit *features*) "-64bit" "") + (excl:ics-target-case + (:-ics "") + (:+ics "-ics"))) + #+clisp (let ((s (lisp-implementation-version))) + (subseq s 0 (position #\space s))) + #+armedbear (lisp-implementation-version) + #+ecl (ecl-version-string) + #+clasp (clasp-version-string)) + +(defun unique-dir-name () + "Return a name that can be used as a directory name that is +unique to a Lisp implementation, Lisp implementation version, +operating system, and hardware architecture." + (flet ((first-of (features) + (loop for f in features + when (find f *features*) return it)) + (maybe-warn (value fstring &rest args) + (cond (value) + (t (apply #'warn fstring args) + "unknown")))) + (let ((lisp (maybe-warn (first-of *implementation-features*) + "No implementation feature found in ~a." + *implementation-features*)) + (os (maybe-warn (first-of *os-features*) + "No os feature found in ~a." *os-features*)) + (arch (maybe-warn (first-of *architecture-features*) + "No architecture feature found in ~a." + *architecture-features*)) + (version (maybe-warn (lisp-version-string) + "Don't know how to get Lisp ~ + implementation version."))) + (format nil "~(~@{~a~^-~}~)" lisp version os arch)))) + +(defun file-newer-p (new-file old-file) + "Returns true if NEW-FILE is newer than OLD-FILE." + (> (file-write-date new-file) (file-write-date old-file))) + +(defun string-starts-with (string prefix) + (string-equal string prefix :end1 (min (length string) (length prefix)))) + +(defun slime-version-string () + "Return a string identifying the SLIME version. +Return nil if nothing appropriate is available." + (with-open-file (s (merge-pathnames "slime.el" *source-directory*) + :if-does-not-exist nil) + (loop with prefix = ";; Version: " + for line = (read-line s nil :eof) + until (eq line :eof) + when (string-starts-with line prefix) + return (subseq line (length prefix))))) + +(defun default-fasl-dir () + (merge-pathnames + (make-pathname + :directory `(:relative ".slime" "fasl" + ,@(if (slime-version-string) (list (slime-version-string))) + ,(unique-dir-name))) + (user-homedir-pathname))) + +(defvar *fasl-directory* (default-fasl-dir) + "The directory where fasl files should be placed.") + +(defun binary-pathname (src-pathname binary-dir) + "Return the pathname where SRC-PATHNAME's binary should be compiled." + (let ((cfp (compile-file-pathname src-pathname))) + (merge-pathnames (make-pathname :name (pathname-name cfp) + :type (pathname-type cfp)) + binary-dir))) + +(defun handle-swank-load-error (condition context pathname) + (fresh-line *error-output*) + (pprint-logical-block (*error-output* () :per-line-prefix ";; ") + (format *error-output* + "~%Error ~A ~A:~% ~A~%" + context pathname condition))) + +(defun compile-files (files fasl-dir load quiet) + "Compile each file in FILES if the source is newer than its +corresponding binary, or the file preceding it was recompiled. +If LOAD is true, load the fasl file." + (let ((needs-recompile nil) + (state :unknown)) + (dolist (src files) + (let ((dest (binary-pathname src fasl-dir))) + (handler-bind + ((error (lambda (c) + (ecase state + (:compile (handle-swank-load-error c "compiling" src)) + (:load (handle-swank-load-error c "loading" dest)) + (:unknown (handle-swank-load-error c "???ing" src)))))) + (when (or needs-recompile + (not (probe-file dest)) + (file-newer-p src dest)) + (ensure-directories-exist dest) + ;; need to recompile SRC, so we'll need to recompile + ;; everything after this too. + (setf needs-recompile t + state :compile) + (or (compile-file src :output-file dest :print nil + :verbose (not quiet)) + ;; An implementation may not necessarily signal a + ;; condition itself when COMPILE-FILE fails (e.g. ECL) + (error "COMPILE-FILE returned NIL."))) + (when load + (setf state :load) + (load dest :verbose (not quiet)))))))) + +#+cormanlisp +(defun compile-files (files fasl-dir load quiet) + "Corman Lisp has trouble with compiled files." + (declare (ignore fasl-dir)) + (when load + (dolist (file files) + (load file :verbose (not quiet) + (force-output))))) + +(defun load-user-init-file () + "Load the user init file, return NIL if it does not exist." + (load (merge-pathnames (user-homedir-pathname) + (make-pathname :name ".swank" :type "lisp")) + :if-does-not-exist nil)) + +(defun load-site-init-file (dir) + (load (make-pathname :name "site-init" :type "lisp" + :defaults dir) + :if-does-not-exist nil)) + +(defun src-files (names src-dir) + (mapcar (lambda (name) + (multiple-value-bind (dirs name) + (etypecase name + (symbol (values '() name)) + (cons (values (butlast name) (car (last name))))) + (make-pathname + :directory (append (or (pathname-directory src-dir) + '(:relative)) + (mapcar #'string-downcase dirs)) + :name (string-downcase name) + :type "lisp" + :defaults src-dir))) + names)) + +(defvar *swank-files* + `(packages + (swank backend) ,@*sysdep-files* (swank match) (swank rpc) + swank)) + +(defvar *contribs* + '(swank-util swank-repl + swank-c-p-c swank-arglists swank-fuzzy + swank-fancy-inspector + swank-presentations swank-presentation-streams + #+(or asdf2 asdf3 sbcl ecl) swank-asdf + swank-package-fu + swank-hyperdoc + #+sbcl swank-sbcl-exts + swank-mrepl + swank-trace-dialog + swank-macrostep + swank-quicklisp) + "List of names for contrib modules.") + +(defun append-dir (absolute name) + (merge-pathnames + (make-pathname :directory `(:relative ,name) :defaults absolute) + absolute)) + +(defun contrib-dir (base-dir) + (append-dir base-dir "contrib")) + +(defun load-swank (&key (src-dir *source-directory*) + (fasl-dir *fasl-directory*) + quiet) + (with-compilation-unit () + (compile-files (src-files *swank-files* src-dir) fasl-dir t quiet)) + (funcall (q "swank::before-init") + (slime-version-string) + (list (contrib-dir fasl-dir) + (contrib-dir src-dir)))) + +(defun delete-stale-contrib-fasl-files (swank-files contrib-files fasl-dir) + (let ((newest (reduce #'max (mapcar #'file-write-date swank-files)))) + (dolist (src contrib-files) + (let ((fasl (binary-pathname src fasl-dir))) + (when (and (probe-file fasl) + (<= (file-write-date fasl) newest)) + (delete-file fasl)))))) + +(defun compile-contribs (&key (src-dir (contrib-dir *source-directory*)) + (fasl-dir (contrib-dir *fasl-directory*)) + (swank-src-dir *source-directory*) + load quiet) + (let* ((swank-src-files (src-files *swank-files* swank-src-dir)) + (contrib-src-files (src-files *contribs* src-dir))) + (delete-stale-contrib-fasl-files swank-src-files contrib-src-files + fasl-dir) + (compile-files contrib-src-files fasl-dir load quiet))) + +(defun loadup () + (load-swank) + (compile-contribs :load t)) + +(defun setup () + (load-site-init-file *source-directory*) + (load-user-init-file) + (when (#-clisp probe-file + #+clisp ext:probe-directory + (contrib-dir *source-directory*)) + (eval `(pushnew 'compile-contribs ,(q "swank::*after-init-hook*")))) + (funcall (q "swank::init"))) + +(defun list-swank-packages () + (remove-if-not (lambda (package) + (let ((name (package-name package))) + (and (string-not-equal name "swank-loader") + (string-starts-with name "swank")))) + (list-all-packages))) + +(defun delete-packages (packages) + (dolist (package packages) + (flet ((handle-package-error (c) + (let ((pkgs (set-difference (package-used-by-list package) + packages))) + (when pkgs + (warn "deleting ~a which is used by ~{~a~^, ~}." + package pkgs)) + (continue c)))) + (handler-bind ((package-error #'handle-package-error)) + (delete-package package))))) + +(defun init (&key delete reload load-contribs (setup t) + (quiet (not *load-verbose*))) + "Load SWANK and initialize some global variables. +If DELETE is true, delete any existing SWANK packages. +If RELOAD is true, reload SWANK, even if the SWANK package already exists. +If LOAD-CONTRIBS is true, load all contribs +If SETUP is true, load user init files and initialize some +global variabes in SWANK." + (when (and delete (find-package :swank)) + (delete-packages (list-swank-packages))) + (cond ((or (not (find-package :swank)) reload) + (load-swank :quiet quiet)) + (t + (warn "Not reloading SWANK. Package already exists."))) + (when load-contribs + (compile-contribs :load t :quiet quiet)) + (when setup + (setup))) + +(defun dump-image (filename) + (init :setup nil) + (funcall (q "swank/backend:save-image") filename)) + +(defun list-fasls (&key (include-contribs t) (compile t) + (quiet (not *compile-verbose*))) + "List up SWANK's fasls along with their dependencies." + (flet ((collect-fasls (files fasl-dir) + (when compile + (compile-files files fasl-dir nil quiet)) + (loop for src in files + when (probe-file (binary-pathname src fasl-dir)) + collect it))) + (append (collect-fasls (src-files *swank-files* *source-directory*) + *fasl-directory*) + (when include-contribs + (collect-fasls (src-files *contribs* + (contrib-dir *source-directory*)) + (contrib-dir *fasl-directory*)))))) |