- cmucl-cvs - mailman3.common-lisp.net

[cmucl-cvs] CMUCL commit: src (12 files)
by Raymond Toy 27 Jun '11

27 Jun '11

Date: Monday, June 27, 2011 @ 08:11:30 Author: rtoy Path: /project/cmucl/cvsroot/src Modified: code/unidata.lisp i18n/CaseFolding.txt i18n/CompositionExclusions.txt i18n/DerivedNormalizationProps.txt i18n/NameAliases.txt i18n/NormalizationCorrections.txt i18n/SpecialCasing.txt i18n/UnicodeData.txt i18n/WordBreakProperty.txt i18n/tests/NormalizationTest.txt i18n/tests/WordBreakTest.txt tools/build-unidata.lisp Update to Unicode 6.0.0. code/unidata.lisp: o Update unicode version to 6.0.0 o Add pointer to build-unidata.lisp. tools/build-unidata.lisp: o Update unicode version to 6.0.0 o Print out directory path so we can see where we're getting the data from. i18n/CaseFolding.txt i18n/CompositionExclusions.txt i18n/DerivedNormalizationProps.txt i18n/NameAliases.txt i18n/NormalizationCorrections.txt i18n/SpecialCasing.txt i18n/UnicodeData.txt i18n/WordBreakProperty.txt i18n/tests/NormalizationTest.txt i18n/tests/WordBreakTest.txt: o Update with new files from unicode.org. ------------------------------------+ code/unidata.lisp | 11 i18n/CaseFolding.txt | 15 i18n/CompositionExclusions.txt | 27 i18n/DerivedNormalizationProps.txt | 163 ++- i18n/NameAliases.txt | 6 i18n/NormalizationCorrections.txt | 6 i18n/SpecialCasing.txt | 6 i18n/UnicodeData.txt | 1886 ++++++++++++++++++++++++++++++++++- i18n/WordBreakProperty.txt | 81 + i18n/tests/NormalizationTest.txt | 73 + i18n/tests/WordBreakTest.txt | 8 tools/build-unidata.lisp | 8 12 files changed, 2173 insertions(+), 117 deletions(-) The diff is longer than the limit of 200KB.

1 0

[cmucl-cvs] CMUCL commit: src/code (stream.lisp)
by Raymond Toy 27 Jun '11

27 Jun '11

Date: Monday, June 27, 2011 @ 08:05:27 Author: rtoy Path: /project/cmucl/cvsroot/src/code Modified: stream.lisp Revert last change to fix Trac #43. That changes causes the Unicode normalization and word-break tests to fail. I do not know why this causes the tests to fail, but it causes the test program to suck in the entire file into a string instead of just one line. -------------+ stream.lisp | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) Index: src/code/stream.lisp diff -u src/code/stream.lisp:1.100 src/code/stream.lisp:1.101 --- src/code/stream.lisp:1.100 Thu Mar 3 08:43:28 2011 +++ src/code/stream.lisp Mon Jun 27 08:05:27 2011 @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /project/cmucl/cvsroot/src/code/stream.lisp,v 1.100 2011/03/03 16:43:28 rtoy Exp $") + "$Header: /project/cmucl/cvsroot/src/code/stream.lisp,v 1.101 2011/06/27 15:05:27 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -854,6 +854,7 @@ ;; If we didn't convert all the octets, ;; adjust the head pointer to indicate ;; that we have unread octets left. + #+nil (decf (lisp::fd-stream-ibuf-head stream) (- (fd-stream-in-length stream) octet-count)) #+(or debug-frc-sr)

1 0

[cmucl-cvs] CMUCL commit: cmucl-www/cmucl-www (build.el)
by Raymond Toy 21 Jun '11

21 Jun '11

Date: Tuesday, June 21, 2011 @ 06:05:49 Author: rtoy Path: /project/cmucl/cvsroot/cmucl-www/cmucl-www Modified: build.el Fix relative html links. I don't know why this no longer works but after the upgrade to common-lisp.net, the generated web pages no longer work on either common-lisp.net or www.cons.org/cmucl. By changing "../" to "./" we get a working copy on common-lisp.net now. (Actually the setup of the webserver on common-lisp.net caused this to fail. But www.cons.org hasn't changed so I don't know why that fails now.) ----------+ build.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) Index: cmucl-www/cmucl-www/build.el diff -u cmucl-www/cmucl-www/build.el:1.9 cmucl-www/cmucl-www/build.el:1.10 --- cmucl-www/cmucl-www/build.el:1.9 Wed Sep 29 16:59:58 2010 +++ cmucl-www/cmucl-www/build.el Tue Jun 21 06:05:49 2011 @@ -92,7 +92,7 @@ (defun wb-home-as-relative-url (path-components) (loop for path in path-components unless (string-match "\\.html\\'" path) - concat "../")) + concat "./")) ;; generate a title string for STR, from the information in ;; `wb-jumpbar-titles' if present, else defaulting to the file's

1 0

[cmucl-cvs] CMUCL commit: src/general-info (release-20c.txt)
by Raymond Toy 10 Jun '11

10 Jun '11

Date: Friday, June 10, 2011 @ 12:34:59 Author: rtoy Path: /project/cmucl/cvsroot/src/general-info Modified: release-20c.txt o Update for recent change. o Update the version number for ASDF. -----------------+ release-20c.txt | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) Index: src/general-info/release-20c.txt diff -u src/general-info/release-20c.txt:1.23 src/general-info/release-20c.txt:1.24 --- src/general-info/release-20c.txt:1.23 Fri Jun 10 10:38:27 2011 +++ src/general-info/release-20c.txt Fri Jun 10 12:34:58 2011 @@ -28,7 +28,7 @@ with all features available, except only Unicode is supported. * Changes - - ASDF2 updated to version 2.014.1. + - ASDF2 updated to version 2.016. - COMPILE-FILE now accepts a :DECODING-ERROR argument that indicates how to handle decoding errors when reading the file. It has the same meaning and effect as the :DECODING-ERROR @@ -54,6 +54,9 @@ - Add LISP:LOAD-ALL-UNICODE-DATA to load all the Unicode information into core. This is useful for creating an executable image that does not need unidata.bin. + - CMUCL no longer exits if you specify a core file with an + executable image. A warning is printed instead and the core + file is used. * ANSI compliance fixes: - Fixes for signaling errors with READ-CHAR and READ-BYTE

1 0

[cmucl-cvs] CMUCL commit: src/lisp (lisp.c)
by Raymond Toy 10 Jun '11

10 Jun '11

Date: Friday, June 10, 2011 @ 12:32:32 Author: rtoy Path: /project/cmucl/cvsroot/src/lisp Modified: lisp.c Allow specifying a core with an executable image. There's no reason why this shouldn't work and tests show that it does work. So instead of disallowing it, just print a warning that it is unusual. Fred also said this should work; it's just a bit odd running a 30MB executable with a 30MB core. --------+ lisp.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) Index: src/lisp/lisp.c diff -u src/lisp/lisp.c:1.82 src/lisp/lisp.c:1.83 --- src/lisp/lisp.c:1.82 Tue May 31 06:26:41 2011 +++ src/lisp/lisp.c Fri Jun 10 12:32:31 2011 @@ -1,7 +1,7 @@ /* * main() entry point for a stand alone lisp image. * - * $Header: /project/cmucl/cvsroot/src/lisp/lisp.c,v 1.82 2011/05/31 13:26:41 rtoy Exp $ + * $Header: /project/cmucl/cvsroot/src/lisp/lisp.c,v 1.83 2011/06/10 19:32:31 rtoy Exp $ * */ @@ -480,8 +480,8 @@ if (strcmp(arg, "-core") == 0) { if (builtin_image_flag) { fprintf(stderr, - "Cannot specify core file in executable image --- sorry about that.\n"); - exit(1); + "Warning: specifying a core file with an executable image is unusual,\nbut should work.\n"); + builtin_image_flag = 0; } if (core != NULL) {

1 0

[cmucl-cvs] CMUCL commit: src (4 files)
by Raymond Toy 10 Jun '11

10 Jun '11

