diff --git a/asdf.lisp b/asdf.lisp index 09c9f50..d73fe08 100755 --- a/asdf.lisp +++ b/asdf.lisp @@ -68,6 +68,27 @@ (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 + (let ((found (search (car i) format))) + (unless found + (return)) + (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. @@ -90,8 +111,8 @@ (unless (and existing-asdf already-there) (when existing-asdf (format *trace-output* - "~&; 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))) @@ -431,7 +452,7 @@ and NIL NAME, TYPE and VERSION components" (and (consp directory) (member (first directory) '(:absolute :relative)))) directory) (t - (error "Unrecognized pathname directory component ~S" directory)))) + (error (compatfmt "~@") directory)))) (defun* merge-pathname-directory-components (specified defaults) (let ((directory (normalize-pathname-directory-component specified))) @@ -512,12 +533,7 @@ and NIL NAME, TYPE and VERSION components" (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 #'format *verbose-out* format-string format-args)) @@ -572,7 +588,7 @@ e.g., \(:file \"foo/bar\"\), which will be unpacked to relative pathnames." (check-type s string) (when (find #\: s) - (error "a portable ASDF pathname designator cannot include a #\: character: ~S" s)) + (error (compatfmt "~@") s)) (let* ((components (split-string s :separator "/")) (last-comp (car (last components)))) (multiple-value-bind (relative components) @@ -580,7 +596,7 @@ pathnames." (if (equal (first-char s) #\/) (progn (when force-relative - (error "absolute pathname designator not allowed: ~S" s)) + (error (compatfmt "~@") s)) (values :absolute (cdr components))) (values :relative nil)) (values :relative components)) @@ -651,9 +667,9 @@ actually-existing directory." ((stringp pathspec) (ensure-directory-pathname (pathname pathspec))) ((not (pathnamep pathspec)) - (error "Invalid pathname designator ~S" pathspec)) + (error (compatfmt "~@") pathspec)) ((wild-pathname-p pathspec) - (error "Can't reliably convert wild pathname ~S" pathspec)) + (error (compatfmt "~@") pathspec)) ((directory-pathname-p pathspec) pathspec) (t @@ -960,9 +976,8 @@ processed in order by OPERATE.")) ((m module) added deleted plist &key) (declare (ignorable deleted plist)) (when (or *asdf-verbose* *load-verbose*) - (asdf-message - #-genera "~&~@<; ~@; Updating ~A for ASDF ~A~@:>~%" - #+genera "~&; 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) @@ -1001,25 +1016,26 @@ processed in order by OPERATE.")) ((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-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-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 "~@") (duplicate-names-name c))))) (define-condition missing-component (system-definition-error) @@ -1040,7 +1056,7 @@ processed in order by OPERATE.")) ((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-operation c) (error-component c))))) (define-condition compile-error (operation-error) ()) (define-condition compile-failed (compile-error) ()) @@ -1052,14 +1068,14 @@ processed in order by OPERATE.")) (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 "~@")))) (define-condition invalid-output-translation (invalid-configuration warning) - ((format :initform "invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}"))) + ((format :initform (compatfmt "~@")))) (defclass component () ((name :accessor component-name :initarg :name :documentation @@ -1123,7 +1139,7 @@ processed in order by OPERATE.")) ;;;; 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) @@ -1133,13 +1149,13 @@ processed in order by OPERATE.")) ;;;; methods: components (defmethod print-object ((c missing-component) s) - (format s "component ~S not found~@[ in ~A~]" + (format s (compatfmt "~@") (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 "~@") (missing-requires c) (missing-version c) (when (missing-parent c) @@ -1199,7 +1215,7 @@ processed in order by OPERATE.")) (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 "~@") pathname (component-find-path component))) (setf (slot-value component 'absolute-pathname) pathname) pathname))) @@ -1268,7 +1284,7 @@ of which is a system object.") (component (component-name name)) (symbol (string-downcase (symbol-name name))) (string name) - (t (sysdef-error "invalid component designator ~A" name)))) + (t (sysdef-error (compatfmt "~@") name)))) (defun* system-registered-p (name) (gethash (coerce-name name) *defined-systems*)) @@ -1361,8 +1377,8 @@ Going forward, we recommend new users should be using the source-registry. (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 "~@") system dir defaults))) (error message)) (remove-entry-from-registry () @@ -1370,7 +1386,7 @@ Going forward, we recommend new users should be using the source-registry. (push dir to-remove)) (coerce-entry-to-directory () :report (lambda (s) - (errfmt s "Coerce entry to ~a, replace ~a and continue." + (format s (compatfmt "~@") (ensure-directory-pathname defaults) dir)) (push (cons dir (ensure-directory-pathname defaults)) to-replace)))))))) ;; cleanup @@ -1406,7 +1422,7 @@ Going forward, we recommend new users should be using the source-registry. (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 "~@") pathname)) 0))) @@ -1423,9 +1439,8 @@ Going forward, we recommend new users should be using the source-registry. :name name :pathname pathname :condition condition)))) (let ((*package* package)) - (asdf-message - #-genera "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%" - #+genera "~&; 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)))) @@ -1452,7 +1467,7 @@ Going forward, we recommend new users should be using the source-registry. (defun* register-system (name system) (setf name (coerce-name name)) (assert (equal name (component-name system))) - (asdf-message "~&; Registering ~A~%" 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) @@ -1792,7 +1807,7 @@ recursive calls to traverse.") required-op required-c required-v)) (retry () :report (lambda (s) - (errfmt s "Retry loading component ~S." required-c)) + (format s "~@" required-c)) :test (lambda (c) (or (null c) @@ -1836,7 +1851,7 @@ recursive calls to traverse.") (when (find (second d) *features* :test 'string-equal) (dep op (third d) nil))) (t - (error "Bad dependency ~a. Dependencies must be (:version ), (:feature [version]), or a name" d)))))) + (error (compatfmt "~@), (:feature [version]), or a name.~@:>") d)))))) flag)))) (defvar *visit-count* 0) ; counter that allows to sort nodes from operation-visited-nodes @@ -1961,7 +1976,7 @@ recursive calls to traverse.") (defmethod perform ((operation operation) (c source-file)) (sysdef-error - "required method PERFORM not implemented for operation ~A, component ~A" + (compatfmt "~@") (class-of operation) (class-of c))) (defmethod perform ((operation operation) (c module)) @@ -1972,7 +1987,8 @@ recursive calls to traverse.") (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 @@ -2022,14 +2038,14 @@ recursive calls to traverse.") (when warnings-p (case (operation-on-warnings operation) (:warn (warn - "COMPILE-FILE warned while performing ~A on ~A." + (compatfmt "~@") 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 "~@") operation c)) (:error (error 'compile-failed :component c :operation operation)) (:ignore nil))) @@ -2131,7 +2147,8 @@ recursive calls to traverse.") (defmethod operation-description ((operation load-op) component) (declare (ignorable operation)) - (format nil "loading component ~S" (component-find-path component))) + (format nil (compatfmt "~@") + (component-find-path component))) ;;;; ------------------------------------------------------------------------- @@ -2174,7 +2191,8 @@ recursive calls to traverse.") (defmethod operation-description ((operation load-source-op) component) (declare (ignorable operation)) - (format nil "loading component ~S" (component-find-path component))) + (format nil (compatfmt "~@") + (component-find-path component))) ;;;; ------------------------------------------------------------------------- @@ -2225,11 +2243,12 @@ recursive calls to traverse.") (retry () :report (lambda (s) - (errfmt s "Retry ~A." (operation-description op component)))) + (format s (compatfmt "~@") + (operation-description op component)))) (accept () :report (lambda (s) - (errfmt s "Continue, treating ~A as having been successful." + (format s (compatfmt "~@") (operation-description op component))) (setf (gethash (type-of op) (component-operation-times component)) @@ -2386,7 +2405,7 @@ Returns the new tree (which probably shares structure with the old one)" (defun* sysdef-error-component (msg type name value) (sysdef-error (concatenate 'string msg - "~&The value specified for ~(~A~) ~A is ~S") + (compatfmt "~&~@")) type name value)) (defun* check-component-input (type name weakly-depends-on @@ -2717,13 +2736,13 @@ located." (t (apply #'warn fstring args) "unknown")))) (let ((lisp (maybe-warn (implementation-type) - "No implementation feature found in ~a." + (compatfmt "~@") *implementation-features*)) (os (maybe-warn (first-feature *os-features*) - "No os feature found in ~a." *os-features*)) + (compatfmt "~@") *os-features*)) (arch (or #-clisp (maybe-warn (first-feature *architecture-features*) - "No architecture feature found in ~a." + (compatfmt "~@") *architecture-features*))) (version (maybe-warn (lisp-version-string) "Don't know how to get Lisp implementation version."))) @@ -2823,14 +2842,15 @@ located." :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 "~@") :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 "~@~%") + description forms)) (funcall validator (car forms) :location file))) (defun* hidden-file-p (pathname) @@ -2951,7 +2971,7 @@ with a different configuration, so the configuration would be re-read then." (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 "~@") s super)) (merge-pathnames* s super))) (defvar *here-directory* nil @@ -2993,7 +3013,7 @@ directive.") (wilden r) r))) (unless (absolute-pathname-p s) - (error "Not an absolute pathname ~S" s)) + (error (compatfmt "~@") s)) s)) (defun* resolve-location (x &key directory wilden) @@ -3065,7 +3085,7 @@ directive.") ((or (null string) (equal string "")) '(:output-translations :inherit-configuration)) ((not (stringp string)) - (error "environment string isn't: ~S" string)) + (error (compatfmt "~@") string)) ((eql (char string 0) #\") (parse-output-translations-string (read-from-string string) :location location)) ((eql (char string 0) #\() @@ -3085,7 +3105,8 @@ directive.") (setf source nil)) ((equal "" s) (when inherit - (error "only one inherited configuration allowed: ~S" string)) + (error (compatfmt "~@") + string)) (setf inherit t) (push :inherit-configuration directives)) (t @@ -3093,7 +3114,8 @@ directive.") (setf start (1+ i)) (when (> start end) (when source - (error "Uneven number of components in source to destination mapping ~S" string)) + (error (compatfmt "~@") + string)) (unless inherit (push :ignore-inherited-configuration directives)) (return `(:output-translations ,@(nreverse directives))))))))) @@ -3244,7 +3266,7 @@ effectively disabling the output translation facility." ((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 @@ -3575,7 +3597,7 @@ with a different configuration, so the configuration would be re-read then." ((or (null string) (equal string "")) '(:source-registry :inherit-configuration)) ((not (stringp string)) - (error "environment string isn't: ~S" string)) + (error (compatfmt "~@") string)) ((find (char string 0) "\"(") (validate-source-registry-form (read-from-string string) :location location)) (t @@ -3589,7 +3611,8 @@ with a different configuration, so the configuration would be re-read then." (cond ((equal "" s) ; empty element: inherit (when inherit - (error "only one inherited configuration allowed: ~S" string)) + (error (compatfmt "~@") + string)) (setf inherit t) (push ':inherit-configuration directives)) ((ends-with s "//") @@ -3785,7 +3808,7 @@ with a different configuration, so the configuration would be re-read then." ((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 "~@~%") name e)))) (let ((*verbose-out* (make-broadcast-stream)) (system (find-system (string-downcase name) nil)))