From e8b1d24b3ec0d3549a41a371b3f16b7415020e1f Mon Sep 17 00:00:00 2001 From: Daniel Barlow Date: Sun, 16 Mar 2003 22:59:18 +0000 Subject: [PATCH] 0.7.13.29 Update contrib/asdf to newer upstream version Add a 'make up' target to its Makefile so that this can be an automatic operation in future --- contrib/asdf/Makefile | 6 +++ contrib/asdf/asdf.lisp | 120 ++++++++++++++++++++++++++++++++---------------- version.lisp-expr | 2 +- 3 files changed, 88 insertions(+), 40 deletions(-) diff --git a/contrib/asdf/Makefile b/contrib/asdf/Makefile index caa7300..735a284 100644 --- a/contrib/asdf/Makefile +++ b/contrib/asdf/Makefile @@ -1,5 +1,11 @@ MODULE=asdf include ../vanilla-module.mk + test:: true + +up: + cvs -d :pserver:anonymous@cvs.cclan.sf.net:/cvsroot/cclan \ + co -kv -p asdf/asdf.lisp >/tmp/$$$$ &&\ + mv /tmp/$$$$ asdf.lisp diff --git a/contrib/asdf/asdf.lisp b/contrib/asdf/asdf.lisp index 94e235f..9f58c2b 100644 --- a/contrib/asdf/asdf.lisp +++ b/contrib/asdf/asdf.lisp @@ -1,4 +1,4 @@ -;;; This is asdf: Another System Definition Facility. $\Revision: 1.62 $ +;;; This is asdf: Another System Definition Facility. 1.65 ;;; ;;; Feedback, bug reports, and patches are all welcome: please mail to ;;; . But note first that the canonical @@ -40,6 +40,7 @@ (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 #:operation ; operations @@ -87,8 +88,8 @@ (in-package #:asdf) -(defvar *asdf-revision* (let* ((v "$\Revision: 1.62 $") - (colon (position #\: v)) +(defvar *asdf-revision* (let* ((v "1.65") + (colon (or (position #\: v) -1)) (dot (position #\. v))) (and v colon dot (list (parse-integer v :start (1+ colon) @@ -308,10 +309,21 @@ and NIL NAME and TYPE components" (t (sysdef-error (formatter "~@") name)))) +;;; for the sake of keeping things reasonably neat, we adopt a +;;; convention that functions in this list are prefixed SYSDEF- + +(defvar *system-definition-search-functions* + '(sysdef-central-registry-search)) + (defun system-definition-pathname (system) (some (lambda (x) (funcall x system)) *system-definition-search-functions*)) +(defvar *central-registry* + '(*default-pathname-defaults* + #+nil "/home/dan/src/sourceforge/cclan/asdf/systems/" + #+nil "telent:asdf;systems;")) + (defun sysdef-central-registry-search (system) (let ((name (coerce-name system))) (block nil @@ -325,17 +337,6 @@ and NIL NAME and TYPE components" (return file))))))) -(defvar *central-registry* - '(*default-pathname-defaults* - #+nil "/home/dan/src/sourceforge/cclan/asdf/systems/" - #+nil "telent:asdf;systems;")) - -;;; for the sake of keeping things reasonably neat, we adopt a -;;; convention that functions in this list are prefixed SYSDEF- - -(defvar *system-definition-search-functions* - '(sysdef-central-registry-search)) - (defun find-system (name &optional (error-p t)) (let* ((name (coerce-name name)) (in-memory (gethash name *defined-systems*)) @@ -405,13 +406,17 @@ system.")) (defmethod source-file-type ((c static-file) (s module)) nil) (defmethod component-relative-pathname ((component source-file)) - (let ((*default-pathname-defaults* (component-parent-pathname component))) - (or (slot-value component 'relative-pathname) - (make-pathname :name (component-name component) - :type - (source-file-type component - (component-system component)))))) - + (let* ((*default-pathname-defaults* (component-parent-pathname component)) + (name-type + (make-pathname + :name (component-name component) + :type (source-file-type component + (component-system component))))) + (if (slot-value component 'relative-pathname) + (merge-pathnames + (slot-value component 'relative-pathname) + name-type) + name-type))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; operations @@ -419,13 +424,18 @@ system.")) ;;; one of these is instantiated whenever (operate ) is called (defclass operation () - ((forced-p :initform nil :initarg :force :accessor operation-forced-p ) + ((forced :initform nil :initarg :force :accessor operation-forced) (original-initargs :initform nil :initarg :original-initargs :accessor operation-original-initargs) (visited-nodes :initform nil :accessor operation-visited-nodes) (visiting-nodes :initform nil :accessor operation-visiting-nodes) (parent :initform nil :initarg :parent :accessor operation-parent))) +(defmethod print-object ((o operation) stream) + (print-unreadable-object (o stream :type t :identity t) + (ignore-errors + (prin1 (operation-original-initargs o) stream)))) + (defmethod shared-initialize :after ((operation operation) slot-names &key force &allow-other-keys) @@ -450,9 +460,29 @@ system.")) (operation-ancestor it) operation)) -(defun make-sub-operation (o type) - (let ((args (operation-original-initargs o))) - (apply #'make-instance type :parent o :original-initargs args args))) + +(defun make-sub-operation (c o dep-c dep-o) + (let* ((args (copy-list (operation-original-initargs o))) + (force-p (getf args :force))) + ;; note explicit comparison with T: any other non-NIL force value + ;; (e.g. :recursive) will pass through + (cond ((and (null (component-parent c)) + (null (component-parent dep-c)) + (not (eql c dep-c))) + (when (eql force-p t) + (setf (getf args :force) nil)) + ;; note we lose the parent slot, because we don't want + ;; forced to propagate backwards either (changes in depended-on + ;; systems shouldn't force recompilation of the depending system) + (apply #'make-instance dep-o + ;:parent o + :original-initargs args args)) + ((subtypep (type-of o) dep-o) + o) + (t + (apply #'make-instance dep-o + :parent o :original-initargs args args))))) + (defgeneric visit-component (operation component data)) @@ -550,18 +580,16 @@ system.")) (defmethod traverse ((operation operation) (c component)) (let ((forced nil)) (labels ((do-one-dep (required-op required-c required-v) - (let ((op (if (subtypep (type-of operation) required-op) - operation - (make-sub-operation operation required-op))) - (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)))) + (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))) + (op (make-sub-operation c operation dep-c required-op))) (traverse op dep-c))) (do-dep (op dep) (cond ((eq op 'feature) @@ -609,8 +637,13 @@ system.")) forced)))) ;; now the thing itself (when (or forced module-ops - (operation-forced-p (operation-ancestor operation)) - (not (operation-done-p operation c))) + (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 @@ -963,6 +996,15 @@ output to *trace-output*. Returns the shell's exit code." (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)) + + (pushnew :asdf *features*) #+sbcl diff --git a/version.lisp-expr b/version.lisp-expr index b3ebddb..73084fc 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.7.13.28" +"0.7.13.29" -- 1.7.10.4