slynk-loader.lisp (13695B)
1 ;;;; -*- indent-tabs-mode: nil -*- 2 ;;; 3 ;;; slynk-loader.lisp --- Compile and load the Sly 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 ;; If you want customize the source- or fasl-directory you can set 12 ;; slynk-loader:*source-directory* resp. slynk-loader:*fasl-directory* 13 ;; before loading this files. 14 ;; E.g.: 15 ;; 16 ;; (load ".../slynk-loader.lisp") 17 ;; (setq slynk-loader::*fasl-directory* "/tmp/fasl/") 18 ;; (slynk-loader:init) 19 20 (cl:defpackage :slynk-loader 21 (:use :cl) 22 (:export #:init 23 #:dump-image 24 #:*source-directory* 25 #:*fasl-directory* 26 #:*load-path*)) 27 28 (cl:in-package :slynk-loader) 29 30 (defvar *source-directory* 31 (make-pathname :name nil :type nil 32 :defaults (or *load-pathname* *default-pathname-defaults*)) 33 "The directory where to look for the source.") 34 35 (defvar *load-path* (list *source-directory*) 36 "A list of directories to search for modules.") 37 38 (defparameter *sysdep-files* 39 #+cmu '(slynk-source-path-parser slynk-source-file-cache (backend cmucl)) 40 #+scl '(slynk-source-path-parser slynk-source-file-cache (backend scl)) 41 #+sbcl '(slynk-source-path-parser slynk-source-file-cache 42 (backend sbcl)) 43 #+clozure '(metering (backend ccl)) 44 #+lispworks '((backend lispworks)) 45 #+allegro '((backend allegro)) 46 #+clisp '(xref metering (backend clisp)) 47 #+armedbear '((backend abcl)) 48 #+cormanlisp '((backend corman)) 49 #+ecl '(slynk-source-path-parser slynk-source-file-cache 50 (backend ecl)) 51 #+clasp '(metering (backend clasp)) 52 #+mkcl '((backend mkcl))) 53 54 (defparameter *implementation-features* 55 '(:allegro :lispworks :sbcl :clozure :cmu :clisp :ccl :corman :cormanlisp 56 :armedbear :gcl :ecl :scl :mkcl :clasp)) 57 58 (defparameter *os-features* 59 '(:macosx :linux :windows :mswindows :win32 :solaris :darwin :sunos :hpux 60 :unix)) 61 62 (defparameter *architecture-features* 63 '(:powerpc :ppc :ppc64 :x86 :x86-64 :x86_64 :amd64 :i686 :i586 :i486 :pc386 :iapx386 64 :sparc64 :sparc :hppa64 :hppa :arm :armv5l :armv6l :armv7l :arm64 :aarch64 65 :pentium3 :pentium4 66 :mips :mipsel 67 :java-1.4 :java-1.5 :java-1.6 :java-1.7)) 68 69 (defun q (s) (read-from-string s)) 70 71 #+ecl 72 (defun ecl-version-string () 73 (format nil "~A~@[-~A~]" 74 (lisp-implementation-version) 75 (when (find-symbol "LISP-IMPLEMENTATION-VCS-ID" :ext) 76 (let ((vcs-id (funcall (q "ext:lisp-implementation-vcs-id")))) 77 (when (>= (length vcs-id) 8) 78 (subseq vcs-id 0 8)))))) 79 80 #+clasp 81 (defun clasp-version-string () 82 (format nil "~A~@[-~A~]" 83 (lisp-implementation-version) 84 (core:lisp-implementation-id))) 85 86 (defun lisp-version-string () 87 #+(or clozure cmu) (substitute-if #\_ (lambda (x) (find x " /")) 88 (lisp-implementation-version)) 89 #+(or cormanlisp scl mkcl) (lisp-implementation-version) 90 #+sbcl (format nil "~a~:[~;-no-threads~]" 91 (lisp-implementation-version) 92 #+sb-thread nil 93 #-sb-thread t) 94 #+lispworks (lisp-implementation-version) 95 #+allegro (format nil "~@{~a~}" 96 excl::*common-lisp-version-number* 97 (if (string= 'lisp "LISP") "A" "M") ; ANSI vs MoDeRn 98 (if (member :smp *features*) "s" "") 99 (if (member :64bit *features*) "-64bit" "") 100 (excl:ics-target-case 101 (:-ics "") 102 (:+ics "-ics"))) 103 #+clisp (let ((s (lisp-implementation-version))) 104 (subseq s 0 (position #\space s))) 105 #+armedbear (lisp-implementation-version) 106 #+ecl (ecl-version-string) ) 107 108 (defun unique-dir-name () 109 "Return a name that can be used as a directory name that is 110 unique to a Lisp implementation, Lisp implementation version, 111 operating system, and hardware architecture." 112 (flet ((first-of (features) 113 (loop for f in features 114 when (find f *features*) return it)) 115 (maybe-warn (value fstring &rest args) 116 (cond (value) 117 (t (apply #'warn fstring args) 118 "unknown")))) 119 (let ((lisp (maybe-warn (first-of *implementation-features*) 120 "No implementation feature found in ~a." 121 *implementation-features*)) 122 (os (maybe-warn (first-of *os-features*) 123 "No os feature found in ~a." *os-features*)) 124 (arch (maybe-warn (first-of *architecture-features*) 125 "No architecture feature found in ~a." 126 *architecture-features*)) 127 (version (maybe-warn (lisp-version-string) 128 "Don't know how to get Lisp ~ 129 implementation version."))) 130 (format nil "~(~@{~a~^-~}~)" lisp version os arch)))) 131 132 (defun file-newer-p (new-file old-file) 133 "Returns true if NEW-FILE is newer than OLD-FILE." 134 (> (file-write-date new-file) (file-write-date old-file))) 135 136 (defun sly-version-string () 137 "Return a string identifying the SLY version. 138 Return nil if nothing appropriate is available." 139 (let ((this-file #.(or *compile-file-truename* *load-truename*))) 140 (with-open-file (s (make-pathname :name "sly" :type "el" 141 :directory (butlast 142 (pathname-directory this-file) 143 1) 144 :defaults this-file)) 145 (let ((seq (make-array 200 :element-type 'character :initial-element #\null))) 146 (read-sequence seq s :end 200) 147 (let* ((beg (search ";; Version:" seq)) 148 (end (position #\NewLine seq :start beg)) 149 (middle (position #\Space seq :from-end t :end end))) 150 (subseq seq (1+ middle) end)))))) 151 152 (defun default-fasl-dir () 153 (merge-pathnames 154 (make-pathname 155 :directory `(:relative ".sly" "fasl" 156 ,@(if (sly-version-string) (list (sly-version-string))) 157 ,(unique-dir-name))) 158 (let ((uhp (user-homedir-pathname))) 159 (make-pathname 160 :directory (or (pathname-directory uhp) 161 '(:absolute)) 162 :defaults uhp)))) 163 164 (defvar *fasl-directory* (default-fasl-dir) 165 "The directory where fasl files should be placed.") 166 167 (defun binary-pathname (src-pathname binary-dir) 168 "Return the pathname where SRC-PATHNAME's binary should be compiled." 169 (let ((cfp (compile-file-pathname src-pathname))) 170 (merge-pathnames (make-pathname :name (pathname-name cfp) 171 :type (pathname-type cfp)) 172 binary-dir))) 173 174 (defun handle-slynk-load-error (condition context pathname) 175 (fresh-line *error-output*) 176 (pprint-logical-block (*error-output* () :per-line-prefix ";; ") 177 (format *error-output* 178 "~%Error ~A ~A:~% ~A~%" 179 context pathname condition))) 180 181 (defun compile-files (files fasl-dir load quiet) 182 "Compile each file in FILES if the source is newer than its 183 corresponding binary, or the file preceding it was recompiled. 184 If LOAD is true, load the fasl file." 185 (let ((needs-recompile nil) 186 (state :unknown)) 187 (dolist (src files) 188 (let ((dest (binary-pathname src fasl-dir))) 189 (handler-bind 190 ((error (lambda (c) 191 (ecase state 192 (:compile (handle-slynk-load-error c "compiling" src)) 193 (:load (handle-slynk-load-error c "loading" dest)) 194 (:unknown (handle-slynk-load-error c "???ing" src)))))) 195 (when (or needs-recompile 196 (not (probe-file dest)) 197 (file-newer-p src dest)) 198 (ensure-directories-exist dest) 199 ;; need to recompile SRC, so we'll need to recompile 200 ;; everything after this too. 201 (setf needs-recompile t 202 state :compile) 203 (or (compile-file src :output-file dest :print nil 204 :verbose (not quiet)) 205 ;; An implementation may not necessarily signal a 206 ;; condition itself when COMPILE-FILE fails (e.g. ECL) 207 (error "COMPILE-FILE returned NIL."))) 208 (when load 209 (setf state :load) 210 (load dest :verbose (not quiet)))))))) 211 212 #+cormanlisp 213 (defun compile-files (files fasl-dir load quiet) 214 "Corman Lisp has trouble with compiled files." 215 (declare (ignore fasl-dir)) 216 (when load 217 (dolist (file files) 218 (load file :verbose (not quiet) 219 (force-output))))) 220 221 (defun ensure-list (o) 222 (if (listp o) o (list o))) 223 224 (defun src-files (files src-dir) 225 "Return actual pathnames for each spec in FILES." 226 (mapcar (lambda (compound-name) 227 (let* ((directories (butlast compound-name)) 228 (name (car (last compound-name)))) 229 (make-pathname :name (string-downcase name) :type "lisp" 230 :directory (append (or (pathname-directory src-dir) 231 '(:relative)) 232 (mapcar #'string-downcase directories)) 233 :defaults src-dir))) 234 (mapcar #'ensure-list files))) 235 236 (defvar *slynk-files* 237 `(slynk-backend ,@*sysdep-files* #-armedbear slynk-gray slynk-match slynk-rpc 238 slynk slynk-completion slynk-apropos)) 239 240 (defun load-slynk (&key (src-dir *source-directory*) 241 (fasl-dir *fasl-directory*) 242 quiet) 243 (compile-files (src-files *slynk-files* src-dir) fasl-dir t quiet)) 244 245 (defun delete-stale-contrib-fasl-files (slynk-files contrib-files fasl-dir) 246 (let ((newest (reduce #'max (mapcar #'file-write-date slynk-files)))) 247 (dolist (src contrib-files) 248 (let ((fasl (binary-pathname src fasl-dir))) 249 (when (and (probe-file fasl) 250 (<= (file-write-date fasl) newest)) 251 (delete-file fasl)))))) 252 253 (defun loadup () 254 (load-slynk)) 255 256 (defun setup () 257 (funcall (q "slynk::init"))) 258 259 (defun string-starts-with (string prefix) 260 (string-equal string prefix :end1 (min (length string) (length prefix)))) 261 262 (defun list-slynk-packages () 263 (remove-if-not (lambda (package) 264 (let ((name (package-name package))) 265 (and (string-not-equal name "slynk-loader") 266 (string-starts-with name "slynk")))) 267 (list-all-packages))) 268 269 (defun delete-packages (packages) 270 (dolist (package packages) 271 (flet ((handle-package-error (c) 272 (let ((pkgs (set-difference (package-used-by-list package) 273 packages))) 274 (when pkgs 275 (warn "deleting ~a which is used by ~{~a~^, ~}." 276 package pkgs)) 277 (continue c)))) 278 (handler-bind ((package-error #'handle-package-error)) 279 (delete-package package))))) 280 281 (defun init (&key delete reload (setup t) 282 (quiet (not *load-verbose*)) 283 load-contribs) 284 "Load SLYNK and initialize some global variables. 285 If DELETE is true, delete any existing SLYNK packages. 286 If RELOAD is true, reload SLYNK, even if the SLYNK package already exists. 287 If SETUP is true, load user init files and initialize some 288 global variabes in SLYNK." 289 (if load-contribs 290 (warn 291 "LOAD-CONTRIBS arg to SLYNK-LOADER:INIT is deprecated and useless")) 292 (when (and delete (find-package :slynk)) 293 (delete-packages (list-slynk-packages)) 294 (mapc #'delete-package '(:slynk :slynk-io-package :slynk-backend))) 295 (cond ((or (not (find-package :slynk)) reload) 296 (load-slynk :quiet quiet)) 297 (t 298 (warn "Not reloading SLYNK. Package already exists."))) 299 (when setup 300 (setup))) 301 302 (defun dump-image (filename) 303 (init :setup nil) 304 (funcall (q "slynk-backend:save-image") filename)) 305 306 307 ;;;;;; Simple *require-module* function for asdf-loader.lisp. 308 309 310 (defun module-binary-dir (src-file) 311 (flet ((dir-components (path) 312 (cdr (pathname-directory path)))) 313 (make-pathname :directory 314 (append 315 (pathname-directory *fasl-directory*) 316 (nthcdr (mismatch (dir-components *fasl-directory*) 317 (dir-components src-file) 318 :test #'equal) 319 (dir-components src-file)))))) 320 321 (defun require-module (module) 322 (labels ((module () (string-upcase module)) 323 (provided () 324 (member (string-upcase (module)) *modules* :test #'string=))) 325 (unless (provided) 326 (let* ((src-file-name (substitute #\- #\/ (string-downcase module))) 327 (src-file 328 (some #'(lambda (dir) 329 (probe-file (make-pathname 330 :name src-file-name 331 :type "lisp" 332 :defaults dir))) 333 *load-path*))) 334 (assert src-file 335 nil 336 "Required module ~a but no source file ~a found in ~a" module 337 src-file-name 338 *load-path*) 339 (compile-files (list src-file) 340 (module-binary-dir src-file) 341 'load 342 nil) 343 (assert (provided) 344 nil 345 "Compiled and loaded ~a but required module ~s was not 346 provided" src-file module)))))