diff --git a/contrib/asdf-bundle/.gitignore b/contrib/asdf-bundle/.gitignore deleted file mode 100644 index f1981605f01cc72a254c16b1a645cf74139fd9be..0000000000000000000000000000000000000000 --- a/contrib/asdf-bundle/.gitignore +++ /dev/null @@ -1 +0,0 @@ -workspace \ No newline at end of file diff --git a/contrib/asdf-bundle/bundle.lisp b/contrib/asdf-bundle/bundle.lisp deleted file mode 100644 index d5efa5dbbbf55de5f0c3f9807abb04cb55ff9f17..0000000000000000000000000000000000000000 --- a/contrib/asdf-bundle/bundle.lisp +++ /dev/null @@ -1,405 +0,0 @@ -;;; -*- Mode: Lisp ; Syntax: ANSI-Common-Lisp -*- - -#+xcvb (module ()) - -(in-package :asdf) - -#+mkcl -(eval-when (:compile-toplevel :load-toplevel :execute) - ;; Make sure we have strict ANSI class redefinition semantics. - (setq clos::*redefine-class-in-place* t)) - -;;; -;;; 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. -;;; - -(defparameter *fasl-type* (pathname-type (compile-file-pathname "foo.lisp")) - "pathname TYPE for lisp FASt Loading files") - -(defclass bundle-op (operation) - ((build-args :initarg :args :initform nil :accessor bundle-op-build-args) - #+ecl (type :reader bundle-op-type) - #+ecl (name-suffix :initarg :name-suffix :initform nil) - #+ecl (lisp-files :initform nil :accessor bundle-op-lisp-files) - #+mkcl (do-fasb :initarg :do-fasb :initform t :reader bundle-op-do-fasb-p) - #+mkcl (do-static-library :initarg :do-static-library :initform t :reader bundle-op-do-static-library-p))) - -(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) - ((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)) - -(defclass monolithic-fasl-op (monolithic-bundle-op fasl-op) ()) - -(defclass monolithic-lib-op (monolithic-bundle-op lib-op) - ((type :initform :lib))) - -(defclass monolithic-dll-op (monolithic-bundle-op dll-op) - ((type :initform :dll))) - -(defclass program-op (monolithic-bundle-op) - ((type :initform :program))) - -#+ecl (monolithic :initform nil :reader bundle-op-monolithic-p) - -#+ecl -(defmethod initialize-instance :after ((instance bundle-op) &rest initargs - &key (name-suffix nil name-suffix-p) - &allow-other-keys) - (declare (ignorable initargs name-suffix)) - (unless name-suffix-p - (setf (slot-value instance 'name-suffix) - (if (bundle-op-monolithic-p instance) ".system-and-dependencies" ".system"))) - (when (typep instance 'monolithic-bundle-op) - (destructuring-bind (&rest original-initargs - &key lisp-files prologue-code epilogue-code - &allow-other-keys) - (slot-value instance 'original-initargs) - (setf (slot-value instance 'original-initargs) - (remove-keys '(lisp-files epilogue-code prologue-code) original-initargs) - (bundle-op-lisp-files instance) lisp-files - (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)))) - -(defmethod bundle-op-build-args :around ((op lib-op)) - (declare (ignorable op)) - (let ((args (call-next-method))) - (remf args :ld-flags) - args)) - -(defvar *force-load-p* nil) - -(defmethod operation-done-p :around ((operation load-op) c) - (declare (ignorable operation 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) - (declare (ignorable o)) - (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))) -(defmethod bundle-sub-operations ((o monolithic-lib-op) c) - (declare (ignorable o)) - (gather-components 'compile-op c - :filter-system nil - :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) - (declare (ignorable o)) - (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) - (declare (ignorable o)) - (list (cons (make-instance 'lib-op) c))) - -#-mkcl -(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)) - (declare (ignorable o)) - (list (list 'compile-op (component-name c)))) - -(defmethod component-depends-on ((o bundle-op) c) - (declare (ignorable o c)) - nil) - -#-mkcl -(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))) - -#-mkcl -(defmethod output-files ((o bundle-op) (c system)) - (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)) - t) - -(defmethod operation-done-p ((o bundle-op) (c source-file)) - (declare (ignorable o c)) - t) - -(defun select-operation (monolithic type) - (ecase type - ((:binary) - (if monolithic 'monolithic-binary-op 'binary-op)) - ((: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) - (move-here nil move-here-p) - &allow-other-keys) - (let* ((operation-name (select-operation monolithic type)) - (move-here-path (if (and move-here - (typep move-here '(or pathname string))) - (pathname move-here) - (merge-pathnames "./asdf-output/"))) - (operation (apply #'operate operation-name - system - (remove-keys '(monolithic type move-here) args))) - (system (find-system system)) - (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) - files))) - -;;; -;;; LOAD-FASL-OP -;;; -;;; This is like ASDF's LOAD-OP, but using monolithic fasl files. -;;; - -(defclass load-fasl-op (operation) ()) - -(defmethod component-depends-on ((o load-fasl-op) (c system)) - (declare (ignorable o)) - (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)) - (declare (ignore o)) - (unless (trivial-system-p c) - (output-files (make-instance 'fasl-op) c))) - -(defmethod perform ((o load-fasl-op) (c t)) - (declare (ignore o c)) - 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 systems in precompiled form. -;;; Only useful when the dependencies have also been precompiled. -;;; - -(defclass compiled-file (component) - ((type :initform nil))) - -(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 *fasl-type*))) - -(defmethod output-files (o (c compiled-file)) - (declare (ignore o c)) - nil) -(defmethod input-files (o (c compiled-file)) - (declare (ignore o c)) - nil) -(defmethod perform ((o load-op) (c compiled-file)) - (declare (ignore o)) - (load (component-pathname c))) -(defmethod perform ((o load-fasl-op) (c compiled-file)) - (declare (ignore o)) - (load (component-pathname c))) -(defmethod perform (o (c compiled-file)) - (declare (ignore o c)) - nil) - -;;; -;;; Pre-built systems -;;; -(defclass prebuilt-system (system) - ((static-library :accessor prebuilt-system-static-library :initarg :lib))) - -(defmethod output-files ((o lib-op) (c prebuilt-system)) - (declare (ignore o)) - (values (list (prebuilt-system-static-library c)) - t)) ; Advertise that we do not want this path renamed by asdf-output-translations - -(defmethod perform ((o lib-op) (c prebuilt-system)) - (first (output-files o c))) - -(defmethod component-depends-on ((o lib-op) (c prebuilt-system)) - (declare (ignorable o c)) - nil) - -(defmethod bundle-sub-operations ((o lib-op) (c prebuilt-system)) - (declare (ignorable o c)) - nil) - -(defmethod bundle-sub-operations ((o monolithic-lib-op) (c prebuilt-system)) - (declare (ignorable o)) - (error "Prebuilt system ~S shipped with ECL can not be used in a monolithic library operation." c)) - -(defmethod bundle-sub-operations ((o monolithic-bundle-op) (c prebuilt-system)) - (declare (ignorable o c)) - nil) - -;;; -;;; PREBUILT SYSTEM CREATOR -;;; - -(defclass binary-op (bundle-op) - ()) - -(defclass monolithic-binary-op (binary-op monolithic-bundle-op) - ()) - -(defun binary-op-dependencies (o s) - (multiple-value-bind (lib-op fasl-op) - (if (bundle-op-monolithic-p o) - (values 'monolithic-lib-op 'monolithic-fasl-op) - (values 'lib-op 'fasl-op)) - (list (list (make-instance lib-op :args (bundle-op-build-args o)) - s) - (list (make-instance fasl-op :args (bundle-op-build-args o)) - 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))) - -(defmethod input-files ((o binary-op) (s system)) - (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)))) - -(defmethod perform ((o binary-op) (s system)) - (let* ((dependencies (binary-op-dependencies o s)) - (library (first (apply #'output-files (first dependencies)))) - (fasl (first (apply #'output-files (second dependencies)))) - (filename (first (output-files o s))) - (name (component-name s)) - (name-keyword (intern (string name) (find-package :keyword)))) - (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) - (format s ";;; Built for ~A ~A on a ~A/~A ~A" - (lisp-implementation-type) - (lisp-implementation-version) - (software-type) - (machine-type) - (software-version)) - (let ((*package* (find-package :keyword))) - (pprint `(defsystem ,name-keyword - :class asdf::prebuilt-system - :components ((:compiled-file ,(pathname-name fasl))) - :lib ,(make-pathname :name (pathname-name library) - :type (pathname-type library))) - s))))) diff --git a/contrib/asdf-bundle/ecl.lisp b/contrib/asdf-bundle/ecl.lisp deleted file mode 100644 index 7dc2ca4254c8131463d631ec0a4b07f2a6ff0c2a..0000000000000000000000000000000000000000 --- a/contrib/asdf-bundle/ecl.lisp +++ /dev/null @@ -1,34 +0,0 @@ -;;; -*- Mode: Lisp ; Syntax: ANSI-Common-Lisp -*- - -#+xcvb (module (:depends-on ("specials"))) - -(in-package :asdf) - -(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))) - -(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 (append object-files (bundle-op-lisp-files o)) - (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))))))) - - -;;; -;;; Final integration steps -;;; - -(export '(make-build load-fasl-op)) - -(pushnew '("fasb" . si::load-binary) ext:*load-hooks* :test 'equal :key 'car) diff --git a/contrib/asdf-bundle/fasl-concat.lisp b/contrib/asdf-bundle/fasl-concat.lisp deleted file mode 100644 index 612730ee69fbe3e97b160ce0411dc6903a254c99..0000000000000000000000000000000000000000 --- a/contrib/asdf-bundle/fasl-concat.lisp +++ /dev/null @@ -1,75 +0,0 @@ -;;; -*- Mode: Lisp ; Syntax: ANSI-Common-Lisp -*- - -#+xcvb (module (:depends-on ("bundle"))) - -(in-package :asdf) - -(declaim (optimize (debug 3) (safety 3) (speed 1))) - -#+sbcl -(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 output) - #+ccl (ccl:fasl-concatenate output inputs :if-exists :supersede) - #+sbcl (concatenate-files inputs output)) - -(defun call-with-staging-pathname (pathname fun) - "Calls fun with a staging pathname, and atomically -renames the staging pathname to the pathname in the end. -Note: this protects only against failure of the program, -not against concurrent attempts. -For the latter case, we ought pick random suffix and atomically open it." - (let* ((pathname (pathname pathname)) - (staging (make-pathname - :name (strcat (pathname-name pathname) "-staging") - :defaults pathname))) - (unwind-protect - (multiple-value-prog1 - (funcall fun staging) - (rename-file staging pathname #+clozure :if-exists #+clozure :rename-and-delete)) - (when (probe-file* staging) - (delete-file staging))))) - -(defmacro with-staging-pathname ((pathname-var &optional (pathname-value pathname-var)) &body body) - `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body))) - -(defmethod perform ((o bundle-op) (c system)) - (let* ((input-files (input-files o c)) - (fasl-files (remove *fasl-type* input-files :key #'pathname-type :test-not #'string=)) - (non-fasl-files (remove *fasl-type* 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 ~A, asdf-bundle can only bundle FASL files, but these were also produced: ~S" - (implementation-type) 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 ~A" - (implementation-type))) - (ensure-directories-exist output-file) - (with-staging-pathname (output-file) - (combine-fasls fasl-files output-file))))) - -(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) diff --git a/contrib/asdf-bundle/mkcl.lisp b/contrib/asdf-bundle/mkcl.lisp deleted file mode 100644 index 60fc1b1bf170b6a86ffcadb8a8f0427eacddd2fb..0000000000000000000000000000000000000000 --- a/contrib/asdf-bundle/mkcl.lisp +++ /dev/null @@ -1,80 +0,0 @@ -;;; -*- Mode: Lisp ; Syntax: ANSI-Common-Lisp -*- - -#+xcvb (module (:depends-on ("specials"))) - -(in-package :asdf) - -(eval-when (:compile-toplevel :load-toplevel :execute) - ;; Make sure we have strict ANSI class redefinition semantics. - (setq clos::*redefine-class-in-place* t)) - -;;; -;;; BUNDLE-SUB-OPERATIONS -;;; -;;; Builds a list of pairs (operation . component) which contains all the -;;; dependencies of this bundle. -;;; - -(defun mkcl-bundle-sub-operations (sys) - (gather-components 'compile-op sys - :filter-system sys - :filter-type '(not system))) - -(defun files-to-bundle (sys) - (loop :for (op . comp) :in (mkcl-bundle-sub-operations sys) - :for sub-files = (output-files op comp) - :when sub-files - :collect (first sub-files))) - -(defmethod component-depends-on ((o bundle-op) (c system)) - (cons `(compile-op ,(component-name c)) (call-next-method))) - -(defmethod output-files ((o bundle-op) (c system)) - (let* ((name (component-name c)) - (static-lib-name (merge-pathnames - (compiler::builder-internal-pathname name :static-library) - (component-relative-pathname c))) - (fasl-bundle-name (merge-pathnames - (compiler::builder-internal-pathname name :fasb) - (component-relative-pathname c)))) - (list static-lib-name fasl-bundle-name))) - -(defmethod perform ((o bundle-op) (c system)) - (let* ((object-files (files-to-bundle c)) - (output (output-files o c))) - (ensure-directories-exist (first output)) - (when (bundle-op-do-static-library-p o) - (apply #'compiler::build-static-library (first output) - :lisp-object-files object-files (bundle-op-build-args o))) - (when (bundle-op-do-fasb-p o) - (apply #'compiler::build-bundle (second output) - :lisp-object-files object-files (bundle-op-build-args o))))) - -(defun bundle-system (system &rest args &key force (verbose t) version &allow-other-keys) - (declare (ignore force verbose version)) - (apply #'operate 'bundle-op system args)) - -(export '(bundle-system)) - - -;;; -;;; BUNDLED FILES -;;; -;;; This component can be used to distribute ASDF libraries in bundled form. -;;; - -(defclass bundle (component) ()) - -(defmethod source-file-type ((c bundle) (s system)) - "fasb") - -(defmethod perform ((o load-op) (c bundle)) - (load (component-pathname c))) - -(defmethod perform (o (c bundle)) - (declare (ignore o)) - nil) - -;; The ability to load a fasb bundle is separate from -;; the ability to build a fasb bundle, so this is somewhat unrelated to what is above. -(pushnew '("fasb" . si::load-binary) si:*load-hooks* :test 'equal :key 'car) diff --git a/contrib/asdf-bundle/specials.lisp b/contrib/asdf-bundle/specials.lisp deleted file mode 100644 index c3e30fc716d00d388eba982a64569ea2b61c3e2e..0000000000000000000000000000000000000000 --- a/contrib/asdf-bundle/specials.lisp +++ /dev/null @@ -1,8 +0,0 @@ -;;; -*- Mode: Lisp ; Syntax: ANSI-Common-Lisp -*- - -#+xcvb (module ()) - -(in-package :asdf) - -(defparameter *fasl-type* (pathname-type (compile-file-pathname "foo.lisp")) - "pathname TYPE for lisp FASt Loading files")