From 1178d4c54199123981024a97a20bfb0b513f4bf1 Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <fare@tunes.org>
Date: Wed, 19 May 2010 18:05:53 -0400
Subject: [PATCH] 1.726: reorder functions and declaim some types to avoid any
 undefined function warning when loading asdf.lisp from source on SBCL.

---
 asdf.lisp | 238 ++++++++++++++++++++++++++++++------------------------
 1 file changed, 131 insertions(+), 107 deletions(-)

diff --git a/asdf.lisp b/asdf.lisp
index b6fdbc8c..7526e3c7 100644
--- a/asdf.lisp
+++ b/asdf.lisp
@@ -70,7 +70,7 @@
                 :test 'equalp :key 'car))
   (let* ((asdf-version
           ;; the 1+ helps the version bumping script discriminate
-          (subseq "VERSION:1.725" (1+ (length "VERSION"))))
+          (subseq "VERSION:1.726" (1+ (length "VERSION"))))
          (existing-asdf (find-package :asdf))
          (vername '#:*asdf-version*)
          (versym (and existing-asdf
@@ -482,9 +482,6 @@ processed in order by `operate`."))
 and NIL NAME, TYPE and VERSION components"
   (make-pathname :name nil :type nil :version nil :defaults pathname))
 
-(defun default-directory ()
-  (truenamize (pathname-directory-pathname *default-pathname-defaults*)))
-
 (defun merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
   "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that if the SPECIFIED pathname
 does not have an absolute directory, then the HOST and DEVICE come from the DEFAULTS.
@@ -539,6 +536,12 @@ Also, if either argument is NIL, then the other argument is returned unmodified.
 (define-modify-macro orf (&rest args)
   or "or a flag")
 
+(defun first-char (s)
+  (and (stringp s) (plusp (length s)) (char s 0)))
+
+(defun last-char (s)
+  (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
+
 (defun asdf-message (format-string &rest format-args)
   (declare (dynamic-extent format-args))
   (apply #'format *verbose-out* format-string format-args))
@@ -619,10 +622,6 @@ pathnames."
     :unless (eq k key)
     :append (list k v)))
 
-(defun resolve-symlinks (path)
-  #-allegro (truenamize path)
-  #+allegro (excl:pathname-resolve-symbolic-links path))
-
 (defun getenv (x)
   #+abcl
   (ext:getenv x)
@@ -761,9 +760,43 @@ actually-existing directory."
             :finally
             (return (solution nil))))))))
 
+(defun resolve-symlinks (path)
+  #-allegro (truenamize path)
+  #+allegro (excl:pathname-resolve-symbolic-links path))
+
+(defun default-directory ()
+  (truenamize (pathname-directory-pathname *default-pathname-defaults*)))
+
 (defun lispize-pathname (input-file)
   (make-pathname :type "lisp" :defaults input-file))
 
+(defparameter *wild-path*
+  (make-pathname :directory '(:relative :wild-inferiors)
+                 :name :wild :type :wild :version :wild))
+
+(defun wilden (path)
+  (merge-pathnames* *wild-path* path))
+
+(defun directorize-pathname-host-device (pathname)
+  (let* ((root (pathname-root pathname))
+         (wild-root (wilden root))
+         (absolute-pathname (merge-pathnames* pathname root))
+         (foo (make-pathname :directory '(:absolute "FOO") :defaults root))
+         (separator (last-char (namestring foo)))
+         (root-namestring (namestring root))
+         (root-string
+          (substitute-if #\/
+                         (lambda (x) (or (eql x #\:)
+                                         (eql x separator)))
+                         root-namestring)))
+    (multiple-value-bind (relative path filename)
+        (component-name-to-pathname-components root-string t)
+      (declare (ignore relative filename))
+      (let ((new-base
+             (make-pathname :defaults root
+                            :directory `(:absolute ,@path))))
+        (translate-pathname absolute-pathname wild-root (wilden new-base))))))
+
 ;;;; -------------------------------------------------------------------------
 ;;;; Classes, Conditions
 
@@ -776,6 +809,15 @@ actually-existing directory."
   ;; order to fix all conditions that build on it.  -- rgr, 28-Jul-02.]
   #+cmu (:report print-object))
 
+(declaim (ftype (function (t) t)
+                format-arguments format-control
+                error-name error-pathname error-condition
+                duplicate-names-name
+                error-component error-operation
+                module-components module-components-by-name)
+         (ftype (function (t t) t) (setf module-components-by-name)))
+
+
 (define-condition formatted-system-definition-error (system-definition-error)
   ((format-control :initarg :format-control :reader format-control)
    (format-arguments :initarg :format-arguments :reader format-arguments))
@@ -1054,6 +1096,27 @@ This is for backward compatibilily.
 Going forward, we recommend new users should be using the source-registry.
 ")
 
+(defun probe-asd (name defaults)
+  (block nil
+    (when (directory-pathname-p defaults)
+      (let ((file
+             (make-pathname
+              :defaults defaults :version :newest :case :local
+              :name name
+              :type "asd")))
+        (when (probe-file file)
+          (return file)))
+      #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
+      (let ((shortcut
+             (make-pathname
+              :defaults defaults :version :newest :case :local
+              :name (concatenate 'string name ".asd")
+              :type "lnk")))
+        (when (probe-file shortcut)
+          (let ((target (parse-windows-shortcut shortcut)))
+            (when target
+              (return (pathname target)))))))))
+
 (defun sysdef-central-registry-search (system)
   (let ((name (coerce-name system))
         (to-remove nil)
@@ -1603,19 +1666,6 @@ recursive calls to traverse.")
       (visit-component operation c flag)
       flag))
 
-(defmethod traverse ((operation operation) (c component))
-  ;; cerror'ing a feature that seems to have NEVER EVER worked
-  ;; ever since danb created it in his 2003-03-16 commit e0d02781.
-  ;; It was both fixed and disabled in the 1.700 rewrite.
-  (when (consp (operation-forced operation))
-    (cerror "Continue nonetheless."
-            "Congratulations, you're the first ever user of the :force (list of system names) feature! Please contact the asdf-devel mailing-list to collect a cookie.")
-    (setf (operation-forced operation)
-          (mapcar #'coerce-name (operation-forced operation))))
-  (flatten-tree
-   (while-collecting (collect)
-     (do-traverse operation c #'collect))))
-
 (defun flatten-tree (l)
   ;; You collected things into a list.
   ;; Most elements are just things to collect again.
@@ -1632,6 +1682,19 @@ recursive calls to traverse.")
                (dolist (x l) (r x))))
       (r* l))))
 
+(defmethod traverse ((operation operation) (c component))
+  ;; cerror'ing a feature that seems to have NEVER EVER worked
+  ;; ever since danb created it in his 2003-03-16 commit e0d02781.
+  ;; It was both fixed and disabled in the 1.700 rewrite.
+  (when (consp (operation-forced operation))
+    (cerror "Continue nonetheless."
+            "Congratulations, you're the first ever user of the :force (list of system names) feature! Please contact the asdf-devel mailing-list to collect a cookie.")
+    (setf (operation-forced operation)
+          (mapcar #'coerce-name (operation-forced operation))))
+  (flatten-tree
+   (while-collecting (collect)
+     (do-traverse operation c #'collect))))
+
 (defmethod perform ((operation operation) (c source-file))
   (sysdef-error
    "~@<required method PERFORM not implemented ~
@@ -2514,16 +2577,38 @@ with a different configuration, so the configuration would be re-read then."
   (setf *output-translations* '())
   (values))
 
-(defparameter *wild-path*
-  (make-pathname :directory '(:relative :wild-inferiors)
-                 :name :wild :type :wild :version :wild))
-
 (defparameter *wild-asd*
   (make-pathname :directory '(:relative :wild-inferiors)
                  :name :wild :type "asd" :version :newest))
 
-(defun wilden (path)
-  (merge-pathnames* *wild-path* path))
+
+(declaim (ftype (function (t &optional boolean) (or null pathname))
+                resolve-location))
+
+(defun resolve-relative-location-component (super x &optional wildenp)
+  (let* ((r (etypecase x
+              (pathname x)
+              (string x)
+              (cons
+               (let ((car (resolve-relative-location-component super (car x) nil)))
+                 (if (null (cdr x))
+                     car
+                     (let ((cdr (resolve-relative-location-component
+                                 (merge-pathnames* car super) (cdr x) wildenp)))
+                       (merge-pathnames* cdr car)))))
+              ((eql :default-directory)
+               (relativize-pathname-directory (default-directory)))
+              ((eql :implementation) (implementation-identifier))
+              ((eql :implementation-type) (string-downcase (implementation-type)))
+              #-(and (or win32 windows mswindows mingw32) (not cygwin))
+              ((eql :uid) (princ-to-string (get-uid)))))
+         (d (if (pathnamep x) r (ensure-directory-pathname r)))
+         (s (if (and wildenp (not (pathnamep x)))
+                (wilden d)
+                d)))
+    (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super))))
+      (error "pathname ~S is not relative to ~S" s super))
+    (merge-pathnames* s super)))
 
 (defun resolve-absolute-location-component (x wildenp)
   (let* ((r
@@ -2553,31 +2638,6 @@ with a different configuration, so the configuration would be re-read then."
       (error "Not an absolute pathname ~S" s))
     s))
 
-(defun resolve-relative-location-component (super x &optional wildenp)
-  (let* ((r (etypecase x
-              (pathname x)
-              (string x)
-              (cons
-               (let ((car (resolve-relative-location-component super (car x) nil)))
-                 (if (null (cdr x))
-                     car
-                     (let ((cdr (resolve-relative-location-component
-                                 (merge-pathnames* car super) (cdr x) wildenp)))
-                       (merge-pathnames* cdr car)))))
-              ((eql :default-directory)
-               (relativize-pathname-directory (default-directory)))
-              ((eql :implementation) (implementation-identifier))
-              ((eql :implementation-type) (string-downcase (implementation-type)))
-              #-(and (or win32 windows mswindows mingw32) (not cygwin))
-              ((eql :uid) (princ-to-string (get-uid)))))
-         (d (if (pathnamep x) r (ensure-directory-pathname r)))
-         (s (if (and wildenp (not (pathnamep x)))
-                (wilden d)
-                d)))
-    (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super))))
-      (error "pathname ~S is not relative to ~S" s super))
-    (merge-pathnames* s super)))
-
 (defun resolve-location (x &optional wildenp)
   (if (atom x)
       (resolve-absolute-location-component x wildenp)
@@ -2708,6 +2768,11 @@ with a different configuration, so the configuration would be re-read then."
   (getenv "ASDF_OUTPUT_TRANSLATIONS"))
 
 (defgeneric process-output-translations (spec &key inherit collect))
+(declaim (ftype (function (t &key (:collect (or symbol function))) null)
+                inherit-output-translations))
+(declaim (ftype (function (t &key (:collect (or symbol function)) (:inherit list)) null)
+                process-output-translations-directive))
+
 (defmethod process-output-translations ((x symbol) &key
                                         (inherit *default-output-translations*)
                                         collect)
@@ -2835,32 +2900,6 @@ effectively disabling the output translation facility."
           (translate-pathname p absolute-source destination)))
        :finally (return p)))))
 
-(defun first-char (s)
-  (and (stringp s) (plusp (length s)) (char s 0)))
-
-(defun last-char (s)
-  (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
-
-(defun directorize-pathname-host-device (pathname)
-  (let* ((root (pathname-root pathname))
-         (wild-root (wilden root))
-         (absolute-pathname (merge-pathnames* pathname root))
-         (foo (make-pathname :directory '(:absolute "FOO") :defaults root))
-         (separator (last-char (namestring foo)))
-         (root-namestring (namestring root))
-         (root-string
-          (substitute-if #\/
-                         (lambda (x) (or (eql x #\:)
-                                         (eql x separator)))
-                         root-namestring)))
-    (multiple-value-bind (relative path filename)
-        (component-name-to-pathname-components root-string t)
-      (declare (ignore relative filename))
-      (let ((new-base
-             (make-pathname :defaults root
-                            :directory `(:absolute ,@path))))
-        (translate-pathname absolute-pathname wild-root (wilden new-base))))))
-
 (defmethod output-files :around (operation component)
   "Translate output files, unless asked not to"
   (declare (ignorable operation component))
@@ -3031,34 +3070,6 @@ with a different configuration, so the configuration would be re-read then."
   (setf *source-registry* '())
   (values))
 
-(defun probe-asd (name defaults)
-  (block nil
-    (when (directory-pathname-p defaults)
-      (let ((file
-             (make-pathname
-              :defaults defaults :version :newest :case :local
-              :name name
-              :type "asd")))
-        (when (probe-file file)
-          (return file)))
-      #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
-      (let ((shortcut
-             (make-pathname
-              :defaults defaults :version :newest :case :local
-              :name (concatenate 'string name ".asd")
-              :type "lnk")))
-        (when (probe-file shortcut)
-          (let ((target (parse-windows-shortcut shortcut)))
-            (when target
-              (return (pathname target)))))))))
-
-(defun sysdef-source-registry-search (system)
-  (ensure-source-registry)
-  (loop :with name = (coerce-name system)
-    :for defaults :in (source-registry)
-    :for file = (probe-asd name defaults)
-    :when file :return file))
-
 (defun validate-source-registry-directive (directive)
   (unless
       (or (member directive '(:default-registry (:default-registry)) :test 'equal)
@@ -3193,6 +3204,11 @@ with a different configuration, so the configuration would be re-read then."
   (getenv "CL_SOURCE_REGISTRY"))
 
 (defgeneric process-source-registry (spec &key inherit register))
+(declaim (ftype (function (t &key (:register (or symbol function))) null)
+                inherit-source-registry))
+(declaim (ftype (function (t &key (:register (or symbol function)) (:inherit list)) null)
+                process-source-registry-directive))
+
 (defmethod process-source-registry ((x symbol) &key inherit register)
   (process-source-registry (funcall x) :inherit inherit :register register))
 (defmethod process-source-registry ((pathname pathname) &key inherit register)
@@ -3243,7 +3259,8 @@ with a different configuration, so the configuration would be re-read then."
       ((:inherit-configuration)
        (inherit-source-registry inherit :register register))
       ((:ignore-inherited-configuration)
-       nil))))
+       nil)))
+  nil)
 
 (defun flatten-source-registry (&optional parameter)
   (remove-duplicates
@@ -3278,6 +3295,13 @@ with a different configuration, so the configuration would be re-read then."
       (source-registry)
       (initialize-source-registry)))
 
+(defun sysdef-source-registry-search (system)
+  (ensure-source-registry)
+  (loop :with name = (coerce-name system)
+    :for defaults :in (source-registry)
+    :for file = (probe-asd name defaults)
+    :when file :return file))
+
 ;;;; -----------------------------------------------------------------
 ;;;; Hook into REQUIRE for ABCL, ClozureCL, CMUCL, ECL and SBCL
 ;;;;
-- 
GitLab