Commit 9990e603 authored by Christophe Rhodes's avatar Christophe Rhodes
Browse files

Fixes 

* don't create a package with gensym.  Instead try creating
  packages with different names until one succeeds;
* delete the scratch package when we're finished with it
* if the user has requested a pathname for a component, don't try to
  construct the default one; it probably won't work.
parent e388107c

asdf.lisp

+31 −20
Original line number Diff line number Diff line 
;;; This is asdf: Another System Definition Facility.  $Revision: 1.92 $

;;; This is asdf: Another System Definition Facility.  $Revision: 1.93 $

;;;

;;; Feedback, bug reports, and patches are all welcome: please mail to

;;; <cclan-list@lists.sf.net>.  But note first that the canonical
@@ -109,7 +109,7 @@ 


(in-package #:asdf)



(defvar *asdf-revision* (let* ((v "$Revision: 1.92 $")

(defvar *asdf-revision* (let* ((v "$Revision: 1.93 $")

			       (colon (or (position #\: v) -1))

			       (dot (position #\. v)))

			  (and v colon dot
@@ -359,6 +359,14 @@ and NIL NAME and TYPE components" 
	  (if (and file (probe-file file))

	      (return file)))))))



(defun make-temporary-package ()

  (flet ((try (counter)

           (ignore-errors

                   (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))
@@ -367,15 +375,18 @@ and NIL NAME and TYPE components" 
    (when (and on-disk

	       (or (not in-memory)

		   (< (car in-memory) (file-write-date on-disk))))

      (let ((*package* (make-package (gensym #.(package-name *package*))

				     :use '(:cl :asdf))))

	(format *verbose-out*

      (let ((package (make-temporary-package)))

        (unwind-protect

             (let ((*package* package))

               (format 

                *verbose-out*

                "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"

                ;; FIXME: This wants to be (ENOUGH-NAMESTRING

                ;; ON-DISK), but CMUCL barfs on that.

		on-disk

		*package*)

	(load on-disk)))

               (load on-disk))

          (delete-package package))))

    (let ((in-memory (gethash name *defined-systems*)))

      (if in-memory

	  (progn (if on-disk (setf (car in-memory) (file-write-date on-disk)))
@@ -429,17 +440,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))

  (let ((relative-pathname (slot-value component 'relative-pathname)))

    (if relative-pathname

        relative-pathname

        (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)))

          name-type))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; operations