Commit d2063dd1 authored by Daniel Barlow's avatar Daniel Barlow
Browse files

Make the :serial switch actually do something (useful for CLX systems)

Some glue that won't affect too many people but that lets ASDF cleanly
hook the extensible PROVIDE/REQUIRE mechanism in upcoming SBCL 0.7.13

Fix wild-modules to not object when we call (setf (module-components))
on a new or about-to-be-reinitialised module.  We need to be able to
do this to get the weeds out, so it should be legal
parent 35c9c4d4
Loading
Loading
Loading
Loading
+20 −2
Original line number Original line Diff line number Diff line
$Id: README,v 1.28 2003/02/04 17:01:24 dan_b Exp $         -*- Text -*-
$Id: README,v 1.29 2003/02/08 15:31:15 dan_b Exp $         -*- Text -*-




asdf: another system definition facility          
asdf: another system definition facility          
@@ -519,7 +519,7 @@ option := :components component-list
	| :output-files  method-form
	| :output-files  method-form
        | :operation-done-p method-form
        | :operation-done-p method-form
        | :depends-on ( {simple-component-name}* ) 
        | :depends-on ( {simple-component-name}* ) 
	| :serialize [ t | nil ]
	| :serial [ t | nil ]
        | :in-order-to ( {dependency}+ )
        | :in-order-to ( {dependency}+ )


component-list := ( {component-def}* )
component-list := ( {component-def}* )
@@ -567,6 +567,24 @@ supports :before methods, they may not do what you want them to - a
after all the dependencies and sub-components have been processed, but
after all the dependencies and sub-components have been processed, but
before the component in question has been compiled.
before the component in question has been compiled.


**** Serial dependencies

If the `:serial t' option is specified for a module, asdf will add
dependencies for each each child component, on all the children
textually preceding it.  This is done as if by :depends-on

:components ((:file "a") (:file "b") (:file "c"))
:serial t

is equivalent to
:components ((:file "a") 
	     (:file "b" :depends-on ("a"))
	     (:file "c" :depends-on ("a" "b")))



have all the 

**** Source location
**** Source location


The :pathname option is optional in all cases for native-syntax
The :pathname option is optional in all cases for native-syntax
+78 −50
Original line number Original line Diff line number Diff line
;;; This is asdf: Another System Definition Facility.  $Revision: 1.57 $
;;; This is asdf: Another System Definition Facility.  $Revision: 1.58 $
;;;
;;;
;;; Feedback, bug reports, and patches are all welcome: please mail to
;;; Feedback, bug reports, and patches are all welcome: please mail to
;;; <cclan-list@lists.sf.net>.  But note first that the canonical
;;; <cclan-list@lists.sf.net>.  But note first that the canonical
@@ -87,8 +87,7 @@


(in-package #:asdf)
(in-package #:asdf)


;;; parse the cvs revision into something that might be vaguely useful.  
(defvar *asdf-revision* (let* ((v "$Revision: 1.58 $")
(defvar *asdf-revision* (let* ((v "$Revision: 1.57 $")
			       (colon (position #\: v))
			       (colon (position #\: v))
			       (dot (position #\. v)))
			       (dot (position #\. v)))
			  (and v colon dot 
			  (and v colon dot 
@@ -806,6 +805,8 @@ Returns the new tree (which probably shares structure with the old one)"
		       :key #'symbol-name :test 'equal)
		       :key #'symbol-name :test 'equal)
	append (list name val)))
	append (list name val)))


(defvar *serial-depends-on*)

(defun parse-component-form (parent options)
(defun parse-component-form (parent options)
  (destructuring-bind
  (destructuring-bind
	(type name &rest rest &key
	(type name &rest rest &key
@@ -813,54 +814,62 @@ Returns the new tree (which probably shares structure with the old one)"
	      ;; remove-keys form.  important to keep them in sync
	      ;; remove-keys form.  important to keep them in sync
	      components pathname default-component-class
	      components pathname default-component-class
	      perform explain output-files operation-done-p
	      perform explain output-files operation-done-p
	      depends-on serialize in-order-to
	      depends-on serial in-order-to
	      ;; list ends
	      ;; list ends
	      &allow-other-keys) options
	      &allow-other-keys) options
    (declare (ignore serialize))
    (let* ((other-args (remove-keys
	    ;; XXX add dependencies for serialized subcomponents
			'(components pathname default-component-class
	    (let* ((other-args (remove-keys
			  perform explain output-files operation-done-p
				'(components pathname default-component-class
			  depends-on serial in-order-to)
				  perform explain output-files operation-done-p
			rest))
				  depends-on serialize in-order-to)
	   (ret
				rest))
	    (or (find-component parent name)
		   (ret
		(make-instance (class-for-type parent type)))))
		    (or (find-component parent name)
      (when (boundp '*serial-depends-on*)
			(make-instance (class-for-type parent type)))))
	(setf depends-on
	      (apply #'reinitialize-instance
	      (concatenate 'list *serial-depends-on* depends-on)))
		     ret
      (apply #'reinitialize-instance
		     :name (coerce-name name)
	     ret
		     :pathname pathname
	     :name (coerce-name name)
		     :parent parent
	     :pathname pathname
		     :in-order-to (union-of-dependencies
	     :parent parent
				   in-order-to
	     other-args)
				   `((compile-op (compile-op ,@depends-on))
      (when (typep ret 'module)
				     (load-op (load-op ,@depends-on))))
	(setf (module-default-component-class ret)
		     :do-first `((compile-op (load-op ,@depends-on)))
	      (or default-component-class
		     other-args)
		  (and (typep parent 'module)
	      (when (typep ret 'module)
		       (module-default-component-class parent))))
		(setf (module-default-component-class ret)
	(let ((*serial-depends-on* nil))
		      (or default-component-class
	  (setf (module-components ret)
			  (and (typep parent 'module)
		(loop for c-form in components
			       (module-default-component-class parent)))))
		      for c = (parse-component-form ret c-form)
	      (when components
		      collect c
		(setf (module-components ret)
		      if serial
		      (mapcar (lambda (x) (parse-component-form ret x)) components)))
		      do (push (component-name c) *serial-depends-on*)))))
	      (loop for (n v) in `((perform ,perform) (explain ,explain)
      
				   (output-files ,output-files)
      (setf (slot-value ret 'in-order-to)
				   (operation-done-p ,operation-done-p))
	    (union-of-dependencies
		    do (map 'nil
	     in-order-to
			    ;; this is inefficient as most of the stored
	     `((compile-op (compile-op ,@depends-on))
			    ;; methods will not be for this particular gf n
	       (load-op (load-op ,@depends-on))))
			    ;; But this is hardly performance-critical
	    (slot-value ret 'do-first) `((compile-op (load-op ,@depends-on))))
			    (lambda (m) (remove-method (symbol-function n) m))
      
			    (component-inline-methods ret))
      (loop for (n v) in `((perform ,perform) (explain ,explain)
		    when v
			   (output-files ,output-files)
		    do (destructuring-bind (op qual (o c) &body body) v
			   (operation-done-p ,operation-done-p))
			 (pushnew
	    do (map 'nil
			  (eval `(defmethod ,n ,qual ((,o ,op) (,c (eql ,ret)))
		    ;; this is inefficient as most of the stored
				  ,@body))
		    ;; methods will not be for this particular gf n
			  (component-inline-methods ret))))
		    ;; But this is hardly performance-critical
	      ret)))
		    (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 resolve-symlinks (path)
(defun resolve-symlinks (path)
@@ -916,6 +925,25 @@ output to *trace-output*. Returns the shell's exit code."
    #-(or openmcl clisp lispworks allegro scl cmu sbcl)
    #-(or openmcl clisp lispworks allegro scl cmu sbcl)
    (error "RUN-SHELL-PROGRAM not implemented for this Lisp")
    (error "RUN-SHELL-PROGRAM not implemented for this Lisp")
    ))
    ))
  


