Commit dbe9bc7f authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

Merging in ECL support.

parent 1f7690b4
;;; 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.
(in-package :asdf)
(require 'cmp)
;;; 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))))
;;; 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)
(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)))
(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))))))
;;; 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.
;;; 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))
;;; 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)))
;;; 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)))
;;; 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)
(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))
(defmethod operation-done-p ((o bundle-op) (c source-file))
(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))
(if monolithic 'monolithic-fasl-op 'fasl-op))
(defun make-build (system &rest args &key (monolithic nil) (type :fasl)
(apply #'operate (select-operation monolithic type)
(remove-keys '(monolithic type) args)))
;;; 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))
(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))
;;; 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))
(slot-value component 'relative-pathname)
(component-name component)
(defmethod output-files (o (c compiled-file))
(defmethod input-files (o (c compiled-file))
(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))
;;; 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)
(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)
......@@ -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
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment