Changeset 13319

Timestamp:

06/10/11 09:28:30 (12 years ago)

Author:

Mark Evenson

Message:

Actual commit of asdf-2.016.1.

File:

• trunk/abcl/src/org/armedbear/lisp/asdf.lisp (modified) (24 diffs)

trunk/abcl/src/org/armedbear/lisp/asdf.lisp

@@ -1 +1 @@
 ;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
-;;; This is ASDF 2.016: Another System Definition Facility.
+;;; This is ASDF 2.016.1: Another System Definition Facility.
 ;;;
 ;;; Feedback, bug reports, and patches are all welcome:
@@ -63 +63 @@
                 :test 'equalp :key 'car)) ; need that BEFORE any mention of package ASDF as below
   #+(and ecl (not ecl-bytecmp)) (require :cmp)
+  #+gcl
+  (when (or (< system::*gcl-major-version* 2)
+            (and (= system::*gcl-major-version* 2)
+                 (< system::*gcl-minor-version* 7)))
+    (pushnew :gcl-pre2.7 *features*))
   #+(and (or win32 windows mswindows mingw32) (not cygwin)) (pushnew :asdf-windows *features*)
   #+(or unix cygwin) (pushnew :asdf-unix *features*)
@@ -85 +90 @@
   ;; Has to be inside the eval-when to make Lispworks happy (!)
   (defmacro compatfmt (format)
-    #-genera format
-    #+genera
+    #-(or gcl genera) format
+    #+(or gcl genera)
     (loop :for (unsupported . replacement) :in
-      '(("~@<" . "")
-        ("; ~@;" . "; ")
-        ("~3i~_" . "")
-        ("~@:>" . "")
-        ("~:>" . "")) :do
+      `(("~3i~_" . "")
+        #+genera
+        ,@(("~@<" . "")
+           ("; ~@;" . "; ")
+           ("~@:>" . "")
+           ("~:>" . ""))) :do
       (loop :for found = (search unsupported format) :while found :do
         (setf format
@@ -107 +113 @@
          ;; "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.016")
+         (asdf-version "2.016.1")
          (existing-asdf (find-class 'component nil))
          (existing-version *asdf-version*)
@@ -368 +374 @@
 ;;;; User-visible parameters
 ;;;;
-(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.345.67\")."
-  *asdf-version*)
-
 (defvar *resolve-symlinks* t
   "Determine whether or not ASDF resolves symlinks when defining systems.
@@ -416 +416 @@
                 condition-format condition-location
                 coerce-name)
-         #-cormanlisp
+         #-(or cormanlisp gcl-pre2.7)
          (ftype (function (t t) t) (setf module-components-by-name)))
 
@@ -424 +424 @@
 (progn
   (deftype logical-pathname () nil)
-  (defun make-broadcast-stream () *error-output*)
-  (defun file-namestring (p)
+  (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)))
+    (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))))
 
 ;;;; -------------------------------------------------------------------------
@@ -445 +436 @@
        `(defmacro ,def* (name formals &rest rest)
           `(progn
-             #+(or ecl gcl) (fmakunbound ',name)
+             #+(or ecl (and gcl (not gcl-pre2.7))) (fmakunbound ',name)
              #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-(
              ,(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl
@@ -516 +507 @@
 
 (defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
-  "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that if the SPECIFIED pathname
-does not have an absolute directory, then the HOST and DEVICE come from the DEFAULTS.
+  "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that
+if the SPECIFIED pathname does not have an absolute directory,
+then the HOST and DEVICE both come from the DEFAULTS, whereas
+if the SPECIFIED pathname does have an absolute directory,
+then the HOST and DEVICE both come from the SPECIFIED.
 Also, if either argument is NIL, then the other argument is returned unmodified."
   (when (null specified) (return-from merge-pathnames* defaults))
@@ -731 +725 @@
 #+genera
 (unless (fboundp 'ensure-directories-exist)
-  (defun ensure-directories-exist (path)
+  (defun* ensure-directories-exist (path)
     (fs:create-directories-recursively (pathname path))))
 
@@ -799 +793 @@
     (string (probe-file* (parse-namestring p)))
     (pathname (unless (wild-pathname-p p)
-                #.(or #+(or allegro clozure cmu cormanlisp ecl sbcl scl) '(probe-file p)
+                #.(or #+(or allegro clozure cmu cormanlisp ecl lispworks sbcl scl)
+                      '(probe-file p)
                       #+clisp (aif (find-symbol* '#:probe-pathname :ext)
                                    `(ignore-errors (,it p)))
                       '(ignore-errors (truename p)))))))
 
-(defun* truenamize (p)
+(defun* truenamize (pathname &optional (defaults *default-pathname-defaults*))
   "Resolve as much of a pathname as possible"
   (block nil
-    (when (typep p '(or null logical-pathname)) (return p))
-    (let* ((p (merge-pathnames* p))
-           (directory (pathname-directory p)))
+    (when (typep pathname '(or null logical-pathname)) (return pathname))
+    (let ((p (merge-pathnames* pathname defaults)))
       (when (typep p 'logical-pathname) (return p))
       (let ((found (probe-file* p)))
         (when found (return found)))
-      #-(or cmu sbcl scl) (when (stringp directory) (return p))
-      (when (not (eq :absolute (car directory))) (return p))
+      (unless (absolute-pathname-p p)
+        (let ((true-defaults (ignore-errors (truename defaults))))
+          (when true-defaults
+            (setf p (merge-pathnames pathname true-defaults)))))
+      (unless (absolute-pathname-p p) (return p))
       (let ((sofar (probe-file* (pathname-root p))))
         (unless sofar (return p))
@@ -825 +822 @@
                                  :version (pathname-version p))
                   sofar)))
-          (loop :for component :in (cdr directory)
+          (loop :with directory = (normalize-pathname-directory-component
+                                   (pathname-directory p))
+            :for component :in (cdr directory)
             :for rest :on (cdr directory)
             :for more = (probe-file*
@@ -848 +847 @@
       path))
 
-(defun ensure-pathname-absolute (path)
+(defun* ensure-pathname-absolute (path)
   (cond
     ((absolute-pathname-p path) path)
@@ -878 +877 @@
 
 #-scl
-(defun directory-separator-for-host (&optional (pathname *default-pathname-defaults*))
+(defun* directory-separator-for-host (&optional (pathname *default-pathname-defaults*))
   (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname)))
     (last-char (namestring foo))))
@@ -962 +961 @@
 (defgeneric* (setf component-property) (new-value component property))
 
-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-gcl :compile-toplevel :load-toplevel :execute)
   (defgeneric* (setf module-components-by-name) (new-value module)))
 
@@ -1271 +1270 @@
       (let ((pathname
              (merge-pathnames*
-             (component-relative-pathname component)
-             (pathname-directory-pathname (component-parent-pathname component)))))
+              (component-relative-pathname component)
+              (pathname-directory-pathname (component-parent-pathname component)))))
         (unless (or (null pathname) (absolute-pathname-p pathname))
           (error (compatfmt "~@<Invalid relative pathname ~S for component ~S~@:>")
@@ -1313 +1312 @@
   (version-satisfies (component-version c) version))
 
-(defun parse-version (string &optional on-error)
+(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.345.67\")."
+  *asdf-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.
@@ -1532 +1537 @@
         (funcall thunk))))
 
-(defmacro with-system-definitions (() &body body)
+(defmacro with-system-definitions ((&optional) &body body)
   `(call-with-system-definitions #'(lambda () ,@body)))
 
@@ -2114 +2119 @@
           :initform nil)))
 
-(defun output-file (operation component)
+(defun* output-file (operation component)
   "The unique output file of performing OPERATION on COMPONENT"
   (let ((files (output-files operation component)))
@@ -2145 +2150 @@
         (*compile-file-failure-behaviour* (operation-on-failure operation)))
     (multiple-value-bind (output warnings-p failure-p)
-        (apply *compile-op-compile-file-function* source-file :output-file output-file
-               (compile-op-flags operation))
+        (apply *compile-op-compile-file-function* source-file
+               :output-file output-file (compile-op-flags operation))
       (unless output
         (error 'compile-error :component c :operation operation))
@@ -3524 +3529 @@
 (defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
   (if (absolute-pathname-p output-file)
-      ;;; If the default ABCL rules for translating from a jar path to
-      ;;; a non-jar path have been affected, no further computation of
-      ;;; the output location is necessary.
-      ;; (if (and (find :abcl *features*)
-      ;;          (pathname-device input-file) ; input-file is in a jar
-      ;;          (not (pathname-device output-file)) ; output-file is not in a jar
-      ;;          (equal (pathname-type input-file) "lisp")
-      ;;          (equal (pathname-type output-file) "abcl"))
-      ;;     output-file
-          (apply 'compile-file-pathname (lispize-pathname input-file) keys);)
+      ;; what cfp should be doing, w/ mp* instead of mp
+      (let* ((type (pathname-type (apply 'compile-file-pathname "x.lisp" keys)))
+             (defaults (make-pathname
+                        :type type :defaults (merge-pathnames* input-file))))
+        (merge-pathnames* output-file defaults))
       (apply-output-translations
-       (apply 'compile-file-pathname
-              (truenamize (lispize-pathname input-file))
-              keys))))
+       (apply 'compile-file-pathname input-file keys))))
 
 (defun* tmpize-pathname (x)
@@ -3738 +3736 @@
   (make-pathname :directory nil :name *wild* :type "asd" :version :newest))
 
-(defun directory-asd-files (directory)
+(defun* directory-asd-files (directory)
   (ignore-errors
     (directory* (merge-pathnames* *wild-asd* directory))))
 
-(defun subdirectories (directory)
+(defun* subdirectories (directory)
   (let* ((directory (ensure-directory-pathname directory))
          #-(or abcl cormanlisp genera xcl)
@@ -3770 +3768 @@
     dirs))
 
-(defun collect-asds-in-directory (directory collect)
+(defun* collect-asds-in-directory (directory collect)
   (map () collect (directory-asd-files directory)))
 
-(defun collect-sub*directories (directory collectp recursep collector)
+(defun* collect-sub*directories (directory collectp recursep collector)
   (when (funcall collectp directory)
     (funcall collector directory))
@@ -3780 +3778 @@
       (collect-sub*directories subdir collectp recursep collector))))
 
-(defun collect-sub*directories-asd-files
+(defun* collect-sub*directories-asd-files
     (directory &key
      (exclude *default-source-registry-exclusions*)