patches for asdf
Christophe Rhodes <[email protected]>
| Newsgroups | gmane.lisp.cclan.general |
|---|---|
| Message-ID | <[email protected]> |
Hi, The attached fixes two long-standing bugs in asdf, I think: firstly, we avoid making a pathname for a component if the user has provided a pathname argument; this avoids warning messages where lisps check the contents of pathname fields eagerly (clisp, recent cmucl). Secondly, the creation and deletion of scratch packages is better handled; we no longer rely bizarrely on gensyms, and we actually delete packages after we've finished with them. I've just built 68 systems with this patch, so I think it's basically sound; I'll commit it soon unless I hear otherwise. Cheers, Christophe
asdf.diff
(application/octet-stream, 2.9 KB)
? ChangeLog
? cclan-package.fasl
? cclan.fasl
Index: asdf.lisp
===================================================================
RCS file: /cvsroot/cclan/asdf/asdf.lisp,v
retrieving revision 1.92
diff -u -r1.92 asdf.lisp
--- asdf.lisp 1 Feb 2006 09:34:39 -0000 1.92
+++ asdf.lisp 20 Mar 2006 12:53:02 -0000
@@ -359,6 +359,14 @@
(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 @@
(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*
- "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
- ;; FIXME: This wants to be (ENOUGH-NAMESTRING
- ;; ON-DISK), but CMUCL barfs on that.
+ (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 @@
(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))
- (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)))
+ (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)))))
+ name-type))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; operations