[cmucl-commit] CMUCL commit: src/contrib/asdf (asdf.lisp)

Raymond Toy rtoy at common-lisp.net
Mon Mar 28 19:23:40 CEST 2011


    Date: Monday, March 28, 2011 @ 13:23:40
  Author: rtoy
    Path: /project/cmucl/cvsroot/src/contrib/asdf

Modified: asdf.lisp

Update to asdf 2.014.


-----------+
 asdf.lisp |  226 ++++++++++++++++++++++++++++++++++++------------------------
 1 file changed, 136 insertions(+), 90 deletions(-)


Index: src/contrib/asdf/asdf.lisp
diff -u src/contrib/asdf/asdf.lisp:1.12 src/contrib/asdf/asdf.lisp:1.13
--- src/contrib/asdf/asdf.lisp:1.12	Thu Mar 24 12:40:59 2011
+++ src/contrib/asdf/asdf.lisp	Mon Mar 28 13:23:39 2011
@@ -1,5 +1,5 @@
 ;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
-;;; This is ASDF 2.013: Another System Definition Facility.
+;;; This is ASDF 2.014: Another System Definition Facility.
 ;;;
 ;;; Feedback, bug reports, and patches are all welcome:
 ;;; please mail to <asdf-devel at common-lisp.net>.