Date: Friday, June 10, 2011 @ 10:38:27 Author: rtoy Path: /project/cmucl/cvsroot/src Modified: code/exports.lisp code/print.lisp code/unidata.lisp general-info/release-20c.txt Add function to load all unicode data into memory. This makes it easy to make an executable image that doesn't need unidata.bin around. (Should we do this for normal cores? It seems to add about 1 MB to the core size.) code/unidata.lisp: o Add LOAD-ALL-UNICODE-DATA to load all unicode data. o Add UNICODE-DATA-LOADED-P to check that unicode data has been loaded. code/print.lisp: o If unicode data is loaded, don't check for existence of *unidata-path*, because we don't need it. code/exports.lisp: o Export LOAD-ALL-UNICODE-DATA. general-info/release-20c.txt: o Update info ------------------------------+ code/exports.lisp | 5 + code/print.lisp | 11 ++-- code/unidata.lisp | 105 +++++++++++++++++++++++++++++------------ general-info/release-20c.txt | 3 + 4 files changed, 88 insertions(+), 36 deletions(-) Index: src/code/exports.lisp diff -u src/code/exports.lisp:1.304 src/code/exports.lisp:1.305 --- src/code/exports.lisp:1.304 Wed Feb 2 04:51:27 2011 +++ src/code/exports.lisp Fri Jun 10 10:38:27 2011 @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /project/cmucl/cvsroot/src/code/exports.lisp,v 1.304 2011/02/02 12:51:27 rtoy Exp $") + "$Header: /project/cmucl/cvsroot/src/code/exports.lisp,v 1.305 2011/06/10 17:38:27 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -910,7 +910,8 @@ #+unicode (:export "STRING-TO-NFC" "STRING-TO-NFD" "STRING-TO-NFKC" "STRING-TO-NFKD" - "UNICODE-COMPLETE" "UNICODE-COMPLETE-NAME")) + "UNICODE-COMPLETE" "UNICODE-COMPLETE-NAME" + "LOAD-ALL-UNICODE-DATA")) (defpackage "EVAL" (:export "*EVAL-STACK-TRACE*" "*INTERNAL-APPLY-NODE-TRACE*" Index: src/code/print.lisp diff -u src/code/print.lisp:1.132 src/code/print.lisp:1.133 --- src/code/print.lisp:1.132 Tue May 31 06:26:40 2011 +++ src/code/print.lisp Fri Jun 10 10:38:27 2011 @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /project/cmucl/cvsroot/src/code/print.lisp,v 1.132 2011/05/31 13:26:40 rtoy Exp $") + "$Header: /project/cmucl/cvsroot/src/code/print.lisp,v 1.133 2011/06/10 17:38:27 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -2164,10 +2164,11 @@ ;;; is initialized. #+unicode (defun reinit-char-attributes () - (unless (probe-file *unidata-path*) - (cerror _"Continue anyway" _"Cannot find ~S, so unicode support is not available" - *unidata-path*) - (return-from reinit-char-attributes nil)) + (unless (unicode-data-loaded-p) + (unless (probe-file *unidata-path*) + (cerror _"Continue anyway" _"Cannot find ~S, so unicode support is not available" + *unidata-path*) + (return-from reinit-char-attributes nil))) (flet ((set-bit (char bit) (let ((code (char-code char))) (setf (aref character-attributes code) Index: src/code/unidata.lisp diff -u src/code/unidata.lisp:1.26 src/code/unidata.lisp:1.27 --- src/code/unidata.lisp:1.26 Tue May 31 06:26:40 2011 +++ src/code/unidata.lisp Fri Jun 10 10:38:27 2011 @@ -4,7 +4,7 @@ ;;; This code was written by Paul Foley and has been placed in the public ;;; domain. ;;; -(ext:file-comment "$Header: /project/cmucl/cvsroot/src/code/unidata.lisp,v 1.26 2011/05/31 13:26:40 rtoy Exp $") +(ext:file-comment "$Header: /project/cmucl/cvsroot/src/code/unidata.lisp,v 1.27 2011/06/10 17:38:27 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -14,11 +14,12 @@ (intl:textdomain "cmucl") (export '(string-to-nfd string-to-nfkc string-to-nfkd string-to-nfc - unicode-complete unicode-complete-name)) + unicode-complete unicode-complete-name + load-all-unicode-data)) (defvar *unidata-path* "ext-formats:unidata.bin") -(defvar *unidata-version* "$Revision: 1.26 $") +(defvar *unidata-version* "$Revision: 1.27 $") (defstruct unidata range @@ -473,33 +474,38 @@ (let ((n (read32 stream))) (and (plusp n) (file-position stream n))))) +;; List of all defined defloaders +(defvar *defloaders* nil) + (defmacro defloader (name (stm locn) &body body) - `(defun ,name () - (labels ((read16 (stm) - (logior (ash (read-byte stm) 8) (read-byte stm))) - (read32 (stm) - (logior (ash (read16 stm) 16) (read16 stm))) - (read-ntrie (bits stm) - (let* ((split (read-byte stm)) - (hlen (read16 stm)) - (mlen (read16 stm)) - (llen (read16 stm)) - (hvec (make-array hlen - :element-type '(unsigned-byte 16))) - (mvec (make-array mlen - :element-type '(unsigned-byte 16))) - (lvec (make-array llen - :element-type (list 'unsigned-byte bits)))) - (read-vector hvec stm :endian-swap :network-order) - (read-vector mvec stm :endian-swap :network-order) - (read-vector lvec stm :endian-swap :network-order) - (values split hvec mvec lvec)))) - (declare (ignorable #'read16 #'read32 #'read-ntrie)) - (with-open-file (,stm *unidata-path* :direction :input - :element-type '(unsigned-byte 8)) - (unless (unidata-locate ,stm ,locn) - (error (intl:gettext "No data in file."))) - ,@body)))) + `(progn + (push ',name *defloaders*) + (defun ,name () + (labels ((read16 (stm) + (logior (ash (read-byte stm) 8) (read-byte stm))) + (read32 (stm) + (logior (ash (read16 stm) 16) (read16 stm))) + (read-ntrie (bits stm) + (let* ((split (read-byte stm)) + (hlen (read16 stm)) + (mlen (read16 stm)) + (llen (read16 stm)) + (hvec (make-array hlen + :element-type '(unsigned-byte 16))) + (mvec (make-array mlen + :element-type '(unsigned-byte 16))) + (lvec (make-array llen + :element-type (list 'unsigned-byte bits)))) + (read-vector hvec stm :endian-swap :network-order) + (read-vector mvec stm :endian-swap :network-order) + (read-vector lvec stm :endian-swap :network-order) + (values split hvec mvec lvec)))) + (declare (ignorable #'read16 #'read32 #'read-ntrie)) + (with-open-file (,stm *unidata-path* :direction :input + :element-type '(unsigned-byte 8)) + (unless (unidata-locate ,stm ,locn) + (error (intl:gettext "No data in file."))) + ,@body))))) (defloader load-range (stm 0) (let* ((n (read32 stm)) @@ -1572,3 +1578,44 @@ (incf p (length code)) (return))))) (nreverse (coerce res 'vector)))) + +;; This is primarily intended for users who what to create a core +;; image that contains all of the unicode data. By doing this, the +;; resulting image no longer needs unidata.bin anymore. This is +;; useful for an executable image. +(defun load-all-unicode-data () + "Load all unicode data and set *UNIDATA-PATH* to NIL. +Normally, the unicode data is loaded as needed. This loads all of the +data, which is useful for creating a core that no longer needs +unidata.bin." + (dolist (loader (reverse *defloaders*)) + (funcall loader)) + t) + +;; CHeck to see if all of the unicode data has been loaded. +(defun unicode-data-loaded-p () + ;; FIXME: Would be nice to be able to do this automatically from the + ;; structure without having to list every slot here. + (and (unidata-range *unicode-data*) + (unidata-name+ *unicode-data*) + (unidata-name *unicode-data*) + (unidata-category *unicode-data*) + (unidata-scase *unicode-data*) + (unidata-numeric *unicode-data*) + (unidata-decomp *unicode-data*) + (unidata-combining *unicode-data*) + (unidata-bidi *unicode-data*) + (unidata-name1+ *unicode-data*) + (unidata-name1 *unicode-data*) + (unidata-qc-nfd *unicode-data*) + (unidata-qc-nfkd *unicode-data*) + (unidata-qc-nfc *unicode-data*) + (unidata-qc-nfkc *unicode-data*) + (unidata-comp-exclusions *unicode-data*) + (unidata-full-case-lower *unicode-data*) + (unidata-full-case-title *unicode-data*) + (unidata-full-case-upper *unicode-data*) + (unidata-case-fold-simple *unicode-data*) + (unidata-case-fold-full *unicode-data*) + (unidata-word-break *unicode-data*) + t)) Index: src/general-info/release-20c.txt diff -u src/general-info/release-20c.txt:1.22 src/general-info/release-20c.txt:1.23 --- src/general-info/release-20c.txt:1.22 Sun Jun 5 13:39:04 2011 +++ src/general-info/release-20c.txt Fri Jun 10 10:38:27 2011 @@ -51,6 +51,9 @@ - Added -unidata command line option to allow user to specify the unidata.bin file to be used instead of the default one. - :CMUCL is now in *FEATURES*. + - Add LISP:LOAD-ALL-UNICODE-DATA to load all the Unicode + information into core. This is useful for creating an + executable image that does not need unidata.bin. * ANSI compliance fixes: - Fixes for signaling errors with READ-CHAR and READ-BYTE

1 0

[cmucl-cvs] CMUCL commit: cmucl-www/cmucl-www/www (index.html)
by Raymond Toy 08 Jun '11

08 Jun '11

Date: Wednesday, June 8, 2011 @ 13:41:48 Author: rtoy Path: /project/cmucl/cvsroot/cmucl-www/cmucl-www/www Modified: index.html Update for 2011-06 snapshot. ------------+ index.html | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) Index: cmucl-www/cmucl-www/www/index.html diff -u cmucl-www/cmucl-www/www/index.html:1.23 cmucl-www/cmucl-www/www/index.html:1.24 --- cmucl-www/cmucl-www/www/index.html:1.23 Sun Apr 10 12:32:47 2011 +++ cmucl-www/cmucl-www/www/index.html Wed Jun 8 13:41:48 2011 @@ -68,7 +68,22 @@ Also see <a href="news/index.html">News</a> for older news. <dl> -<dt>Snapshot 2011-04 +<dt>Snapshot 2011-06 + +<dd> The 2011-06 snapshot has been released. See the release notes for +details, but here is a quick summary of the changes between the this +snapshot and the previous snapshot. + <ul> + <li> <code>:CMUCL</code> is now in <code>*FEATURES*</code> + <li> Added command line option, <code>-unidata</code>, to allow user + to specify the location and name of the unidata.bin file. This is + used instead of the default location. + <li> Opening a file whose name contains "[" with <code>:IF-EXISTS + :NEW-VERSION</code> no longer causes an error. + </ul> +</dd> + +<dt>Snapshot 2011-04 <dd> The 2011-04 snapshot has been released. See the release nots for details, but here is a quick summary of the changes between the

1 0

[cmucl-cvs] CMUCL commit: cmucl-www/cmucl-www/www (download.html)
by Raymond Toy 08 Jun '11

08 Jun '11

Date: Wednesday, June 8, 2011 @ 13:37:48 Author: rtoy Path: /project/cmucl/cvsroot/cmucl-www/cmucl-www/www Modified: download.html Update for 2011-06 snapshot. ---------------+ download.html | 70 +++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 69 insertions(+), 1 deletion(-) Index: cmucl-www/cmucl-www/www/download.html diff -u cmucl-www/cmucl-www/www/download.html:1.33 cmucl-www/cmucl-www/www/download.html:1.34 --- cmucl-www/cmucl-www/www/download.html:1.33 Tue Apr 12 07:41:42 2011 +++ cmucl-www/cmucl-www/www/download.html Wed Jun 8 13:37:47 2011 @@ -90,6 +90,74 @@ <th>Miscellaneous files</th> </tr> <tr> + <td>2011-06</td> + <td> +  + <ul> + <li><a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2011/06/cmucl-2011…">Unicode</a></li> + <li><a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2011/06/cmucl-2011…">Unicode extras</a></li> + <li><a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2011/06/cmucl-2011…">Non-Unicode</a></li> + <li><a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2011/06/cmucl-2011…">Non-Unicode extras</a></li> + </ul> + </td> + <td> + <ul> +  + <li> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2011/06/cmucl-2011…">Unicode</a></li> + <li> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2011/06/cmucl-2011…">Unicode extras</a></li> + <li> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2011/06/cmucl-2011…">Non-Unicode</a></li> + <li> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2011/06/cmucl-2011…">Non-Unicode extras</a></li> + </ul> + </td> + <td> +  + <dl> + <dt>8.2-stable + <dd> <a + href="http://common-lisp.net/project/cmucl/downloads/snapshot/2011/06/cmucl-2011-…">Unicode (sse2 only)</a></dd> + <dd> <a + href="http://common-lisp.net/project/cmucl/downloads/snapshot/2011/06/cmucl-2011-…">Unicode extras (sse2 only)</a></dd> + </dl> + </td> + <td> +  + <dl> + <dt>Solaris10/sparc + <dd> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2011/06/cmucl-2011…">Unicode</a></dd> + <dd> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2011/06/cmucl-2011…">Unicode extras</a></dd> + <dd> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2011/06/cmucl-2011…">Non-Unicode</a></dd> + <dd> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2011/06/cmucl-2011…">Non-Unicode extras</a></> +  + </dl> + </td> +  + <td> + + + </td> + <td> +  + <ul> + <li> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2011/06/cmucl-src-…">Source code</a></li> + <li> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2011/06/release-20…">Release notes for 20c</a></li> + </ul> + </td> + </tr> + + <tr> <td>2011-04</td> <td>  @@ -132,7 +200,7 @@ <dd> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2011/04/cmucl-2011…">Unicode</a></dd> <dd> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2011/04/cmucl-2011…">Unicode extras</a></dd> <dd> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2011/04/cmucl-2011…">Non-Unicode</a></dd> - <dd> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2011/04/cmucl-2011…">Non-uUnicode extras</a></dd> + <dd> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2011/04/cmucl-2011…">Non-Unicode extras</a></dd> </dl> </td> <td>

1 0

[cmucl-cvs] CMUCL commit: src/code (module.lisp)
by Raymond Toy 08 Jun '11

08 Jun '11

Date: Wednesday, June 8, 2011 @ 08:56:56 Author: rtoy Path: /project/cmucl/cvsroot/src/code Modified: module.lisp (require "asdf") loads asdf now. This change need to support the new recommended way of loading asdf2 with require. This is a backward compatible change. -------------+ module.lisp | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) Index: src/code/module.lisp diff -u src/code/module.lisp:1.16 src/code/module.lisp:1.17 --- src/code/module.lisp:1.16 Tue May 11 19:50:11 2010 +++ src/code/module.lisp Wed Jun 8 08:56:55 2011 @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /project/cmucl/cvsroot/src/code/module.lisp,v 1.16 2010/05/12 02:50:11 rtoy Rel $") + "$Header: /project/cmucl/cvsroot/src/code/module.lisp,v 1.17 2011/06/08 15:56:55 rtoy Exp $") ;;; ;;; ********************************************************************** @@ -140,6 +140,10 @@ (defmodule :defsystem "modules:defsystem/defsystem") +;; Allow user to load asdf using either (require :asdf) or (require +;; "asdf") (defmodule :asdf "modules:asdf/asdf") +(defmodule "asdf" + "modules:asdf/asdf") \ No newline at end of file

1 0

[cmucl-cvs] CMUCL commit: src/contrib/asdf (asdf.lisp)
by Raymond Toy 08 Jun '11

08 Jun '11

Date: Wednesday, June 8, 2011 @ 08:42:22 Author: rtoy Path: /project/cmucl/cvsroot/src/contrib/asdf Modified: asdf.lisp Update to release 2.016. -----------+ asdf.lisp | 1221 ++++++++++++++++++++++++++++++++++++------------------------ 1 file changed, 747 insertions(+), 474 deletions(-) Index: src/contrib/asdf/asdf.lisp diff -u src/contrib/asdf/asdf.lisp:1.14 src/contrib/asdf/asdf.lisp:1.15 --- src/contrib/asdf/asdf.lisp:1.14 Tue Mar 29 21:27:50 2011 +++ src/contrib/asdf/asdf.lisp Wed Jun 8 08:42:22 2011 @@ -1,5 +1,5 @@ ;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- -;;; This is ASDF 2.014.1: Another System Definition Facility. +;;; This is ASDF 2.016: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to <asdf-devel(a)common-lisp.net>. @@ -19,7 +19,7 @@ ;;; http://www.opensource.org/licenses/mit-license.html on or about ;;; Monday; July 13, 2009) ;;; -;;; Copyright (c) 2001-2010 Daniel Barlow and contributors +;;; Copyright (c) 2001-2011 Daniel Barlow and contributors ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining ;;; a copy of this software and associated documentation files (the @@ -49,41 +49,28 @@ (cl:in-package #-genera :common-lisp-user #+genera :future-common-lisp-user) +#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl) +(error "ASDF is not supported on your implementation. Please help us with it.") + #+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this (eval-when (:compile-toplevel :load-toplevel :execute) - ;;; make package if it doesn't exist yet. - ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it. - (unless (find-package :asdf) - (make-package :asdf :use '(:common-lisp))) ;;; Implementation-dependent tweaks ;; (declaim (optimize (speed 2) (debug 2) (safety 3))) ; NO: rely on the implementation defaults. #+allegro (setf excl::*autoload-package-name-alist* (remove "asdf" excl::*autoload-package-name-alist* - :test 'equalp :key 'car)) + :test 'equalp :key 'car)) ; need that BEFORE any mention of package ASDF as below #+(and ecl (not ecl-bytecmp)) (require :cmp) #+(and (or win32 windows mswindows mingw32) (not cygwin)) (pushnew :asdf-windows *features*) - #+(or unix cygwin) (pushnew :asdf-unix *features*)) + #+(or unix cygwin) (pushnew :asdf-unix *features*) + ;;; make package if it doesn't exist yet. + ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it. + (unless (find-package :asdf) + (make-package :asdf :use '(:common-lisp)))) (in-package :asdf) -;;; Strip out formating that is not supported on Genera. -(defmacro compatfmt (format) - #-genera format - #+genera - (let ((r '(("~@<" . "") - ("; ~@;" . "; ") - ("~3i~_" . "") - ("~@:>" . "") - ("~:>" . "")))) - (dolist (i r) - (loop :for found = (search (car i) format) :while found :do - (setf format (concatenate 'simple-string (subseq format 0 found) - (cdr i) - (subseq format (+ found (length (car i)))))))) - format)) - ;;;; Create packages in a way that is compatible with hot-upgrade. ;;;; See https://bugs.launchpad.net/asdf/+bug/485687 ;;;; See more near the end of the file. @@ -91,6 +78,26 @@ (eval-when (:load-toplevel :compile-toplevel :execute) (defvar *asdf-version* nil) (defvar *upgraded-p* nil) + (defvar *asdf-verbose* nil) ; was t from 2.000 to 2.014.12. + (defun find-symbol* (s p) + (find-symbol (string s) p)) + ;; Strip out formatting that is not supported on Genera. + ;; Has to be inside the eval-when to make Lispworks happy (!) + (defmacro compatfmt (format) + #-genera format + #+genera + (loop :for (unsupported . replacement) :in + '(("~@<" . "") + ("; ~@;" . "; ") + ("~3i~_" . "") + ("~@:>" . "") + ("~:>" . "")) :do + (loop :for found = (search unsupported format) :while found :do + (setf format + (concatenate 'simple-string + (subseq format 0 found) replacement + (subseq format (+ found (length unsupported))))))) + format) (let* (;; For bug reporting sanity, please always bump this version when you modify this file. ;; Please also modify asdf.asd to reflect this change. The script bin/bump-version ;; can help you do these changes in synch (look at the source for documentation). @@ -99,18 +106,18 @@ ;; "2.345.6" would be a development version in the official upstream ;; "2.345.0.7" would be your seventh local modification of official release 2.345 ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 - (asdf-version "2.014.1") - (existing-asdf (fboundp 'find-system)) + (asdf-version "2.016") + (existing-asdf (find-class 'component nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) (unless (and existing-asdf already-there) - (when existing-asdf + (when (and existing-asdf *asdf-verbose*) (format *trace-output* - (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%") - existing-version asdf-version)) + (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%") + existing-version asdf-version)) (labels ((present-symbol-p (symbol package) - (member (nth-value 1 (find-sym symbol package)) '(:internal :external))) + (member (nth-value 1 (find-symbol* symbol package)) '(:internal :external))) (present-symbols (package) ;; #-genera (loop :for s :being :the :present-symbols :in package :collect s) #+genera (let (l) @@ -140,14 +147,12 @@ p) (t (make-package name :nicknames nicknames :use use)))))) - (find-sym (symbol package) - (find-symbol (string symbol) package)) (intern* (symbol package) (intern (string symbol) package)) (remove-symbol (symbol package) - (let ((sym (find-sym symbol package))) + (let ((sym (find-symbol* symbol package))) (when sym - (unexport sym package) + #-cormanlisp (unexport sym package) (unintern sym package) sym))) (ensure-unintern (package symbols) @@ -156,19 +161,19 @@ :for removed = (remove-symbol sym package) :when removed :do (loop :for p :in packages :do - (when (eq removed (find-sym sym p)) + (when (eq removed (find-symbol* sym p)) (unintern removed p))))) (ensure-shadow (package symbols) (shadow symbols package)) (ensure-use (package use) (dolist (used (reverse use)) (do-external-symbols (sym used) - (unless (eq sym (find-sym sym package)) + (unless (eq sym (find-symbol* sym package)) (remove-symbol sym package))) (use-package used package))) (ensure-fmakunbound (package symbols) (loop :for name :in symbols - :for sym = (find-sym name package) + :for sym = (find-symbol* name package) :when sym :do (fmakunbound sym))) (ensure-export (package export) (let ((formerly-exported-symbols nil) @@ -184,7 +189,7 @@ (loop :for user :in (package-used-by-list package) :for shadowing = (package-shadowing-symbols user) :do (loop :for new :in newly-exported-symbols - :for old = (find-sym new user) + :for old = (find-symbol* new user) :when (and old (not (member old shadowing))) :do (unintern old user))) (loop :for x :in newly-exported-symbols :do @@ -213,7 +218,7 @@ #:perform-with-restarts #:component-relative-pathname #:system-source-file #:operate #:find-component #:find-system #:apply-output-translations #:translate-pathname* #:resolve-location - #:compile-file*) + #:compile-file* #:source-file-type) :unintern (#:*asdf-revision* #:around #:asdf-method-combination #:split #:make-collector @@ -225,7 +230,8 @@ #:inherit-source-registry #:process-source-registry-directive) :export (#:defsystem #:oos #:operate #:find-system #:run-shell-command - #:system-definition-pathname #:find-component ; miscellaneous + #:system-definition-pathname #:with-system-definitions + #:search-for-system-definition #:find-component ; miscellaneous #:compile-system #:load-system #:test-system #:clear-system #:compile-op #:load-op #:load-source-op #:test-op @@ -233,12 +239,15 @@ #:feature ; sort-of operation #:version ; metaphorically sort-of an operation #:version-satisfies + #:upgrade-asdf + #:implementation-identifier #:implementation-type #:input-files #:output-files #:output-file #:perform ; operation methods #:operation-done-p #:explain #:component #:source-file #:c-source-file #:cl-source-file #:java-source-file + #:cl-source-file.cl #:cl-source-file.lsp #:static-file #:doc-file #:html-file @@ -349,7 +358,7 @@ #:subdirectories #:truenamize #:while-collecting))) - #+genera (import 'scl:boolean :asdf) + #+genera (import 'scl:boolean :asdf) (setf *asdf-version* asdf-version *upgraded-p* (if existing-version (cons existing-version *upgraded-p*) @@ -361,7 +370,7 @@ (defun asdf-version () "Exported interface to the version of ASDF currently installed. A string. You can compare this string with e.g.: -(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.013\")." +(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.345.67\")." *asdf-version*) (defvar *resolve-symlinks* t @@ -382,8 +391,6 @@ (defvar *verbose-out* nil) -(defvar *asdf-verbose* t) - (defparameter +asdf-methods+ '(perform-with-restarts perform explain output-files operation-done-p)) @@ -396,6 +403,41 @@ (setf excl:*warn-on-nested-reader-conditionals* nil))) ;;;; ------------------------------------------------------------------------- +;;;; Resolve forward references + +(declaim (ftype (function (t) t) + format-arguments format-control + error-name error-pathname error-condition + duplicate-names-name + error-component error-operation + module-components module-components-by-name + circular-dependency-components + condition-arguments condition-form + condition-format condition-location + coerce-name) + #-cormanlisp + (ftype (function (t t) t) (setf module-components-by-name))) + +;;;; ------------------------------------------------------------------------- +;;;; Compatibility with Corman Lisp +#+cormanlisp +(progn + (deftype logical-pathname () nil) + (defun make-broadcast-stream () *error-output*) + (defun file-namestring (p) + (setf p (pathname p)) + (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))) + (defparameter *count* 3) + (defun dbg (&rest x) + (format *error-output* "~S~%" x))) +#+cormanlisp +(defun maybe-break () + (decf *count*) + (unless (plusp *count*) + (setf *count* 3) + (break))) + +;;;; ------------------------------------------------------------------------- ;;;; General Purpose Utilities (macrolet @@ -403,8 +445,9 @@ `(defmacro ,def* (name formals &rest rest) `(progn #+(or ecl gcl) (fmakunbound ',name) - ,(when (and #+ecl (symbolp name)) - `(declaim (notinline ,name))) ; fails for setf functions on ecl + #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-( + ,(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl + `(declaim (notinline ,name))) (,',def ,name ,formals ,@rest))))) (defdef defgeneric* defgeneric) (defdef defun* defun)) @@ -512,7 +555,8 @@ and NIL NAME, TYPE and VERSION components" (when pathname (make-pathname :name nil :type nil :version nil - :directory (merge-pathname-directory-components '(:relative :back) (pathname-directory pathname)) + :directory (merge-pathname-directory-components + '(:relative :back) (pathname-directory pathname)) :defaults pathname))) @@ -528,10 +572,10 @@ (defun* last-char (s) (and (stringp s) (plusp (length s)) (char s (1- (length s))))) - + (defun* asdf-message (format-string &rest format-args) (declare (dynamic-extent format-args)) - (apply #'format *verbose-out* format-string format-args)) + (apply 'format *verbose-out* format-string format-args)) (defun* split-string (string &key max (separator '(#\Space #\Tab))) "Split STRING into a list of components separated by @@ -539,10 +583,10 @@ If MAX is specified, then no more than max(1,MAX) components will be returned, starting the separation from the end, e.g. when called with arguments \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")." - (block nil + (catch nil (let ((list nil) (words 0) (end (length string))) (flet ((separatorp (char) (find char separator)) - (done () (return (cons (subseq string 0 end) list)))) + (done () (throw nil (cons (subseq string 0 end) list)))) (loop :for start = (if (and max (>= words (1- max))) (done) @@ -622,10 +666,20 @@ (defun* getenv (x) (declare (ignorable x)) - #+(or abcl clisp) (ext:getenv x) + #+(or abcl clisp xcl) (ext:getenv x) #+allegro (sys:getenv x) #+clozure (ccl:getenv x) #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=)) + #+cormanlisp + (let* ((buffer (ct:malloc 1)) + (cname (ct:lisp-string-to-c-string x)) + (needed-size (win:getenvironmentvariable cname buffer 0)) + (buffer1 (ct:malloc (1+ needed-size)))) + (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size)) + nil + (ct:c-string-to-lisp-string buffer1)) + (ct:free buffer) + (ct:free buffer1))) #+ecl (si:getenv x) #+gcl (system:getenv x) #+genera nil @@ -635,8 +689,8 @@ (unless (ccl:%null-ptr-p value) (ccl:%get-cstring value)))) #+sbcl (sb-ext:posix-getenv x) - #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl sbcl scl) - (error "getenv not available on your implementation")) + #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl) + (error "~S is not supported on your implementation" 'getenv)) (defun* directory-pathname-p (pathname) "Does PATHNAME represent a directory? @@ -712,6 +766,7 @@ '(ffi:clines "#include <sys/types.h>" "#include <unistd.h>")) (defun* get-uid () #+allegro (excl.osi:getuid) + #+ccl (ccl::getuid) #+clisp (loop :for s :in '("posix:uid" "LINUX:getuid") :for f = (ignore-errors (read-from-string s)) :when f :return (funcall f)) @@ -720,7 +775,7 @@ '(ffi:c-inline () () :int "getuid()" :one-liner t) '(ext::getuid)) #+sbcl (sb-unix:unix-getuid) - #-(or allegro clisp cmu ecl sbcl scl) + #-(or allegro ccl clisp cmu ecl sbcl scl) (let ((uid-string (with-output-to-string (*verbose-out*) (run-shell-command "id -ur")))) @@ -732,22 +787,21 @@ (defun* pathname-root (pathname) (make-pathname :directory '(:absolute) :name nil :type nil :version nil - :defaults pathname ;; host device, and on scl scheme scheme-specific-part port username password + :defaults pathname ;; host device, and on scl, *some* + ;; scheme-specific parts: port username password, not others: . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) -(defun* find-symbol* (s p) - (find-symbol (string s) p)) - (defun* probe-file* (p) "when given a pathname P, probes the filesystem for a file or directory with given pathname and if it exists return its truename." (etypecase p - (null nil) - (string (probe-file* (parse-namestring p))) - (pathname (unless (wild-pathname-p p) - #.(or #+(or allegro clozure cmu ecl sbcl scl) '(probe-file p) - #+clisp (aif (find-symbol (string '#:probe-pathname) :ext) `(ignore-errors (,it p))) - '(ignore-errors (truename p))))))) + (null nil) + (string (probe-file* (parse-namestring p))) + (pathname (unless (wild-pathname-p p) + #.(or #+(or allegro clozure cmu cormanlisp ecl sbcl scl) '(probe-file p) + #+clisp (aif (find-symbol* '#:probe-pathname :ext) + `(ignore-errors (,it p))) + '(ignore-errors (truename p))))))) (defun* truenamize (p) "Resolve as much of a pathname as possible" @@ -788,16 +842,32 @@ path (excl:pathname-resolve-symbolic-links path))) +(defun* resolve-symlinks* (path) + (if *resolve-symlinks* + (and path (resolve-symlinks path)) + path)) + +(defun ensure-pathname-absolute (path) + (cond + ((absolute-pathname-p path) path) + ((stringp path) (ensure-pathname-absolute (pathname path))) + ((not (pathnamep path)) (error "not a valid pathname designator ~S" path)) + (t (let ((resolved (resolve-symlinks path))) + (assert (absolute-pathname-p resolved)) + resolved)))) + (defun* default-directory () (truenamize (pathname-directory-pathname *default-pathname-defaults*))) (defun* lispize-pathname (input-file) (make-pathname :type "lisp" :defaults input-file)) +(defparameter *wild* #-cormanlisp :wild #+cormanlisp "*") (defparameter *wild-file* - (make-pathname :name :wild :type :wild :version :wild :directory nil)) + (make-pathname :name *wild* :type *wild* + :version (or #-(or abcl xcl) *wild*) :directory nil)) (defparameter *wild-directory* - (make-pathname :directory '(:relative :wild) :name nil :type nil :version nil)) + (make-pathname :directory `(:relative ,*wild*) :name nil :type nil :version nil)) (defparameter *wild-inferiors* (make-pathname :directory '(:relative :wild-inferiors) :name nil :type nil :version nil)) (defparameter *wild-path* @@ -834,27 +904,27 @@ #+scl (defun* directorize-pathname-host-device (pathname) (let ((scheme (ext:pathname-scheme pathname)) - (host (pathname-host pathname)) - (port (ext:pathname-port pathname)) - (directory (pathname-directory pathname))) + (host (pathname-host pathname)) + (port (ext:pathname-port pathname)) + (directory (pathname-directory pathname))) (flet ((not-unspecific (component) - (and (not (eq component :unspecific)) component))) + (and (not (eq component :unspecific)) component))) (cond ((or (not-unspecific port) - (and (not-unspecific host) (plusp (length host))) - (not-unspecific scheme)) - (let ((prefix "")) - (when (not-unspecific port) - (setf prefix (format nil ":~D" port))) - (when (and (not-unspecific host) (plusp (length host))) - (setf prefix (concatenate 'string host prefix))) - (setf prefix (concatenate 'string ":" prefix)) - (when (not-unspecific scheme) - (setf prefix (concatenate 'string scheme prefix))) - (assert (and directory (eq (first directory) :absolute))) - (make-pathname :directory `(:absolute ,prefix ,@(rest directory)) - :defaults pathname))) - (t - pathname))))) + (and (not-unspecific host) (plusp (length host))) + (not-unspecific scheme)) + (let ((prefix "")) + (when (not-unspecific port) + (setf prefix (format nil ":~D" port))) + (when (and (not-unspecific host) (plusp (length host))) + (setf prefix (concatenate 'string host prefix))) + (setf prefix (concatenate 'string ":" prefix)) + (when (not-unspecific scheme) + (setf prefix (concatenate 'string scheme prefix))) + (assert (and directory (eq (first directory) :absolute))) + (make-pathname :directory `(:absolute ,prefix ,@(rest directory)) + :defaults pathname))) + (t + pathname))))) ;;;; ------------------------------------------------------------------------- ;;;; ASDF Interface, in terms of generic functions. @@ -891,6 +961,9 @@ (defgeneric* (setf component-property) (new-value component property)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defgeneric* (setf module-components-by-name) (new-value module))) + (defgeneric* version-satisfies (component version)) (defgeneric* find-component (base path) @@ -967,12 +1040,12 @@ (when *upgraded-p* (when (find-class 'module nil) (eval - `(defmethod update-instance-for-redefined-class :after + '(defmethod update-instance-for-redefined-class :after ((m module) added deleted plist &key) (declare (ignorable deleted plist)) - (when (or *asdf-verbose* *load-verbose*) + (when *asdf-verbose* (asdf-message (compatfmt "~&~@<; ~@;Updating ~A for ASDF ~A~@:>~%") - m ,(asdf-version))) + m (asdf-version))) (when (member 'components-by-name added) (compute-module-components-by-name m)) (when (typep m 'system) @@ -994,44 +1067,31 @@ ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.] #+cmu (:report print-object)) -(declaim (ftype (function (t) t) - format-arguments format-control - error-name error-pathname error-condition - duplicate-names-name - error-component error-operation - module-components module-components-by-name - circular-dependency-components - condition-arguments condition-form - condition-format condition-location - coerce-name) - (ftype (function (t t) t) (setf module-components-by-name))) - - (define-condition formatted-system-definition-error (system-definition-error) ((format-control :initarg :format-control :reader format-control) (format-arguments :initarg :format-arguments :reader format-arguments)) (:report (lambda (c s) - (apply #'format s (format-control c) (format-arguments c))))) + (apply 'format s (format-control c) (format-arguments c))))) (define-condition load-system-definition-error (system-definition-error) ((name :initarg :name :reader error-name) (pathname :initarg :pathname :reader error-pathname) (condition :initarg :condition :reader error-condition)) (:report (lambda (c s) - (format s (compatfmt "~@<Error while trying to load definition for system ~A from pathname ~A: ~3i~_~A~@:>") - (error-name c) (error-pathname c) (error-condition c))))) + (format s (compatfmt "~@<Error while trying to load definition for system ~A from pathname ~A: ~3i~_~A~@:>") + (error-name c) (error-pathname c) (error-condition c))))) (define-condition circular-dependency (system-definition-error) ((components :initarg :components :reader circular-dependency-components)) (:report (lambda (c s) - (format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>") - (circular-dependency-components c))))) + (format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>") + (circular-dependency-components c))))) (define-condition duplicate-names (system-definition-error) ((name :initarg :name :reader duplicate-names-name)) (:report (lambda (c s) - (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~A~@:>") - (duplicate-names-name c))))) + (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~A~@:>") + (duplicate-names-name c))))) (define-condition missing-component (system-definition-error) ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires) @@ -1073,8 +1133,11 @@ ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>")))) (defclass component () - ((name :accessor component-name :initarg :name :documentation + ((name :accessor component-name :initarg :name :type string :documentation "Component name: designator for a string composed of portable pathname characters") + ;; We might want to constrain version with + ;; :type (and string (satisfies parse-version)) + ;; but we cannot until we fix all systems that don't use it correctly! (version :accessor component-version :initarg :version) (description :accessor component-description :initarg :description) (long-description :accessor component-long-description :initarg :long-description) @@ -1154,7 +1217,7 @@ (missing-requires c) (missing-version c) (when (missing-parent c) - (component-name (missing-parent c))))) + (coerce-name (missing-parent c))))) (defmethod component-system ((component component)) (aif (component-parent component) @@ -1244,21 +1307,41 @@ (defmethod version-satisfies ((c component) version) (unless (and version (slot-boundp c 'version)) + (when version + (warn "Requested version ~S but component ~S has no version" version c)) (return-from version-satisfies t)) (version-satisfies (component-version c) version)) +(defun parse-version (string &optional on-error) + "Parse a version string as a series of natural integers separated by dots. +Return a (non-null) list of integers if the string is valid, NIL otherwise. +If on-error is error, warn, or designates a function of compatible signature, +the function is called with an explanation of what is wrong with the argument. +NB: ignores leading zeroes, and so doesn't distinguish between 2.003 and 2.3" + (and + (or (stringp string) + (when on-error + (funcall on-error "~S: ~S is not a string" + 'parse-version string)) nil) + (or (loop :for prev = nil :then c :for c :across string + :always (or (digit-char-p c) + (and (eql c #\.) prev (not (eql prev #\.)))) + :finally (return (and c (digit-char-p c)))) + (when on-error + (funcall on-error "~S: ~S doesn't follow asdf version numbering convention" + 'parse-version string)) nil) + (mapcar #'parse-integer (split-string string :separator ".")))) + (defmethod version-satisfies ((cver string) version) - (let ((x (mapcar #'parse-integer - (split-string cver :separator "."))) - (y (mapcar #'parse-integer - (split-string version :separator ".")))) + (let ((x (parse-version cver 'warn)) + (y (parse-version version 'warn))) (labels ((bigger (x y) (cond ((not y) t) ((not x) nil) ((> (car x) (car y)) t) ((= (car x) (car y)) (bigger (cdr x) (cdr y)))))) - (and (= (car x) (car y)) + (and x y (= (car x) (car y)) (or (not (cdr y)) (bigger (cdr x) (cdr y))))))) ;;;; ------------------------------------------------------------------------- @@ -1284,12 +1367,21 @@ (defun* system-registered-p (name) (gethash (coerce-name name) *defined-systems*)) +(defun* register-system (system) + (check-type system system) + (let ((name (component-name system))) + (check-type name string) + (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system) + (unless (eq system (cdr (gethash name *defined-systems*))) + (setf (gethash name *defined-systems*) + (cons (get-universal-time) system))))) + (defun* clear-system (name) "Clear the entry for a system in the database of systems previously loaded. Note that this does NOT in any way cause the code of the system to be unloaded." - ;; There is no "unload" operation in Common Lisp, and a general such operation - ;; cannot be portably written, considering how much CL relies on side-effects - ;; to global data structures. + ;; There is no "unload" operation in Common Lisp, and + ;; a general such operation cannot be portably written, + ;; considering how much CL relies on side-effects to global data structures. (remhash (coerce-name name) *defined-systems*)) (defun* map-systems (fn) @@ -1308,16 +1400,14 @@ ;;; convention that functions in this list are prefixed SYSDEF- (defparameter *system-definition-search-functions* - '(sysdef-central-registry-search sysdef-source-registry-search sysdef-find-asdf)) + '(sysdef-central-registry-search + sysdef-source-registry-search + sysdef-find-asdf)) -(defun* system-definition-pathname (system) +(defun* search-for-system-definition (system) (let ((system-name (coerce-name system))) - (or - (some #'(lambda (x) (funcall x system-name)) - *system-definition-search-functions*) - (let ((system-pair (system-registered-p system-name))) - (and system-pair - (system-source-file (cdr system-pair))))))) + (some #'(lambda (x) (funcall x system-name)) + (cons 'find-system-if-being-defined *system-definition-search-functions*)))) (defvar *central-registry* nil "A list of 'system directory designators' ASDF uses to find systems. @@ -1381,8 +1471,8 @@ (push dir to-remove)) (coerce-entry-to-directory () :report (lambda (s) - (format s (compatfmt "~@<Coerce entry to ~a, replace ~a and continue.~@:>") - (ensure-directory-pathname defaults) dir)) + (format s (compatfmt "~@<Coerce entry to ~a, replace ~a and continue.~@:>") + (ensure-directory-pathname defaults) dir)) (push (cons dir (ensure-directory-pathname defaults)) to-replace)))))))) ;; cleanup (dolist (dir to-remove) @@ -1414,72 +1504,98 @@ ;; and we can survive and we will continue the planning ;; as if the file were very old. ;; (or should we treat the case in a different, special way?) - (or (and pathname (probe-file* pathname) (file-write-date pathname)) + (or (and pathname (probe-file* pathname) (ignore-errors (file-write-date pathname))) (progn (when (and pathname *asdf-verbose*) (warn (compatfmt "~@<Missing FILE-WRITE-DATE for ~S, treating it as zero.~@:>") pathname)) 0))) +(defmethod find-system ((name null) &optional (error-p t)) + (when error-p + (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>")))) + (defmethod find-system (name &optional (error-p t)) (find-system (coerce-name name) error-p)) -(defun load-sysdef (name pathname) +(defvar *systems-being-defined* nil + "A hash-table of systems currently being defined keyed by name, or NIL") + +(defun* find-system-if-being-defined (name) + (when *systems-being-defined* + (gethash (coerce-name name) *systems-being-defined*))) + +(defun* call-with-system-definitions (thunk) + (if *systems-being-defined* + (funcall thunk) + (let ((*systems-being-defined* (make-hash-table :test 'equal))) + (funcall thunk)))) + +(defmacro with-system-definitions (() &body body) + `(call-with-system-definitions #'(lambda () ,@body))) + +(defun* load-sysdef (name pathname) ;; Tries to load system definition with canonical NAME from PATHNAME. - (let ((package (make-temporary-package))) - (unwind-protect - (handler-bind - ((error #'(lambda (condition) - (error 'load-system-definition-error - :name name :pathname pathname - :condition condition)))) - (let ((*package* package)) - (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%") - pathname package) - (load pathname))) - (delete-package package)))) + (with-system-definitions () + (let ((package (make-temporary-package))) + (unwind-protect + (handler-bind + ((error #'(lambda (condition) + (error 'load-system-definition-error + :name name :pathname pathname + :condition condition)))) + (let ((*package* package)) + (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%") + pathname package) + (load pathname))) + (delete-package package))))) (defmethod find-system ((name string) &optional (error-p t)) - (catch 'find-system + (with-system-definitions () (let* ((in-memory (system-registered-p name)) ; load from disk if absent or newer on disk - (on-disk (system-definition-pathname name))) - (when (and on-disk - (or (not in-memory) + (previous (cdr in-memory)) + (previous (and (typep previous 'system) previous)) + (previous-time (car in-memory)) + (found (search-for-system-definition name)) + (found-system (and (typep found 'system) found)) + (pathname (or (and (typep found '(or pathname string)) (pathname found)) + (and found-system (system-source-file found-system)) + (and previous (system-source-file previous))))) + (setf pathname (resolve-symlinks* pathname)) + (when (and pathname (not (absolute-pathname-p pathname))) + (setf pathname (ensure-pathname-absolute pathname)) + (when found-system + (%set-system-source-file pathname found-system))) + (when (and previous (not (#-cormanlisp equal #+cormanlisp equalp + (system-source-file previous) pathname))) + (%set-system-source-file pathname previous) + (setf previous-time nil)) + (when (and found-system (not previous)) + (register-system found-system)) + (when (and pathname + (or (not previous-time) ;; don't reload if it's already been loaded, ;; or its filestamp is in the future which means some clock is skewed ;; and trying to load might cause an infinite loop. - (< (car in-memory) (safe-file-write-date on-disk) (get-universal-time)))) - (load-sysdef name on-disk)) + (< previous-time (safe-file-write-date pathname) (get-universal-time)))) + (load-sysdef name pathname)) (let ((in-memory (system-registered-p name))) ; try again after loading from disk (cond (in-memory - (when on-disk - (setf (car in-memory) (safe-file-write-date on-disk))) + (when pathname + (setf (car in-memory) (safe-file-write-date pathname))) (cdr in-memory)) (error-p (error 'missing-component :requires name))))))) -(defun* register-system (name system) - (setf name (coerce-name name)) - (assert (equal name (component-name system))) - (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system) - (setf (gethash name *defined-systems*) (cons (get-universal-time) system))) - (defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys) (setf fallback (coerce-name fallback) - source-file (or source-file - (if *resolve-symlinks* - (or *compile-file-truename* *load-truename*) - (or *compile-file-pathname* *load-pathname*))) requested (coerce-name requested)) (when (equal requested fallback) - (let* ((registered (cdr (gethash fallback *defined-systems*))) - (system (or registered - (apply 'make-instance 'system - :name fallback :source-file source-file keys)))) - (unless registered - (register-system fallback system)) - (throw 'find-system system)))) + (let ((registered (cdr (gethash fallback *defined-systems*)))) + (or registered + (apply 'make-instance 'system + :name fallback :source-file source-file keys))))) (defun* sysdef-find-asdf (name) ;; Bug: :version *asdf-version* won't be updated when ASDF is updated. @@ -1523,6 +1639,10 @@ (defclass cl-source-file (source-file) ((type :initform "lisp"))) +(defclass cl-source-file.cl (cl-source-file) + ((type :initform "cl"))) +(defclass cl-source-file.lsp (cl-source-file) + ((type :initform "lsp"))) (defclass c-source-file (source-file) ((type :initform "c"))) (defclass java-source-file (source-file) @@ -1572,12 +1692,13 @@ (values filename type)) (t (split-name-type filename))) - (make-pathname :directory `(,relative ,@path) :name name :type type - :defaults (or defaults *default-pathname-defaults*))))))) + (apply 'make-pathname :directory (cons relative path) :name name :type type + (when defaults `(:defaults ,defaults)))))))) (defun* merge-component-name-type (name &key type defaults) ;; For backwards compatibility only, for people using internals. - ;; Will be removed in a future release, e.g. 2.014. + ;; Will be removed in a future release, e.g. 2.016. + (warn "Please don't use ASDF::MERGE-COMPONENT-NAME-TYPE. Use ASDF:COERCE-PATHNAME.") (coerce-pathname name :type type :defaults defaults)) (defmethod component-relative-pathname ((component component)) @@ -1593,15 +1714,14 @@ ;;; one of these is instantiated whenever #'operate is called (defclass operation () - ( - ;; as of danb's 2003-03-16 commit e0d02781, :force can be: - ;; T to force the inside of existing system, + (;; as of danb's 2003-03-16 commit e0d02781, :force can be: + ;; T to force the inside of the specified system, ;; but not recurse to other systems we depend on. ;; :ALL (or any other atom) to force all systems ;; including other systems we depend on. ;; (SYSTEM1 SYSTEM2 ... SYSTEMN) ;; to force systems named in a given list - ;; However, but this feature never worked before ASDF 1.700 and is currently cerror'ed out. + ;; However, but this feature has only ever worked but starting with ASDF 2.014.5 (forced :initform nil :initarg :force :accessor operation-forced) (original-initargs :initform nil :initarg :original-initargs :accessor operation-original-initargs) @@ -1643,13 +1763,13 @@ (not (eql c dep-c))) (when (eql force-p t) (setf (getf args :force) nil)) - (apply #'make-instance dep-o + (apply 'make-instance dep-o :parent o :original-initargs args args)) ((subtypep (type-of o) dep-o) o) (t - (apply #'make-instance dep-o + (apply 'make-instance dep-o :parent o :original-initargs args args))))) @@ -1681,11 +1801,13 @@ (gethash node (operation-visiting-nodes (operation-ancestor o))))) (defmethod component-depends-on ((op-spec symbol) (c component)) + ;; Note: we go from op-spec to operation via make-instance + ;; to allow for specialization through defmethod's, even though + ;; it's a detour in the default case below. (component-depends-on (make-instance op-spec) c)) (defmethod component-depends-on ((o operation) (c component)) - (cdr (assoc (class-name (class-of o)) - (component-in-order-to c)))) + (cdr (assoc (type-of o) (component-in-order-to c)))) (defmethod component-self-dependencies ((o operation) (c component)) (let ((all-deps (component-depends-on o c))) @@ -1802,13 +1924,13 @@ required-op required-c required-v)) (retry () :report (lambda (s) - (format s "~@<Retry loading component ~3i~_~S.~@:>" required-c)) + (format s "~@<Retry loading ~3i~_~A.~@:>" required-c)) :test (lambda (c) - (or (null c) - (and (typep c 'missing-dependency) - (equalp (missing-requires c) - required-c)))))))) + (or (null c) + (and (typep c 'missing-dependency) + (equalp (missing-requires c) + required-c)))))))) (defun* do-dep (operation c collect op dep) ;; type of arguments uncertain: @@ -1855,11 +1977,11 @@ (funcall collect x)) (defmethod do-traverse ((operation operation) (c component) collect) - (let ((flag nil)) ;; return value: must we rebuild this and its dependencies? + (let ((*forcing* *forcing*) + (flag nil)) ;; return value: must we rebuild this and its dependencies? (labels ((update-flag (x) - (when x - (setf flag t))) + (orf flag x)) (dep (op comp) (update-flag (do-dep operation c collect op comp)))) ;; Have we been visited yet? If so, just process the result. @@ -1873,6 +1995,13 @@ (setf (visiting-component operation c) t) (unwind-protect (progn + (let ((f (operation-forced + (operation-ancestor operation)))) + (when (and f (or (not (consp f)) ;; T or :ALL + (and (typep c 'system) ;; list of names of systems to force + (member (component-name c) f + :test #'string=)))) + (setf *forcing* t))) ;; first we check and do all the dependencies for the module. ;; Operations planned in this loop will show up ;; in the results, and are consumed below. @@ -1912,22 +2041,13 @@ :try-next) (not at-least-one)) (error error))))))) - (update-flag - (or - *forcing* - (not (operation-done-p operation c)) + (update-flag (or *forcing* (not (operation-done-p operation c)))) ;; For sub-operations, check whether ;; the original ancestor operation was forced, ;; or names us amongst an explicit list of things to force... ;; except that this check doesn't distinguish ;; between all the things with a given name. Sigh. ;; BROKEN! - (let ((f (operation-forced - (operation-ancestor operation)))) - (and f (or (not (consp f)) ;; T or :ALL - (and (typep c 'system) ;; list of names of systems to force - (member (component-name c) f - :test #'string=))))))) (when flag (let ((do-first (cdr (assoc (class-name (class-of operation)) (component-do-first c))))) @@ -1956,12 +2076,7 @@ (r* l)))) (defmethod traverse ((operation operation) (c component)) - ;; cerror'ing a feature that seems to have NEVER EVER worked - ;; ever since danb created it in his 2003-03-16 commit e0d02781. - ;; It was both fixed and disabled in the 1.700 rewrite. (when (consp (operation-forced operation)) - (cerror "Continue nonetheless." - "Congratulations, you're the first ever user of the :force (list of system names) feature! Please contact the asdf-devel mailing-list to collect a cookie.") (setf (operation-forced operation) (mapcar #'coerce-name (operation-forced operation)))) (flatten-tree @@ -1979,11 +2094,12 @@ nil) (defmethod explain ((operation operation) (component component)) - (asdf-message "~&;;; ~A~%" (operation-description operation component))) + (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") + (operation-description operation component))) (defmethod operation-description (operation component) - (format nil (compatfmt "~@<~A on component ~S~@:>") - (class-of operation) (component-find-path component))) + (format nil (compatfmt "~@<~A on ~A~@:>") + (class-of operation) component)) ;;;; ------------------------------------------------------------------------- ;;;; compile-op @@ -2030,13 +2146,8 @@ (multiple-value-bind (output warnings-p failure-p) (apply *compile-op-compile-file-function* source-file :output-file output-file (compile-op-flags operation)) - (when warnings-p - (case (operation-on-warnings operation) - (:warn (warn - (compatfmt "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>") - operation c)) - (:error (error 'compile-warned :component c :operation operation)) - (:ignore nil))) + (unless output + (error 'compile-error :component c :operation operation)) (when failure-p (case (operation-on-failure operation) (:warn (warn @@ -2044,8 +2155,13 @@ operation c)) (:error (error 'compile-failed :component c :operation operation)) (:ignore nil))) - (unless output - (error 'compile-error :component c :operation operation))))) + (when warnings-p + (case (operation-on-warnings operation) + (:warn (warn + (compatfmt "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>") + operation c)) + (:error (error 'compile-warned :component c :operation operation)) + (:ignore nil)))))) (defmethod output-files ((operation compile-op) (c cl-source-file)) (declare (ignorable operation)) @@ -2067,7 +2183,12 @@ (defmethod operation-description ((operation compile-op) component) (declare (ignorable operation)) - (format nil "compiling component ~S" (component-find-path component))) + (format nil (compatfmt "~@<compiling ~3i~_~A~@:>") component)) + +(defmethod operation-description ((operation compile-op) (component module)) + (declare (ignorable operation)) + (format nil (compatfmt "~@<compiled ~3i~_~A~@:>") component)) + ;;;; ------------------------------------------------------------------------- ;;;; load-op @@ -2080,6 +2201,7 @@ (map () #'load (input-files o c))) (defmethod perform-with-restarts (operation component) + ;;(when *asdf-verbose* (explain operation component)) ; TOO verbose, especially as the default. (perform operation component)) (defmethod perform-with-restarts ((o load-op) (c cl-source-file)) @@ -2094,7 +2216,7 @@ (setf state :success)) (:failed-load (setf state :recompiled) - (perform (make-instance 'compile-op) c)) + (perform (make-sub-operation c o c 'compile-op) c)) (t (with-simple-restart (try-recompiling "Recompile ~a and try loading it again" @@ -2142,9 +2264,18 @@ (defmethod operation-description ((operation load-op) component) (declare (ignorable operation)) - (format nil (compatfmt "~@<Loading component: ~3i~_~S~@:>") - (component-find-path component))) + (format nil (compatfmt "~@<loading ~3i~_~A~@:>") + component)) + +(defmethod operation-description ((operation load-op) (component cl-source-file)) + (declare (ignorable operation)) + (format nil (compatfmt "~@<loading FASL for ~3i~_~A~@:>") + component)) +(defmethod operation-description ((operation load-op) (component module)) + (declare (ignorable operation)) + (format nil (compatfmt "~@<loaded ~3i~_~A~@:>") + component)) ;;;; ------------------------------------------------------------------------- ;;;; load-source-op @@ -2166,16 +2297,12 @@ (declare (ignorable operation c)) nil) -;;; FIXME: we simply copy load-op's dependencies. this is Just Not Right. +;;; FIXME: We simply copy load-op's dependencies. This is Just Not Right. (defmethod component-depends-on ((o load-source-op) (c component)) (declare (ignorable o)) - (let ((what-would-load-op-do (cdr (assoc 'load-op - (component-in-order-to c))))) - (mapcar #'(lambda (dep) - (if (eq (car dep) 'load-op) - (cons 'load-source-op (cdr dep)) - dep)) - what-would-load-op-do))) + (loop :with what-would-load-op-do = (component-depends-on 'load-op c) + :for (op . co) :in what-would-load-op-do + :when (eq op 'load-op) :collect (cons 'load-source-op co))) (defmethod operation-done-p ((o load-source-op) (c source-file)) (declare (ignorable o)) @@ -2186,8 +2313,12 @@ (defmethod operation-description ((operation load-source-op) component) (declare (ignorable operation)) - (format nil (compatfmt "~@<Loading component: ~3i~_~S~@:>") - (component-find-path component))) + (format nil (compatfmt "~@<Loading source of ~3i~_~A~@:>") + component)) + +(defmethod operation-description ((operation load-source-op) (component module)) + (declare (ignorable operation)) + (format nil (compatfmt "~@<Loaded source of ~3i~_~A~@:>") component)) ;;;; ------------------------------------------------------------------------- @@ -2213,48 +2344,93 @@ ;;;; Invoking Operations (defgeneric* operate (operation-class system &key &allow-other-keys)) +(defgeneric* perform-plan (plan &key)) + +;;;; Try to upgrade of ASDF. If a different version was used, return T. +;;;; We need do that before we operate on anything that depends on ASDF. +(defun* upgrade-asdf () + (let ((version (asdf:asdf-version))) + (handler-bind (((or style-warning warning) #'muffle-warning)) + (operate 'load-op :asdf :verbose nil)) + (let ((new-version (asdf:asdf-version))) + (block nil + (cond + ((equal version new-version) + (return nil)) + ((version-satisfies new-version version) + (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%") + version new-version)) + ((version-satisfies version new-version) + (warn (compatfmt "~&~@<Downgraded ASDF from version ~A to version ~A~@:>~%") + version new-version)) + (t + (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%") + version new-version))) + (let ((asdf (find-system :asdf))) + ;; invalidate all systems but ASDF itself + (setf *defined-systems* (make-defined-systems-table)) + (register-system asdf) + t))))) + +(defmethod perform-plan ((steps list) &key) + (let ((*package* *package*) + (*readtable* *readtable*)) + (with-compilation-unit () + (loop :for (op . component) :in steps :do + (loop + (restart-case + (progn + (perform-with-restarts op component) + (return)) + (retry () + :report + (lambda (s) + (format s (compatfmt "~@<Retry ~A.~@:>") + (operation-description op component)))) + (accept () + :report + (lambda (s) + (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>") + (operation-description op component))) + (setf (gethash (type-of op) + (component-operation-times component)) + (get-universal-time)) + (return)))))))) (defmethod operate (operation-class system &rest args &key ((:verbose *asdf-verbose*) *asdf-verbose*) version force &allow-other-keys) (declare (ignore force)) - (let* ((*package* *package*) - (*readtable* *readtable*) - (op (apply #'make-instance operation-class - :original-initargs args - args)) - (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream))) - (system (if (typep system 'component) system (find-system system)))) - (unless (version-satisfies system version) - (error 'missing-component-of-version :requires system :version version)) - (let ((steps (traverse op system))) - (with-compilation-unit () - (loop :for (op . component) :in steps :do - (loop - (restart-case - (progn - (perform-with-restarts op component) - (return)) - (retry () - :report - (lambda (s) - (format s (compatfmt "~@<Retry ~A.~@:>") - (operation-description op component)))) - (accept () - :report - (lambda (s) - (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>") - (operation-description op component))) - (setf (gethash (type-of op) - (component-operation-times component)) - (get-universal-time)) - (return)))))) - (values op steps)))) + (with-system-definitions () + (let* ((op (apply 'make-instance operation-class + :original-initargs args + args)) + (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream))) + (system (etypecase system + (system system) + ((or string symbol) (find-system system))))) + (unless (version-satisfies system version) + (error 'missing-component-of-version :requires system :version version)) + (let ((steps (traverse op system))) + (when (and (not (equal '("asdf") (component-find-path system))) + (find '("asdf") (mapcar 'cdr steps) + :test 'equal :key 'component-find-path) + (upgrade-asdf)) + ;; If we needed to upgrade ASDF to achieve our goal, + ;; then do it specially as the first thing, then + ;; invalidate all existing system + ;; retry the whole thing with the new OPERATE function, + ;; which on some implementations + ;; has a new symbol shadowing the current one. + (return-from operate + (apply (find-symbol* 'operate :asdf) operation-class system args))) + (perform-plan steps) + (values op steps))))) (defun* oos (operation-class system &rest args &key force verbose version &allow-other-keys) (declare (ignore force verbose version)) - (apply #'operate operation-class system args)) + (apply 'operate operation-class system args)) (let ((operate-docstring "Operate does three things: @@ -2281,12 +2457,11 @@ (setf (documentation 'operate 'function) operate-docstring)) -(defun* load-system (system &rest args &key force verbose version - &allow-other-keys) - "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for -details." +(defun* load-system (system &rest args &key force verbose version &allow-other-keys) + "Shorthand for `(operate 'asdf:load-op system)`. +See OPERATE for details." (declare (ignore force verbose version)) - (apply #'operate 'load-op system args) + (apply 'operate 'load-op system args) t) (defun* compile-system (system &rest args &key force verbose version @@ -2294,7 +2469,7 @@ "Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE for details." (declare (ignore force verbose version)) - (apply #'operate 'compile-op system args) + (apply 'operate 'compile-op system args) t) (defun* test-system (system &rest args &key force verbose version @@ -2302,17 +2477,14 @@ "Shorthand for `(operate 'asdf:test-op system)`. See OPERATE for details." (declare (ignore force verbose version)) - (apply #'operate 'test-op system args) + (apply 'operate 'test-op system args) t) ;;;; ------------------------------------------------------------------------- ;;;; Defsystem (defun* load-pathname () - (let ((pn (or *load-pathname* *compile-file-pathname*))) - (if *resolve-symlinks* - (and pn (resolve-symlinks pn)) - pn))) + (resolve-symlinks* (or *load-pathname* *compile-file-pathname*))) (defun* determine-system-pathname (pathname pathname-supplied-p) ;; The defsystem macro calls us to determine @@ -2328,45 +2500,18 @@ directory-pathname (default-directory)))) -(defmacro defsystem (name &body options) - (setf name (coerce-name name)) - (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system) - defsystem-depends-on &allow-other-keys) - options - (let ((component-options (remove-keys '(:class) options))) - `(progn - ;; system must be registered before we parse the body, otherwise - ;; we recur when trying to find an existing system of the same name - ;; to reuse options (e.g. pathname) from - ,@(loop :for system :in defsystem-depends-on - :collect `(load-system ',(coerce-name system))) - (let ((s (system-registered-p ',name))) - (cond ((and s (eq (type-of (cdr s)) ',class)) - (setf (car s) (get-universal-time))) - (s - (change-class (cdr s) ',class)) - (t - (register-system (quote ,name) - (make-instance ',class :name ',name)))) - (%set-system-source-file (load-pathname) - (cdr (system-registered-p ',name)))) - (parse-component-form - nil (list* - :module (coerce-name ',name) - :pathname - ,(determine-system-pathname pathname pathname-arg-p) - ',component-options)))))) - (defun* class-for-type (parent type) (or (loop :for symbol :in (list type (find-symbol* type *package*) (find-symbol* type :asdf)) :for class = (and symbol (find-class symbol nil)) - :when (and class (subtypep class 'component)) + :when (and class + (#-cormanlisp subtypep #+cormanlisp cl::subclassp + class (find-class 'component))) :return class) (and (eq type :file) - (or (module-default-component-class parent) + (or (and parent (module-default-component-class parent)) (find-class *default-component-class*))) (sysdef-error "don't recognize component type ~A" type))) @@ -2458,6 +2603,7 @@ perform explain output-files operation-done-p weakly-depends-on depends-on serial in-order-to + (version nil versionp) ;; list ends &allow-other-keys) options (declare (ignorable perform explain output-files operation-done-p)) @@ -2471,6 +2617,11 @@ (class-for-type parent type)))) (error 'duplicate-names :name name)) + (when versionp + (unless (parse-version version nil) + (warn (compatfmt "~@<Invalid version ~S for component ~S~@[ of ~S~]~@:>") + version name parent))) + (let* ((other-args (remove-keys '(components pathname default-component-class perform explain output-files operation-done-p @@ -2484,7 +2635,7 @@ (appendf depends-on (remove-if (complement #'find-system) weakly-depends-on))) (when *serial-depends-on* (push *serial-depends-on* depends-on)) - (apply #'reinitialize-instance ret + (apply 'reinitialize-instance ret :name (coerce-name name) :pathname pathname :parent parent @@ -2517,6 +2668,40 @@ (%refresh-component-inline-methods ret rest) ret))) +(defun* do-defsystem (name &rest options + &key (pathname nil pathname-arg-p) (class 'system) + defsystem-depends-on &allow-other-keys) + ;; The system must be registered before we parse the body, + ;; otherwise we recur when trying to find an existing system + ;; of the same name to reuse options (e.g. pathname) from. + ;; To avoid infinite recursion in cases where you defsystem a system + ;; that is registered to a different location to find-system, + ;; we also need to remember it in a special variable *systems-being-defined*. + (with-system-definitions () + (let* ((name (coerce-name name)) + (registered (system-registered-p name)) + (system (cdr (or registered + (register-system (make-instance 'system :name name))))) + (component-options (remove-keys '(:class) options))) + (%set-system-source-file (load-pathname) system) + (setf (gethash name *systems-being-defined*) system) + (when registered + (setf (car registered) (get-universal-time))) + (map () 'load-system defsystem-depends-on) + ;; We change-class (when necessary) AFTER we load the defsystem-dep's + ;; since the class might not be defined as part of those. + (let ((class (class-for-type nil class))) + (unless (eq (type-of system) class) + (change-class system class))) + (parse-component-form + nil (list* + :module name + :pathname (determine-system-pathname pathname pathname-arg-p) + component-options))))) + +(defmacro defsystem (name &body options) + `(apply 'do-defsystem ',name ',options)) + ;;;; --------------------------------------------------------------------------- ;;;; run-shell-command ;;;; @@ -2534,7 +2719,7 @@ "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and synchronously execute the result using a Bourne-compatible shell, with output to *VERBOSE-OUT*. Returns the shell's exit code." - (let ((command (apply #'format nil control-string args))) + (let ((command (apply 'format nil control-string args))) (asdf-message "; $ ~A~%" command) #+abcl @@ -2552,8 +2737,8 @@ (asdf-message "~{~&; ~a~%~}~%" stdout) exit-code) - #+clisp ;XXX not exactly *verbose-out*, I know - (or (ext:run-shell-command command :output :terminal :wait t) 0) + #+clisp ;XXX not exactly *verbose-out*, I know + (or (ext:run-shell-command command :output (and *verbose-out* :terminal) :wait t) 0) #+clozure (nth-value 1 @@ -2578,7 +2763,7 @@ #+sbcl (sb-ext:process-exit-code - (apply #'sb-ext:run-program + (apply 'sb-ext:run-program #+win32 "sh" #-win32 "/bin/sh" (list "-c" command) :input nil :output *verbose-out* @@ -2591,12 +2776,28 @@ (list "-c" command) :input nil :output *verbose-out*)) - #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl) + #+xcl + (ext:run-shell-command command) + + #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl xcl) (error "RUN-SHELL-COMMAND not implemented for this Lisp"))) ;;;; --------------------------------------------------------------------------- ;;;; system-relative-pathname +(defun* system-definition-pathname (x) + ;; As of 2.014.8, we mean to make this function obsolete, + ;; but that won't happen until all clients have been updated. + ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead" + "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete. +It used to expose ASDF internals with subtle differences with respect to +user expectations, that have been refactored away since. +We recommend you use ASDF:SYSTEM-SOURCE-FILE instead +for a mostly compatible replacement that we're supporting, +or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME +if that's whay you mean." ;;) + (system-source-file x)) + (defmethod system-source-file ((system-name string)) (system-source-file (find-system system-name))) (defmethod system-source-file ((system-name symbol)) @@ -2644,10 +2845,10 @@ (:ccl :clozure) (:corman :cormanlisp) (:lw :lispworks) - :clisp :cmu :ecl :gcl :sbcl :scl :symbolics)) + :clisp :cmu :ecl :gcl :sbcl :scl :symbolics :xcl)) (defparameter *os-features* - '((:win :windows :mswindows :win32 :mingw32) ;; shorten things on windows + '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; shorten things on windows (:solaris :sunos) (:linux :linux-target) ;; for GCL at least, must appear before :bsd. (:macosx :darwin :darwin-target :apple) @@ -2656,54 +2857,48 @@ :genera)) (defparameter *architecture-features* - '((:amd64 :x86-64 :x86_64 :x8664-target) + '((:x64 :amd64 :x86-64 :x86_64 :x8664-target #+(and clisp word-size=64) :pc386) (:x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target) - :hppa64 - :hppa - (:ppc64 :ppc64-target) - (:ppc32 :ppc32-target :ppc :powerpc) - :sparc64 - (:sparc32 :sparc) + :hppa64 :hppa + (:ppc64 :ppc64-target) (:ppc32 :ppc32-target :ppc :powerpc) + :sparc64 (:sparc32 :sparc) (:arm :arm-target) (:java :java-1.4 :java-1.5 :java-1.6 :java-1.7) + :mipsel :mipseb :mips + :alpha :imach)) (defun* lisp-version-string () (let ((s (lisp-implementation-version))) - (declare (ignorable s)) - #+allegro (format nil - "~A~A~A~A" - excl::*common-lisp-version-number* - ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox - (if (eq excl:*current-case-mode* - :case-sensitive-lower) "M" "A") - ;; Note if not using International ACL - ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-targe… - (excl:ics-target-case - (:-ics "8") - (:+ics "")) - (if (member :64bit *features*) "-64bit" "")) - #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*) - #+clisp (subseq s 0 (position #\space s)) ; strip build information (date, etc.) - #+clozure (format nil "~d.~d-f~d" ; shorten for windows - ccl::*openmcl-major-version* - ccl::*openmcl-minor-version* - (logand ccl::fasl-version #xFF)) - #+cmu (substitute #\- #\/ s) - #+ecl (format nil "~A~@[-~A~]" s - (let ((vcs-id (ext:lisp-implementation-vcs-id))) - (when (>= (length vcs-id) 8) - (subseq vcs-id 0 8)))) - #+gcl (subseq s (1+ (position #\space s))) - #+genera (multiple-value-bind (major minor) (sct:get-system-version "System") - (format nil "~D.~D" major minor)) - #+lispworks (format nil "~A~@[~A~]" s - (when (member :lispworks-64bit *features*) "-64bit")) - ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; f-f-v redundant w/ version - #+mcl (subseq s 8) ; strip the leading "Version " - #+(or cormanlisp sbcl scl) s - #-(or allegro armedbear clisp clozure cmu cormanlisp - ecl gcl genera lispworks mcl sbcl scl) s)) + (or + #+allegro (format nil + "~A~A~A" + excl::*common-lisp-version-number* + ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox + (if (eq excl:*current-case-mode* + :case-sensitive-lower) "M" "A") + ;; Note if not using International ACL + ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-targe… + (excl:ics-target-case + (:-ics "8") + (:+ics ""))) ; redundant? (if (member :64bit *features*) "-64bit" "")) + #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*) + #+clisp (subseq s 0 (position #\space s)) ; strip build information (date, etc.) + #+clozure (format nil "~d.~d-f~d" ; shorten for windows + ccl::*openmcl-major-version* + ccl::*openmcl-minor-version* + (logand ccl::fasl-version #xFF)) + #+cmu (substitute #\- #\/ s) + #+ecl (format nil "~A~@[-~A~]" s + (let ((vcs-id (ext:lisp-implementation-vcs-id))) + (when (>= (length vcs-id) 8) + (subseq vcs-id 0 8)))) + #+gcl (subseq s (1+ (position #\space s))) + #+genera (multiple-value-bind (major minor) (sct:get-system-version "System") + (format nil "~D.~D" major minor)) + ;; #+lispworks (format nil "~A~@[~A~]" s (when (member :lispworks-64bit *features*) "-64bit") #+mcl (subseq s 8) ; strip the leading "Version " + ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; f-f-v redundant w/ version + s))) (defun* first-feature (features) (labels @@ -2728,7 +2923,7 @@ (labels ((maybe-warn (value fstring &rest args) (cond (value) - (t (apply #'warn fstring args) + (t (apply 'warn fstring args) "unknown")))) (let ((lisp (maybe-warn (implementation-type) (compatfmt "~@<No implementation feature found in ~a.~@:>") @@ -2753,8 +2948,19 @@ #+asdf-unix #\: #-asdf-unix #\;) +;; Note: ASDF may expect user-homedir-pathname to provide the pathname of +;; the current user's home directory, while MCL by default provides the +;; directory from which MCL was started. +;; See http://code.google.com/p/mcl/wiki/Portability +#.(or #+mcl ;; the #$ doesn't work on other implementations, even inside #+mcl + `(defun current-user-homedir-pathname () + ,(read-from-string "(ccl::findfolder #$kuserdomain #$kCurrentUserFolderType))"))) + (defun* user-homedir () - (truenamize (pathname-directory-pathname (user-homedir-pathname)))) + (truenamize + (pathname-directory-pathname + #+mcl (current-user-homedir-pathname) + #-mcl (user-homedir-pathname)))) (defun* try-directory-subpath (x sub &key type) (let* ((p (and x (ensure-directory-pathname x))) @@ -2763,29 +2969,34 @@ (ts (and sp (probe-file* sp)))) (and ts (values sp ts)))) (defun* user-configuration-directories () - (remove-if - #'null - (flet ((try (x sub) (try-directory-subpath x sub :type :directory))) - `(,(try (getenv "XDG_CONFIG_HOME") "common-lisp/") - ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS") - :for dir :in (split-string dirs :separator ":") - :collect (try dir "common-lisp/")) - #+asdf-windows - ,@`(#+lispworks ,(try (sys:get-folder-path :common-appdata) "common-lisp/config/") - ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData - ,(try (getenv "APPDATA") "common-lisp/config/")) - ,(try (user-homedir) ".config/common-lisp/"))))) + (let ((dirs + (flet ((try (x sub) (try-directory-subpath x sub))) + `(,(try (getenv "XDG_CONFIG_HOME") "common-lisp/") + ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS") + :for dir :in (split-string dirs :separator ":") + :collect (try dir "common-lisp/")) + #+asdf-windows + ,@`(,(try (or #+lispworks (sys:get-folder-path :local-appdata) + (getenv "LOCALAPPDATA")) + "common-lisp/config/") + ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData + ,(try (or #+lispworks (sys:get-folder-path :appdata) + (getenv "APPDATA")) + "common-lisp/config/")) + ,(try (user-homedir) ".config/common-lisp/"))))) + (remove-duplicates (remove-if #'null dirs) :from-end t :test 'equal))) (defun* system-configuration-directories () (remove-if #'null - (append - #+asdf-windows - (flet ((try (x sub) (try-directory-subpath x sub :type :directory))) - `(,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/") - ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData - ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/")))) - #+asdf-unix - (list #p"/etc/common-lisp/")))) + `(#+asdf-windows + ,(flet ((try (x sub) (try-directory-subpath x sub))) + ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData + (try (or #+lispworks (sys:get-folder-path :common-appdata) + (getenv "ALLUSERSAPPDATA") + (try (getenv "ALLUSERSPROFILE") "Application Data/")) + "common-lisp/config/")) + #+asdf-unix #p"/etc/common-lisp/"))) + (defun* in-first-directory (dirs x) (loop :for dir :in dirs :thereis (and dir (probe-file* (merge-pathnames* x (ensure-directory-pathname dir)))))) @@ -2845,7 +3056,7 @@ (let ((forms (read-file-forms file))) (unless (length=n-p forms 1) (error (compatfmt "~@<One and only one form allowed for ~A. Got: ~3i~_~S~@:>~%") - description forms)) + description forms)) (funcall validator (car forms) :location file))) (defun* hidden-file-p (pathname) @@ -2857,7 +3068,8 @@ #+clozure '(:follow-links nil) #+clisp '(:circle t :if-does-not-exist :ignore) #+(or cmu scl) '(:follow-links nil :truenamep nil) - #+sbcl (when (find-symbol "RESOLVE-SYMLINKS" "SB-IMPL") '(:resolve-symlinks nil)))))) + #+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl) + '(:resolve-symlinks nil)))))) (defun* validate-configuration-directory (directory tag validator &key invalid-form-reporter) "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will @@ -2903,7 +3115,11 @@ (or (try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation) #+asdf-windows - (try (getenv "APPDATA") "common-lisp" "cache" :implementation) + (try (or #+lispworks (sys:get-folder-path :local-appdata) + (getenv "LOCALAPPDATA") + #+lispworks (sys:get-folder-path :appdata) + (getenv "APPDATA")) + "common-lisp" "cache" :implementation) '(:home ".cache" "common-lisp" :implementation)))) (defvar *system-cache* ;; No good default, plus there's a security problem @@ -3002,7 +3218,10 @@ :default-directory) :directory t :wilden nil)) ((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil)) - ((eql :system-cache) (resolve-location *system-cache* :directory t :wilden nil)) + ((eql :system-cache) + (warn "Using the :system-cache is deprecated. ~%~ +Please remove it from your ASDF configuration") + (resolve-location *system-cache* :directory t :wilden nil)) ((eql :default-directory) (default-directory)))) (s (if (and wilden (not (pathnamep x))) (wilden r) @@ -3101,7 +3320,7 @@ ((equal "" s) (when inherit (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>") - string)) + string)) (setf inherit t) (push :inherit-configuration directives)) (t @@ -3110,7 +3329,7 @@ (when (> start end) (when source (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>") - string)) + string)) (unless inherit (push :ignore-inherited-configuration directives)) (return `(:output-translations ,@(nreverse directives))))))))) @@ -3128,8 +3347,9 @@ ;; so we must disable translations for implementation paths. #+sbcl ,(let ((h (getenv "SBCL_HOME"))) (when (plusp (length h)) `((,(truenamize h) ,*wild-inferiors*) ()))) - #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; not needed: no precompiled ASDF system - #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ())) ; not needed: no precompiled ASDF system + ;; The below two are not needed: no precompiled ASDF system there + ;; #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) + ;; #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ())) ;; All-import, here is where we want user stuff to be: :inherit-configuration ;; These are for convenience, and can be overridden by the user: @@ -3142,7 +3362,7 @@ (defparameter *output-translations-directory* (coerce-pathname "asdf-output-translations.conf.d/")) (defun* user-output-translations-pathname () - (in-user-configuration-directory *output-translations-file* )) + (in-user-configuration-directory *output-translations-file*)) (defun* system-output-translations-pathname () (in-system-configuration-directory *output-translations-file*)) (defun* user-output-translations-directory-pathname () @@ -3216,8 +3436,9 @@ ((eq dst t) (funcall collect (list trusrc t))) (t - (let* ((trudst (make-pathname - :defaults (if dst (resolve-location dst :directory t :wilden t) trusrc))) + (let* ((trudst (if dst + (resolve-location dst :directory t :wilden t) + trusrc)) (wilddst (merge-pathnames* *wild-file* trudst))) (funcall collect (list wilddst t)) (funcall collect (list trusrc trudst))))))))))) @@ -3271,6 +3492,7 @@ (defun* apply-output-translations (path) (etypecase path + #+cormanlisp (t (truenamize path)) (logical-pathname path) ((or pathname string) @@ -3300,7 +3522,8 @@ t)) (defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys) - (or output-file + (if (absolute-pathname-p output-file) + (apply 'compile-file-pathname (lispize-pathname input-file) keys) (apply-output-translations (apply 'compile-file-pathname (truenamize (lispize-pathname input-file)) @@ -3316,7 +3539,7 @@ (delete-file x))) (defun* compile-file* (input-file &rest keys &key output-file &allow-other-keys) - (let* ((output-file (or output-file (apply 'compile-file-pathname* input-file keys))) + (let* ((output-file (apply 'compile-file-pathname* input-file :output-file output-file keys)) (tmp-file (tmpize-pathname output-file)) (status :error)) (multiple-value-bind (output-truename warnings-p failure-p) @@ -3383,7 +3606,7 @@ (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on ECL and CLISP")) (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp"))) (mapped-files (if map-all-source-files *wild-file* - (make-pathname :name :wild :version :wild :type fasl-type))) + (make-pathname :type fasl-type :defaults *wild-file*))) (destination-directory (if centralize-lisp-binaries `(,default-toplevel-directory @@ -3417,8 +3640,7 @@ :do (write-char (code-char code) out)))) (defun* read-little-endian (s &optional (bytes 4)) - (loop - :for i :from 0 :below bytes + (loop :for i :from 0 :below bytes :sum (ash (read-byte s) (* 8 i)))) (defun* parse-file-location-info (s) @@ -3485,64 +3707,62 @@ ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs" "_sgbak" "autom4te.cache" "cover_db" "_build" - "debian")) ;; debian often build stuff under the debian directory... BAD. + "debian")) ;; debian often builds stuff under the debian directory... BAD. (defvar *source-registry-exclusions* *default-source-registry-exclusions*) -(defvar *source-registry* () - "Either NIL (for uninitialized), or a list of one element, -said element itself being a list of directory pathnames where to look for .asd files") - -(defun* source-registry () - (car *source-registry*)) - -(defun* (setf source-registry) (new-value) - (setf *source-registry* (list new-value)) - new-value) +(defvar *source-registry* nil + "Either NIL (for uninitialized), or an equal hash-table, mapping +system names to pathnames of .asd files") (defun* source-registry-initialized-p () - (and *source-registry* t)) + (typep *source-registry* 'hash-table)) (defun* clear-source-registry () "Undoes any initialization of the source registry. You might want to call that before you dump an image that would be resumed with a different configuration, so the configuration would be re-read then." - (setf *source-registry* '()) + (setf *source-registry* nil) (values)) (defparameter *wild-asd* - (make-pathname :directory nil :name :wild :type "asd" :version :newest)) + (make-pathname :directory nil :name *wild* :type "asd" :version :newest)) -(defun directory-has-asd-files-p (directory) +(defun directory-asd-files (directory) (ignore-errors - (and (directory* (merge-pathnames* *wild-asd* directory)) t))) + (directory* (merge-pathnames* *wild-asd* directory)))) (defun subdirectories (directory) (let* ((directory (ensure-directory-pathname directory)) - #-(or cormanlisp genera) + #-(or abcl cormanlisp genera xcl) (wild (merge-pathnames* - #-(or abcl allegro cmu lispworks scl) + #-(or abcl allegro cmu lispworks scl xcl) *wild-directory* - #+(or abcl allegro cmu lispworks scl) "*.*" + #+(or abcl allegro cmu lispworks scl xcl) "*.*" directory)) (dirs - #-(or cormanlisp genera) + #-(or abcl cormanlisp genera xcl) (ignore-errors (directory* wild . #.(or #+clozure '(:directories t :files nil) #+mcl '(:directories t)))) + #+(or abcl xcl) (system:list-directory directory) #+cormanlisp (cl::directory-subdirs directory) #+genera (fs:directory-list directory)) - #+(or abcl allegro cmu genera lispworks scl) - (dirs (remove-if-not #+abcl #'extensions:probe-directory - #+allegro #'excl:probe-directory - #+lispworks #'lw:file-directory-p - #+genera #'(lambda (x) (getf (cdr x) :directory)) - #-(or abcl allegro genera lispworks) #'directory-pathname-p - dirs)) - #+genera - (dirs (mapcar #'(lambda (x) (ensure-directory-pathname (first x))) dirs))) + #+(or abcl allegro cmu genera lispworks scl xcl) + (dirs (loop :for x :in dirs + :for d = #+(or abcl xcl) (extensions:probe-directory x) + #+allegro (excl:probe-directory x) + #+(or cmu scl) (directory-pathname-p x) + #+genera (getf (cdr x) :directory) + #+lispworks (lw:file-directory-p x) + :when d :collect #+(or abcl allegro xcl) d + #+genera (ensure-directory-pathname (first x)) + #+(or cmu lispworks scl) x))) dirs)) +(defun collect-asds-in-directory (directory collect) + (map () collect (directory-asd-files directory))) + (defun collect-sub*directories (directory collectp recursep collector) (when (funcall collectp directory) (funcall collector directory)) @@ -3550,15 +3770,15 @@ (when (funcall recursep subdir) (collect-sub*directories subdir collectp recursep collector)))) -(defun collect-sub*directories-with-asd +(defun collect-sub*directories-asd-files (directory &key (exclude *default-source-registry-exclusions*) collect) (collect-sub*directories directory - #'directory-has-asd-files-p + (constantly t) #'(lambda (x) (not (member (car (last (pathname-directory x))) exclude :test #'equal))) - collect)) + #'(lambda (dir) (collect-asds-in-directory dir collect)))) (defun* validate-source-registry-directive (directive) (or (member directive '(:default-registry)) @@ -3603,17 +3823,21 @@ :with end = (length string) :for pos = (position *inter-directory-separator* string :start start) :do (let ((s (subseq string start (or pos end)))) - (cond - ((equal "" s) ; empty element: inherit - (when inherit - (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>") - string)) - (setf inherit t) - (push ':inherit-configuration directives)) - ((ends-with s "//") - (push `(:tree ,(subseq s 0 (1- (length s)))) directives)) - (t - (push `(:directory ,s) directives))) + (flet ((check (dir) + (unless (absolute-pathname-p dir) + (error (compatfmt "~@<source-registry string must specify absolute pathnames: ~3i~_~S~@:>") string)) + dir)) + (cond + ((equal "" s) ; empty element: inherit + (when inherit + (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>") + string)) + (setf inherit t) + (push ':inherit-configuration directives)) + ((ends-with s "//") ;; TODO: allow for doubling of separator even outside Unix? + (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives)) + (t + (push `(:directory ,(check s)) directives)))) (cond (pos (setf start (1+ pos))) @@ -3624,8 +3848,8 @@ (defun* register-asd-directory (directory &key recurse exclude collect) (if (not recurse) - (funcall collect directory) - (collect-sub*directories-with-asd + (collect-asds-in-directory directory collect) + (collect-sub*directories-asd-files directory :exclude exclude :collect collect))) (defparameter *default-source-registries* @@ -3645,30 +3869,27 @@ :inherit-configuration #+cmu (:tree #p"modules:"))) (defun* default-source-registry () - (flet ((try (x sub) (try-directory-subpath x sub :type :directory))) + (flet ((try (x sub) (try-directory-subpath x sub))) `(:source-registry - #+sbcl (:directory ,(merge-pathnames* ".sbcl/systems/" (user-homedir))) + #+sbcl (:directory ,(try (user-homedir) ".sbcl/systems/")) (:directory ,(default-directory)) - ,@(let* - #+asdf-unix - ((datahome - (or (getenv "XDG_DATA_HOME") - (try (user-homedir) ".local/share/"))) - (datadirs - (or (getenv "XDG_DATA_DIRS") "/usr/local/share:/usr/share")) - (dirs (cons datahome (split-string datadirs :separator ":")))) - #+asdf-windows - ((datahome (getenv "APPDATA")) - (datadir - #+lispworks (sys:get-folder-path :local-appdata) - #-lispworks (try (getenv "ALLUSERSPROFILE") - "Application Data")) - (dirs (list datahome datadir))) - #-(or asdf-unix asdf-windows) - ((dirs ())) - (loop :for dir :in dirs - :collect `(:directory ,(try dir "common-lisp/systems/")) - :collect `(:tree ,(try dir "common-lisp/source/")))) + ,@(loop :for dir :in + `(#+asdf-unix + ,@`(,(or (getenv "XDG_DATA_HOME") + (try (user-homedir) ".local/share/")) + ,@(split-string (or (getenv "XDG_DATA_DIRS") + "/usr/local/share:/usr/share") + :separator ":")) + #+asdf-windows + ,@`(,(or #+lispworks (sys:get-folder-path :local-appdata) + (getenv "LOCALAPPDATA")) + ,(or #+lispworks (sys:get-folder-path :appdata) + (getenv "APPDATA")) + ,(or #+lispworks (sys:get-folder-path :common-appdata) + (getenv "ALLUSERSAPPDATA") + (try (getenv "ALLUSERSPROFILE") "Application Data/")))) + :collect `(:directory ,(try dir "common-lisp/systems/")) + :collect `(:tree ,(try dir "common-lisp/source/"))) :inherit-configuration))) (defun* user-source-registry () (in-user-configuration-directory *source-registry-file*)) @@ -3757,19 +3978,34 @@ ;; Will read the configuration and initialize all internal variables, ;; and return the new configuration. -(defun* compute-source-registry (&optional parameter) - (while-collecting (collect) - (dolist (entry (flatten-source-registry parameter)) - (destructuring-bind (directory &key recurse exclude) entry +(defun* compute-source-registry (&optional parameter (registry *source-registry*)) + (dolist (entry (flatten-source-registry parameter)) + (destructuring-bind (directory &key recurse exclude) entry + (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates (register-asd-directory - directory - :recurse recurse :exclude exclude :collect #'collect))))) + directory :recurse recurse :exclude exclude :collect + #'(lambda (asd) + (let ((name (pathname-name asd))) + (cond + ((gethash name registry) ; already shadowed by something else + nil) + ((gethash name h) ; conflict at current level + (when *asdf-verbose* + (warn (compatfmt "~@<In source-registry entry ~A~@[/~*~] ~ + found several entries for ~A - picking ~S over ~S~:>") + directory recurse name (gethash name h) asd))) + (t + (setf (gethash name registry) asd) + (setf (gethash name h) asd)))))) + h))) + (values)) (defvar *source-registry-parameter* nil) (defun* initialize-source-registry (&optional (parameter *source-registry-parameter*)) - (setf *source-registry-parameter* parameter - (source-registry) (compute-source-registry parameter))) + (setf *source-registry-parameter* parameter) + (setf *source-registry* (make-hash-table :test 'equal)) + (compute-source-registry parameter)) ;; Checks an initial variable to see whether the state is initialized ;; or cleared. In the former case, return current configuration; in @@ -3780,24 +4016,60 @@ ;; you may override the configuration explicitly by calling ;; initialize-source-registry directly with your parameter. (defun* ensure-source-registry (&optional parameter) - (if (source-registry-initialized-p) - (source-registry) - (initialize-source-registry parameter))) + (unless (source-registry-initialized-p) + (initialize-source-registry parameter)) + (values)) (defun* sysdef-source-registry-search (system) (ensure-source-registry) - (loop :with name = (coerce-name system) - :for defaults :in (source-registry) - :for file = (probe-asd name defaults) - :when file :return file)) + (values (gethash (coerce-name system) *source-registry*))) (defun* clear-configuration () (clear-source-registry) (clear-output-translations)) + +;;; ECL support for COMPILE-OP / LOAD-OP +;;; +;;; In ECL, these operations produce both FASL files and the +;;; object files that they are built from. Having both of them allows +;;; us to later on reuse the object files for bundles, libraries, +;;; standalone executables, etc. +;;; +;;; This has to be in asdf.lisp and not asdf-ecl.lisp, or else it becomes +;;; a problem for asdf on ECL to compile asdf-ecl.lisp after loading asdf.lisp. +;;; +#+ecl +(progn + (setf *compile-op-compile-file-function* + (lambda (input-file &rest keys &key output-file &allow-other-keys) + (declare (ignore output-file)) + (multiple-value-bind (object-file flags1 flags2) + (apply 'compile-file* input-file :system-p t keys) + (values (and object-file + (c::build-fasl (compile-file-pathname object-file :type :fasl) + :lisp-files (list object-file)) + object-file) + flags1 + flags2)))) + + (defmethod output-files ((operation compile-op) (c cl-source-file)) + (declare (ignorable operation)) + (let ((p (lispize-pathname (component-pathname c)))) + (list (compile-file-pathname p :type :object) + (compile-file-pathname p :type :fasl)))) + + (defmethod perform ((o load-op) (c cl-source-file)) + (map () #'load + (loop :for i :in (input-files o c) + :unless (string= (pathname-type i) "fas") + :collect (compile-file-pathname (lispize-pathname i)))))) + ;;;; ----------------------------------------------------------------- ;;;; Hook into REQUIRE for ABCL, CLISP, ClozureCL, CMUCL, ECL and SBCL ;;;; +(defvar *require-asdf-operator* 'load-op) + (defun* module-provide-asdf (name) (handler-bind ((style-warning #'muffle-warning) @@ -3806,9 +4078,10 @@ (format *error-output* (compatfmt "~@<ASDF could not load ~(~A~) because ~A.~@:>~%") name e)))) (let ((*verbose-out* (make-broadcast-stream)) - (system (find-system (string-downcase name) nil))) + (system (find-system (string-downcase name) nil))) (when system - (load-system system))))) + (operate *require-asdf-operator* system :verbose nil) + t)))) #+(or abcl clisp clozure cmu ecl sbcl) (let ((x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom))))

1 0