WIP: Fix declaim ftype for mark-component-preloaded

(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

(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*))

       (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."

    (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*

      ((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

  (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"

    (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)