(pushnew :asdf *features*)
(pushnew :asdf *features*)

#+sbcl
(eval-when (:compile-toplevel :load-toplevel :execute)
  (when (sb-ext:posix-getenv "SBCL_BUILDING_CONTRIB")
    (pushnew :sbcl-hooks-require *features*)))

#+(and sbcl sbcl-hooks-require)
(progn
  (defun module-provide-asdf (name)
    (let ((system (asdf:find-system name nil)))
      (when system
	(asdf:operate 'asdf:load-op name)
	(provide name))))

  (pushnew
   (merge-pathnames "systems/"
		    (truename (sb-ext:posix-getenv "SBCL_HOME")))
   *central-registry*)
  
  (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*))
+1 −1
Original line number Original line Diff line number Diff line
@@ -4,4 +4,4 @@
(load "../wild-modules")
(load "../wild-modules")


(setf asdf:*central-registry* '(*default-pathname-defaults*))
(setf asdf:*central-registry* '(*default-pathname-defaults*))
(asdf:oos 'asdf:load-op 'wild-module)
(asdf:operate 'asdf:load-op 'wild-module)
+3 −3
Original line number Original line Diff line number Diff line
@@ -7,9 +7,9 @@
                      :initform nil :initarg :component-options)))
                      :initform nil :initarg :component-options)))


(defmethod (setf module-components) (new-value (module wild-module))
(defmethod (setf module-components) (new-value (module wild-module))
  (declare (ignore new-value))
  (when  new-value
  (sysdef-error "Cannot explicitly set wild-module ~A's components. Please ~
    (sysdef-error "Cannot explicitly set wild-module ~A's components. Please ~
use a wild pathname instead." module))
use a wild pathname instead." module)))


(defmethod reinitialize-instance :after ((self wild-module) &key)
(defmethod reinitialize-instance :after ((self wild-module) &key)
  (let ((pathname (slot-value self 'relative-pathname)))
  (let ((pathname (slot-value self 'relative-pathname)))