From ff4520a3edef4003d767e793890f489e772a1b3e Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <fare@tunes.org>
Date: Sun, 6 Feb 2011 17:30:35 -0500
Subject: [PATCH] 2.012.6: Another pass at refactoring ECL support, based on a
 patch by Juanjo

---
 asdf-ecl.lisp | 46 +++++++++++++++++++++++++++++++++++++---------
 asdf.asd      |  2 +-
 asdf.lisp     | 35 +++++++++--------------------------
 3 files changed, 47 insertions(+), 36 deletions(-)

diff --git a/asdf-ecl.lisp b/asdf-ecl.lisp
index 3cf85751..1d8e43be 100644
--- a/asdf-ecl.lisp
+++ b/asdf-ecl.lisp
@@ -12,7 +12,36 @@
 #+xcvb (module (:depends-on ("asdf")))
 
 (in-package :asdf)
-(require :cmp)
+
+;;;
+;;; We rewrite a subset of ASDF functions so that instead of generating one
+;;; FASL file per lisp file, ASDF creates an object file and a FASL file. The
+;;; object file is reused by the extensions below.
+;;;
+
+(setf *compile-op-compile-file-function*
+      (lambda (input-file &rest keys &key output-file &allow-other-keys)
+        (declare (ignore output-file))
+        (multiple-value-bind (object-file flags1 flags2)
+            (apply #'compile-file* input-file :system-p t keys)
+          (values (and object-file
+                       (c::build-fasl (compile-file-pathname object-file :type :fasl)
+                                      :lisp-files (list object-file))
+                       object-file)
+                  flags1
+                  flags2))))
+
+(defmethod output-files ((operation compile-op) (c cl-source-file))
+  (declare (ignorable operation))
+  (let ((p (lispize-pathname (component-pathname c))))
+    (list (compile-file-pathname p :type :object)
+          (compile-file-pathname p :type :fasl))))
+
+(defmethod perform ((o load-op) (c cl-source-file))
+  (map () #'load
+       (loop :for i :in (input-files o c)
+          :unless (string= (pathname-type i) "fas")
+          :collect (compile-file-pathname (lispize-pathname i)))))
 
 ;;;
 ;;; COMPILE-OP / LOAD-OP
@@ -96,11 +125,11 @@
          (*force-load-p* t)
          (tree (traverse (make-instance 'load-op) system)))
     (append
-     (loop for (op . component) in tree
-        when (and (typep op 'load-op)
+     (loop :for (op . component) :in tree
+       :when (and (typep op 'load-op)
                   (typep component filter-type)
                   (or (not filter-system) (eq (component-system component) filter-system)))
-        collect (progn
+       :collect (progn
                   (when (eq component system) (setf include-self nil))
                   (cons operation component)))
      (and include-self (list (cons operation system))))))
@@ -414,7 +443,6 @@
 (export '(make-build load-fasl-op prebuilt-system))
 (push '("fasb" . si::load-binary) si::*load-hooks*)
 
-(require 'cmp)
 (defvar *require-asdf-operator* 'load-op)
 
 (defun module-provide-asdf (name)
@@ -430,9 +458,9 @@
                                        :source-file nil)))
 
 (setf si::*module-provider-functions*
-      (loop for f in si::*module-provider-functions*
-         unless (eq f 'module-provide-asdf)
-         collect #'(lambda (name)
+      (loop :for f :in si::*module-provider-functions*
+        :unless (eq f 'module-provide-asdf)
+        :collect #'(lambda (name)
                      (let ((l (multiple-value-list (funcall f name))))
                        (and (first l) (register-pre-built-system name))
                        (values-list l)))))
@@ -440,4 +468,4 @@
 (pushnew 'module-provide-asdf ext:*module-provider-functions*)
 (pushnew (translate-logical-pathname "SYS:") *central-registry*)
 
-(provide 'asdf)
+(provide :asdf)
diff --git a/asdf.asd b/asdf.asd
index 9699e2a5..38c84b76 100644
--- a/asdf.asd
+++ b/asdf.asd
@@ -12,7 +12,7 @@
   :licence "MIT"
   :description "Another System Definition Facility"
   :long-description "ASDF builds Common Lisp software organized into defined systems."
-  :version "2.012.5" ;; to be automatically updated by bin/bump-revision
+  :version "2.012.6" ;; to be automatically updated by bin/bump-revision
   :depends-on ()
   :components
   ((:file "asdf")
diff --git a/asdf.lisp b/asdf.lisp
index c6ad0bc3..3c1c873f 100644
--- a/asdf.lisp
+++ b/asdf.lisp
@@ -1,5 +1,5 @@
 ;;; -*- mode: common-lisp; package: asdf; -*-
-;;; This is ASDF 2.012.5: Another System Definition Facility.
+;;; This is ASDF 2.012.6: Another System Definition Facility.
 ;;;
 ;;; Feedback, bug reports, and patches are all welcome:
 ;;; please mail to <asdf-devel@common-lisp.net>.
@@ -83,7 +83,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.012.5")
+         (asdf-version "2.012.6")
          (existing-asdf (fboundp 'find-system))
          (existing-version *asdf-version*)
          (already-there (equal asdf-version existing-version)))
@@ -767,8 +767,6 @@ with given pathname and if it exists return its truename."
                             :directory `(:absolute ,@path))))
         (translate-pathname absolute-pathname wild-root (wilden new-base))))))
 
-(defgeneric* compile-file* (x &key output-file &allow-other-keys))
-
 ;;;; -------------------------------------------------------------------------
 ;;;; ASDF Interface, in terms of generic functions.
 (defgeneric* find-system (system &optional error-p))
@@ -1907,6 +1905,9 @@ recursive calls to traverse.")
   (setf (gethash (type-of operation) (component-operation-times c))
         (get-universal-time)))
 
+(defvar *compile-op-compile-file-function* 'compile-file*
+  "Function used to compile lisp files.")
+
 ;;; 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 ((operation compile-op) (c cl-source-file))
@@ -1918,7 +1919,7 @@ recursive calls to traverse.")
         (*compile-file-warnings-behaviour* (operation-on-warnings operation))
         (*compile-file-failure-behaviour* (operation-on-failure operation)))
     (multiple-value-bind (output warnings-p failure-p)
-        (apply #'compile-file* source-file :output-file output-file
+        (apply *compile-op-compile-file-function* source-file :output-file output-file
                (compile-op-flags operation))
       (when warnings-p
         (case (operation-on-warnings operation)
@@ -1940,9 +1941,7 @@ recursive calls to traverse.")
 (defmethod output-files ((operation compile-op) (c cl-source-file))
   (declare (ignorable operation))
   (let ((p (lispize-pathname (component-pathname c))))
-    #-broken-fasl-loader
-    (list (compile-file-pathname p #+ecl :type #+ecl :object)
-          #+ecl (compile-file-pathname p :type :fasl))
+    #-broken-fasl-loader (list (compile-file-pathname p))
     #+broken-fasl-loader (list p)))
 
 (defmethod perform ((operation compile-op) (c static-file))
@@ -1969,11 +1968,7 @@ recursive calls to traverse.")
 (defclass load-op (basic-load-op) ())
 
 (defmethod perform ((o load-op) (c cl-source-file))
-  (map () #'load
-       #-ecl (input-files o c)
-       #+ecl (loop :for i :in (input-files o c)
-               :unless (string= (pathname-type i) "fas")
-               :collect (compile-file-pathname (lispize-pathname i)))))
+  (map () #'load (input-files o c)))
 
 (defmethod perform-with-restarts (operation component)
   (perform operation component))
@@ -3193,7 +3188,7 @@ effectively disabling the output translation facility."
   (when (and x (probe-file x))
     (delete-file x)))
 
-(defmethod compile-file* (input-file &rest keys &key output-file &allow-other-keys)
+(defun* compile-file* (input-file &rest keys &key output-file &allow-other-keys)
   (let* ((output-file (or output-file (apply 'compile-file-pathname* input-file keys)))
          (tmp-file (tmpize-pathname output-file))
          (status :error))
@@ -3217,18 +3212,6 @@ effectively disabling the output translation facility."
          (setf output-truename nil)))
       (values output-truename warnings-p failure-p))))
 
-#+(and ecl (not ecl-bytecmp))
-(defmethod compile-file* :around (input-file &rest keys &key output-file &allow-other-keys)
-  (declare (ignore output-file))
-  (multiple-value-bind (object-file flags1 flags2)
-      (apply #'call-next-method input-file :system-p t keys)
-    (values (and object-file
-                 (c::build-fasl (compile-file-pathname object-file :type :fasl)
-                                :lisp-files (list object-file))
-                           object-file)
-            flags1
-            flags2)))
-
 #+abcl
 (defun* translate-jar-pathname (source wildcard)
   (declare (ignore wildcard))
-- 
GitLab