Skip to content
Snippets Groups Projects
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
No related branches found
No related tags found
No related merge requests found
......@@ -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"
......
......@@ -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)
......
......@@ -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*))
......@@ -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*
......
......@@ -326,11 +326,13 @@ actually-existing directory."
((directory-pathname-p pathspec)
pathspec)
(t
(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)))))
(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)
(error (c) (call-function on-error (compatfmt "~@<error while trying to create a directory pathname for ~S: ~A~@:>") pathspec c)))))))
;;; Parsing filenames
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment