diff --git a/.gitignore b/.gitignore index 545c4e6cb259ff320e8a0564f31ca4f7173dfdd1..0c3be1668f746b37eb2bafd83a38fdadbdf1fb09 100644 --- a/.gitignore +++ b/.gitignore @@ -5,6 +5,9 @@ common-lisp.net init-lisp.lisp website/changelog.xml +# Test stuff +test/results/ + # We build these at various stages in the make process LICENSE website/output/ @@ -16,3 +19,4 @@ lift-local.config *.cfsl *.fas *.lib +*.o diff --git a/asdf.lisp b/asdf.lisp index 863351bd846eb991e37eab4b1235f0c6b0268af7..2d633e2cd11830eebb14c12ecf88340a5bd68c73 100644 --- a/asdf.lisp +++ b/asdf.lisp @@ -197,6 +197,9 @@ Defaults to `t`.") (let ((system-p (getf plist 'system-p))) (when system-p (setf (getf (slot-value c 'flags) :system-p) system-p)))))) +;;;; ------------------------------------------------------------------------- +;;;; CLOS magic for asdf:around methods + (define-method-combination standard-asdf-method-combination () ((around-asdf (around)) (around (:around)) @@ -232,6 +235,9 @@ methods will be run *around* any `:around` methods, so that the core protocol may employ around methods and those around methods will not be overridden by around methods added by a system developer.") +;;;; ------------------------------------------------------------------------- +;;;; ASDF Interface, in terms of generic functions. + (defgeneric perform (operation component) (:method-combination standard-asdf-method-combination)) (defgeneric operation-done-p (operation component) @@ -330,8 +336,8 @@ mapping is to place the output in subdirectories of structure will mirror that of the source.")) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; utility stuff +;;;; ------------------------------------------------------------------------- +;;;; General Purpose Utilities (defmacro aif (test then &optional else) `(let ((it ,test)) (if it ,then ,else))) @@ -378,9 +384,6 @@ and NIL NAME and TYPE components" (t (values relative (butlast components) last-comp)))))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; syntax - (defun remove-keys (key-names args) (loop for (name val) on args by #'cddr unless (member (symbol-name name) key-names @@ -400,8 +403,8 @@ and NIL NAME and TYPE components" #-allegro (truename path) #+allegro (excl:pathname-resolve-symbolic-links path)) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; classes, conditions +;;;; ------------------------------------------------------------------------- +;;;; Classes, Conditions (define-condition system-definition-error (error) () ;; [this use of :report should be redundant, but unfortunately it's not. @@ -557,7 +560,8 @@ and NIL NAME and TYPE components" (source-file :reader system-source-file :initarg :source-file :writer %set-system-source-file))) -;;; version-satisfies +;;;; ------------------------------------------------------------------------- +;;;; version-satisfies (defmethod version-satisfies ((c component) version) (unless (and version (slot-boundp c 'version)) @@ -575,8 +579,8 @@ and NIL NAME and TYPE components" (and (= (car x) (car y)) (or (not (cdr y)) (bigger (cdr x) (cdr y))))))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; finding systems +;;;; ------------------------------------------------------------------------- +;;;; Finding systems (defun make-defined-systems-table () (make-hash-table :test 'equal)) @@ -648,22 +652,6 @@ actually-existing directory." (and (check-one (pathname-name pathname)) (check-one (pathname-type pathname))))) -#+(or) -;;test -;;?? move into testsuite sometime soon -(every (lambda (p) - (directory-pathname-p p)) - (list - (make-pathname :name "." :type nil :directory '(:absolute "tmp")) - (make-pathname :name "." :type "" :directory '(:absolute "tmp")) - (make-pathname :name nil :type "" :directory '(:absolute "tmp")) - (make-pathname :name "" :directory '(:absolute "tmp")) - (make-pathname :type :unspecific :directory '(:absolute "tmp")) - (make-pathname :name :unspecific :directory '(:absolute "tmp")) - (make-pathname :name :unspecific :directory '(:absolute "tmp")) - (make-pathname :type "" :directory '(:absolute "tmp")) - )) - (defun ensure-directory-pathname (pathname) (if (directory-pathname-p pathname) pathname @@ -775,8 +763,8 @@ to `~a` which is not a directory.~@:>" (cons (get-universal-time) system))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; finding components +;;;; ------------------------------------------------------------------------- +;;;; Finding components (defmethod find-component ((module module) name &optional version) (if (slot-boundp module 'components) @@ -822,10 +810,10 @@ to `~a` which is not a directory.~@:>" (component-name component) (source-file-type component (component-system component)))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; operations +;;;; ------------------------------------------------------------------------- +;;;; Operations -;;; one of these is instantiated whenever (operate ) is called +;;; one of these is instantiated whenever #'operate is called (defclass operation () ((forced :initform nil :initarg :force :accessor operation-forced) @@ -1101,7 +1089,8 @@ to `~a` which is not a directory.~@:>" (defmethod explain ((operation operation) (component component)) (asdf-message "~&;;; ~A on ~A~%" operation component)) -;;; compile-op +;;;; ------------------------------------------------------------------------- +;;;; compile-op (defclass compile-op (operation) ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil) @@ -1158,7 +1147,8 @@ to `~a` which is not a directory.~@:>" nil) -;;; load-op +;;;; ------------------------------------------------------------------------- +;;;; load-op (defclass basic-load-op (operation) ()) @@ -1220,7 +1210,8 @@ to `~a` which is not a directory.~@:>" (cons (list 'compile-op (component-name c)) (call-next-method))) -;;; load-source-op +;;;; ------------------------------------------------------------------------- +;;;; load-source-op (defclass load-source-op (basic-load-op) ()) @@ -1252,6 +1243,10 @@ to `~a` which is not a directory.~@:>" (component-property c 'last-loaded-as-source))) nil t)) + +;;;; ------------------------------------------------------------------------- +;;;; test-op + (defclass test-op (operation) ()) (defmethod perform ((operation test-op) (c component)) @@ -1265,8 +1260,8 @@ to `~a` which is not a directory.~@:>" (cons `(load-op ,(component-name c)) (call-next-method))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; invoking operations +;;;; ------------------------------------------------------------------------- +;;;; Invoking Operations (defun operate (operation-class system &rest args &key (verbose t) version force &allow-other-keys) @@ -1349,6 +1344,9 @@ created with the same initargs as the original one. (declare (ignore force verbose version)) (apply #'operate 'test-op system args)) +;;;; ------------------------------------------------------------------------- +;;;; Defsystem + (defun determine-system-pathname (pathname pathname-supplied-p) ;; called from the defsystem macro. ;; the pathname of a system is either @@ -1576,9 +1574,13 @@ Returns the new tree (which probably shares structure with the old one)" ;;;; ;;;; run-shell-command functions for other lisp implementations will be ;;;; gratefully accepted, if they do the same thing. -;;;; If the docstring is ambiguous, send a bug report +;;;; If the docstring is ambiguous, send a bug report. ;;;; -;;;; XXX fare: This probably doesn't belong here. Does anyone rely on it? +;;;; We probably should move this functionality to its own system and deprecate +;;;; use of it from the asdf package. However, this would break unspecified +;;;; existing software, so until a clear alternative exists, we can't deprecate +;;;; it, and even after it's been deprecated, we will support it for a few +;;;; years so everyone has time to migrate away from it. -- fare 2009-12-01 (defun run-shell-command (control-string &rest args) "Interpolate `args` into `control-string` as if by `format`, and @@ -1633,7 +1635,7 @@ output to `*verbose-out*`. Returns the shell's exit code." (si:system command) #-(or openmcl clisp lispworks allegro scl cmu sbcl ecl) - (error "RUN-SHELL-PROGRAM not implemented for this Lisp") + (error "RUN-SHELL-COMMAND not implemented for this Lisp") )) ;;;; --------------------------------------------------------------------------- @@ -1648,7 +1650,7 @@ output to `*verbose-out*`. Returns the shell's exit code." :defaults (system-source-file system-name))) (defun system-relative-pathname (system pathname &key name type) - (let ((directory (pathname-directory pathname))) + (let ((directory (pathname-directory pathname))) (merge-pathnames (make-pathname :name (or name (pathname-name pathname)) :type (or type (pathname-type pathname)) @@ -2026,6 +2028,7 @@ applied by the plain `*source-to-target-mappings*`." ;;;; Things to do in case we're upgrading from a previous version of ASDF. ;;;; See https://bugs.launchpad.net/asdf/+bug/485687 ;;;; +;;;; TODO: debug why it's not enough to upgrade from ECL <= 9.11.1 (eval-when (:compile-toplevel :load-toplevel :execute) #+ecl ;; Support upgrade from before ECL went to 1.369 (when (fboundp 'compile-op-system-p) diff --git a/test/test-utilities.script b/test/test-utilities.script new file mode 100644 index 0000000000000000000000000000000000000000..66569fa56ebc5f4384775d70be5d63c263db44ca --- /dev/null +++ b/test/test-utilities.script @@ -0,0 +1,26 @@ +;;; -*- Lisp -*- +(load "script-support") +(load "../asdf") +(in-package :asdf) +(cl-user::quit-on-error + +(assert + (every #'directory-pathname-p + (list + (make-pathname :name nil :type "" :directory '(:absolute "tmp")) + (make-pathname :name "" :directory '(:absolute "tmp")) + (make-pathname :type "" :directory '(:absolute "tmp")) +;; CLHS 19.2.2.2.3 says we can't portably specify :unspecific here, +;; and some implementations will enforce it. +;; (make-pathname :type :unspecific :directory '(:absolute "tmp")) +;; (make-pathname :name :unspecific :directory '(:absolute "tmp")) +;; (make-pathname :name :unspecific :directory '(:absolute "tmp")) + ))) +(assert + (every (complement #'directory-pathname-p) + (list + (make-pathname :name "foo" :type nil :directory '(:absolute "tmp")) + (make-pathname :name nil :type "bar" :directory '(:absolute "tmp")) + (make-pathname :name "." :type nil :directory '(:absolute "tmp")) + (make-pathname :name "." :type "" :directory '(:absolute "tmp"))))) +)