X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fasdf%2Fasdf.lisp;h=ce424a5d7d6225d396e7b22ff1129e7c03ca7148;hb=7be549a3b25b8808defdea3a5e213b1747e236a5;hp=098cdfdb35bac23ee04f76bf4108fb9469ba58e5;hpb=3eb0a28fe6a7912d6ff2b97221325c0e3bfc5703;p=sbcl.git diff --git a/contrib/asdf/asdf.lisp b/contrib/asdf/asdf.lisp index 098cdfd..ce424a5 100644 --- a/contrib/asdf/asdf.lisp +++ b/contrib/asdf/asdf.lisp @@ -1,19 +1,20 @@ -;;; This is asdf: Another System Definition Facility. 1.93 +;;; This is asdf: Another System Definition Facility. +;;; hash - $Format:%H$ ;;; ;;; Feedback, bug reports, and patches are all welcome: please mail to -;;; . But note first that the canonical -;;; source for asdf is presently the cCLan CVS repository at -;;; +;;; . But note first that the canonical +;;; source for asdf is presently on common-lisp.net at +;;; ;;; ;;; If you obtained this copy from anywhere else, and you experience ;;; trouble using it, or find bugs, you may want to check at the ;;; location above for a more recent version (and for documentation ;;; and test files, if your copy came without them) before reporting -;;; bugs. There are usually two "supported" revisions - the CVS HEAD +;;; bugs. There are usually two "supported" revisions - the git HEAD ;;; is the latest development version, whereas the revision tagged ;;; RELEASE may be slightly older but is considered `stable' -;;; Copyright (c) 2001-2003 Daniel Barlow and contributors +;;; Copyright (c) 2001-2009 Daniel Barlow and contributors ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining ;;; a copy of this software and associated documentation files (the @@ -40,15 +41,14 @@ (defpackage #:asdf (:export #:defsystem #:oos #:operate #:find-system #:run-shell-command #:system-definition-pathname #:find-component ; miscellaneous - #:hyperdocumentation #:hyperdoc - - #:compile-op #:load-op #:load-source-op #:test-system-version + #:compile-system #:load-system #:test-system + #:compile-op #:load-op #:load-source-op #:test-op - #:operation ; operations - #:feature ; sort-of operation - #:version ; metaphorically sort-of an operation + #:operation ; operations + #:feature ; sort-of operation + #:version ; metaphorically sort-of an operation - #:input-files #:output-files #:perform ; operation methods + #:input-files #:output-files #:perform ; operation methods #:operation-done-p #:explain #:component #:source-file @@ -78,11 +78,14 @@ #:system-author #:system-maintainer #:system-license + #:system-licence + #:system-source-file + #:system-relative-pathname #:operation-on-warnings #:operation-on-failure - ;#:*component-parent-pathname* + ;#:*component-parent-pathname* #:*system-definition-search-functions* #:*central-registry* ; variables #:*compile-file-warnings-behaviour* @@ -93,36 +96,59 @@ #:error-component #:error-operation #:system-definition-error #:missing-component + #:missing-component-of-version #:missing-dependency + #:missing-dependency-of-version #:circular-dependency ; errors #:duplicate-names + #:try-recompiling #:retry #:accept ; restarts + #:standard-asdf-method-combination + #:around ; protocol assistants ) (:use :cl)) -#+nil -(error "The author of this file habitually uses #+nil to comment out forms. But don't worry, it was unlikely to work in the New Implementation of Lisp anyway") +#+nil +(error "The author of this file habitually uses #+nil to comment out ~ + forms. But don't worry, it was unlikely to work in the New ~ + Implementation of Lisp anyway") (in-package #:asdf) -(defvar *asdf-revision* (let* ((v "1.93") - (colon (or (position #\: v) -1)) - (dot (position #\. v))) - (and v colon dot - (list (parse-integer v :start (1+ colon) - :junk-allowed t) - (parse-integer v :start (1+ dot) - :junk-allowed t))))) +(defvar *asdf-revision* + ;; find first tag that looks like /tags/[0-9]*\.[0-9]*. E.g., /tags/1.34 + ;; return nil or a list of the major and minor version numbers + (let* ((v "$Format:%d$") + (to-find "tags/") + (start 0)) + (when v + (loop for tag-start = (search to-find v :test #'char= :start2 start) + while tag-start do + (when tag-start + (let ((dot (position #\. v :start tag-start)) + (space (position #\space v :start tag-start))) + (when (and dot (or (not space) (< dot space))) + ;; success + (return + (list (parse-integer v :start (+ tag-start (length to-find)) + :junk-allowed t) + (parse-integer v :start (1+ dot) + :junk-allowed t)))) + (setf start (1+ tag-start)))))))) (defvar *compile-file-warnings-behaviour* :warn) + (defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn) (defvar *verbose-out* nil) +(defparameter +asdf-methods+ + '(perform explain output-files operation-done-p)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; utility stuff @@ -135,7 +161,12 @@ and NIL NAME and TYPE components" (make-pathname :name nil :type nil :defaults pathname)) (define-modify-macro appendf (&rest args) - append "Append onto list") + append "Append onto list") + +(defun asdf-message (format-string &rest format-args) + (declare (dynamic-extent format-args)) + (apply #'format *verbose-out* format-string format-args)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; classes, condiitons @@ -163,12 +194,18 @@ and NIL NAME and TYPE components" (define-condition missing-component (system-definition-error) ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires) - (version :initform nil :reader missing-version :initarg :version) (parent :initform nil :reader missing-parent :initarg :parent))) +(define-condition missing-component-of-version (missing-component) + ((version :initform nil :reader missing-version :initarg :version))) + (define-condition missing-dependency (missing-component) ((required-by :initarg :required-by :reader missing-required-by))) +(define-condition missing-dependency-of-version (missing-dependency + missing-component-of-version) + ()) + (define-condition operation-error (error) ((component :reader error-component :initarg :component) (operation :reader error-operation :initarg :operation)) @@ -184,7 +221,7 @@ and NIL NAME and TYPE components" "Component name: designator for a string composed of portable pathname characters") (version :accessor component-version :initarg :version) (in-order-to :initform nil :initarg :in-order-to) - ;;; XXX crap name + ;; XXX crap name (do-first :initform nil :initarg :do-first) ;; methods defined using the "inline" style inside a defsystem form: ;; need to store them somewhere so we can delete them when the system @@ -213,14 +250,20 @@ and NIL NAME and TYPE components" ;;;; methods: components (defmethod print-object ((c missing-component) s) - (format s "~@" (missing-requires c) - (missing-version c) (when (missing-parent c) (component-name (missing-parent c))))) +(defmethod print-object ((c missing-component-of-version) s) + (format s "~@" + (missing-requires c) + (missing-version c) + (when (missing-parent c) + (component-name (missing-parent c))))) + (defgeneric component-system (component) (:documentation "Find the top-level system containing COMPONENT")) @@ -285,7 +328,8 @@ and NIL NAME and TYPE components" :accessor system-long-description :initarg :long-description) (author :accessor system-author :initarg :author) (maintainer :accessor system-maintainer :initarg :maintainer) - (licence :accessor system-licence :initarg :licence))) + (licence :accessor system-licence :initarg :licence + :accessor system-license :initarg :license))) ;;; version-satisfies @@ -295,13 +339,13 @@ and NIL NAME and TYPE components" (nreverse (let ((list nil) (start 0) (words 0) end) (loop - (when (and max (>= words (1- max))) - (return (cons (subseq string start) list))) - (setf end (position-if #'is-ws string :start start)) - (push (subseq string start end) list) - (incf words) - (unless end (return list)) - (setf start (1+ end))))))) + (when (and max (>= words (1- max))) + (return (cons (subseq string start) list))) + (setf end (position-if #'is-ws string :start start)) + (push (subseq string start end) list) + (incf words) + (unless end (return list)) + (setf start (1+ end))))))) (defgeneric version-satisfies (component version)) @@ -324,13 +368,21 @@ and NIL NAME and TYPE components" ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; finding systems -(defvar *defined-systems* (make-hash-table :test 'equal)) +(defun make-defined-systems-table () + (make-hash-table :test 'equal)) + +(defvar *defined-systems* (make-defined-systems-table)) + (defun coerce-name (name) - (typecase name - (component (component-name name)) - (symbol (string-downcase (symbol-name name))) - (string name) - (t (sysdef-error "~@" name)))) + (typecase name + (component (component-name name)) + (symbol (string-downcase (symbol-name name))) + (string name) + (t (sysdef-error "~@" name)))) + +(defun system-registered-p (name) + (gethash (coerce-name name) *defined-systems*)) + ;;; for the sake of keeping things reasonably neat, we adopt a ;;; convention that functions in this list are prefixed SYSDEF- @@ -339,13 +391,26 @@ and NIL NAME and TYPE components" '(sysdef-central-registry-search)) (defun system-definition-pathname (system) - (some (lambda (x) (funcall x system)) - *system-definition-search-functions*)) + (let ((system-name (coerce-name system))) + (or + (some (lambda (x) (funcall x system-name)) + *system-definition-search-functions*) + (let ((system-pair (system-registered-p system-name))) + (and system-pair + (system-source-file (cdr system-pair))))))) (defvar *central-registry* - '(*default-pathname-defaults* - #+nil "/home/dan/src/sourceforge/cclan/asdf/systems/" - #+nil "telent:asdf;systems;")) + '(*default-pathname-defaults*) +"A list of 'system directory designators' ASDF uses to find systems. + +A 'system directory designator' is a pathname or a function +which evaluates to a pathname. For example: + + (setf asdf:*central-registry* + (list '*default-pathname-defaults* + #p\"/home/me/cl/systems/\" + #p\"/usr/share/common-lisp/systems/\")) +") (defun sysdef-central-registry-search (system) (let ((name (coerce-name system))) @@ -362,15 +427,15 @@ and NIL NAME and TYPE components" (defun make-temporary-package () (flet ((try (counter) (ignore-errors - (make-package (format nil "ASDF~D" counter) - :use '(:cl :asdf))))) + (make-package (format nil "ASDF~D" counter) + :use '(:cl :asdf))))) (do* ((counter 0 (+ counter 1)) (package (try counter) (try counter))) (package package)))) (defun find-system (name &optional (error-p t)) (let* ((name (coerce-name name)) - (in-memory (gethash name *defined-systems*)) + (in-memory (system-registered-p name)) (on-disk (system-definition-pathname name))) (when (and on-disk (or (not in-memory) @@ -378,8 +443,7 @@ and NIL NAME and TYPE components" (let ((package (make-temporary-package))) (unwind-protect (let ((*package* package)) - (format - *verbose-out* + (asdf-message "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%" ;; FIXME: This wants to be (ENOUGH-NAMESTRING ;; ON-DISK), but CMUCL barfs on that. @@ -387,19 +451,17 @@ and NIL NAME and TYPE components" *package*) (load on-disk)) (delete-package package)))) - (let ((in-memory (gethash name *defined-systems*))) + (let ((in-memory (system-registered-p name))) (if in-memory (progn (if on-disk (setf (car in-memory) (file-write-date on-disk))) (cdr in-memory)) (if error-p (error 'missing-component :requires name)))))) (defun register-system (name system) - (format *verbose-out* "~&~@<; ~@;registering ~A as ~A~@:>~%" system name) - (setf (gethash (coerce-name name) *defined-systems*) + (asdf-message "~&~@<; ~@;registering ~A as ~A~@:>~%" system name) + (setf (gethash (coerce-name name) *defined-systems*) (cons (get-universal-time) system))) -(defun system-registered-p (name) - (gethash (coerce-name name) *defined-systems*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; finding components @@ -442,7 +504,10 @@ system.")) (defmethod component-relative-pathname ((component source-file)) (let ((relative-pathname (slot-value component 'relative-pathname))) (if relative-pathname - relative-pathname + (merge-pathnames + relative-pathname + (make-pathname + :type (source-file-type component (component-system component)))) (let* ((*default-pathname-defaults* (component-parent-pathname component)) (name-type @@ -477,17 +542,51 @@ system.")) ;; empty method to disable initarg validity checking ) -(defgeneric perform (operation component)) -(defgeneric operation-done-p (operation component)) -(defgeneric explain (operation component)) -(defgeneric output-files (operation component)) -(defgeneric input-files (operation component)) +(define-method-combination standard-asdf-method-combination () + ((around-asdf (around)) + (around (:around)) + (before (:before)) + (primary () :required t) + (after (:after))) + (flet ((call-methods (methods) + (mapcar #'(lambda (method) + `(call-method ,method)) + methods))) + (let* ((form (if (or before after (rest primary)) + `(multiple-value-prog1 + (progn ,@(call-methods before) + (call-method ,(first primary) + ,(rest primary))) + ,@(call-methods (reverse after))) + `(call-method ,(first primary)))) + (standard-form (if around + `(call-method ,(first around) + (,@(rest around) + (make-method ,form))) + form))) + (if around-asdf + `(call-method ,(first around-asdf) + (,@(rest around-asdf) (make-method ,standard-form))) + standard-form)))) + +(defgeneric perform (operation component) + (:method-combination standard-asdf-method-combination)) +(defgeneric operation-done-p (operation component) + (:method-combination standard-asdf-method-combination)) +(defgeneric explain (operation component) + (:method-combination standard-asdf-method-combination)) +(defgeneric output-files (operation component) + (:method-combination standard-asdf-method-combination)) +(defgeneric input-files (operation component) + (:method-combination standard-asdf-method-combination)) (defun node-for (o c) (cons (class-name (class-of o)) c)) (defgeneric operation-ancestor (operation) - (:documentation "Recursively chase the operation's parent pointer until we get to the head of the tree")) + (:documentation + "Recursively chase the operation's parent pointer until we get to +the head of the tree")) (defmethod operation-ancestor ((operation operation)) (aif (operation-parent operation) @@ -515,6 +614,8 @@ system.")) :parent o :original-initargs args args))))) +(defgeneric component-visited-p (operation component)) + (defgeneric visit-component (operation component data)) (defmethod visit-component ((o operation) (c component) data) @@ -522,8 +623,6 @@ system.")) (push (cons (node-for o c) data) (operation-visited-nodes (operation-ancestor o))))) -(defgeneric component-visited-p (operation component)) - (defmethod component-visited-p ((o operation) (c component)) (assoc (node-for o c) (operation-visited-nodes (operation-ancestor o)) @@ -546,11 +645,29 @@ system.")) (defgeneric component-visiting-p (operation component)) (defmethod component-visiting-p ((o operation) (c component)) - (let ((node (cons o c))) + (let ((node (node-for o c))) (member node (operation-visiting-nodes (operation-ancestor o)) :test 'equal))) -(defgeneric component-depends-on (operation component)) +(defgeneric component-depends-on (operation component) + (:documentation + "Returns a list of dependencies needed by the component to perform + the operation. A dependency has one of the following forms: + + ( *), where is a class + designator and each is a component + designator, which means that the component depends on + having been performed on each ; or + + (FEATURE ), which means that the component depends + on 's presence in *FEATURES*. + + Methods specialized on subclasses of existing component types + should usually append the results of CALL-NEXT-METHOD to the + list.")) + +(defmethod component-depends-on ((op-spec symbol) (c component)) + (component-depends-on (make-instance op-spec) c)) (defmethod component-depends-on ((o operation) (c component)) (cdr (assoc (class-name (class-of o)) @@ -580,61 +697,111 @@ system.")) (defmethod input-files ((operation operation) (c module)) nil) (defmethod operation-done-p ((o operation) (c component)) - (let ((out-files (output-files o c)) - (in-files (input-files o c))) - (cond ((and (not in-files) (not out-files)) - ;; arbitrary decision: an operation that uses nothing to - ;; produce nothing probably isn't doing much - t) - ((not out-files) - (let ((op-done - (gethash (type-of o) - (component-operation-times c)))) - (and op-done - (>= op-done - (or (apply #'max - (mapcar #'file-write-date in-files)) 0))))) - ((not in-files) nil) - (t - (and - (every #'probe-file out-files) - (> (apply #'min (mapcar #'file-write-date out-files)) - (apply #'max (mapcar #'file-write-date in-files)) )))))) + (flet ((fwd-or-return-t (file) + ;; if FILE-WRITE-DATE returns NIL, it's possible that the + ;; user or some other agent has deleted an input file. If + ;; that's the case, well, that's not good, but as long as + ;; the operation is otherwise considered to be done we + ;; could continue and survive. + (let ((date (file-write-date file))) + (cond + (date) + (t + (warn "~@" + file o c) + (return-from operation-done-p t)))))) + (let ((out-files (output-files o c)) + (in-files (input-files o c))) + (cond ((and (not in-files) (not out-files)) + ;; arbitrary decision: an operation that uses nothing to + ;; produce nothing probably isn't doing much + t) + ((not out-files) + (let ((op-done + (gethash (type-of o) + (component-operation-times c)))) + (and op-done + (>= op-done + (apply #'max + (mapcar #'fwd-or-return-t in-files)))))) + ((not in-files) nil) + (t + (and + (every #'probe-file out-files) + (> (apply #'min (mapcar #'file-write-date out-files)) + (apply #'max (mapcar #'fwd-or-return-t in-files))))))))) ;;; So you look at this code and think "why isn't it a bunch of ;;; methods". And the answer is, because standard method combination ;;; runs :before methods most->least-specific, which is back to front -;;; for our purposes. And CLISP doesn't have non-standard method -;;; combinations, so let's keep it simple and aspire to portability +;;; for our purposes. (defgeneric traverse (operation component)) (defmethod traverse ((operation operation) (c component)) (let ((forced nil)) - (labels ((do-one-dep (required-op required-c required-v) + (labels ((%do-one-dep (required-op required-c required-v) (let* ((dep-c (or (find-component (component-parent c) ;; XXX tacky. really we should build the ;; in-order-to slot with canonicalized ;; names instead of coercing this late (coerce-name required-c) required-v) - (error 'missing-dependency :required-by c - :version required-v - :requires required-c))) + (if required-v + (error 'missing-dependency-of-version + :required-by c + :version required-v + :requires required-c) + (error 'missing-dependency + :required-by c + :requires required-c)))) (op (make-sub-operation c operation dep-c required-op))) (traverse op dep-c))) + (do-one-dep (required-op required-c required-v) + (loop + (restart-case + (return (%do-one-dep required-op required-c required-v)) + (retry () + :report (lambda (s) + (format s "~@" + required-c)) + :test + (lambda (c) +#| + (print (list :c1 c (typep c 'missing-dependency))) + (when (typep c 'missing-dependency) + (print (list :c2 (missing-requires c) required-c + (equalp (missing-requires c) + required-c)))) +|# + (and (typep c 'missing-dependency) + (equalp (missing-requires c) + required-c))))))) (do-dep (op dep) (cond ((eq op 'feature) (or (member (car dep) *features*) - (error 'missing-dependency :required-by c - :requires (car dep) :version nil))) + (error 'missing-dependency + :required-by c + :requires (car dep)))) (t (dolist (d dep) (cond ((consp d) - (assert (string-equal - (symbol-name (first d)) - "VERSION")) - (appendf forced - (do-one-dep op (second d) (third d)))) + (cond ((string-equal + (symbol-name (first d)) + "VERSION") + (appendf + forced + (do-one-dep op (second d) (third d)))) + ((and (string-equal + (symbol-name (first d)) + "FEATURE") + (find (second d) *features* + :test 'string-equal)) + (appendf + forced + (do-one-dep op (second d) (third d)))) + (t + (error "Dependencies must be (:version ), (:feature ), or a name")))) (t (appendf forced (do-one-dep op d nil))))))))) (aif (component-visited-p operation c) @@ -644,45 +811,51 @@ system.")) (if (component-visiting-p operation c) (error 'circular-dependency :components (list c))) (setf (visiting-component operation c) t) - (loop for (required-op . deps) in (component-depends-on operation c) - do (do-dep required-op deps)) - ;; constituent bits - (let ((module-ops - (when (typep c 'module) - (let ((at-least-one nil) - (forced nil) - (error nil)) - (loop for kid in (module-components c) - do (handler-case - (appendf forced (traverse operation kid )) - (missing-dependency (condition) - (if (eq (module-if-component-dep-fails c) :fail) - (error condition)) - (setf error condition)) - (:no-error (c) - (declare (ignore c)) - (setf at-least-one t)))) - (when (and (eq (module-if-component-dep-fails c) :try-next) - (not at-least-one)) - (error error)) - forced)))) - ;; now the thing itself - (when (or forced module-ops - (not (operation-done-p operation c)) - (let ((f (operation-forced (operation-ancestor operation)))) - (and f (or (not (consp f)) - (member (component-name - (operation-ancestor operation)) - (mapcar #'coerce-name f) - :test #'string=))))) - (let ((do-first (cdr (assoc (class-name (class-of operation)) - (slot-value c 'do-first))))) - (loop for (required-op . deps) in do-first - do (do-dep required-op deps))) - (setf forced (append (delete 'pruned-op forced :key #'car) - (delete 'pruned-op module-ops :key #'car) - (list (cons operation c)))))) - (setf (visiting-component operation c) nil) + (unwind-protect + (progn + (loop for (required-op . deps) in + (component-depends-on operation c) + do (do-dep required-op deps)) + ;; constituent bits + (let ((module-ops + (when (typep c 'module) + (let ((at-least-one nil) + (forced nil) + (error nil)) + (loop for kid in (module-components c) + do (handler-case + (appendf forced (traverse operation kid )) + (missing-dependency (condition) + (if (eq (module-if-component-dep-fails c) + :fail) + (error condition)) + (setf error condition)) + (:no-error (c) + (declare (ignore c)) + (setf at-least-one t)))) + (when (and (eq (module-if-component-dep-fails c) + :try-next) + (not at-least-one)) + (error error)) + forced)))) + ;; now the thing itself + (when (or forced module-ops + (not (operation-done-p operation c)) + (let ((f (operation-forced + (operation-ancestor operation)))) + (and f (or (not (consp f)) + (member (component-name + (operation-ancestor operation)) + (mapcar #'coerce-name f) + :test #'string=))))) + (let ((do-first (cdr (assoc (class-name (class-of operation)) + (slot-value c 'do-first))))) + (loop for (required-op . deps) in do-first + do (do-dep required-op deps))) + (setf forced (append (delete 'pruned-op forced :key #'car) + (delete 'pruned-op module-ops :key #'car) + (list (cons operation c))))))) + (setf (visiting-component operation c) nil)) (visit-component operation c (and forced t)) forced))) @@ -697,7 +870,7 @@ system.")) nil) (defmethod explain ((operation operation) (component component)) - (format *verbose-out* "~&;;; ~A on ~A~%" operation component)) + (asdf-message "~&;;; ~A on ~A~%" operation component)) ;;; compile-op @@ -722,9 +895,7 @@ system.")) (let ((source-file (component-pathname c)) (output-file (car (output-files operation c)))) (multiple-value-bind (output warnings-p failure-p) - (compile-file source-file - :output-file output-file) - ;(declare (ignore output)) + (compile-file source-file :output-file output-file) (when warnings-p (case (operation-on-warnings operation) (:warn (warn @@ -752,15 +923,62 @@ system.")) (defmethod output-files ((operation compile-op) (c static-file)) nil) +(defmethod input-files ((op compile-op) (c static-file)) + nil) + + ;;; load-op -(defclass load-op (operation) ()) +(defclass basic-load-op (operation) ()) + +(defclass load-op (basic-load-op) ()) (defmethod perform ((o load-op) (c cl-source-file)) (mapcar #'load (input-files o c))) +(defmethod perform around ((o load-op) (c cl-source-file)) + (let ((state :initial)) + (loop until (or (eq state :success) + (eq state :failure)) do + (case state + (:recompiled + (setf state :failure) + (call-next-method) + (setf state :success)) + (:failed-load + (setf state :recompiled) + (perform (make-instance 'asdf:compile-op) c)) + (t + (with-simple-restart + (try-recompiling "Recompile ~a and try loading it again" + (component-name c)) + (setf state :failed-load) + (call-next-method) + (setf state :success))))))) + +(defmethod perform around ((o compile-op) (c cl-source-file)) + (let ((state :initial)) + (loop until (or (eq state :success) + (eq state :failure)) do + (case state + (:recompiled + (setf state :failure) + (call-next-method) + (setf state :success)) + (:failed-compile + (setf state :recompiled) + (perform (make-instance 'asdf:compile-op) c)) + (t + (with-simple-restart + (try-recompiling "Try recompiling ~a" + (component-name c)) + (setf state :failed-compile) + (call-next-method) + (setf state :success))))))) + (defmethod perform ((operation load-op) (c static-file)) nil) + (defmethod operation-done-p ((operation load-op) (c static-file)) t) @@ -773,7 +991,7 @@ system.")) ;;; load-source-op -(defclass load-source-op (operation) ()) +(defclass load-source-op (basic-load-op) ()) (defmethod perform ((o load-source-op) (c cl-source-file)) (let ((source (component-pathname c))) @@ -808,44 +1026,87 @@ system.")) (defmethod perform ((operation test-op) (c component)) nil) +(defmethod operation-done-p ((operation test-op) (c system)) + "Testing a system is _never_ done." + nil) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; invoking operations -(defun operate (operation-class system &rest args) - (let* ((op (apply #'make-instance operation-class - :original-initargs args args)) - (*verbose-out* - (if (getf args :verbose t) - *trace-output* - (make-broadcast-stream))) - (system (if (typep system 'component) system (find-system system))) - (steps (traverse op system))) - (with-compilation-unit () - (loop for (op . component) in steps do - (loop - (restart-case - (progn (perform op component) - (return)) - (retry () - :report - (lambda (s) - (format s "~@" - op component))) - (accept () - :report - (lambda (s) - (format s - "~@" - op component)) - (setf (gethash (type-of op) - (component-operation-times component)) - (get-universal-time)) - (return)))))))) - -(defun oos (&rest args) - "Alias of OPERATE function" - (apply #'operate args)) +(defun operate (operation-class system &rest args &key (verbose t) version force + &allow-other-keys) + (declare (ignore force)) + (let* ((*package* *package*) + (*readtable* *readtable*) + (op (apply #'make-instance operation-class + :original-initargs args + args)) + (*verbose-out* (if verbose *standard-output* (make-broadcast-stream))) + (system (if (typep system 'component) system (find-system system)))) + (unless (version-satisfies system version) + (error 'missing-component-of-version :requires system :version version)) + (let ((steps (traverse op system))) + (with-compilation-unit () + (loop for (op . component) in steps do + (loop + (restart-case + (progn (perform op component) + (return)) + (retry () + :report + (lambda (s) + (format s "~@" + op component))) + (accept () + :report + (lambda (s) + (format s "~@" + op component)) + (setf (gethash (type-of op) + (component-operation-times component)) + (get-universal-time)) + (return))))))))) + +(defun oos (operation-class system &rest args &key force (verbose t) version + &allow-other-keys) + (declare (ignore force verbose version)) + (apply #'operate operation-class system args)) + +(let ((operate-docstring + "Operate does three things: + +1. It creates an instance of `operation-class` using any keyword parameters +as initargs. +2. It finds the asdf-system specified by `system` (possibly loading +it from disk). +3. It then calls `traverse` with the operation and system as arguments + +The traverse operation is wrapped in `with-compilation-unit` and error +handling code. If a `version` argument is supplied, then operate also +ensures that the system found satisfies it using the `version-satisfies` +method.")) + (setf (documentation 'oos 'function) + (format nil + "Short for _operate on system_ and an alias for the [operate][] function. ~&~&~a" + operate-docstring)) + (setf (documentation 'operate 'function) + operate-docstring)) + +(defun load-system (system &rest args &key force (verbose t) version) + "Shorthand for `(operate 'asdf:load-op system)`. See [operate][] for details." + (declare (ignore force verbose version)) + (apply #'operate 'load-op system args)) + +(defun compile-system (system &rest args &key force (verbose t) version) + "Shorthand for `(operate 'asdf:compile-op system)`. See [operate][] for details." + (declare (ignore force verbose version)) + (apply #'operate 'compile-op system args)) + +(defun test-system (system &rest args &key force (verbose t) version) + "Shorthand for `(operate 'asdf:test-op system)`. See [operate][] for details." + (declare (ignore force verbose version)) + (apply #'operate 'test-op system args)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; syntax @@ -860,40 +1121,49 @@ system.")) (aux key arglist))) (defmacro defsystem (name &body options) - (destructuring-bind (&key pathname (class 'system) &allow-other-keys) options + (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system) + &allow-other-keys) + options (let ((component-options (remove-keyword :class options))) `(progn - ;; system must be registered before we parse the body, otherwise - ;; we recur when trying to find an existing system of the same name - ;; to reuse options (e.g. pathname) from - (let ((s (system-registered-p ',name))) - (cond ((and s (eq (type-of (cdr s)) ',class)) - (setf (car s) (get-universal-time))) - (s - #+clisp - (sysdef-error "Cannot redefine the existing system ~A with a different class" s) - #-clisp - (change-class (cdr s) ',class)) - (t - (register-system (quote ,name) - (make-instance ',class :name ',name))))) - (parse-component-form nil (apply - #'list - :module (coerce-name ',name) - :pathname - (or ,pathname - (pathname-sans-name+type - (resolve-symlinks *load-truename*)) - *default-pathname-defaults*) - ',component-options)))))) + ;; system must be registered before we parse the body, otherwise + ;; we recur when trying to find an existing system of the same name + ;; to reuse options (e.g. pathname) from + (let ((s (system-registered-p ',name))) + (cond ((and s (eq (type-of (cdr s)) ',class)) + (setf (car s) (get-universal-time))) + (s + (change-class (cdr s) ',class)) + (t + (register-system (quote ,name) + (make-instance ',class :name ',name))))) + (parse-component-form nil (apply + #'list + :module (coerce-name ',name) + :pathname + ;; to avoid a note about unreachable code + ,(if pathname-arg-p + pathname + `(or (when *load-truename* + (pathname-sans-name+type + (resolve-symlinks + *load-truename*))) + *default-pathname-defaults*)) + ',component-options)))))) (defun class-for-type (parent type) - (let ((class - (find-class - (or (find-symbol (symbol-name type) *package*) - (find-symbol (symbol-name type) #.(package-name *package*))) - nil))) + (let* ((extra-symbols (list (find-symbol (symbol-name type) *package*) + (find-symbol (symbol-name type) + (load-time-value + (package-name :asdf))))) + (class (dolist (symbol (if (keywordp type) + extra-symbols + (cons type extra-symbols))) + (when (and symbol + (find-class symbol nil) + (subtypep symbol 'component)) + (return (find-class symbol)))))) (or class (and (eq type :file) (or (module-default-component-class parent) @@ -934,7 +1204,49 @@ Returns the new tree (which probably shares structure with the old one)" (defvar *serial-depends-on*) +(defun sysdef-error-component (msg type name value) + (sysdef-error (concatenate 'string msg + "~&The value specified for ~(~A~) ~A is ~W") + type name value)) + +(defun check-component-input (type name weakly-depends-on depends-on components in-order-to) + "A partial test of the values of a component." + (when weakly-depends-on (warn "We got one! XXXXX")) + (unless (listp depends-on) + (sysdef-error-component ":depends-on must be a list." + type name depends-on)) + (unless (listp weakly-depends-on) + (sysdef-error-component ":weakly-depends-on must be a list." + type name weakly-depends-on)) + (unless (listp components) + (sysdef-error-component ":components must be NIL or a list of components." + type name components)) + (unless (and (listp in-order-to) (listp (car in-order-to))) + (sysdef-error-component ":in-order-to must be NIL or a list of components." + type name in-order-to))) + +(defun %remove-component-inline-methods (ret rest) + (loop for name in +asdf-methods+ + do (map 'nil + ;; this is inefficient as most of the stored + ;; methods will not be for this particular gf n + ;; But this is hardly performance-critical + (lambda (m) + (remove-method (symbol-function name) m)) + (component-inline-methods ret))) + ;; clear methods, then add the new ones + (setf (component-inline-methods ret) nil) + (loop for name in +asdf-methods+ + for v = (getf rest (intern (symbol-name name) :keyword)) + when v do + (destructuring-bind (op qual (o c) &body body) v + (pushnew + (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret))) + ,@body)) + (component-inline-methods ret))))) + (defun parse-component-form (parent options) + (destructuring-bind (type name &rest rest &key ;; the following list of keywords is reproduced below in the @@ -945,14 +1257,15 @@ Returns the new tree (which probably shares structure with the old one)" depends-on serial in-order-to ;; list ends &allow-other-keys) options + (declare (ignorable perform explain output-files operation-done-p)) (check-component-input type name weakly-depends-on depends-on components in-order-to) (when (and parent - (find-component parent name) - ;; ignore the same object when rereading the defsystem - (not - (typep (find-component parent name) - (class-for-type parent type)))) + (find-component parent name) + ;; ignore the same object when rereading the defsystem + (not + (typep (find-component parent name) + (class-for-type parent type)))) (error 'duplicate-names :name name)) (let* ((other-args (remove-keys @@ -969,8 +1282,7 @@ Returns the new tree (which probably shares structure with the old one)" (when (boundp '*serial-depends-on*) (setf depends-on (concatenate 'list *serial-depends-on* depends-on))) - (apply #'reinitialize-instance - ret + (apply #'reinitialize-instance ret :name (coerce-name name) :pathname pathname :parent parent @@ -996,9 +1308,9 @@ Returns the new tree (which probably shares structure with the old one)" name-hash) (error 'duplicate-names :name (component-name c)) - (setf (gethash (component-name c) - name-hash) - t))))) + (setf (gethash (component-name c) + name-hash) + t))))) (setf (slot-value ret 'in-order-to) (union-of-dependencies @@ -1007,43 +1319,9 @@ Returns the new tree (which probably shares structure with the old one)" (load-op (load-op ,@depends-on)))) (slot-value ret 'do-first) `((compile-op (load-op ,@depends-on)))) - (loop for (n v) in `((perform ,perform) (explain ,explain) - (output-files ,output-files) - (operation-done-p ,operation-done-p)) - do (map 'nil - ;; this is inefficient as most of the stored - ;; methods will not be for this particular gf n - ;; But this is hardly performance-critical - (lambda (m) (remove-method (symbol-function n) m)) - (component-inline-methods ret)) - when v - do (destructuring-bind (op qual (o c) &body body) v - (pushnew - (eval `(defmethod ,n ,qual ((,o ,op) (,c (eql ,ret))) - ,@body)) - (component-inline-methods ret)))) - ret))) - -(defun check-component-input (type name weakly-depends-on depends-on components in-order-to) - "A partial test of the values of a component." - (when weakly-depends-on (warn "We got one! XXXXX")) - (unless (listp depends-on) - (sysdef-error-component ":depends-on must be a list." - type name depends-on)) - (unless (listp weakly-depends-on) - (sysdef-error-component ":weakly-depends-on must be a list." - type name weakly-depends-on)) - (unless (listp components) - (sysdef-error-component ":components must be NIL or a list of components." - type name components)) - (unless (and (listp in-order-to) (listp (car in-order-to))) - (sysdef-error-component ":in-order-to must be NIL or a list of components." - type name in-order-to))) + (%remove-component-inline-methods ret rest) -(defun sysdef-error-component (msg type name value) - (sysdef-error (concatenate 'string msg - "~&The value specified for ~(~A~) ~A is ~W") - type name value)) + ret))) (defun resolve-symlinks (path) #-allegro (truename path) @@ -1057,18 +1335,17 @@ Returns the new tree (which probably shares structure with the old one)" ;;; is ambiguous, send a bug report (defun run-shell-command (control-string &rest args) - "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and + "Interpolate `args` into `control-string` as if by `format`, and synchronously execute the result using a Bourne-compatible shell, with -output to *verbose-out*. Returns the shell's exit code." +output to `*verbose-out*`. Returns the shell's exit code." (let ((command (apply #'format nil control-string args))) - (format *verbose-out* "; $ ~A~%" command) + (asdf-message "; $ ~A~%" command) #+sbcl - (sb-impl::process-exit-code + (sb-ext:process-exit-code (sb-ext:run-program - #-win32 "/bin/sh" - #+win32 "sh" + #+win32 "sh" #-win32 "/bin/sh" (list "-c" command) - :search #-win32 nil #+win32 t + #+win32 #+win32 :search t :input nil :output *verbose-out*)) #+(or cmu scl) @@ -1079,7 +1356,16 @@ output to *verbose-out*. Returns the shell's exit code." :input nil :output *verbose-out*)) #+allegro - (excl:run-shell-command command :input nil :output *verbose-out*) + ;; will this fail if command has embedded quotes - it seems to work + (multiple-value-bind (stdout stderr exit-code) + (excl.osi:command-output + (format nil "~a -c \"~a\"" + #+mswindows "sh" #-mswindows "/bin/sh" command) + :input nil :whole nil + #+mswindows :show-window #+mswindows :hide) + (format *verbose-out* "~{~&; ~a~%~}~%" stderr) + (format *verbose-out* "~{~&; ~a~%~}~%" stdout) + exit-code) #+lispworks (system:call-system-showing-output @@ -1087,7 +1373,7 @@ output to *verbose-out*. Returns the shell's exit code." :shell-type "/bin/sh" :output-stream *verbose-out*) - #+clisp ;XXX not exactly *verbose-out*, I know + #+clisp ;XXX not exactly *verbose-out*, I know (ext:run-shell-command command :output :terminal :wait t) #+openmcl @@ -1096,20 +1382,44 @@ output to *verbose-out*. Returns the shell's exit code." (ccl:run-program "/bin/sh" (list "-c" command) :input nil :output *verbose-out* :wait t))) + #+ecl ;; courtesy of Juan Jose Garcia Ripoll (si:system command) + #-(or openmcl clisp lispworks allegro scl cmu sbcl ecl) (error "RUN-SHELL-PROGRAM not implemented for this Lisp") )) - -(defgeneric hyperdocumentation (package name doc-type)) -(defmethod hyperdocumentation ((package symbol) name doc-type) - (hyperdocumentation (find-package package) name doc-type)) - -(defun hyperdoc (name doc-type) - (hyperdocumentation (symbol-package name) name doc-type)) - +(defgeneric system-source-file (system) + (:documentation "Return the source file in which system is defined.")) + +(defmethod system-source-file ((system-name t)) + (system-source-file (find-system system-name))) + +(defmethod system-source-file ((system system)) + (let ((pn (and (slot-boundp system 'relative-pathname) + (make-pathname + :type "asd" + :name (asdf:component-name system) + :defaults (asdf:component-relative-pathname system))))) + (when pn + (probe-file pn)))) + +(defun system-source-directory (system-name) + (make-pathname :name nil + :type nil + :defaults (system-source-file system-name))) + +(defun system-relative-pathname (system pathname &key name type) + ;; you're not allowed to muck with the return value of pathname-X + (let ((directory (copy-list (pathname-directory pathname)))) + (when (eq (car directory) :absolute) + (setf (car directory) :relative)) + (merge-pathnames + (make-pathname :name (or name (pathname-name pathname)) + :type (or type (pathname-type pathname)) + :directory directory) + (system-source-directory system)))) (pushnew :asdf *features*) @@ -1129,20 +1439,23 @@ output to *verbose-out*. Returns the shell's exit code." t)))) (defun contrib-sysdef-search (system) - (let* ((name (coerce-name system)) - (home (truename (sb-ext:posix-getenv "SBCL_HOME"))) - (contrib (merge-pathnames - (make-pathname :directory `(:relative ,name) - :name name - :type "asd" - :case :local - :version :newest) - home))) - (probe-file contrib))) + (let ((home (sb-ext:posix-getenv "SBCL_HOME"))) + (when (and home (not (string= home ""))) + (let* ((name (coerce-name system)) + (home (truename home)) + (contrib (merge-pathnames + (make-pathname :directory `(:relative ,name) + :name name + :type "asd" + :case :local + :version :newest) + home))) + (probe-file contrib))))) (pushnew - '(merge-pathnames "site-systems/" - (truename (sb-ext:posix-getenv "SBCL_HOME"))) + '(let ((home (sb-ext:posix-getenv "SBCL_HOME"))) + (when (and home (not (string= home ""))) + (merge-pathnames "site-systems/" (truename home)))) *central-registry*) (pushnew @@ -1153,4 +1466,8 @@ output to *verbose-out*. Returns the shell's exit code." (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*) (pushnew 'contrib-sysdef-search *system-definition-search-functions*)) +(if *asdf-revision* + (asdf-message ";; ASDF, revision ~a" *asdf-revision*) + (asdf-message ";; ASDF, revision unknown; possibly a development version")) + (provide 'asdf)