(in-package :asdf)
;;;
-;;; COMPILE-OP / LOAD-OP (in asdf.lisp)
-;;;
-;;; In ECL, these operations 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.
-;;;
-
-;;;
;;; 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.
+;;; 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.
;;;
+(defparameter *fasl-type* (pathname-type (compile-file-pathname "foo.lisp"))
+ "pathname TYPE for lisp FASt Loading files")
+
(defclass bundle-op (operation)
((type :reader bundle-op-type)
(monolithic :initform nil :reader bundle-op-monolithic-p)
(declare (ignorable initargs name-suffix))
(unless name-suffix-p
(setf (slot-value instance 'name-suffix)
- (if (bundle-op-monolithic-p instance) "-mono" "")))
+ (if (bundle-op-monolithic-p instance) ".system-and-dependencies" ".system")))
(when (typep instance 'monolithic-bundle-op)
(destructuring-bind (&rest original-initargs
&key prologue-code epilogue-code &allow-other-keys)
(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.
+ ;; 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)))
;;;
;;; 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.
+;;; 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.
+;;; 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
;;;
;;;
;;; STATIC LIBRARIES
;;;
-;;; Gather the object files of all components and, if monolithic, also
-;;; of systems and subsystems.
+;;; 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
;;; 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.
+;;; 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)
(declare (ignorable o))
(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))))
+ (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))
(declare (ignorable o))
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)))
+ (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))
- (declare (ignorable o c))
- (loop for file in (call-next-method)
- collect (make-pathname :type "fasb" :defaults file)))
+ (list (compile-file-pathname
+ (make-pathname
+ :name (strcat (component-name c) (slot-value o 'name-suffix)
+ #|"-" (string-downcase (implementation-type))|#)
+ :type "lisp"
+ :defaults (system-source-directory c))
+ #+ecl :type #+ecl (bundle-op-type o))))
(defmethod perform ((o bundle-op) (c t))
(declare (ignorable o c))
(files (and system (output-files operation system))))
(if (or move-here (and (null move-here-p)
(member operation-name '(:program :binary))))
- (loop with dest-path = (truename (ensure-directories-exist move-here-path))
- for f in files
- for new-f = (make-pathname :name (pathname-name f)
- :type (pathname-type f)
- :defaults dest-path)
- do (progn
- (when (probe-file new-f)
- (delete-file new-f))
- (rename-file f new-f))
- collect new-f)
+ (loop :with dest-path = (truename (ensure-directories-exist move-here-path))
+ :for f :in files
+ :for new-f = (make-pathname :name (pathname-name f)
+ :type (pathname-type f)
+ :defaults dest-path)
+ :do (progn
+ (when (probe-file new-f)
+ (delete-file new-f))
+ (rename-file f new-f))
+ :collect new-f)
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))
(declare (ignorable o))
(unless (trivial-system-p c)
(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))))))
+ (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.
+;;; This component can be used to distribute ASDF systems in precompiled form.
+;;; Only useful when the dependencies have also been precompiled.
;;;
(defclass compiled-file (component) ())
+
+(defun trivial-system-p (c)
+ (every #'(lambda (c) (typep c 'compiled-file)) (module-components c)))
+
(defmethod component-relative-pathname ((component compiled-file))
(compile-file-pathname
(coerce-pathname
(or (slot-value component 'relative-pathname)
(component-name component))
- :type "fas")))
+ :type *fasl-type*)))
(defmethod output-files (o (c compiled-file))
(declare (ignore o c))
(defmethod output-files ((o lib-op) (c prebuilt-system))
(declare (ignore o))
- (values (list (compile-file-pathname (prebuilt-system-static-library c)
- :type :lib))
- t ; Advertise that we do not want this path renamed
- ))
+ (values (list (merge-pathnames* (compile-file-pathname (prebuilt-system-static-library c)
+ #+ecl :type #+ecl :lib)
+ (system-source-directory c)))
+ t)) ; We do not want this path renamed by asdf-output-translations
(defmethod perform ((o lib-op) (c prebuilt-system))
- (car (output-files o c)))
+ (first (output-files o c)))
(defmethod component-depends-on ((o lib-op) (c prebuilt-system))
(declare (ignorable o c))
s))))
(defmethod component-depends-on ((o binary-op) (s system))
- (loop for dep in (binary-op-dependencies o s)
- append (apply #'component-depends-on dep)))
+ (loop :for dep :in (binary-op-dependencies o s)
+ :append (apply #'component-depends-on dep)))
(defmethod input-files ((o binary-op) (s system))
- (loop for dep in (binary-op-dependencies o s)
- append (apply #'input-files dep)))
+ (loop :for dep :in (binary-op-dependencies o s)
+ :append (apply #'input-files dep)))
(defmethod output-files ((o binary-op) (s system))
(list* (merge-pathnames* (make-pathname :name (component-name s)
:type "asd")
(component-relative-pathname s))
- (loop for dep in (binary-op-dependencies o s)
- append (apply #'output-files dep))))
+ (loop :for dep :in (binary-op-dependencies o s)
+ :append (apply #'output-files dep))))
(defmethod perform ((o binary-op) (s system))
(let* ((dependencies (binary-op-dependencies o s))
(filename (first (output-files o s)))
(name (component-name s))
(name-keyword (intern (string name) (find-package :keyword))))
- (loop for dep in dependencies
- do (apply #'perform dep))
+ (dolist (dep dependencies)
+ (apply #'perform dep))
(with-open-file (s filename :direction :output :if-exists :supersede
:if-does-not-exist :create)
(format s ";;; Prebuilt ASDF definition for system ~A" name)
:lib ,(make-pathname :name (pathname-name library)
:type (pathname-type library)))
s)))))
-
--- /dev/null
+;;; -*- Mode: Lisp ; Syntax: ANSI-Common-Lisp -*-
+
+#+xcvb (module (:depends-on ("bundle")))
+
+(in-package :asdf)
+
+(declaim (optimize (debug 3) (safety 3) (speed 1)))
+
+(defun concatenate-files (inputs output)
+ (let ((infiles (mapcar #'sb-ext:native-namestring inputs))
+ (outfile (sb-ext:native-namestring output)))
+ (assert
+ (= 0 (sb-ext:process-exit-code
+ #+win32
+ (sb-ext:run-program
+ "copy" `("/b" ,@(loop :for (i . morep) :on infiles
+ :collect i :when morep :collect "+") ,output)
+ :input nil :output nil :error nil :wait t)
+ #-win32
+ (sb-ext:run-program
+ "cat" infiles :output outfile
+ :if-output-exists :supersede :external-format :latin1
+ :input nil :error nil :search t :wait t))))))
+
+(defun combine-fasls (inputs outputs)
+ (assert (length=n-p outputs 1))
+ (ensure-directories-exist (first outputs))
+ (concatenate-files inputs (first outputs)))
+
+(defmethod perform ((o bundle-op) (c system))
+ (let* ((input-files (input-files o c))
+ (fasl-files (remove "fasl" input-files :key #'pathname-type :test-not #'string=))
+ (non-fasl-files (remove "fasl" input-files :key #'pathname-type :test #'string=))
+ (output-files (output-files o c))
+ (output-file (first output-files)))
+ (when input-files
+ (assert output-files)
+ (when non-fasl-files
+ (error "On SBCL, asdf-bundle can only bundle FASL files, but these were also produced: ~S" non-fasl-files))
+ (when (and (typep o 'monolithic-bundle-op)
+ (or (monolithic-op-prologue-code o) (monolithic-op-epilogue-code o)))
+ (error "prologue-code and epilogue-code are not supported on SBCL"))
+ (ensure-directories-exist output-file)
+ (combine-fasls fasl-files output-files))))
+
+
+;;; On SBCL, everything happens in the lib-op dependency
+(defmethod output-files ((o fasl-op) (c component))
+ (declare (ignorable o c))
+ nil)
+
+(defmethod input-files ((o fasl-op) (c component))
+ (declare (ignorable o c))
+ nil)
common-lisp.net / projects/asdf/asdf-bundle.git / commitdiff