@@ -68,6 +68,22 @@
 
 (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.
@@ -83,18 +99,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.013")
+         (asdf-version "2.014")
          (existing-asdf (fboundp 'find-system))
          (existing-version *asdf-version*)
          (already-there (equal asdf-version existing-version)))
     (unless (and existing-asdf already-there)
       (when existing-asdf
         (format *trace-output*
-         "~&; Upgrading ASDF package ~@[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-symbol symbol package)) '(:internal :external)))
+             (member (nth-value 1 (find-sym symbol package)) '(:internal :external)))
            (present-symbols (package)
              ;; #-genera (loop :for s :being :the :present-symbols :in package :collect s) #+genera
              (let (l)
@@ -422,7 +438,7 @@
 
 (defun* normalize-pathname-directory-component (directory)
   (cond
-    #-(or sbcl cmu)
+    #-(or cmu sbcl scl)
     ((stringp directory) `(:absolute ,directory) directory)
     #+gcl
     ((and (consp directory) (stringp (first directory)))
@@ -431,7 +447,7 @@
          (and (consp directory) (member (first directory) '(:absolute :relative))))
      directory)
     (t
-     (error "Unrecognized pathname directory component ~S" directory))))
+     (error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") directory))))
 
 (defun* merge-pathname-directory-components (specified defaults)
   (let ((directory (normalize-pathname-directory-component specified)))
@@ -461,6 +477,9 @@
 Also, if either argument is NIL, then the other argument is returned unmodified."
   (when (null specified) (return-from merge-pathnames* defaults))
   (when (null defaults) (return-from merge-pathnames* specified))
+  #+scl
+  (ext:resolve-pathname specified defaults)
+  #-scl
   (let* ((specified (pathname specified))
          (defaults (pathname defaults))
          (directory (normalize-pathname-directory-component (pathname-directory specified)))
@@ -509,15 +528,10 @@
 (defun* last-char (s)
   (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
 
-(defun* errfmt (out format-string &rest format-args)
-  (declare (dynamic-extent format-args))
-  (apply #'format out
-         #-genera (format nil "~~@<~A~~:>" format-string) #+genera format-string
-         format-args))
-
+	  
 (defun* asdf-message (format-string &rest format-args)
   (declare (dynamic-extent format-args))
-  (apply #'errfmt *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
@@ -569,7 +583,7 @@
 pathnames."
   (check-type s string)
   (when (find #\: s)
-    (error "a portable ASDF pathname designator cannot include a #\: character: ~S" s))
+    (error (compatfmt "~@<A portable ASDF pathname designator cannot include a #\: character: ~3i~_~S~@:>") s))
   (let* ((components (split-string s :separator "/"))
          (last-comp (car (last components))))
     (multiple-value-bind (relative components)
@@ -577,7 +591,7 @@
             (if (equal (first-char s) #\/)
                 (progn
                   (when force-relative
-                    (error "absolute pathname designator not allowed: ~S" s))
+                    (error (compatfmt "~@<Absolute pathname designator not allowed: ~3i~_~S~@:>") s))
                   (values :absolute (cdr components)))
                 (values :relative nil))
           (values :relative components))
@@ -648,9 +662,9 @@
    ((stringp pathspec)
     (ensure-directory-pathname (pathname pathspec)))
    ((not (pathnamep pathspec))
-    (error "Invalid pathname designator ~S" pathspec))
+    (error (compatfmt "~@<Invalid pathname designator ~S~@:>") pathspec))
    ((wild-pathname-p pathspec)
-    (error "Can't reliably convert wild pathname ~S" pathspec))
+    (error (compatfmt "~@<Can't reliably convert wild pathname ~3i~_~S~@:>") pathspec))
    ((directory-pathname-p pathspec)
     pathspec)
    (t
@@ -716,10 +730,10 @@
           (error () (error "Unable to find out user ID")))))))
 
 (defun* pathname-root (pathname)
-  (make-pathname :host (pathname-host pathname)
-                 :device (pathname-device pathname)
-                 :directory '(:absolute)
-                 :name nil :type nil :version nil))
+  (make-pathname :directory '(:absolute)
+                 :name nil :type nil :version nil
+                 :defaults pathname ;; host device, and on scl scheme scheme-specific-part port username password
+                 . #.(or #+scl '(:parameters nil :query nil :fragment nil))))
 
 (defun* find-symbol* (s p)
   (find-symbol (string s) p))
@@ -744,7 +758,7 @@
       (when (typep p 'logical-pathname) (return p))
       (let ((found (probe-file* p)))
         (when found (return found)))
-      #-(or sbcl cmu) (when (stringp directory) (return p))
+      #-(or cmu sbcl scl) (when (stringp directory) (return p))
       (when (not (eq :absolute (car directory))) (return p))
       (let ((sofar (probe-file* (pathname-root p))))
         (unless sofar (return p))
@@ -792,10 +806,12 @@
 (defun* wilden (path)
   (merge-pathnames* *wild-path* path))
 
+#-scl
 (defun directory-separator-for-host (&optional (pathname *default-pathname-defaults*))
   (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname)))
     (last-char (namestring foo))))
 
+#-scl
 (defun* directorize-pathname-host-device (pathname)
   (let* ((root (pathname-root pathname))
          (wild-root (wilden root))
@@ -815,6 +831,31 @@
                             :directory `(:absolute , at path))))
         (translate-pathname absolute-pathname wild-root (wilden new-base))))))
 
+#+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)))
+    (flet ((not-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)))))
+
 ;;;; -------------------------------------------------------------------------
 ;;;; ASDF Interface, in terms of generic functions.
 (defgeneric* find-system (system &optional error-p))
@@ -930,7 +971,8 @@
            ((m module) added deleted plist &key)
          (declare (ignorable deleted plist))
          (when (or *asdf-verbose* *load-verbose*)
-           (asdf-message "~&; Updating ~A for ASDF ~A~%" m ,(asdf-version)))
+           (asdf-message (compatfmt "~&~@<; ~@;Updating ~A for ASDF ~A~@:>~%")
+			 m ,(asdf-version)))
          (when (member 'components-by-name added)
            (compute-module-components-by-name m))
          (when (typep m 'system)
@@ -969,25 +1011,26 @@
   ((format-control :initarg :format-control :reader format-control)
    (format-arguments :initarg :format-arguments :reader format-arguments))
   (:report (lambda (c s)
-               (apply #'errfmt 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)
-	     (errfmt s "Error while trying to load definition for system ~A from pathname ~A: ~A"
+	     (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)
-	     (errfmt s "Circular dependency: ~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)
-	     (errfmt s "Error while defining system: multiple components are given same name ~A"
+	     (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)
@@ -1008,7 +1051,7 @@
   ((component :reader error-component :initarg :component)
    (operation :reader error-operation :initarg :operation))
   (:report (lambda (c s)
-               (errfmt s "erred while invoking ~A on ~A"
+               (format s (compatfmt "~@<Error while invoking ~A on ~A~@:>")
                        (error-operation c) (error-component c)))))
 (define-condition compile-error (operation-error) ())
 (define-condition compile-failed (compile-error) ())
@@ -1020,14 +1063,14 @@
    (format :reader condition-format :initarg :format)
    (arguments :reader condition-arguments :initarg :arguments :initform nil))
   (:report (lambda (c s)
-               (errfmt s "~? (will be skipped)"
+               (format s (compatfmt "~@<~? (will be skipped)~@:>")
                        (condition-format c)
                        (list* (condition-form c) (condition-location c)
                               (condition-arguments c))))))
 (define-condition invalid-source-registry (invalid-configuration warning)
-  ((format :initform "invalid source registry ~S~@[ in ~S~]~@{ ~@?~}")))
+  ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
 (define-condition invalid-output-translation (invalid-configuration warning)
-  ((format :initform "invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}")))
+  ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
 
 (defclass component ()
   ((name :accessor component-name :initarg :name :documentation
@@ -1091,7 +1134,7 @@
 ;;;; methods: conditions
 
 (defmethod print-object ((c missing-dependency) s)
-  (format s "~A, required by ~A"
+  (format s (compatfmt "~@<~A, required by ~A~@:>")
           (call-next-method c nil) (missing-required-by c)))
 
 (defun* sysdef-error (format &rest arguments)
@@ -1101,13 +1144,13 @@
 ;;;; methods: components
 
 (defmethod print-object ((c missing-component) s)
-  (format s "component ~S not found~@[ in ~A~]"
+  (format s (compatfmt "~@<Component ~S not found~@[ in ~A~]~@:>")
           (missing-requires c)
           (when (missing-parent c)
             (coerce-name (missing-parent c)))))
 
 (defmethod print-object ((c missing-component-of-version) s)
-  (format s "component ~S does not match version ~A~@[ in ~A~]"
+  (format s (compatfmt "~@<Component ~S does not match version ~A~@[ in ~A~]~@:>")
           (missing-requires c)
           (missing-version c)
           (when (missing-parent c)
@@ -1167,7 +1210,7 @@
              (component-relative-pathname component)
              (pathname-directory-pathname (component-parent-pathname component)))))
         (unless (or (null pathname) (absolute-pathname-p pathname))
-          (error "Invalid relative pathname ~S for component ~S"
+          (error (compatfmt "~@<Invalid relative pathname ~S for component ~S~@:>")
                  pathname (component-find-path component)))
         (setf (slot-value component 'absolute-pathname) pathname)
         pathname)))
@@ -1236,7 +1279,7 @@
     (component (component-name name))
     (symbol (string-downcase (symbol-name name)))
     (string name)
-    (t (sysdef-error "invalid component designator ~A" name))))
+    (t (sysdef-error (compatfmt "~@<Invalid component designator: ~3i~_~A~@:>") name))))
 
 (defun* system-registered-p (name)
   (gethash (coerce-name name) *defined-systems*))
@@ -1329,8 +1372,8 @@
                         (restart-case
                             (let* ((*print-circle* nil)
                                    (message
-                                    (errfmt nil
-                                            "While searching for system ~S: ~S evaluated to ~S which is not a directory."
+                                    (format nil
+                                            (compatfmt "~@<While searching for system ~S: ~3i~_~S evaluated to ~S which is not a directory.~@:>")
                                             system dir defaults)))
                               (error message))
                           (remove-entry-from-registry ()
@@ -1338,7 +1381,7 @@
                             (push dir to-remove))
                           (coerce-entry-to-directory ()
                             :report (lambda (s)
-				      (errfmt s "Coerce entry to ~a, replace ~a and continue."
+				      (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
@@ -1374,7 +1417,7 @@
   (or (and pathname (probe-file* pathname) (file-write-date pathname))
       (progn
         (when (and pathname *asdf-verbose*)
-          (warn "Missing FILE-WRITE-DATE for ~S: treating it as zero."
+          (warn (compatfmt "~@<Missing FILE-WRITE-DATE for ~S, treating it as zero.~@:>")
                 pathname))
         0)))
 
@@ -1391,9 +1434,8 @@
                                 :name name :pathname pathname
                                 :condition condition))))
            (let ((*package* package))
-             (asdf-message
-              "~&; Loading system definition from ~A into ~A~%"
-              pathname package)
+             (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%")
+			   pathname package)
              (load pathname)))
       (delete-package package))))
 
@@ -1418,9 +1460,10 @@
            (error 'missing-component :requires name)))))))
 
 (defun* register-system (name system)
-  (asdf-message "~&; Registering ~A as ~A~%" system name)
-  (setf (gethash (coerce-name name) *defined-systems*)
-        (cons (get-universal-time) 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)
@@ -1496,11 +1539,6 @@
   (declare (ignorable s))
   (source-file-explicit-type component))
 
-(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.
-  (coerce-pathname name :type type :defaults defaults))
-
 (defun* coerce-pathname (name &key type defaults)
   "coerce NAME into a PATHNAME.
 When given a string, portably decompose it into a relative pathname:
@@ -1515,9 +1553,8 @@
   ;; to the below make-pathname, which may crucially matter to people using
   ;; merge-pathnames with non-default hosts,  e.g. for logical-pathnames.
   ;; NOTE that the host and device slots will be taken from the defaults,
-  ;; but that should only matter if you either (a) use absolute pathnames, or
-  ;; (b) later merge relative pathnames with CL:MERGE-PATHNAMES instead of
-  ;; ASDF:MERGE-PATHNAMES*
+  ;; but that should only matter if you later merge relative pathnames with
+  ;; CL:MERGE-PATHNAMES instead of ASDF:MERGE-PATHNAMES*
   (etypecase name
     ((or null pathname)
      name)
@@ -1535,12 +1572,13 @@
               (values filename type))
              (t
               (split-name-type filename)))
-         (let* ((defaults (pathname (or defaults *default-pathname-defaults*)))
-                (host (pathname-host defaults))
-                (device (pathname-device defaults)))
-           (make-pathname :directory `(,relative , at path)
-                          :name name :type type
-                          :host host :device device)))))))
+         (make-pathname :directory `(,relative , at path) :name name :type type
+                        :defaults (or defaults *default-pathname-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.
+  (coerce-pathname name :type type :defaults defaults))
 
 (defmethod component-relative-pathname ((component component))
   (coerce-pathname
@@ -1764,7 +1802,7 @@
                              required-op required-c required-v))
       (retry ()
         :report (lambda (s)
-		  (errfmt s "Retry loading component ~S." required-c))
+		  (format s "~@<Retry loading component ~3i~_~S.~@:>" required-c))
         :test
         (lambda (c)
 	  (or (null c)
@@ -1808,7 +1846,7 @@
                           (when (find (second d) *features* :test 'string-equal)
                             (dep op (third d) nil)))
                          (t
-                          (error "Bad dependency ~a.  Dependencies must be (:version <version>), (:feature <feature> [version]), or a name" d))))))
+                          (error (compatfmt "~@<Bad dependency ~a.  Dependencies must be (:version <version>), (:feature <feature> [version]), or a name.~@:>") d))))))
            flag))))
 
 (defvar *visit-count* 0) ; counter that allows to sort nodes from operation-visited-nodes
@@ -1933,7 +1971,7 @@
 
 (defmethod perform ((operation operation) (c source-file))
   (sysdef-error
-   "required method PERFORM not implemented for operation ~A, component ~A"
+   (compatfmt "~@<Required method PERFORM not implemented for operation ~A, component ~A~@:>")
    (class-of operation) (class-of c)))
 
 (defmethod perform ((operation operation) (c module))
@@ -1944,7 +1982,8 @@
   (asdf-message "~&;;; ~A~%" (operation-description operation component)))
 
 (defmethod operation-description (operation component)
-  (format nil "~A on component ~S" (class-of operation) (component-find-path component)))
+  (format nil (compatfmt "~@<~A on component ~S~@:>")
+	  (class-of operation) (component-find-path component)))
 
 ;;;; -------------------------------------------------------------------------
 ;;;; compile-op
@@ -1994,14 +2033,14 @@
       (when warnings-p
         (case (operation-on-warnings operation)
           (:warn (warn
-                  "COMPILE-FILE warned while performing ~A on ~A."
+                  (compatfmt "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>")
                   operation c))
           (:error (error 'compile-warned :component c :operation operation))
           (:ignore nil)))
       (when failure-p
         (case (operation-on-failure operation)
           (:warn (warn
-                  "COMPILE-FILE failed while performing ~A on ~A."
+                  (compatfmt "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>")
                   operation c))
           (:error (error 'compile-failed :component c :operation operation))
           (:ignore nil)))
@@ -2103,7 +2142,8 @@
 
 (defmethod operation-description ((operation load-op) component)
   (declare (ignorable operation))
-  (format nil "loading component ~S" (component-find-path component)))
+  (format nil (compatfmt "~@<Loading component: ~3i~_~S~@:>")
+	  (component-find-path component)))
 
 
 ;;;; -------------------------------------------------------------------------
@@ -2146,7 +2186,8 @@
 
 (defmethod operation-description ((operation load-source-op) component)
   (declare (ignorable operation))
-  (format nil "loading component ~S" (component-find-path component)))
+  (format nil (compatfmt "~@<Loading component: ~3i~_~S~@:>")
+	  (component-find-path component)))
 
 
 ;;;; -------------------------------------------------------------------------
@@ -2197,11 +2238,12 @@
               (retry ()
                 :report
                 (lambda (s)
-		  (errfmt s "Retry ~A." (operation-description op component))))
+		  (format s (compatfmt "~@<Retry ~A.~@:>")
+			  (operation-description op component))))
               (accept ()
                 :report
                 (lambda (s)
-		  (errfmt s "Continue, treating ~A as having been successful."
+		  (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>")
 			  (operation-description op component)))
                 (setf (gethash (type-of op)
                                (component-operation-times component))
@@ -2287,6 +2329,7 @@
         (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
@@ -2296,7 +2339,7 @@
          ;; 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 ,system))
+             :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)))
@@ -2357,7 +2400,7 @@
 
 (defun* sysdef-error-component (msg type name value)
   (sysdef-error (concatenate 'string msg
-                             "~&The value specified for ~(~A~) ~A is ~S")
+                             (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
                 type name value))
 
 (defun* check-component-input (type name weakly-depends-on
@@ -2688,13 +2731,13 @@
                (t (apply #'warn fstring args)
                   "unknown"))))
     (let ((lisp (maybe-warn (implementation-type)
-                            "No implementation feature found in ~a."
+                            (compatfmt "~@<No implementation feature found in ~a.~@:>")
                             *implementation-features*))
           (os   (maybe-warn (first-feature *os-features*)
-                            "No os feature found in ~a." *os-features*))
+                            (compatfmt "~@<No OS feature found in ~a.~@:>") *os-features*))
           (arch (or #-clisp
                     (maybe-warn (first-feature *architecture-features*)
-                                "No architecture feature found in ~a."
+                                (compatfmt "~@<No architecture feature found in ~a.~@:>")
                                 *architecture-features*)))
           (version (maybe-warn (lisp-version-string)
                                "Don't know how to get Lisp implementation version.")))
@@ -2794,14 +2837,15 @@
     :finally
     (unless (= inherit 1)
       (report-invalid-form invalid-form-reporter
-             :arguments (list "One and only one of ~S or ~S is required"
+             :arguments (list (compatfmt "~@<One and only one of ~S or ~S is required.~@:>")
                               :inherit-configuration :ignore-inherited-configuration)))
     (return (nreverse x))))
 
 (defun* validate-configuration-file (file validator &key description)
   (let ((forms (read-file-forms file)))
     (unless (length=n-p forms 1)
-      (error "One and only one form allowed for ~A. Got: ~S~%" description forms))
+      (error (compatfmt "~@<One and only one form allowed for ~A. Got: ~3i~_~S~@:>~%")
+	     description forms))
     (funcall validator (car forms) :location file)))
 
 (defun* hidden-file-p (pathname)
@@ -2922,7 +2966,7 @@
          (d (if (or (pathnamep x) (not directory)) r (ensure-directory-pathname r)))
          (s (if (or (pathnamep x) (not wilden)) d (wilden d))))
     (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super))))
