From 9f8b254664d2864ae524c3a12c912437accfdb20 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Mon, 19 May 2003 14:47:14 +0000 Subject: [PATCH] 0.8alpha.0.38: Slight change to REQUIRE/PROVIDE protocol ... as observed by Tony Martinez sbcl-devel 2003-05-13, REQUIRE takes a string designator, so allow this ... update to latest ASDF, which changes the asdf hook slightly such that individual modules are required (ha!) to PROVIDE themselves; make it so. --- contrib/asdf/asdf.lisp | 23 +++++++++++++-- contrib/sb-aclrepl/sb-aclrepl.asd | 3 ++ contrib/sb-bsd-sockets/sb-bsd-sockets.asd | 3 ++ contrib/sb-grovel/sb-grovel.asd | 3 ++ contrib/sb-posix/sb-posix.asd | 8 +++--- contrib/sb-rotate-byte/sb-rotate-byte.asd | 3 ++ contrib/sb-rt/sb-rt.asd | 3 ++ src/code/module.lisp | 43 +++++++++++++++++------------ version.lisp-expr | 2 +- 9 files changed, 65 insertions(+), 26 deletions(-) diff --git a/contrib/asdf/asdf.lisp b/contrib/asdf/asdf.lisp index 4f7aff7..a2e61e1 100644 --- a/contrib/asdf/asdf.lisp +++ b/contrib/asdf/asdf.lisp @@ -1,4 +1,4 @@ -;;; This is asdf: Another System Definition Facility. 1.68 +;;; This is asdf: Another System Definition Facility. 1.72 ;;; ;;; Feedback, bug reports, and patches are all welcome: please mail to ;;; . But note first that the canonical @@ -89,7 +89,7 @@ (in-package #:asdf) -(defvar *asdf-revision* (let* ((v "1.68") +(defvar *asdf-revision* (let* ((v "1.72") (colon (or (position #\: v) -1)) (dot (position #\. v))) (and v colon dot @@ -889,6 +889,7 @@ Returns the new tree (which probably shares structure with the old one)" depends-on serial in-order-to ;; list ends &allow-other-keys) options + (check-component-input type name depends-on components in-order-to) (let* ((other-args (remove-keys '(components pathname default-component-class perform explain output-files operation-done-p @@ -943,6 +944,22 @@ Returns the new tree (which probably shares structure with the old one)" (component-inline-methods ret)))) ret))) +(defun check-component-input (type name depends-on components in-order-to) + "A partial test of the values of a component." + (unless (listp depends-on) + (sysdef-error-component ":depends-on must be a list." + type name 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 sysdef-error-component (msg type name value) + (sysdef-error (concatenate 'string msg + "~&The value specified for ~(~A~) ~A is ~W") + type name value)) (defun resolve-symlinks (path) #-allegro (truename path) @@ -1020,7 +1037,7 @@ output to *trace-output*. Returns the shell's exit code." (let ((system (asdf:find-system name nil))) (when system (asdf:operate 'asdf:load-op name) - (provide name)))) + t))) (pushnew '(merge-pathnames "systems/" diff --git a/contrib/sb-aclrepl/sb-aclrepl.asd b/contrib/sb-aclrepl/sb-aclrepl.asd index 0c5b8f8..9a7a134 100644 --- a/contrib/sb-aclrepl/sb-aclrepl.asd +++ b/contrib/sb-aclrepl/sb-aclrepl.asd @@ -11,6 +11,9 @@ (:file "inspect" :depends-on ("repl")) (:file "debug" :depends-on ("repl")))) +(defmethod perform :after ((o load-op) (c (eql (find-system :sb-aclrepl)))) + (provide 'sb-aclrepl)) + (defmethod perform ((o test-op) (c (eql (find-system :sb-aclrepl)))) (oos 'load-op 'sb-aclrepl-tests) (oos 'test-op 'sb-aclrepl-tests)) diff --git a/contrib/sb-bsd-sockets/sb-bsd-sockets.asd b/contrib/sb-bsd-sockets/sb-bsd-sockets.asd index c0eb896..4aa65e1 100644 --- a/contrib/sb-bsd-sockets/sb-bsd-sockets.asd +++ b/contrib/sb-bsd-sockets/sb-bsd-sockets.asd @@ -94,6 +94,9 @@ (:static-file "doc" :pathname "doc.lisp") (:static-file "TODO"))) +(defmethod perform :after ((o load-op) (c (eql (find-system :sb-bsd-sockets)))) + (provide 'sb-bsd-sockets)) + (defmethod perform ((o test-op) (c (eql (find-system :sb-bsd-sockets)))) (or (funcall (intern "DO-TESTS" (find-package "SB-RT"))) (error "test-op failed"))) diff --git a/contrib/sb-grovel/sb-grovel.asd b/contrib/sb-grovel/sb-grovel.asd index 9f29c2b..361bd2e 100644 --- a/contrib/sb-grovel/sb-grovel.asd +++ b/contrib/sb-grovel/sb-grovel.asd @@ -10,6 +10,9 @@ (:file "foreign-glue" :depends-on ("defpackage")) (:file "array-data" :depends-on ("defpackage")))) +(defmethod perform :after ((o load-op) (c (eql (find-system :sb-grovel)))) + (provide 'sb-grovel)) + (defmethod perform ((o test-op) (c (eql (find-system :sb-grovel)))) t) diff --git a/contrib/sb-posix/sb-posix.asd b/contrib/sb-posix/sb-posix.asd index 052e531..f01b53d 100644 --- a/contrib/sb-posix/sb-posix.asd +++ b/contrib/sb-posix/sb-posix.asd @@ -13,8 +13,8 @@ :package :sb-posix :depends-on ("defpackage")) (:file "interface" :depends-on ("constants" "macros")))) -#| -(defmethod perform ((o test-op) (c (eql (find-system :sb-grovel)))) - t) +(defmethod perform :after ((o test-op) (c (eql (find-system :sb-posix)))) + (provide 'sb-posix)) -|# \ No newline at end of file +(defmethod perform ((o test-op) (c (eql (find-system :sb-posix)))) + t) diff --git a/contrib/sb-rotate-byte/sb-rotate-byte.asd b/contrib/sb-rotate-byte/sb-rotate-byte.asd index 0451fd8..7df4f29 100644 --- a/contrib/sb-rotate-byte/sb-rotate-byte.asd +++ b/contrib/sb-rotate-byte/sb-rotate-byte.asd @@ -16,6 +16,9 @@ :if-component-dep-fails :ignore) (:file "rotate-byte" :depends-on ("compiler")))) +(defmethod perform :after ((o load-op) (c (eql (find-system :sb-rotate-byte)))) + (provide 'sb-rotate-byte)) + (defmethod perform ((o test-op) (c (eql (find-system :sb-rotate-byte)))) (or (load (compile-file "rotate-byte-tests.lisp")) (error "test-op failed"))) diff --git a/contrib/sb-rt/sb-rt.asd b/contrib/sb-rt/sb-rt.asd index bb79d60..a6177a3 100644 --- a/contrib/sb-rt/sb-rt.asd +++ b/contrib/sb-rt/sb-rt.asd @@ -8,6 +8,9 @@ :version "0.1.7" ; our version "0", GCL CVS version "1.7" :components ((:file "rt"))) +(defmethod perform :after ((o load-op) (c (eql (find-system :sb-rt)))) + (provide 'sb-rt)) + (defmethod perform ((o test-op) (c (eql (find-system :sb-rt)))) ;; FIXME: Maybe also import rt-tests.lisp? t) diff --git a/src/code/module.lisp b/src/code/module.lisp index 77fe18b..83f129d 100644 --- a/src/code/module.lisp +++ b/src/code/module.lisp @@ -42,29 +42,36 @@ needs to be. If PATHNAMES is not supplied, functions from the list *MODULE-PROVIDER-FUNCTIONS* are called in order with MODULE-NAME as an argument, until one of them returns non-NIL." - (unless (member (string module-name) *modules* :test #'string=) - (cond (pathnames - (unless (listp pathnames) (setf pathnames (list pathnames))) - ;; ambiguity in standard: should we try all pathnames in the - ;; list, or should we stop as soon as one of them calls PROVIDE? - (dolist (ele pathnames t) - (load ele))) - (t - (unless (some (lambda (p) (funcall p module-name)) - sb!ext::*module-provider-functions*) - (error "Don't know how to load ~A" module-name)))))) - + (let ((saved-modules (copy-list *modules*))) + (unless (member (string module-name) *modules* :test #'string=) + (cond (pathnames + (unless (listp pathnames) (setf pathnames (list pathnames))) + ;; ambiguity in standard: should we try all pathnames in the + ;; list, or should we stop as soon as one of them calls PROVIDE? + (dolist (ele pathnames t) + (load ele)) + ;; should we do this? Probably can't hurt, while we're + ;; taking the above view of "load everything"... though + ;; maybe having REQUIRE directly call PROVIDE is + ;; aesthetically suboptimal. + (provide module-name)) + (t + (unless (some (lambda (p) (funcall p module-name)) + sb!ext::*module-provider-functions*) + (error "Don't know how to load ~A" module-name))))) + (set-difference *modules* saved-modules))) ;;;; miscellany (defun module-provide-contrib (name) - "Stringify and downcase NAME if it is a symbol, then attempt to load - the file $SBCL_HOME/name/name" - (let ((name (if (symbolp name) (string-downcase (symbol-name name)) name))) + "Stringify and downcase NAME, then attempt to load the file + $SBCL_HOME/name/name" + (let ((filesys-name (string-downcase (string name)))) (load - (merge-pathnames (make-pathname :directory (list :relative name) - :name name) + (merge-pathnames (make-pathname :directory (list :relative filesys-name) + :name filesys-name) (truename (posix-getenv "SBCL_HOME"))))) - (provide name)) + (provide name) + t) diff --git a/version.lisp-expr b/version.lisp-expr index 7313c14..69cfebc 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8alpha.0.37" +"0.8alpha.0.38" -- 1.7.10.4