Commit 444d732f authored by Robert Goldman's avatar Robert Goldman
Browse files

Merge branch 'fix-require-some-more' into 'master'

Fix require some more

This replaces !20 with a new branch name, to account for the widening in purpose.

See merge request !21
parents a1aa0b12 70b9388c
Loading
Loading
Loading
Loading
+1 −1
Original line number Diff line number Diff line
@@ -127,7 +127,7 @@ or NIL if not found."
  (defvar *preloaded-systems* (make-hash-table :test 'equal)
    "Registration table for preloaded systems.")

  (declaim (ftype (function (component) t) mark-component-preloaded)) ; defined in asdf/operate
  (declaim (ftype (function (t) t) mark-component-preloaded)) ; defined in asdf/operate

  (defun make-preloaded-system (name keys)
    "Make a preloaded system of given NAME with build information from KEYS"
+1 −1
Original line number Diff line number Diff line
@@ -198,7 +198,7 @@ the implementation's REQUIRE rather than by internal ASDF mechanisms."))
    (let* ((module (or (required-module s) (coerce-name s)))
           (*modules-being-required* (cons module *modules-being-required*)))
      (assert (null (component-children s)))
      (require module)))
      (require #-cmucl module #+cmucl (string-upcase module))))

  (defmethod resolve-dependency-combination (component (combinator (eql :require)) arguments)
    (unless (and (length=n-p arguments 1)
+23 −6
Original line number Diff line number Diff line
@@ -159,18 +159,26 @@
(assert-equal (component-version (registered-system "require-system/ordinary")) "2.0")


;;; We can't actually test portably loading an implementation-dependent module,
;;; because we don't know what modules does implementations ship, so we'll only
;;; test the feature on implementations that support hooking ASDF into CL:REQUIRE
;;; Which is most of the interesting ones, anyway.
;;; ASDF assumes that if a same-named system can be found by find-system, then
;;; it overrides any same-named implementation-dependent module (after downcasing)
;;; specified via (:require ...), so as to avoid recursive calls to asdf:operate from
;;; within plan execution, and any double-loading or infinite loop that could result.
;;;
;;; That means that we can't "just" test the (:require ...) feature portably by
;;; relying on the ASDF hook into CL:REQUIRE that many implementations provide.

#+clisp
(defparameter *dynmod-list*
  (mapcar 'pathname-name
          (directory-files (subpathname (lisp-implementation-directory) "dynmod/") "*.lisp")))

(defparameter *mod*
  (or
   #+abcl :abcl-contrib
   #+allegro :yacc
   #+clisp "zlib" ;; Has to be lower case!
   #+clisp (first (remove "asdf" *dynmod-list* :test 'equal))
   #+(or clozure cmucl) :defsystem
   #+ecl :ecl-curl
   #+ecl :serve-event ;; loads faster than :ecl-quicklisp
   #+lispworks "comm"
   #+mkcl :walker
   #+sbcl :sb-md5
@@ -179,14 +187,23 @@
(unless *mod*
  (leave-test "This implementation doesn't provide a known module" 0))

;; Prevent ASDF from finding the modules as ASDF systems on ECL, MKCL, SBCL (and maybe more).
(setf asdf::*system-definition-search-functions*
      (remove 'asdf::sysdef-source-registry-search asdf::*system-definition-search-functions*))
(asdf::clear-defined-systems)
(clear-cache)


(defun has-module-p (x)
  ;; note that the spec is case-sensitive, but we'll cast a wider net.
  (and (member x *modules* :test 'string-equal) t))

(DBG :before *modules*)
(assert (not (find-system *mod* nil)))
(assert (not (has-module-p *mod*)))

(eval `(def-test-system :require-test :depends-on ((:require ,*mod*))))

(load-system :require-test)
(DBG :after *modules*)
(assert (has-module-p *mod*))
+2 −2
Original line number Diff line number Diff line
@@ -71,7 +71,7 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
       (or (ignore-errors (truename p))
           ;; this is here because trying to find the truename of a directory pathname WITHOUT supplying
           ;; a trailing directory separator, causes an error on some lisps.
           #+(or clisp gcl) (if-let (d (ensure-directory-pathname p)) (ignore-errors (truename d)))))))
           #+(or clisp gcl) (if-let (d (ensure-directory-pathname p nil)) (ignore-errors (truename d)))))))

  (defun safe-file-write-date (pathname)
    "Safe variant of FILE-WRITE-DATE that may return NIL rather than raise an error."
@@ -546,7 +546,7 @@ NILs."
    (let ((dir
            #+abcl extensions:*lisp-home*
            #+(or allegro clasp ecl mkcl) #p"SYS:"
            ;;#+clisp custom:*lib-directory* ; causes failure in asdf-pathname-test(!)
            #+clisp custom:*lib-directory*
            #+clozure #p"ccl:"
            #+cmucl (ignore-errors (pathname-parent-directory-pathname (truename #p"modules:")))
            #+gcl system::*system-directory*
+7 −5
Original line number Diff line number Diff line
@@ -326,11 +326,13 @@ actually-existing directory."
      ((directory-pathname-p pathspec)
       pathspec)
      (t
       (handler-case
           (make-pathname :directory (append (or (normalize-pathname-directory-component
                                                  (pathname-directory pathspec))
                                                 (list :relative))
                                             (list (file-namestring pathspec)))
                      :name nil :type nil :version nil :defaults pathspec)))))
                          :name nil :type nil :version nil :defaults pathspec)
         (error (c) (call-function on-error (compatfmt "~@<error while trying to create a directory pathname for ~S: ~A~@:>") pathspec c)))))))


;;; Parsing filenames