-      (error "pathname ~S is not relative to ~S" s super))
+      (error (compatfmt "~@<Pathname ~S is not relative to ~S~@:>") s super))
     (merge-pathnames* s super)))
 
 (defvar *here-directory* nil
@@ -2964,7 +3008,7 @@
                 (wilden r)
                 r)))
     (unless (absolute-pathname-p s)
-      (error "Not an absolute pathname ~S" s))
+      (error (compatfmt "~@<Not an absolute pathname: ~3i~_~S~@:>") s))
     s))
 
 (defun* resolve-location (x &key directory wilden)
@@ -3036,7 +3080,7 @@
     ((or (null string) (equal string ""))
      '(:output-translations :inherit-configuration))
     ((not (stringp string))
-     (error "environment string isn't: ~S" string))
+     (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
     ((eql (char string 0) #\")
      (parse-output-translations-string (read-from-string string) :location location))
     ((eql (char string 0) #\()
@@ -3056,7 +3100,8 @@
            (setf source nil))
           ((equal "" s)
            (when inherit
-             (error "only one inherited configuration allowed: ~S" string))
+             (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
+		    string))
            (setf inherit t)
            (push :inherit-configuration directives))
           (t
@@ -3064,7 +3109,8 @@
         (setf start (1+ i))
         (when (> start end)
           (when source
-            (error "Uneven number of components in source to destination mapping ~S" string))
+            (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>")
+		   string))
           (unless inherit
             (push :ignore-inherited-configuration directives))
           (return `(:output-translations ,@(nreverse directives)))))))))
@@ -3215,7 +3261,7 @@
     ((eq destination t)
      path)
     ((not (pathnamep destination))
-     (error "invalid destination"))
+     (error "Invalid destination"))
     ((not (absolute-pathname-p destination))
      (translate-pathname path absolute-source (merge-pathnames* destination root)))
     (root
@@ -3546,7 +3592,7 @@
     ((or (null string) (equal string ""))
      '(:source-registry :inherit-configuration))
     ((not (stringp string))
-     (error "environment string isn't: ~S" string))
+     (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
     ((find (char string 0) "\"(")
      (validate-source-registry-form (read-from-string string) :location location))
     (t
@@ -3560,7 +3606,8 @@
         (cond
          ((equal "" s) ; empty element: inherit
           (when inherit
-            (error "only one inherited configuration allowed: ~S" string))
+            (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
+		   string))
           (setf inherit t)
           (push ':inherit-configuration directives))
          ((ends-with s "//")
@@ -3756,13 +3803,12 @@
       ((style-warning #'muffle-warning)
        (missing-component (constantly nil))
        (error #'(lambda (e)
-                  (errfmt *error-output* "ASDF could not load ~(~A~) because ~A.~%"
+                  (format *error-output* (compatfmt "~@<ASDF could not load ~(~A~) because ~A.~@:>~%")
                           name e))))
-    (let* ((*verbose-out* (make-broadcast-stream))
+    (let ((*verbose-out* (make-broadcast-stream))
            (system (find-system (string-downcase name) nil)))
       (when system
-        (load-system system)
-        t))))
+        (load-system system)))))
 
 #+(or abcl clisp clozure cmu ecl sbcl)
 (let ((x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom))))


More information about the cmucl-commit mailing list