Commit be28d1e9 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

2.011.4: improve the AOT DSL, make configuration DSLs more future-proof,

add condition class(es) for configuration processing failures (lp#684332),
don't try (and fail) getting the architecture under CLISP (lp#688228).
parent d5637f10
Loading
Loading
Loading
Loading
+1 −1
Original line number Diff line number Diff line
@@ -12,7 +12,7 @@
  :licence "MIT"
  :description "Another System Definition Facility"
  :long-description "ASDF builds Common Lisp software organized into defined systems."
  :version "2.011.3"
  :version "2.011.4"
  ;;:version #.(asdf:asdf-version) ; how do we make that the *described* ASDF's version rather than the *previously loaded* ASDF's version?
  :depends-on ()
  :components
+161 −93
Original line number Diff line number Diff line
@@ -76,9 +76,9 @@
  (let* (;; For bug reporting sanity, please always bump this version when you modify this file.
         ;; "2.345" would be an official release
         ;; "2.345.6" would be a development version in the official upstream
         ;; "2.345.0.7" would be your local modification of an official release
         ;; "2.345.6.7" would be your local modification of a development version
         (asdf-version "2.011.3")
         ;; "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.011.4")
         (existing-asdf (fboundp 'find-system))
         (existing-version *asdf-version*)
         (already-there (equal asdf-version existing-version)))
@@ -713,9 +713,14 @@ with given pathname and if it exists return its truename."
(defun* lispize-pathname (input-file)
  (make-pathname :type "lisp" :defaults input-file))

(defparameter *wild-file*
  (make-pathname :name :wild :type :wild :version :wild :directory nil))
(defparameter *wild-directory*
  (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*
  (make-pathname :directory '(:relative :wild-inferiors)
                 :name :wild :type :wild :version :wild))
  (merge-pathnames *wild-file* *wild-inferiors*))

(defun* wilden (path)
  (merge-pathnames* *wild-path* path))
@@ -939,6 +944,21 @@ processed in order by OPERATE."))
(define-condition compile-failed (compile-error) ())
(define-condition compile-warned (compile-error) ())

(define-condition invalid-configuration ()
  ((form :reader condition-form :initarg :form)
   (location :reader condition-location :initarg :location)
   (format :reader condition-format :initarg :format)
   (arguments :reader condition-arguments :initarg :arguments :initform nil))
  (:report (lambda (c s)
             (format s "~@<~? (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~]~@{ ~@?~}~>")))
(define-condition invalid-output-translation (invalid-configuration warning)
  ((format :initform "~@<invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~>")))

(defclass component ()
  ((name :accessor component-name :initarg :name :documentation
         "Component name: designator for a string composed of portable pathname characters")
@@ -2593,7 +2613,8 @@ located."
                            *implementation-features*))
          (os   (maybe-warn (first-feature *os-features*)
                            "No os feature found in ~a." *os-features*))
          (arch (maybe-warn (first-feature *architecture-features*)
          (arch #+clisp "" #-clisp
                (maybe-warn (first-feature *architecture-features*)
                            "No architecture feature found in ~a."
                            *architecture-features*))
          (version (maybe-warn (lisp-version-string)
@@ -2603,7 +2624,6 @@ located."
       (format nil "~(~@{~a~^-~}~)" lisp version os arch)))))



;;; ---------------------------------------------------------------------------
;;; Generic support for configuration files

@@ -2656,43 +2676,88 @@ located."
    (or (member x kw)
        (and (length=n-p x 1) (member (car x) kw)))))

(defun* report-invalid-form (reporter &rest args)
  (etypecase reporter
    (null
     (apply 'error 'invalid-configuration args))
    (function
     (apply reporter args))
    ((or symbol string)
     (apply 'error reporter args))
    (cons
     (apply 'apply (append reporter args)))))

(defvar *ignored-configuration-form* nil)

(defun* validate-configuration-form (form tag directive-validator
                                    &optional (description tag))
                                    &key location invalid-form-reporter)
  (unless (and (consp form) (eq (car form) tag))
    (error "Error: Form doesn't specify ~A ~S~%" description form))
  (loop :with inherit = 0
    :for directive :in (cdr form) :do
    (if (configuration-inheritance-directive-p directive)
        (incf inherit)
        (funcall directive-validator directive))
    (setf *ignored-configuration-form* t)
    (report-invalid-form invalid-form-reporter :form form :location location)
    (return-from validate-configuration-form nil))
  (loop :with inherit = 0 :with ignore-invalid-p = nil :with x = (list tag)
    :for directive :in (cdr form)
    :when (cond
            ((configuration-inheritance-directive-p directive)
             (incf inherit) t)
            ((eq directive :ignore-invalid-entries)
             (setf ignore-invalid-p t) t)
            ((funcall directive-validator directive)
             t)
            (ignore-invalid-p
             nil)
            (t
             (setf *ignored-configuration-form* t)
             (report-invalid-form invalid-form-reporter :form directive :location location)
             nil))
    :do (push directive x)
    :finally
    (unless (= inherit 1)
      (error "One and only one of ~S or ~S is required"
      (report-invalid-form invalid-form-reporter
             :arguments (list "One and only one of ~S or ~S is required"
                              :inherit-configuration :ignore-inherited-configuration)))
  form)
    (return (nreverse x))))

(defun* validate-configuration-file (file validator description)
(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))
    (funcall validator (car forms))))
    (funcall validator (car forms) :location file)))

(defun* hidden-file-p (pathname)
  (equal (first-char (pathname-name pathname)) #\.))

(defun* validate-configuration-directory (directory tag validator)
(defun* directory* (pathname-spec &rest keys &key &allow-other-keys)
  (apply 'directory pathname-spec
         (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
                             #+ccl '(:follow-links nil)
                             #+clisp '(:circle t :if-does-not-exist :ignore)
                             #+(or cmu scl) '(:follow-links nil :truenamep nil)
                             #+sbcl '(: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
be applied to the results to yield a configuration form.  Current
values of TAG include :source-registry and :output-translations."
  (let ((files (sort (ignore-errors
                       (remove-if
                        'hidden-file-p
                        (directory (make-pathname :name :wild :type "conf" :defaults directory)
                                   #+sbcl :resolve-symlinks #+sbcl nil)))
                        (directory* (make-pathname :name :wild :type "conf" :defaults directory))))
                     #'string< :key #'namestring)))
    `(,tag
      ,@(loop :for file :in files :append
          (mapcar validator (read-file-forms file)))
          (loop :with ignore-invalid-p = nil
            :for form :in (read-file-forms file)
            :when (eq form :ignore-invalid-entries)
              :do (setf ignore-invalid-p t)
            :else
              :when (funcall validator form)
                :collect form
              :else
                :when ignore-invalid-p
                  :do (setf *ignored-configuration-form* t)
                :else
                  :do (report-invalid-form invalid-form-reporter :form form :location file)))
      :inherit-configuration)))


@@ -2732,7 +2797,8 @@ and the order is by decreasing length of namestring of the source pathname.")
                             (etypecase (car x)
                               ((eql t) -1)
                               (pathname
                                (length (pathname-directory (car x)))))))))
                                (let ((directory (pathname-directory (car x))))
                                  (if (listp directory) (length directory) 0))))))))
  new-value)

(defun* output-translations-initialized-p ()
@@ -2766,6 +2832,9 @@ with a different configuration, so the configuration would be re-read then."
                       (merge-pathnames* cdr car)))))
              ((eql :default-directory)
               (relativize-pathname-directory (default-directory)))
              ((eql :*/) *wild-directory*)
              ((eql :**/) *wild-inferiors*)
              ((eql :*.*.*) *wild-file*)
              ((eql :implementation) (implementation-identifier))
              ((eql :implementation-type) (string-downcase (implementation-type)))
              #-(and (or win32 windows mswindows mingw32) (not cygwin))
@@ -2832,8 +2901,17 @@ directive.")
        :finally (return path))))

(defun* location-designator-p (x)
  (flet ((componentp (c) (typep c '(or string pathname keyword))))
    (or (typep x 'boolean) (componentp x) (and (consp x) (every #'componentp x)))))
  (flet ((absolute-component-p (c)
           (typep c '(or string pathname
                      (member :root :home :here :user-cache :system-cache :default-directory))))
         (relative-component-p (c)
           (typep c '(or string pathname
                      (member :default-directory :*/ :**/ :*.*.*
                        :implementation :implementation-type
                        #-(and (or win32 windows mswindows mingw32) (not cygwin)) :uid)))))
    (or (typep x 'boolean)
        (absolute-component-p x)
        (and (consp x) (absolute-component-p (first x)) (every #'relative-component-p (rest x))))))

(defun* location-function-p (x)
  (and
@@ -2846,10 +2924,7 @@ directive.")
            (length=n-p (second x) 2)))))

(defun* validate-output-translations-directive (directive)
  (unless
      (or (member directive '(:inherit-configuration
                              :ignore-inherited-configuration
                              :enable-user-cache :disable-cache nil))
  (or (member directive '(:enable-user-cache :disable-cache nil))
      (and (consp directive)
           (or (and (length=n-p directive 2)
                    (or (and (eq (first directive) :include)
@@ -2858,35 +2933,34 @@ directive.")
                             (or (location-designator-p (second directive))
                                 (location-function-p (second directive))))))
               (and (length=n-p directive 1)
                        (location-designator-p (first directive))))))
    (error "Invalid directive ~S~%" directive))
  directive)
                    (location-designator-p (first directive)))))))

(defun* validate-output-translations-form (form)
(defun* validate-output-translations-form (form &key location)
  (validate-configuration-form
   form
   :output-translations
   'validate-output-translations-directive
   "output translations"))
   :location location :invalid-form-reporter 'invalid-output-translation))

(defun* validate-output-translations-file (file)
  (validate-configuration-file
   file 'validate-output-translations-form "output translations"))
   file 'validate-output-translations-form :description "output translations"))

(defun* validate-output-translations-directory (directory)
  (validate-configuration-directory
   directory :output-translations 'validate-output-translations-directive))
   directory :output-translations 'validate-output-translations-directive
   :invalid-form-reporter 'invalid-output-translation))

(defun* parse-output-translations-string (string)
(defun* parse-output-translations-string (string &key location)
  (cond
    ((or (null string) (equal string ""))
     '(:output-translations :inherit-configuration))
    ((not (stringp string))
     (error "environment string isn't: ~S" string))
    ((eql (char string 0) #\")
     (parse-output-translations-string (read-from-string string)))
     (parse-output-translations-string (read-from-string string) :location location))
    ((eql (char string 0) #\()
     (validate-output-translations-form (read-from-string string)))
     (validate-output-translations-form (read-from-string string) :location location))
    (t
     (loop
      :with inherit = nil
@@ -2994,7 +3068,7 @@ directive.")
         (process-output-translations-directive '(t t) :collect collect))
        ((:inherit-configuration)
         (inherit-output-translations inherit :collect collect))
        ((:ignore-inherited-configuration nil)
        ((:ignore-inherited-configuration :ignore-invalid-entries nil)
         nil))
      (let ((src (first directive))
            (dst (second directive)))
@@ -3017,9 +3091,7 @@ directive.")
                  (t
                   (let* ((trudst (make-pathname
                                   :defaults (if dst (resolve-location dst :directory t :wilden t) trusrc)))
                          (wilddst (make-pathname
                                    :name :wild :type :wild :version :wild
                                    :defaults trudst)))
                          (wilddst (merge-pathnames* *wild-file* trudst)))
                     (funcall collect (list wilddst t))
                     (funcall collect (list trusrc trudst)))))))))))

@@ -3180,21 +3252,19 @@ call that function where you would otherwise have loaded and configured A-B-L.")
  (when (null map-all-source-files)
    (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")))
         (wild-inferiors (make-pathname :directory '(:relative :wild-inferiors)))
         (mapped-files (make-pathname
                        :name :wild :version :wild
                        :type (if map-all-source-files :wild fasl-type)))
         (mapped-files (if map-all-source-files *wild-file*
                           (make-pathname :name :wild :version :wild :type fasl-type)))
         (destination-directory
          (if centralize-lisp-binaries
              `(,default-toplevel-directory
                ,@(when include-per-user-information
                        (cdr (pathname-directory (user-homedir))))
                :implementation ,wild-inferiors)
              `(:root ,wild-inferiors :implementation))))
                :implementation ,*wild-inferiors*)
              `(:root ,*wild-inferiors* :implementation))))
    (initialize-output-translations
     `(:output-translations
       ,@source-to-target-mappings
       ((:root ,wild-inferiors ,mapped-files)
       ((:root ,*wild-inferiors* ,mapped-files)
        (,@destination-directory ,mapped-files))
       (t t)
       :ignore-inherited-configuration))))
@@ -3314,11 +3384,8 @@ with a different configuration, so the configuration would be re-read then."
  (make-pathname :directory nil :name :wild :type "asd" :version :newest))

(defun directory-has-asd-files-p (directory)
  (and (ignore-errors
         (directory (merge-pathnames* *wild-asd* directory)
                    #+sbcl #+sbcl :resolve-symlinks nil
                    #+ccl #+ccl :follow-links nil
                    #+clisp #+clisp :circle t))
  (ignore-errors
    (directory* (merge-pathnames* *wild-asd* directory))
    t))

(defun subdirectories (directory)
@@ -3326,19 +3393,14 @@ with a different configuration, so the configuration would be re-read then."
         #-cormanlisp
         (wild (merge-pathnames*
                #-(or abcl allegro lispworks scl)
                (make-pathname :directory '(:relative :wild) :name nil :type nil :version nil)
                *wild-directory*
                #+(or abcl allegro lispworks scl) "*.*"
                directory))
         (dirs
          #-cormanlisp
          (ignore-errors
            (directory wild .
              #.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
                    #+ccl '(:follow-links nil :directories t :files nil)
                    #+clisp '(:circle t :if-does-not-exist :ignore)
                    #+(or cmu scl) '(:follow-links nil :truenamep nil)
                    #+digitool '(:directories t)
                    #+sbcl '(:resolve-symlinks nil))))
            (directory* wild . #.(or #+ccl '(:directories t :files nil)
                                     #+digitool '(:directories t))))
          #+cormanlisp (cl::directory-subdirs directory))
         #+(or abcl allegro lispworks scl)
         (dirs (remove-if-not #+abcl #'extensions:probe-directory
@@ -3366,39 +3428,40 @@ with a different configuration, so the configuration would be re-read then."
   collect))

(defun* validate-source-registry-directive (directive)
  (unless
      (or (member directive '(:default-registry (:default-registry)) :test 'equal)
          (destructuring-bind (kw &rest rest) directive
            (case kw
  (or (member directive '(:default-registry))
      (and (consp directive)
           (let ((rest (rest directive)))
             (case (first directive)
               ((:include :directory :tree)
                (and (length=n-p rest 1)
                     (location-designator-p (first rest))))
               ((:exclude :also-exclude)
                (every #'stringp rest))
              (null rest))))
    (error "Invalid directive ~S~%" directive))
  directive)
               ((:default-registry)
                (null rest)))))))

(defun* validate-source-registry-form (form)
(defun* validate-source-registry-form (form &key location)
  (validate-configuration-form
   form :source-registry 'validate-source-registry-directive "a source registry"))
   form :source-registry 'validate-source-registry-directive
   :location location :invalid-form-reporter 'invalid-source-registry))

(defun* validate-source-registry-file (file)
  (validate-configuration-file
   file 'validate-source-registry-form "a source registry"))
   file 'validate-source-registry-form :description "a source registry"))

(defun* validate-source-registry-directory (directory)
  (validate-configuration-directory
   directory :source-registry 'validate-source-registry-directive))
   directory :source-registry 'validate-source-registry-directive
   :invalid-form-reporter 'invalid-source-registry))

(defun* parse-source-registry-string (string)
(defun* parse-source-registry-string (string &key location)
  (cond
    ((or (null string) (equal string ""))
     '(:source-registry :inherit-configuration))
    ((not (stringp string))
     (error "environment string isn't: ~S" string))
    ((find (char string 0) "\"(")
     (validate-source-registry-form (read-from-string string)))
     (validate-source-registry-form (read-from-string string) :location location))
    (t
     (loop
      :with inherit = nil
@@ -3640,6 +3703,11 @@ with a different configuration, so the configuration would be re-read then."
      (declare (ignorable initargs))
      (when system-p (appendf (compile-op-flags op) (list :system-p system-p))))))

;;; If a previous version of ASDF failed to read some configuration, try again.
(when *ignored-configuration-form*
  (clear-configuration)
  (setf *ignored-configuration-form* nil))

;;;; -----------------------------------------------------------------
;;;; Done!
(when *load-verbose*
+20 −4
Original line number Diff line number Diff line
@@ -1808,6 +1808,11 @@ DIRECTIVE :=
    :inherit-configuration | ; splices inherited configuration (often specified last)
    :ignore-inherited-configuration | ; drop inherited configuration (specified anywhere)

    ;; forward compatibility directive (since ASDF 2.011.4), useful when
    ;; you want to use new configuration features but have to bootstrap a
    ;; the newer required ASDF from an older release that doesn't sport said features:
    :ignore-invalid-entries | ; drops subsequent invalid entries instead of erroring out

    ;; add a single directory to be scanned (no recursion)
    (:directory DIRECTORY-PATHNAME-DESIGNATOR) |

@@ -1847,7 +1852,7 @@ ABSOLUTE-COMPONENT-DESIGNATOR :=
RELATIVE-COMPONENT-DESIGNATOR :=
    STRING | ;; namestring (directory assumed where applicable)
    PATHNAME | ;; pathname
    :IMPLEMENTATION | ;; a directory based on implementation, e.g. sbcl-1.0.32.30-linux-x86-64
    :IMPLEMENTATION | ;; a directory based on implementation, e.g. sbcl-1.0.45-linux-amd64
    :IMPLEMENTATION-TYPE | ;; a directory based on lisp-implementation-type only, e.g. sbcl
    :UID | ;; current UID -- not available on Windows
    :USER ;; current USER name -- NOT IMPLEMENTED(!)
@@ -2311,10 +2316,15 @@ DIRECTIVE :=
    :inherit-configuration | ; splices inherited configuration (often specified last)
    :ignore-inherited-configuration | ; drop inherited configuration (specified anywhere)

    ;; forward compatibility directive (since ASDF 2.011.4), useful when
    ;; you want to use new configuration features but have to bootstrap a
    ;; the newer required ASDF from an older release that doesn't sport said features:
    :ignore-invalid-entries | ; drops subsequent invalid entries instead of erroring out

    ;; include a configuration file or directory
    (:include PATHNAME-DESIGNATOR) |

    ;; enable global cache in ~/.common-lisp/cache/sbcl-1.0.35-x86-64/ or something.
    ;; enable global cache in ~/.common-lisp/cache/sbcl-1.0.45-linux-amd64/ or something.
    :enable-user-cache |
    ;; Disable global cache. Map / to /
    :disable-cache |
@@ -2342,8 +2352,11 @@ ABSOLUTE-COMPONENT-DESIGNATOR :=
RELATIVE-COMPONENT-DESIGNATOR :=
    STRING | ;; namestring, directory is assumed. If the last component, /**/*.* is added
    PATHNAME | ;; pathname unless last component, directory is assumed.
    :IMPLEMENTATION | ;; a directory based on implementation, e.g. sbcl-1.0.32.30-linux-x86-64
    :IMPLEMENTATION | ;; a directory based on implementation, e.g. sbcl-1.0.45-linux-amd64
    :IMPLEMENTATION-TYPE | ;; a directory based on lisp-implementation-type only, e.g. sbcl
    :*/ | ;; any direct subdirectory (since ASDF 2.011.4)
    :**/ | ;; any recursively inferior subdirectory (since ASDF 2.011.4)
    :*.*.* | ;; any file (since ASDF 2.011.4)
    :UID | ;; current UID -- not available on Windows
    :USER ;; current USER name -- NOT IMPLEMENTED(!)

@@ -2395,6 +2408,9 @@ which will do the same thing internally for you:
     `((:root ,wild-subdir ,wild-file) ;; Or using the implicit wildcard, just :root
       (:root ,wild-subdir :implementation ,wild-file)))
@end verbatim
Starting with ASDF 2.011.4, you can use the simpler:
	@code{`(:root (:root :**/ :implementation :*.*.*))}



@code{:include} statements cause the search to recurse with the path specifications
@@ -2594,7 +2610,7 @@ But so are good design ideas and elegant implementation tricks.

@c @itemize
@c @item
@c SBCL, version 1.0 on Mac OS X for intel: @code{sbcl-1.0-darwin-x86}
@c SBCL, version 1.0.45 on Mac OS X for Intel: @code{sbcl-1.0.45-darwin-x86}

@c @item
@c Franz Allegro, version 8.0, ANSI Common Lisp: @code{allegro-8.0a-macosx-x86}