From 32b945abf23928e432d5c01d51c48806bd947876 Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau Date: Sat, 17 Sep 2016 11:44:09 -0400 Subject: [PATCH 1/4] UIOP: Fix long-standing pathname issue on CLISP Make ENSURE-DIRECTORY-PATHNAME and TRUENAME* more robust in case MAKE-PATHNAME throws an error when trying to synthetize a pathname with components that the implementation considers invalid. Uncomment the proper definition of LISP-IMPLEMENTATION-DIRECTORY on CLISP, which now doesn't break asdf-pathname-test anymore. --- uiop/filesystem.lisp | 4 ++-- uiop/pathname.lisp | 12 +++++++----- 2 files changed, 9 insertions(+), 7 deletions(-) diff --git a/uiop/filesystem.lisp b/uiop/filesystem.lisp index 7f1e199c..a04334a9 100644 --- a/uiop/filesystem.lisp +++ b/uiop/filesystem.lisp @@ -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* diff --git a/uiop/pathname.lisp b/uiop/pathname.lisp index 2d618a58..15af1fb4 100644 --- a/uiop/pathname.lisp +++ b/uiop/pathname.lisp @@ -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 "~@") pathspec c))))))) ;;; Parsing filenames -- GitLab From 96ea927078fc4d11c09bc3e9ad30352a054ac99d Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau Date: Sat, 17 Sep 2016 11:47:44 -0400 Subject: [PATCH 2/4] Fix declaim ftype for mark-component-preloaded SBCL cares about type declarations, and the declared ftype became a lie after allowing arbitrary component designators rather than only components in calls to mark-component-preloaded, which *sometimes* caused errors. --- find-system.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/find-system.lisp b/find-system.lisp index e754c991..084d133f 100644 --- a/find-system.lisp +++ b/find-system.lisp @@ -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" -- GitLab From c69ad702b21acd34ebfdffdc0e672db7c35b0256 Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau Date: Sat, 17 Sep 2016 11:48:39 -0400 Subject: [PATCH 3/4] On CMUCL, upcase module name before you require them. --- operate.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/operate.lisp b/operate.lisp index 86b68655..8c1a4806 100644 --- a/operate.lisp +++ b/operate.lisp @@ -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) -- GitLab From 89c79c4879abbf9a8609ccf200b199c263021ef6 Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau Date: Sat, 17 Sep 2016 11:49:28 -0400 Subject: [PATCH 4/4] Fix test-require Make it more robust on various CLISP, ECL, MKCL, SBCL: disable the source-registry so ASDF won't override a module with a system, try harder to find modules that will be provided by the implementation. --- test/test-require.script | 29 +++++++++++++++++++++++------ 1 file changed, 23 insertions(+), 6 deletions(-) diff --git a/test/test-require.script b/test/test-require.script index 072b3dab..01fbc694 100644 --- a/test/test-require.script +++ b/test/test-require.script @@ -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-events ;; 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*)) -- GitLab