From dbe9bc7fb4a909a5ca84a7d1d542ace609b55fc0 Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <fare@tunes.org>
Date: Mon, 30 Nov 2009 06:54:23 -0500
Subject: [PATCH] Merging in ECL support.

---
 asdf-ecl.lisp | 325 ++++++++++++++++++++++++++++++++++++++++++++++++++
 asdf.lisp     |   6 +-
 2 files changed, 329 insertions(+), 2 deletions(-)
 create mode 100644 asdf-ecl.lisp

diff --git a/asdf-ecl.lisp b/asdf-ecl.lisp
new file mode 100644
index 00000000..cb0d72cc
--- /dev/null
+++ b/asdf-ecl.lisp
@@ -0,0 +1,325 @@
+;;; Copyright (c) 2005, Michael Goffioul (michael dot goffioul at swing dot be)
+;;;
+;;;   This program is free software; you can redistribute it and/or
+;;;   modify it under the terms of the GNU Library General Public
+;;;   License as published by the Free Software Foundation; either
+;;;   version 2 of the License, or (at your option) any later version.
+;;;
+;;;   See file '../../Copyright' for full details.
+;;;
+;;; ECL SPECIFIC OPERATIONS FOR ASDF
+;;;
+
+(in-package :asdf)
+(require 'cmp)
+
+;;;
+;;; COMPILE-OP / LOAD-OP
+;;;
+;;; We change these operations to produce both FASL files and the
+;;; object files that they are built from. Having both of them allows
+;;; us to later on reuse the object files for bundles, libraries,
+;;; standalone executables, etc.
+;;;
+
+(defmethod initialize-instance :after ((instance compile-op) &key &allow-other-keys)
+  (setf (slot-value instance 'flags) '(:system-p t)))
+
+(defmethod output-files ((o compile-op) (c cl-source-file))
+  (list (compile-file-pathname (component-pathname c) :type :object)
+        (compile-file-pathname (component-pathname c) :type :fasl)))
+
+(defmethod perform :after ((o compile-op) (c cl-source-file))
+  ;; Note how we use OUTPUT-FILES to find the binary locations
+  ;; This allows the user to override the names.
+  (let* ((input (output-files o c))
+	 (output (compile-file-pathname (first input) :type :fasl)))
+    (c:build-fasl output :lisp-files (remove "fas" input :key #'pathname-type :test #'string=))))
+
+(defmethod perform ((o load-op) (c cl-source-file))
+  (loop for i in (input-files o c)
+       unless (string= (pathname-type i) "fas")
+       collect (let ((output (compile-file-pathname i)))
+                 (load output))))
+
+;;;
+;;; BUNDLE-OP
+;;;
+;;; This operation takes all components from one or more systems and
+;;; creates a single output file, which may be a FASL, a statically
+;;; linked library, a shared library, etc The different targets are
+;;; defined by specialization.
+;;;
+
+(defclass bundle-op (operation)
+  ((type :reader bundle-op-type)
+   (monolithic :initform nil :reader bundle-op-monolithic-p)
+   (name-suffix :initarg :name-suffix :initform nil)
+   (build-args :initarg :args :initform nil :accessor bundle-op-build-args)))
+
+(defclass fasl-op (bundle-op)
+  ((type :initform :fasl)))
+
+(defclass lib-op (bundle-op)
+  ((type :initform :lib)))
+
+(defclass dll-op (bundle-op)
+  ((type :initform :dll)))
+
+(defclass monolithic-bundle-op (bundle-op)
+  ((monolithic :initform t)
+   (prologue-code :accessor monolithic-op-prologue-code)
+   (epilogue-code :accessor monolithic-op-epilogue-code)))
+
+(defclass monolithic-fasl-op (fasl-op monolithic-bundle-op) ())
+
+(defclass monolithic-lib-op (lib-op monolithic-bundle-op)
+  ((type :initform :lib)))
+
+(defclass monolithic-dll-op (dll-op monolithic-bundle-op)
+  ((type :initform :dll)))
+
+(defclass program-op (monolithic-bundle-op)
+  ((type :initform :program)))
+
+(defmethod initialize-instance :after ((instance bundle-op) &rest initargs
+				       &key (name-suffix nil name-suffix-p)
+				       &allow-other-keys)
+  (unless name-suffix-p
+    (setf (slot-value instance 'name-suffix)
+	  (if (bundle-op-monolithic-p instance) "-mono" "")))
+  (when (typep instance 'monolithic-bundle-op)
+    (destructuring-bind (&rest original-initargs
+                         &key prologue-code epilogue-code &allow-other-keys)
+        (slot-value instance 'original-initargs)
+      (setf (slot-value instance 'original-initargs)
+            (remove-keys '(epilogue-code prologue-code) original-initargs)
+            (monolithic-op-prologue-code instance) prologue-code
+            (monolithic-op-epilogue-code instance) epilogue-code)))
+  (setf (bundle-op-build-args instance)
+	(remove-keys '(type monolithic name-suffix)
+		     (slot-value instance 'original-initargs))))
+
+(defvar *force-load-p* nil)
+
+(defmethod operation-done-p :around ((operation load-op) c)
+  (if *force-load-p* nil (call-next-method)))
+
+(defun gather-components (op-type system &key filter-system filter-type include-self)
+  ;; This function creates a list of components, matched together with an
+  ;; operation. This list may be restricted to sub-components of SYSTEM if
+  ;; GATHER-ALL = NIL (default), and it may include the system itself.
+  (let* ((operation (make-instance op-type))
+         (*force-load-p* t)
+         (tree (traverse (make-instance 'load-op) system)))
+    (append
+     (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
+		  (when (eq component system) (setf include-self nil))
+		  (cons operation component)))
+     (and include-self (list (cons operation system))))))
+
+;;;
+;;; BUNDLE-SUB-OPERATIONS
+;;;
+;;; Builds a list of pairs (operation . component) which contains all the
+;;; dependencies of this bundle. This list is used by TRAVERSE and also
+;;; by INPUT-FILES. The dependencies depend on the strategy, as explained
+;;; below.
+;;;
+(defgeneric bundle-sub-operations (operation component))
+;;;
+;;; First we handle monolithic bundles. These are standalone systems
+;;; which contain everything, including other ASDF systems required
+;;; by the current one. A PROGRAM is always monolithic.
+;;;
+;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL
+;;;
+;;; Gather the static libraries of all components.
+;;;
+(defmethod bundle-sub-operations ((o monolithic-bundle-op) c)
+  (gather-components 'lib-op c :filter-type 'system :include-self t))
+;;;
+;;; STATIC LIBRARIES
+;;;
+;;; Gather the object files of all components and, if monolithic, also
+;;; of systems and subsystems.
+;;;
+(defmethod bundle-sub-operations ((o lib-op) c)
+  (gather-components 'compile-op c
+		     :filter-system (and (not (bundle-op-monolithic-p o)) c)
+		     :filter-type '(not system)))
+;;;
+;;; SHARED LIBRARIES
+;;;
+;;; Gather the dynamically linked libraries of all components.
+;;; They will be linked into this new shared library, together
+;;; with the static library of this module.
+;;;
+(defmethod bundle-sub-operations ((o dll-op) c)
+  (list (cons (make-instance 'lib-op) c)))
+;;;
+;;; FASL FILES
+;;;
+;;; Gather the statically linked library of this component.
+;;;
+(defmethod bundle-sub-operations ((o fasl-op) c)
+  (list (cons (make-instance 'lib-op) c)))
+
+(defmethod component-depends-on ((o bundle-op) (c system))
+  (loop for (op . dep) in (bundle-sub-operations o c)
+     when (typep dep 'system)
+     collect (list (class-name (class-of op))
+		   (component-name dep))))
+
+(defmethod component-depends-on ((o lib-op) (c system))
+  (list (list 'compile-op (component-name c))))
+
+(defmethod component-depends-on ((o bundle-op) c)
+  nil)
+
+(defmethod input-files ((o bundle-op) (c system))
+  (loop for (sub-op . sub-c) in (bundle-sub-operations o c)
+     nconc (output-files sub-op sub-c)))
+
+(defmethod output-files ((o bundle-op) (c system))
+  (let ((name (concatenate 'base-string (component-name c)
+			   (slot-value o 'name-suffix))))
+    (list (merge-pathnames (compile-file-pathname name :type (bundle-op-type o))
+			   (component-relative-pathname c)))))
+
+(defmethod output-files ((o fasl-op) (c system))
+  (loop for file in (call-next-method)
+     collect (make-pathname :type "fasb" :defaults file)))
+
+(defmethod perform ((o bundle-op) (c t))
+  t)
+
+(defmethod operation-done-p ((o bundle-op) (c source-file))
+  t)
+
+(defmethod perform ((o bundle-op) (c system))
+  (let* ((object-files (remove "fas" (input-files o c) :key #'pathname-type :test #'string=))
+	 (output (output-files o c)))
+    (ensure-directories-exist (first output))
+    (apply #'c::builder (bundle-op-type o) (first output) :lisp-files object-files
+	   (append (bundle-op-build-args o)
+                   (when (and (typep o 'monolithic-bundle-op)
+                              (monolithic-op-prologue-code o))
+                     `(:prologue-code ,(monolithic-op-prologue-code o)))
+                   (when (and (typep o 'monolithic-bundle-op)
+                              (monolithic-op-epilogue-code o))
+                     `(:epilogue-code ,(monolithic-op-epilogue-code o)))))))
+
+(defun select-operation (monolithic type)
+  (ecase type
+    ((:dll :shared-library)
+     (if monolithic 'monolithic-dll-op 'dll-op))
+    ((:lib :static-library)
+     (if monolithic 'monolithic-lib-op 'lib-op))
+    ((:fasl)
+     (if monolithic 'monolithic-fasl-op 'fasl-op))
+    ((:program)
+     'program-op)))
+    
+
+(defun make-build (system &rest args &key (monolithic nil) (type :fasl)
+                   &allow-other-keys)
+  (apply #'operate (select-operation monolithic type)
+	 system
+	 (remove-keys '(monolithic type) args)))
+
+;;;
+;;; LOAD-FASL-OP
+;;;
+;;; This is like ASDF's LOAD-OP, but using monolithic fasl files.
+;;;
+
+(defclass load-fasl-op (operation) ())
+
+(defun trivial-system-p (c)
+  (every #'(lambda (c) (typep c 'compiled-file)) (module-components c)))
+
+(defmethod component-depends-on ((o load-fasl-op) (c system))
+  (unless (trivial-system-p c)
+    (subst 'load-fasl-op 'load-op
+           (subst 'fasl-op 'compile-op
+                  (component-depends-on (make-instance 'load-op) c)))))
+
+(defmethod input-files ((o load-fasl-op) (c system))
+  (unless (trivial-system-p c)
+    (output-files (make-instance 'fasl-op) c)))
+
+(defmethod perform ((o load-fasl-op) (c t))
+  nil)
+
+(defmethod perform ((o load-fasl-op) (c system))
+  (let ((l (input-files o c)))
+    (and l
+         (load (first l))
+         (loop for i in (module-components c)
+            do (setf (gethash 'load-op (component-operation-times i))
+                     (get-universal-time))))))
+
+;;;
+;;; PRECOMPILED FILES
+;;;
+;;; This component can be used to distribute ASDF libraries in precompiled
+;;; form. Only useful when the dependencies have also been precompiled.
+;;;
+
+(defclass compiled-file (component) ())
+(defmethod component-relative-pathname ((component compiled-file))
+  (compile-file-pathname
+   (merge-component-relative-pathname
+    (slot-value component 'relative-pathname)
+    (component-name component)
+    "fas")))
+
+(defmethod output-files (o (c compiled-file))
+  nil)
+(defmethod input-files (o (c compiled-file))
+  nil)
+(defmethod perform ((o load-op) (c compiled-file))
+  (load (component-pathname c)))
+(defmethod perform ((o load-fasl-op) (c compiled-file))
+  (load (component-pathname c)))
+(defmethod perform (o (c compiled-file))
+  nil)
+
+;;;
+;;; Final integration steps
+;;;
+
+(export '(make-build load-fasl-op))
+(push '("fasb" . si::load-binary) si::*load-hooks*)
+
+(require 'cmp)
+(defvar *require-asdf-operator* 'load-op)
+
+(defun module-provide-asdf (name)
+  (handler-bind ((style-warning #'muffle-warning))
+    (let* ((*verbose-out* (make-broadcast-stream))
+           (system (asdf:find-system name nil)))
+      (when system
+        (asdf:operate *require-asdf-operator* name)
+        t))))
+
+(defun register-pre-built-system (name)
+  (register-system name (make-instance 'system :name name)))
+
+(setf si::*module-provider-functions*
+      (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)))))
+#+win32 (push '("asd" . si::load-source) si::*load-hooks*)
+(pushnew 'module-provide-asdf ext:*module-provider-functions*)
+(pushnew (translate-logical-pathname "SYS:") *central-registry*)
+
+(provide 'asdf)
diff --git a/asdf.lisp b/asdf.lisp
index c713bdad..fd39e8a8 100644
--- a/asdf.lisp
+++ b/asdf.lisp
@@ -1064,7 +1064,8 @@ to `~a` which is not a directory.~@:>"
    (on-warnings :initarg :on-warnings :accessor operation-on-warnings
                 :initform *compile-file-warnings-behaviour*)
    (on-failure :initarg :on-failure :accessor operation-on-failure
-               :initform *compile-file-failure-behaviour*)))
+               :initform *compile-file-failure-behaviour*)
+   (flags :initarg :system-p :accessor compile-op-flags :initform nil)))
 
 (defmethod perform :before ((operation compile-op) (c source-file))
   (map nil #'ensure-directories-exist (output-files operation c)))
@@ -1080,7 +1081,8 @@ to `~a` which is not a directory.~@:>"
   (let ((source-file (component-pathname c))
         (output-file (car (output-files operation c))))
     (multiple-value-bind (output warnings-p failure-p)
-        (compile-file source-file :output-file output-file)
+        (apply #'compile-file source-file :output-file output-file
+               (compile-op-flags operation))
       (when warnings-p
         (case (operation-on-warnings operation)
           (:warn (warn
-- 
GitLab