From a7464ad317f180b40230579bf67755093a00a87d Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <tunes@google.com>
Date: Sun, 6 Jan 2013 19:58:00 -0500
Subject: [PATCH] 2.26.57: Fix make-pathname* (bug found by rpgoldman).
 Implement concatenate-source-op &co

---
 asdf.asd                            |   2 +-
 asdf.lisp                           | 306 +++++++++++++++++++---------
 test/test-concatenate-source.script |  35 ++++
 3 files changed, 247 insertions(+), 96 deletions(-)
 create mode 100644 test/test-concatenate-source.script

diff --git a/asdf.asd b/asdf.asd
index 98cdb8ff..d99f7146 100644
--- a/asdf.asd
+++ b/asdf.asd
@@ -14,7 +14,7 @@
   :licence "MIT"
   :description "Another System Definition Facility"
   :long-description "ASDF builds Common Lisp software organized into defined systems."
-  :version "2.26.56" ;; to be automatically updated by bin/bump-revision
+  :version "2.26.57" ;; to be automatically updated by bin/bump-revision
   :depends-on ()
   :components
   ((:file "asdf")))
diff --git a/asdf.lisp b/asdf.lisp
index 5a7e01d2..3a902011 100644
--- a/asdf.lisp
+++ b/asdf.lisp
@@ -1,5 +1,5 @@
 ;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
-;;; This is ASDF 2.26.56: Another System Definition Facility.
+;;; This is ASDF 2.26.57: Another System Definition Facility.
 ;;;
 ;;; Feedback, bug reports, and patches are all welcome:
 ;;; please mail to <asdf-devel@common-lisp.net>.
@@ -126,7 +126,7 @@
          ;; "2.345.6" would be a development version in the official upstream
          ;; "2.345.0.7" would be your seventh local modification of official release 2.345
          ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
-         (asdf-version "2.26.56")
+         (asdf-version "2.26.57")
          (existing-asdf (find-class 'component nil))
          (existing-version *asdf-version*)
          (already-there (equal asdf-version existing-version)))
@@ -600,12 +600,13 @@ and NIL NAME, TYPE and VERSION components"
       ((and (consp d) (eq :absolute (first d))) `(:root ,@(rest d)))
       (t d))))
 
-(defun* make-pathname* (&key host device directory name type version defaults)
-  (make-pathname
-   :defaults (or defaults *default-pathname-defaults*)
-   :host host :device device :name name :type type :version version
-   :directory (denormalize-pathname-directory-component directory)))
-   
+(defun* make-pathname* (&rest keys &key (directory nil directoryp)
+                              host device name type version defaults)
+  (declare (ignore host device name type version defaults))
+  (apply 'make-pathname
+         (append (when directoryp
+                   `(:directory ,(denormalize-pathname-directory-component directory)))
+                 keys)))
 
 (defun* make-pathname-logical (pathname host)
   "Take a PATHNAME's directory, name, type and version components,
@@ -1509,6 +1510,67 @@ Returns two values:
               (acons property new-value (slot-value c 'properties)))))
   new-value)
 
+(defclass proto-system () ; slots to keep when resetting a system
+  ;; To preserve identity for all objects, we'd need keep the components slots
+  ;; but also to modify parse-component-form to reset the recycled objects.
+  ((name) (source-file) #|(children) (children-by-names)|#))
+
+;; Backward-compatibility: inherit from module. ASDF3: only inherit from parent-component.
+(defclass system (module proto-system)
+  (;; {,long-}description is now inherited from component, but we add the legacy accessors
+   (description :accessor system-description)
+   (long-description :accessor system-long-description)
+   (author :accessor system-author :initarg :author)
+   (maintainer :accessor system-maintainer :initarg :maintainer)
+   (licence :accessor system-licence :initarg :licence
+            :accessor system-license :initarg :license)
+   (source-file :initarg :source-file :writer %set-system-source-file) ; upgrade issues on CLISP, CMUCL
+   (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on)))
+
+(defmethod component-pathname ((system system))
+  (if (or (slot-boundp system 'relative-pathname)
+            (slot-boundp system 'absolute-pathname)
+            (slot-value system 'source-file))
+    (call-next-method)
+    (default-directory)))
+
+;;; component subclasses
+
+(defclass file-component (child-component)
+  ((type :accessor file-type :initarg :type))) ; no default
+(defclass source-file (file-component)
+  ((type :initform nil))) ;; NB: many systems have come to rely on this default.
+(defclass cl-source-file (source-file)
+  ((type :initform "lisp")))
+(defclass cl-source-file.cl (cl-source-file)
+  ((type :initform "cl")))
+(defclass cl-source-file.lsp (cl-source-file)
+  ((type :initform "lsp")))
+(defclass c-source-file (source-file)
+  ((type :initform "c")))
+(defclass java-source-file (source-file)
+  ((type :initform "java")))
+(defclass static-file (source-file)
+  ((type :initform nil)))
+(defclass doc-file (static-file) ())
+(defclass html-file (doc-file)
+  ((type :initform "html")))
+
+(defmethod source-file-type ((component parent-component) system) ; not just for source-file. ASDF3: rename.
+  (declare (ignorable component system))
+  :directory)
+(defmethod source-file-type ((component file-component) system)
+  (declare (ignorable system))
+  (file-type component))
+
+(defmethod component-relative-pathname ((component component))
+  (coerce-pathname
+   (or (slot-value component 'relative-pathname)
+       (component-name component))
+   :type (source-file-type component (component-system component))
+   :defaults (component-parent-pathname component)))
+
+;;;; Encodings
 (defvar *default-encoding* :default
   "Default encoding for source files.
 The default value :default preserves the legacy behavior.
@@ -1540,7 +1602,11 @@ hopefully, if done consistently, that won't affect program behavior too much.")
 (defmethod component-encoding ((c component))
   (or (loop :for x = c :then (component-parent x)
         :while x :thereis (%component-encoding x))
-      (detect-encoding (component-pathname c))))
+      (call-next-method)))
+(defmethod component-encoding ((c file-component))
+  (detect-encoding (component-pathname c)))
+(defmethod component-encoding ((c parent-component))
+  *default-encoding*)
 
 (defun* default-encoding-external-format (encoding)
   (case encoding
@@ -1561,30 +1627,6 @@ and implementation-defined external-format's")
 (defmethod component-external-format ((c component))
   (encoding-external-format (component-encoding c)))
 
-(defclass proto-system () ; slots to keep when resetting a system
-  ;; To preserve identity for all objects, we'd need keep the components slots
-  ;; but also to modify parse-component-form to reset the recycled objects.
-  ((name) (source-file) #|(children) (children-by-names)|#))
-
-;; Backward-compatibility: inherit from module. ASDF3: only inherit from parent-component.
-(defclass system (module proto-system)
-  (;; {,long-}description is now inherited from component, but we add the legacy accessors
-   (description :accessor system-description)
-   (long-description :accessor system-long-description)
-   (author :accessor system-author :initarg :author)
-   (maintainer :accessor system-maintainer :initarg :maintainer)
-   (licence :accessor system-licence :initarg :licence
-            :accessor system-license :initarg :license)
-   (source-file :initarg :source-file :writer %set-system-source-file) ; upgrade issues on CLISP, CMUCL
-   (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on)))
-
-(defmethod component-pathname ((system system))
-  (if (or (slot-boundp system 'relative-pathname)
-            (slot-boundp system 'absolute-pathname)
-            (slot-value system 'source-file))
-    (call-next-method)
-    (default-directory)))
-
 ;;;; -------------------------------------------------------------------------
 ;;;; version-satisfies
 
@@ -2086,42 +2128,6 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
   (declare (ignorable combinator)) ;; See https://bugs.launchpad.net/asdf/+bug/527788
   (resolve-dependency-name component (first arguments) (second arguments)))
 
-;;; component subclasses
-
-(defclass file-component (child-component)
-  ((type :accessor file-type :initarg :type))) ; no default
-(defclass source-file (file-component)
-  ((type :initform nil))) ;; NB: many systems have come to rely on this default.
-(defclass cl-source-file (source-file)
-  ((type :initform "lisp")))
-(defclass cl-source-file.cl (cl-source-file)
-  ((type :initform "cl")))
-(defclass cl-source-file.lsp (cl-source-file)
-  ((type :initform "lsp")))
-(defclass c-source-file (source-file)
-  ((type :initform "c")))
-(defclass java-source-file (source-file)
-  ((type :initform "java")))
-(defclass static-file (source-file)
-  ((type :initform nil)))
-(defclass doc-file (static-file) ())
-(defclass html-file (doc-file)
-  ((type :initform "html")))
-
-(defmethod source-file-type ((component parent-component) system) ; not just for source-file. ASDF3: rename.
-  (declare (ignorable component system))
-  :directory)
-(defmethod source-file-type ((component file-component) system)
-  (declare (ignorable system))
-  (file-type component))
-
-(defmethod component-relative-pathname ((component component))
-  (coerce-pathname
-   (or (slot-value component 'relative-pathname)
-       (component-name component))
-   :type (source-file-type component (component-system component))
-   :defaults (component-parent-pathname component)))
-
 ;;;; -------------------------------------------------------------------------
 ;;;; Operations
 
@@ -2556,10 +2562,11 @@ in some previous image, or T if it needs to be done.")
 ;;;; -------------------------------------------------------------------------
 ;;;; compile-op
 
-(defclass compile-op (downward-operation)
+(defclass basic-compile-op (operation)
   ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
    (flags :initarg :flags :accessor compile-op-flags
           :initform nil)))
+(defclass compile-op (basic-compile-op downward-operation) ())
 
 ;; backward-compatibility
 (defgeneric* operation-on-warnings (operation))
@@ -2608,10 +2615,10 @@ in some previous image, or T if it needs to be done.")
 
 ;;; perform is required to check output-files to find out where to put
 ;;; its answers, in case it has been overridden for site policy
-(defmethod perform ((o compile-op) (c cl-source-file))
+(defun* perform-lisp-compilation (o c)
   (let (;; Before 2.26.53, that was unfortunately component-pathname. Now,
         ;; we consult input-files, the first of which should be the one to compile-file
-        (input-file (first (input-files o c))) 
+        (input-file (first (input-files o c)))
         ;; on some implementations, there are more than one output-file,
         ;; but the first one should always be the primary fasl that gets loaded.
         (output-file (first (output-files o c))))
@@ -2639,15 +2646,18 @@ in some previous image, or T if it needs to be done.")
           (:error (error 'compile-warned :component c :operation o))
           (:ignore nil))))))
 
+(defmethod perform ((o compile-op) (c cl-source-file))
+  (perform-lisp-compilation o c))
+
 (defmethod output-files ((o compile-op) (c cl-source-file))
   (declare (ignorable o))
-  (let* ((p (lispize-pathname (component-pathname c)))
-         (f (compile-file-pathname ;; fasl
-             p #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl))
-         #+mkcl (o (compile-file-pathname p :fasl-p nil))) ;; object file
+  (let* ((i (first (input-files o c)))
+         (f (compile-file-pathname
+             i #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl))
+         #+mkcl (o (compile-file-pathname i :fasl-p nil))) ;; object file
     #+ecl (if (use-ecl-byte-compiler-p)
               (list f)
-              (list (compile-file-pathname p :type :object) f))
+              (list (compile-file-pathname i :type :object) f))
     #+mkcl (list o f)
     #-(or ecl mkcl) (list f)))
 
@@ -2686,13 +2696,7 @@ in some previous image, or T if it needs to be done.")
         (perform (find-operation o 'compile-op) c)))))
 
 (defmethod perform ((o load-op) (c cl-source-file))
-  (map () #'load
-       #-(or ecl mkcl)
-       (input-files o c)
-       #+(or ecl mkcl)
-       (loop :for i :in (input-files o c)
-             :unless (string= (pathname-type i) "fas")
-             :collect (compile-file-pathname (lispize-pathname i)))))
+  (load (first (input-files o c))))
 
 (defmethod perform ((o load-op) (c static-file))
   (declare (ignorable o c))
@@ -2747,12 +2751,15 @@ in some previous image, or T if it needs to be done.")
   (declare (ignorable o))
   `((prepare-source-op ,c) ,@(call-next-method)))
 
-(defmethod perform ((o load-source-op) (c cl-source-file))
-  (declare (ignorable o))
+(defun perform-load-lisp-source (c)
   (call-with-around-compile-hook
    c #'(lambda () (load (component-pathname c)
                         #-gcl<2.7 :external-format #-gcl<2.7 (component-external-format c)))))
 
+(defmethod perform ((o load-source-op) (c cl-source-file))
+  (declare (ignorable o))
+  (perform-load-lisp-source c))
+
 (defmethod perform ((o load-source-op) (c static-file))
   (declare (ignorable o c))
   nil)
@@ -4673,12 +4680,14 @@ with a different configuration, so the configuration would be re-read then."
 (defclass dll-op (bundle-op)
   ((type :initform :dll)))
 
-(defclass monolithic-bundle-op (bundle-op)
+(defclass monolithic-op (operation) ()) ;; operation on a system and its dependencies
+
+(defclass monolithic-bundle-op (monolithic-op bundle-op)
   ((prologue-code :accessor monolithic-op-prologue-code)
    (epilogue-code :accessor monolithic-op-epilogue-code)))
 
-(defun* bundle-op-monolithic-p (op)
-  (typep op 'monolithic-bundle-op))
+(defun* operation-monolithic-p (op)
+  (typep op 'monolithic-op))
 
 (defclass monolithic-fasl-op (monolithic-bundle-op fasl-op) ())
 
@@ -4697,7 +4706,7 @@ with a different configuration, so the configuration would be re-read then."
   (declare (ignorable initargs name-suffix))
   (unless name-suffix-p
     (setf (slot-value instance 'name-suffix)
-          (if (bundle-op-monolithic-p instance) ".all-systems" ".system")))
+          (if (operation-monolithic-p instance) ".all-systems" ".system")))
   (when (typep instance 'monolithic-bundle-op)
     (destructuring-bind (&rest original-initargs
                          &key lisp-files prologue-code epilogue-code
@@ -4719,7 +4728,8 @@ with a different configuration, so the configuration would be re-read then."
     (remf args :ld-flags)
     args))
 
-(defun* gather-components (operation system &key other-systems filter-type include-self)
+(defun* gather-components (operation system
+                                     &key other-systems filter-type include-self)
   ;; This function creates a list of actions pairing the operation with sub-components of system
   ;; and its dependencies if requested.
   ;; This list may be restricted to sub-components of SYSTEM
@@ -4774,7 +4784,7 @@ with a different configuration, so the configuration would be re-read then."
 ;;;
 (defmethod bundle-sub-operations ((o lib-op) c)
   (gather-components (find-operation o 'compile-op) c
-                     :other-systems (bundle-op-monolithic-p o)
+                     :other-systems (operation-monolithic-p o)
                      :filter-type '(not system)))
 ;;;
 ;;; SHARED LIBRARIES
@@ -4906,10 +4916,10 @@ with a different configuration, so the configuration would be re-read then."
   nil)
 (defmethod input-files (o (c compiled-file))
   (declare (ignorable o))
-  (load (component-pathname c)))
+  (component-pathname c))
 (defmethod perform ((o load-op) (c compiled-file))
   (declare (ignorable o))
-  (load (component-pathname c)))
+  (load (first (input-files o c))))
 (defmethod perform ((o load-source-op) (c compiled-file))
   (perform (find-operation o 'load-op) c))
 (defmethod perform ((o load-fasl-op) (c compiled-file))
@@ -4970,7 +4980,7 @@ with a different configuration, so the configuration would be re-read then."
 
 (defun* binary-op-dependencies (o s)
   (multiple-value-bind (lib-op fasl-op)
-      (if (bundle-op-monolithic-p o)
+      (if (operation-monolithic-p o)
           (values 'monolithic-lib-op 'monolithic-fasl-op)
           (values 'lib-op 'fasl-op))
     `((,(find-operation o lib-op) ,s)
@@ -5186,6 +5196,112 @@ using WRITE-SEQUENCE and a sensibly sized buffer." ; copied from xcvb-driver
   (apply #'operate 'bundle-op system args))
 );mkcl
 
+;;;
+;;; Concatenate sources
+;;;
+
+(defclass concatenated-source-system (system)
+  ((concatenated-source-file
+    :initform nil :initarg :concatenated-source-file :reader system-concatenated-source-file)
+   (translate-output-p
+    :initform t :initarg :translate-output-p :reader system-translate-output-p)))
+
+(defmethod system-concatenated-source-file ((s system))
+  (declare (ignorable s))
+  nil)
+(defmethod system-translate-output-p ((s system))
+  (declare (ignorable s))
+  t)
+
+(defclass concatenate-source-op (operation) ())
+(defclass load-concatenated-source-op (basic-load-op operation) ())
+(defclass compile-concatenated-source-op (basic-compile-op operation) ())
+(defclass load-compiled-concatenated-source-op (basic-load-op operation) ())
+(defclass monolithic-concatenate-source-op (concatenate-source-op monolithic-op) ())
+(defclass monolithic-load-concatenated-source-op (load-concatenated-source-op monolithic-op) ())
+(defclass monolithic-compile-concatenated-source-op (compile-concatenated-source-op monolithic-op) ())
+(defclass monolithic-load-compiled-concatenated-source-op (load-compiled-concatenated-source-op monolithic-op) ())
+
+(defmethod input-files ((o concatenate-source-op) (s system))
+  (loop :with op = (make-operation 'compile-op)
+        :with components = (gather-components op s
+                                              :include-self nil
+                                              :filter-type 'source-file
+                                              :other-systems (operation-monolithic-p o))
+        :with non-cl-source-files = nil
+        :with encoding = (or (component-encoding s) *default-encoding*)
+        :with other-encodings = '()
+        :with around-compile = (around-compile-hook s)
+        :with other-around-compile = '()
+        :for (o . c) :in components
+        :do (cond
+              ((typep c 'cl-source-file)
+               (let ((e (component-encoding c)))
+                 (unless (equal e encoding)
+                   (pushnew e other-encodings :test 'equal)))
+               (let ((a (around-compile-hook c)))
+                 (unless (equal a around-compile)
+                   (pushnew a other-around-compile :test 'equal))))
+              (t
+               (push c non-cl-source-files)))
+        :append (input-files o c) :into inputs
+        :finally
+           (when non-cl-source-files
+             (warn "~S depends on these non CL source files: ~A"
+                   'concatenated-source-op non-cl-source-files))
+           (when other-encodings
+             (warn "~S uses encoding ~A but has sources that use these encodings: ~A"
+                   'concatenated-source-op encoding other-encodings))
+           (when other-around-compile
+             (warn "~S uses around-compile hook ~A but has sources that use these hooks: ~A"
+                   'concatenated-source-op around-compile other-around-compile))
+           (return inputs)))
+
+(defmethod output-files ((o concatenate-source-op) (s system))
+  (declare (ignorable o))
+  (let ((of (or (system-concatenated-source-file s) (strcat (coerce-name s) ".lisp")))
+        (top (system-translate-output-p s)))
+    (values (list (system-relative-pathname s of)) (not top))))
+(defmethod input-files ((o load-concatenated-source-op) (s system))
+  (output-files (find-operation o 'concatenate-source-op) s))
+(defmethod input-files ((o compile-concatenated-source-op) (s system))
+  (output-files (find-operation o 'concatenate-source-op) s))
+(defmethod output-files ((o compile-concatenated-source-op) (s system))
+  (let ((input (first (input-files o s))))
+    (list (compile-file-pathname input))))
+(defmethod input-files ((o load-compiled-concatenated-source-op) (s system))
+  (output-files (find-operation o 'compile-concatenated-source-op) s))
+
+(defmethod perform ((o concatenate-source-op) (s system))
+  (let ((inputs (input-files o s))
+        (output (output-file o s)))
+    (concatenate-files inputs output)))
+(defmethod perform ((o load-concatenated-source-op) (s system))
+  (declare (ignorable o))
+  (perform-load-lisp-source s))
+(defmethod perform ((o compile-concatenated-source-op) (s system))
+  (perform-lisp-compilation o s))
+(defmethod perform ((o load-compiled-concatenated-source-op) (s system))
+  (load (first (input-files o s))))
+
+(defmethod component-depends-on ((o concatenate-source-op) (s system))
+  (declare (ignorable o s)) nil)
+(defmethod component-depends-on ((o load-concatenated-source-op) (s system))
+  (declare (ignorable o s)) `((prepare-op ,s) (concatenate-source-op ,s)))
+(defmethod component-depends-on ((o compile-concatenated-source-op) (s system))
+  (declare (ignorable o s)) `((concatenate-source-op ,s)))
+(defmethod component-depends-on ((o load-compiled-concatenated-source-op) (s system))
+  (declare (ignorable o s)) `((compile-concatenated-source-op ,s)))
+
+(defmethod component-depends-on ((o monolithic-concatenate-source-op) (s system))
+  (declare (ignorable o s)) nil)
+(defmethod component-depends-on ((o monolithic-load-concatenated-source-op) (s system))
+  (declare (ignorable o s)) `((monolithic-concatenate-source-op ,s)))
+(defmethod component-depends-on ((o monolithic-compile-concatenated-source-op) (s system))
+  (declare (ignorable o s)) `((monolithic-concatenate-source-op ,s)))
+(defmethod component-depends-on ((o monolithic-load-compiled-concatenated-source-op) (s system))
+  (declare (ignorable o s)) `((monolithic-compile-concatenated-source-op ,s)))
+
 ;;;; -----------------------------------------------------------------
 ;;;; Done!
 (when *load-verbose*
diff --git a/test/test-concatenate-source.script b/test/test-concatenate-source.script
new file mode 100644
index 00000000..90f3ee88
--- /dev/null
+++ b/test/test-concatenate-source.script
@@ -0,0 +1,35 @@
+;;; -*- Lisp -*-
+(load "script-support.lisp")
+(load-asdf)
+
+(quit-on-error
+  (defsystem :test-concatenate-source
+    :depends-on (:file3-only)
+    :components
+    ((:file "file2" :depends-on ("foo"))
+     (:module "foo" :pathname ""
+       :components ((:file "file1")
+                    (:file "file4" :if-feature (:not :common-lisp))))))
+  (let ((mcso (asdf::make-operation 'asdf::monolithic-concatenate-source-op))
+        (mccso (asdf::make-operation 'asdf::monolithic-compile-concatenated-source-op))
+        (mlccso (asdf::make-operation 'asdf::monolithic-load-compiled-concatenated-source-op))
+        (sys (find-system :test-concatenate-source)))
+    (assert (asdf::operation-monolithic-p mcso))
+    (assert-equal
+     (input-files mcso sys)
+     (loop :for n :in '(3 1 2)
+           :collect (asdf::subpathname *test-directory* (format nil "file~D.lisp" n))))
+    (assert-equal
+     (output-file mcso sys)
+     (apply-output-translations (asdf::subpathname *test-directory* "test-concatenate-source.lisp")))
+    (assert-equal
+     (output-files mcso sys)
+     (input-files mccso sys))
+    (assert-equal
+     (output-file mccso sys)
+     (apply-output-translations (compile-file-pathname (asdf::subpathname *test-directory* "test-concatenate-source.lisp"))))
+    (assert-equal
+     (output-files mccso sys)
+     (input-files mlccso sys))
+    (operate 'asdf::monolithic-load-compiled-concatenated-source-op sys)
+    (assert (symbol-value (asdf::find-symbol* :*file3* :test-package)))))
-- 
GitLab