;;; asdfa.lisp --- addenda to asdf ;;; Copyright (C) 2003-2009 by Walter C. Pelissero ;;; Author: Walter C. Pelissero ;;; $Id: asdfa.lisp,v 1.37 2009/06/26 16:07:45 wcp Exp $ ;;; Under the same whatsoever usage and copying conditions ASDF might be. ;;; Commentary: ;;; ;;; This file adds five operations to ASDF's standard repertoire and ;;; amends compile-op. ;;; ;;; The new ops are: PACK-op, TAG-op, STAT-op, MAKE-EXE-op and ;;; REVERT-op. The first one creates a tar/zip archive of the files ;;; in a system. The second one creates a tag file (Emacs or Vi ;;; compatible). The third, stat-op, gives some statistics on the ;;; system files. The fourth, make-exe-op, automates the creation of ;;; self sufficient monolithic fasl files, concatenating all the ;;; compiled files into a single one that can be later executed in one ;;; go. The last one, revert-op, removes the files produced by ;;; another operation (default is the compilation). ;;; ;;; Check the documentation of each class for further details. ;;; ;;; The amendments to compile-op concern the destination of compiled ;;; files; with *output-root-directory* you can specify where they ;;; should go. If you leave *output-root-directory* alone, the ;;; original behaviour of compile-op is preserved. ;;; ;;; One possible use of *output-root-directory* is the compilation for ;;; delivery of an executable. You normally want to develop with all ;;; the available support for debugging and in the safest environment ;;; you can possibly get from your Lisp system. That's why you ;;; probably have some very conservative optimisation proclamations in ;;; your Lisp start-up file just for the purpose. Not quite so when ;;; you deliver your program for general use. In that case you may ;;; want the highest execution speed and little or no support for ;;; debugging; you just set *output-root-directory* and compile with ;;; the most reckless optimisation proclamations you deem suitable for ;;; general use of your program. ;;; ;;; You may want to add the following lines to your .emacs file to ;;; integrate these primitives into your SLIME session. ;;; ;;; (defslime-repl-shortcut slime-repl-compile-system ("pack-system") ;;; (:handler (lambda () ;;; (interactive) ;;; (slime-oos (slime-read-system-name) "ASDFA:PACK-OP"))) ;;; (:one-liner "Pack an ASDF system for distribution.")) ;;; ;;; (defslime-repl-shortcut slime-repl-compile-system ("stat-system") ;;; (:handler (lambda () ;;; (interactive) ;;; (slime-oos (slime-read-system-name) "ASDFA:STAT-OP"))) ;;; (:one-liner "Produce figures about an ASDF system.")) ;;; ;;; Fort these shortcuts to work you must patch SLIME: ;;; ;;; diff -c -r1.92 swank-backend.lisp ;;; *** swank-backend.lisp 23 Oct 2005 08:47:54 -0000 1.92 ;;; --- swank-backend.lisp 24 Jan 2006 13:51:45 -0000 ;;; *************** ;;; *** 313,319 **** ;;; (error "ASDF is not loaded.")) ;;; (with-compilation-hooks () ;;; (let ((operate (find-symbol "OPERATE" :asdf)) ;;; ! (operation (find-symbol operation-name :asdf))) ;;; (when (null operation) ;;; (error "Couldn't find ASDF operation ~S" operation-name)) ;;; (apply operate operation system-name keyword-args)))) ;;; --- 313,323 ---- ;;; (error "ASDF is not loaded.")) ;;; (with-compilation-hooks () ;;; (let ((operate (find-symbol "OPERATE" :asdf)) ;;; ! (operation (let ((colon (position #\: operation-name))) ;;; ! (if colon ;;; ! (find-symbol (subseq operation-name (1+ colon)) ;;; ! (subseq operation-name 0 colon)) ;;; ! (find-symbol operation-name :asdf))))) ;;; (when (null operation) ;;; (error "Couldn't find ASDF operation ~S" operation-name)) ;;; (apply operate operation system-name keyword-args)))) ;;; (cl:in-package :cl-user) (defpackage :asdf-add-ons (:nicknames :asdfa) (:use :common-lisp :asdf) (:export #:pack-op #:stat-op #:tag-op #:make-exe-op #:revert-op #:*output-root-directory* #:*system-paths*)) (in-package :asdf-add-ons) (defun common-path (path1 path2) "Return the common directory between two pathnames. Example: (common-path #P\"/usr/home/john/text.doc\" #P\"/usr/home/bill/me.jpg\") => #P\"/usr/home/\"" (do ((p1 (pathname-directory path1) (cdr p1)) (p2 (pathname-directory path2) (cdr p2)) (result nil)) ((or (endp p1) (endp p2) (not (equal (car p1) (car p2)))) (make-pathname :directory (nreverse result))) (push (car p1) result))) (defun time-stamp-string () "Return a string made up like YYYYMMDD, which turns out to be a sensible choice to version-tag the archive files." (multiple-value-bind (s m h dd mm yy) (get-decoded-time) (declare (ignore s m h)) (format nil "~4D~2,'0D~2,'0D" yy mm dd))) (defun system-file (component) (declare (type component component)) (truename (system-definition-pathname (component-system component)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass simple-system-wide-operation (operation) ()) (defmethod input-files ((operation simple-system-wide-operation) (component module)) (mapcan #'(lambda (c) (input-files operation c)) (module-components component))) (defmethod input-files ((operation simple-system-wide-operation) (component source-file)) (list (component-pathname component))) (defmethod perform ((operation simple-system-wide-operation) component) nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; STATIC-FILEs don't have an associated type (nothing after the last ;; dot in the pathname). If the file in the system definition has a ;; type (like "foo.txt"), in some of the following operations, this ;; may cause an error on some Lisp implementations (at least SBCL). ;; This around method takes care to adjust things. (defmethod component-relative-pathname :around ((component static-file)) (let ((path (call-next-method))) (if (pathname-type path) path (let ((name (parse-namestring (pathname-name path)))) (make-pathname :defaults path :name (pathname-name name) :type (pathname-type name)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass pack-op (simple-system-wide-operation) ((archive-type :type (member :tgz :tbz2 :zip) :initarg :archive-type :initform :tbz2 :reader pack-op-archive-type :documentation "Type of the archive file. Either :TGZ, :TBZ2 or :ZIP.") (output-file :type (or pathname (member :time :version)) :initarg :output-file :initform :version :reader pack-op-output-file :documentation "Pathname of the output file or a keyword specifying how to compose the output pathname.")) (:documentation "Operation class to archive the complete collection of files making up a system in a tar file. Other archivers are available; see the ARCHIVE-TYPE slot. Currently supported formats are :TGZ, TBZ2 and :ZIP. The output file name can be chosen with the OUTPUT-FILE slot, which is a pathname or a keyword that specifies how to compose the output pathname. Examples: (oos 'pack-op :foo :archive-type :tgz :output-file :time) (oos 'pack-op :bar :archive-type :zip :output-file #P\"bar.jar\") (oos 'pack-op :baz :archive-type :tbz2)")) (defmethod output-files ((operation pack-op) (component system)) (let ((system-pathname (system-file component)) (output-file (pack-op-output-file operation)) (type (case (pack-op-archive-type operation) (:tgz "tgz") (:tbz2 "tbz") (:zip "zip")))) (list (cond ((pathnamep output-file) (merge-pathnames output-file system-pathname)) ((eq output-file :time) (make-pathname :defaults system-pathname :name (format nil "~A-~A.src" (pathname-name system-pathname) (time-stamp-string)) :type type)) ((eq output-file :version) (make-pathname :defaults system-pathname :name (format nil "~A-~A.src" (pathname-name system-pathname) (if (slot-boundp component 'version) (component-version component) (time-stamp-string))) :type type)) (t (error "~S is an invalid output file specifier." output-file)))))) (defmethod perform ((operation pack-op) (component system)) (let* ((output-file (car (output-files operation component))) (system-file (system-file component)) (files (cons system-file (input-files operation component))) (root (reduce #'common-path files)) #+cmu(lisp::*ignore-wildcards* t) #+sbcl(sb-impl::*ignore-wildcards* t)) (run-shell-command "cd ~A && ~A '~A'~{ '~A'~}" (namestring root) (case (pack-op-archive-type operation) (:tgz "tar czf") (:tbz2 "tar cyf") (:zip "zip")) (namestring output-file) (mapcar #'(lambda (f) (enough-namestring f root)) files)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass stat-op (simple-system-wide-operation) ((source-only :type boolean :initarg :source-only :initform nil :reader stat-op-source-only :documentation "If true do statistics about the source files only, excluding documentation and such. If false do statistics about the whole system.") (command :type string :initarg :command :initform "wc" :reader stat-op-command :documentation "Command to be run to generate the statistics.")) (:documentation "Operation class to gather static statistics on the source code making up a system. Currently it simply counts lines, words and characters with the Unix command \"wc\".")) (defmethod perform ((operation stat-op) (component system)) (let ((system-file (system-file component)) (files (input-files operation component))) (unless (stat-op-source-only operation) (push system-file files)) (run-shell-command "~A ~{ '~A'~}" (stat-op-command operation) (mapcar #'namestring files)))) (defmethod input-files ((operation stat-op) (component source-file)) (when (or (not (typep component 'static-file)) (not (stat-op-source-only operation))) (list (component-pathname component)))) (defmethod operation-done-p ((operation stat-op) (component component)) nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass tag-op (simple-system-wide-operation) ((tags-type :type (member :emacs :vi) :initarg :tags-type :initform :emacs :reader tag-op-tags-type :documentation "Type of tags to be generated. Either :ETAGS for Emacs or :CTAGS for Vi.")) (:documentation "Operation class to create tag files from the source code making up a system. Two formats are supported; see the TAGS-TYPE slot for details.")) (defmethod perform ((operation tag-op) (component system)) (run-shell-command "~A '~A' ~{ '~A'~}" (case (tag-op-tags-type operation) (:emacs "etags -o") (:vi "ctags -f")) (namestring (car (output-files operation component))) (mapcar #'namestring (input-files operation component)))) (defmethod output-files ((operation tag-op) (component system)) (let ((system-file (system-file component))) (list (make-pathname :defaults system-file :name (case (tag-op-tags-type operation) (:emacs "TAGS") (:vi "tags")) :type nil)))) (defmethod input-files ((operation tag-op) (component static-file)) nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #+sbcl (eval-when (:load-toplevel :compile-toplevel :execute) (require :sb-executable) ;; see below the OUTPUT-FILES method (require :sb-grovel)) (defclass make-exe-op (simple-system-wide-operation) ((output-file :type string :initarg :output-file :reader make-exe-op-output-file :documentation "Pathname of the output file. If NIL a sensible name is defaulted.") (initial-function :type (or string symbol) :initarg :initial-function :reader make-exe-op-initial-function :documentation "Function to be run on startup.") (initial-package :type (or string symbol) :initarg :initial-package :reader make-exe-op-initial-package :documentation "Package where the initial-function is defined.") (init-file :initarg :init-file :initform nil :reader make-exe-op-init-file :documentation "Name of the file the executable should read upon startup.") (runtime-flags :type list :initarg :runtime-flags :initform '() :reader make-exe-op-runtime-flags :documentation "Additional runtime flags to pass to the lisp executable upon execution.")) (:documentation "Operation class to create and executable of the files in a system. This is a trickery known to work on SBCL and CMUCL.")) (defmethod input-files ((operation make-exe-op) (system system)) (loop with files = () for (op . c) in (asdf::traverse (make-instance 'load-op :force t) system) when (and (typep op 'load-op) ;; avoid infinite recursion (not (eq c system))) do (dolist (in (input-files operation c)) (pushnew in files :test #'pathname-match-p)) finally (return (nreverse files)))) (defmethod perform ((operation make-exe-op) (component system)) (let ((output-file (car (output-files operation component))) (input-files (input-files operation component))) (format t "; Creating ~A containing:~%~{; ~A~%~}" output-file input-files) ;; for CMUCL use my executable.lisp (a counterfeit of the SBCL one) #+cmu (executable:make-executable output-file input-files :runtime-flags (make-exe-op-runtime-flags operation) :init-file (make-exe-op-init-file operation) :initial-function (make-exe-op-initial-function operation) :initial-package (make-exe-op-initial-package operation)) #+sbcl (sb-executable:make-executable output-file input-files :initial-function (make-exe-op-initial-function operation)))) (defmethod output-files ((operation make-exe-op) (component system)) (let ((system-file (system-file component))) (list (or (and (slot-boundp operation 'output-file) (make-exe-op-output-file operation)) (make-pathname :defaults system-file :type "exe"))))) (defmethod input-files ((op make-exe-op) (c component)) (declare (ignore op)) (output-files (make-instance 'compile-op) c)) (defmethod input-files ((op make-exe-op) (c c-source-file)) (declare (ignore op c)) nil) (defmethod component-depends-on ((operation make-exe-op) (c component)) (cons (list 'compile-op (component-name c)) (call-next-method))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Almost identical to Marco Baringer's clean-op. (defclass revert-op (operation) ((operation :accessor revert-op-operation :initarg :operation :initform 'compile-op :documentation "The operation to revert the effects of.")) (:documentation "Operation class to remove any file generated by another ASDF operation. The operation, this operation reverts the effects of, is stored in the OPERATION slot. Usually this will be the compilation but could be anything. Just in case you were wondering: \(oos 'revert-op :system :operation 'revert-op) Doesn't do anything useful.")) (defmethod perform ((op revert-op) (c component)) "Delete all the output files generated by an operation on C." (dolist (f (output-files (make-instance (revert-op-operation op)) c)) (when (probe-file f) (format t "; Deleting ~A.~%" f) (delete-file f)))) (defmethod operation-done-p ((op revert-op) (c component)) "Return T if the output files of an operation on C don't exist." (loop for f in (output-files (make-instance (revert-op-operation op)) c) never (probe-file f))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar *output-root-directory* (make-pathname :directory '(:absolute)) "Absolute pathname of the root of directory tree holding the FASL files. The purpose of this variable is to change the destination of compiled files to another place other than the directory of the source file.") (defvar *system-paths* '(#P"/usr/local/") "List of directory roots that should not be modified according as of *OUTPUT-ROOT-DIRECTORY*. This is, for instance, to prevent SBCL from recompiling its own components when we change the output root.") (defun possibly-truename (path) (if (probe-file path) (truename path) path)) (defmethod output-files :around ((op compile-op) (c component)) (declare (ignore op c)) (mapcar #'(lambda (path) (if (some #'(lambda (dir) (let ((tn (possibly-truename dir))) (pathname-match-p (possibly-truename path) (make-pathname :defaults tn :directory (append (pathname-directory tn) '(:wild-inferiors)) :name :wild :type :wild)))) *system-paths*) path (let ((dir (pathname-directory path))) (assert (eq (car dir) :absolute)) (merge-pathnames (make-pathname :defaults path :directory (cons :relative (cdr dir))) *output-root-directory*)))) (call-next-method))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; [Lifted from CLiki without permission] ;;; If the fasl was stale, try to recompile and load (once). Since only SBCL ;;; has a separate condition for bogus fasls we retry on any old error ;;; on other lisps. Actually, Allegro has a similar condition, but it's ;;; unexported. Works nicely for the ACL7 upgrade, though. ;;; CMUCL has an invalid-fasl condition as of 19c. (defmethod perform :around ((o load-op) (c cl-source-file)) (handler-case (call-next-method o c) (#+sbcl sb-ext:invalid-fasl #+allegro excl::file-incompatible-fasl-error #+lispworks conditions:fasl-error #+cmu ext:invalid-fasl #-(or sbcl allegro lispworks cmu) error () (perform (make-instance 'compile-op) c) (call-next-method)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (pushnew :asdfa cl:*features*)