diff --git a/contrib/asdf/bundle.lisp b/contrib/asdf/asdf-bundle.lisp similarity index 60% rename from contrib/asdf/bundle.lisp rename to contrib/asdf/asdf-bundle.lisp index 5b149f4f2..c54a04451 100644 --- a/contrib/asdf/bundle.lisp +++ b/contrib/asdf/asdf-bundle.lisp @@ -25,8 +25,8 @@ (defclass bundle-op (operation) ((build-args :initarg :args :initform nil :accessor bundle-op-build-args) + (name-suffix :initarg :name-suffix :initform nil) #+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))) @@ -58,7 +58,6 @@ (defclass program-op (monolithic-bundle-op) ((type :initform :program))) -#+ecl (defmethod initialize-instance :after ((instance bundle-op) &rest initargs &key (name-suffix nil name-suffix-p) &allow-other-keys) @@ -73,9 +72,10 @@ (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))) + (monolithic-op-epilogue-code instance) epilogue-code) + #-ecl (assert (null lisp-files)) + #+ecl (setf (bundle-op-lisp-files instance) lisp-files))) (setf (bundle-op-build-args instance) (remove-keys '(type monolithic name-suffix) (slot-value instance 'original-initargs)))) @@ -195,7 +195,7 @@ #|"-" (string-downcase (implementation-type))|#) :type "lisp" :defaults (system-source-directory c)) - #+ecl :type #+ecl (bundle-op-type o)))) + #+ecl :type #+ecl (bundle-op-type o)))) (defmethod perform ((o bundle-op) (c t)) (declare (ignorable o c)) @@ -403,3 +403,234 @@ :lib ,(make-pathname :name (pathname-name library) :type (pathname-type library))) s))))) + +(defun copy-stream-to-stream (input output &key (element-type 'character) (buffer-size 8192)) + "Copy the contents of the INPUT stream into the OUTPUT stream, +using WRITE-SEQUENCE and a sensibly sized buffer." ; copied from xcvb-driver + (with-open-stream (input input) + (loop + :for buffer = (make-array (list buffer-size) :element-type element-type) + :for end = (read-sequence buffer input) + :until (zerop end) + :do (write-sequence buffer output :end end) + (when (< end buffer-size) (return))))) + +(defun concatenate-files (inputs output) + (with-open-file (o output :element-type '(unsigned-byte 8) + :direction :output :if-exists :rename-and-delete) + (dolist (input inputs) + (with-open-file (i input :element-type '(unsigned-byte 8) + :direction :input :if-does-not-exist :error) + (copy-stream-to-stream i o :element-type '(unsigned-byte 8)))))) + +(defun* add-pathname-suffix (pathname suffix) + (make-pathname :name (strcat (pathname-name pathname) suffix) + :defaults pathname)) + +(defun combine-fasls (inputs output) + #-(or allegro clisp clozure cmu lispworks sbcl scl) + (declare (ignore inputs output)) + #-(or allegro clisp clozure cmu lispworks sbcl scl) + (error "~S is not supported on ~A" 'combine-fasls (implementation-type)) + #+clozure (ccl:fasl-concatenate output inputs :if-exists :supersede) + #+(or allegro clisp cmu sbcl scl) (concatenate-files inputs output) + #+lispworks + (let (fasls) + (unwind-protect + (progn + (loop :for i :in inputs + :for n :from 1 + :for f = (add-pathname-suffix + output (format nil "-FASL~D" n)) + :do (lispworks:copy-file i f) + (push f fasls)) + (ignore-errors (lispworks:delete-system :fasls-to-concatenate)) + (eval `(scm:defsystem :fasls-to-concatenate + (:default-pathname ,(pathname-directory-pathname output)) + :members + ,(loop :for f :in (reverse fasls) + :collect `(,(namestring f) :load-only t)))) + (scm:concatenate-system output :fasls-to-concatenate)) + (loop :for f :in fasls :do (ignore-errors (delete-file f))) + (ignore-errors (lispworks:delete-system :fasls-to-concatenate))))) + +(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 (add-pathname-suffix pathname "-ASDF-TMP"))) + (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))) + +#-(or ecl mkcl) +(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 source-file)) + (declare (ignorable o c)) + nil) + +(defmethod input-files ((o fasl-op) (c source-file)) + (declare (ignorable o c)) + nil) + +(defclass precompiled-system (system) + ((fasl :initarg :fasl :reader %system-fasl))) + +(defgeneric system-fasl (system) + (:method ((system precompiled-system)) + (let* ((f (%system-fasl system)) + (p (etypecase f + ((or pathname string) f) + (function (funcall f)) + (cons (eval f))))) + (pathname p)))) + +(defmethod input-files ((o load-op) (s precompiled-system)) + (declare (ignorable o)) + (list (system-fasl s))) + +(defmethod perform ((o load-op) (s precompiled-system)) + (declare (ignorable o)) + (load (system-fasl s))) + +(defmethod input-files ((o load-fasl-op) (s precompiled-system)) + (declare (ignorable o)) + (input-files (make-instance 'load-op) s)) + +(defmethod perform ((o load-fasl-op) (s precompiled-system)) + (declare (ignorable o)) + (perform (make-instance 'load-op) s)) + +#| ;; Example use: +(asdf:defsystem :precompiled-asdf-utils :class asdf::precompiled-system :fasl (asdf:apply-output-translations (asdf:system-relative-pathname :asdf-utils "asdf-utils.system.fasl"))) +(asdf:load-system :precompiled-asdf-utils) +|# + +#+ecl +(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))) + +#+ecl +(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))))))) + +#+mkcl +(progn +;;; +;;; 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)) + +;;; +;;; 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. +);mkcl + +;;; +;;; Final integration steps +;;; + +(export '(load-fasl-op precompiled-system + #+ecl make-build #+mkcl bundle-system)) + +#+(or ecl mkcl) +(pushnew '("fasb" . si::load-binary) si:*load-hooks* :test 'equal :key 'car) diff --git a/contrib/asdf/asdf.lisp b/contrib/asdf/asdf.lisp index 283ad86ab..670c0d5b2 100644 --- a/contrib/asdf/asdf.lisp +++ b/contrib/asdf/asdf.lisp @@ -1,5 +1,5 @@ ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*- -;;; This is ASDF 2.26: Another System Definition Facility. +;;; This is ASDF 2.26.6: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to . @@ -118,7 +118,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.26") + (asdf-version "2.26.6") (existing-asdf (find-class 'component nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) @@ -215,10 +215,10 @@ (ensure-package (name &key nicknames use unintern shadow export redefined-functions) (let* ((p (ensure-exists name nicknames use))) - (ensure-unintern p (append unintern #+cmu redefined-functions)) + (ensure-unintern p unintern) (ensure-shadow p shadow) (ensure-export p export) - #-cmu (ensure-fmakunbound p redefined-functions) + (ensure-fmakunbound p redefined-functions) p))) (macrolet ((pkgdcl (name &key nicknames use export @@ -411,7 +411,7 @@ Defaults to T.") Valid values are :error, :warn, and :ignore.") (defvar *compile-file-failure-behaviour* - (or #+sbcl :error #+clisp :ignore :warn) + (or #+(or mkcl sbcl) :error #+clisp :ignore :warn) "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE) when compiling a file? Valid values are :error, :warn, and :ignore. Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.") @@ -1212,8 +1212,8 @@ processed in order by OPERATE.")) ((component :reader error-component :initarg :component) (operation :reader error-operation :initarg :operation)) (:report (lambda (c s) - (format s (compatfmt "~@") - (error-operation c) (error-component c))))) + (format s (compatfmt "~@<~A while invoking ~A on ~A~@:>") + (type-of c) (error-operation c) (error-component c))))) (define-condition compile-error (operation-error) ()) (define-condition compile-failed (compile-error) ()) (define-condition compile-warned (compile-error) ()) @@ -1461,8 +1461,7 @@ and implementation-defined external-format's") (maintainer :accessor system-maintainer :initarg :maintainer) (licence :accessor system-licence :initarg :licence :accessor system-license :initarg :license) - (source-file :reader %system-source-file :initarg :source-file ; for CLISP upgrade - :writer %set-system-source-file) + (source-file :initarg :source-file :writer %set-system-source-file) ; upgrade issues on CLISP, CMUCL (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on))) ;;;; ------------------------------------------------------------------------- @@ -1636,12 +1635,8 @@ Note that this does NOT in any way cause the code of the system to be unloaded." FN should be a function of one argument. It will be called with an object of type asdf:system." - (maphash #'(lambda (_ datum) - (declare (ignore _)) - (destructuring-bind (_ . def) datum - (declare (ignore _)) - (funcall fn def))) - *defined-systems*)) + (loop :for (nil . system) :being :the hash-values :of *defined-systems* + :do (funcall fn system))) ;;; for the sake of keeping things reasonably neat, we adopt a ;;; convention that functions in this list are prefixed SYSDEF- @@ -1795,6 +1790,8 @@ Going forward, we recommend new users should be using the source-registry. (defvar *systems-being-defined* nil "A hash-table of systems currently being defined keyed by name, or NIL") +(defvar *systems-being-operated* nil + "A boolean indicating that some systems are being operated on") (defun* find-system-if-being-defined (name) (when *systems-being-defined* @@ -2004,10 +2001,10 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. ;; the &allow-other-keys disables initarg validity checking (declare (ignorable operation slot-names force force-not)) (macrolet ((frob (x) ;; normalize forced and forced-not slots - `(when (consp (,x operation)) - (setf (,x operation) - (mapcar #'coerce-name (,x operation)))))) - (frob operation-forced) (frob operation-forced-not)) + `(when (consp (slot-value operation ',x)) + (setf (slot-value operation ',x) + (mapcar #'coerce-name (slot-value operation ',x)))))) + (frob forced) (frob forced-not)) (values)) (defun* node-for (o c) @@ -2357,7 +2354,7 @@ recursive calls to traverse.") (r* (svref x 0)) (c x))) (r* (l) - (dolist (x l) (r x)))) + (map () #'r l))) (r* l)))) (defmethod traverse ((operation operation) (c component)) @@ -2458,11 +2455,11 @@ recursive calls to traverse.") (let ((*package* (find-package package))) (read-from-string fun)))))))) -(defmethod call-with-around-compile-hook ((c component) thunk) - (let ((hook (around-compile-hook c))) - (if hook - (funcall (ensure-function hook) thunk) - (funcall thunk)))) +(defun call-around-hook (hook function) + (funcall (or (ensure-function hook) 'funcall) function)) + +(defmethod call-with-around-compile-hook ((c component) function) + (call-around-hook (around-compile-hook c) function)) ;;; perform is required to check output-files to find out where to put ;;; its answers, in case it has been overridden for site policy @@ -2618,10 +2615,9 @@ recursive calls to traverse.") (defmethod operation-done-p ((o load-source-op) (c source-file)) (declare (ignorable o)) - (if (or (not (component-property c 'last-loaded-as-source)) - (> (safe-file-write-date (component-pathname c)) - (component-property c 'last-loaded-as-source))) - nil t)) + (and (component-property c 'last-loaded-as-source) + (<= (safe-file-write-date (component-pathname c)) + (component-property c 'last-loaded-as-source)))) (defmethod operation-description ((operation load-source-op) component) (declare (ignorable operation)) @@ -2657,6 +2653,7 @@ recursive calls to traverse.") (defgeneric* operate (operation-class system &key &allow-other-keys)) (defgeneric* perform-plan (plan &key)) +(defgeneric* plan-operates-on-p (plan component)) ;;;; Separating this into a different function makes it more forward-compatible (defun* cleanup-upgraded-asdf (old-version) @@ -2691,6 +2688,10 @@ recursive calls to traverse.") (operate 'load-op :asdf :verbose nil)) (cleanup-upgraded-asdf version))) +(defmethod plan-operates-on-p ((plan list) (component-path list)) + (find component-path (mapcar 'cdr plan) + :test 'equal :key 'component-find-path)) + (defmethod perform-plan ((steps list) &key) (let ((*package* *package*) (*readtable* *readtable*)) @@ -2699,38 +2700,44 @@ recursive calls to traverse.") (perform-with-restarts op component))))) (defmethod operate (operation-class system &rest args - &key ((:verbose *asdf-verbose*) *asdf-verbose*) version force - &allow-other-keys) - (declare (ignore force)) + &key force force-not verbose version &allow-other-keys) + (declare (ignore force force-not)) (with-system-definitions () - (let* ((op (apply 'make-instance operation-class - :original-initargs args - args)) - (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream))) + (let* ((*asdf-verbose* verbose) + (*verbose-out* (if verbose *standard-output* (make-broadcast-stream))) + (op (apply 'make-instance operation-class + :original-initargs args args)) (system (etypecase system (system system) - ((or string symbol) (find-system system))))) - (unless (version-satisfies system version) - (error 'missing-component-of-version :requires system :version version)) - (let ((steps (traverse op system))) - (when (and (not (equal '("asdf") (component-find-path system))) - (find '("asdf") (mapcar 'cdr steps) - :test 'equal :key 'component-find-path) - (upgrade-asdf)) - ;; If we needed to upgrade ASDF to achieve our goal, - ;; then do it specially as the first thing, then - ;; invalidate all existing system - ;; retry the whole thing with the new OPERATE function, - ;; which on some implementations - ;; has a new symbol shadowing the current one. - (return-from operate - (apply (find-symbol* 'operate :asdf) operation-class system args))) - (perform-plan steps) - (values op steps))))) + ((or string symbol) (find-system system)))) + (systems-being-operated *systems-being-operated*) + (*systems-being-operated* (or systems-being-operated (make-hash-table :test 'equal)))) + (check-type system system) + (setf (gethash (coerce-name system) *systems-being-operated*) system) + (flet ((upgrade () + ;; If we needed to upgrade ASDF to achieve our goal, + ;; then do it specially as the first thing, + ;; which will invalidate all existing systems; + ;; afterwards, retry the whole thing with the new OPERATE function, + ;; which on some implementations + ;; has a new symbol shadowing the current one. + (unless (gethash "asdf" *systems-being-operated*) + (upgrade-asdf) + (return-from operate + (apply (find-symbol* 'operate :asdf) operation-class system args))))) + (when systems-being-operated ;; Upgrade if loading a system from another one. + (upgrade)) + (unless (version-satisfies system version) + (error 'missing-component-of-version :requires system :version version)) + (let ((plan (traverse op system))) + (when (plan-operates-on-p plan '("asdf")) + (upgrade)) ;; Upgrade early if the plan involves upgrading asdf at any time. + (perform-plan plan) + (values op plan)))))) -(defun* oos (operation-class system &rest args &key force verbose version - &allow-other-keys) - (declare (ignore force verbose version)) +(defun* oos (operation-class system &rest args + &key force force-not verbose version &allow-other-keys) + (declare (ignore force force-not verbose version)) (apply 'operate operation-class system args)) (let ((operate-docstring @@ -3183,11 +3190,11 @@ if that's whay you mean." ;;) (unless (slot-boundp system 'source-file) (%set-system-source-file (probe-asd (component-name system) (component-pathname system)) system)) - (%system-source-file system)) + (slot-value system 'source-file)) (defmethod system-source-file ((system-name string)) - (%system-source-file (find-system system-name))) + (system-source-file (find-system system-name))) (defmethod system-source-file ((system-name symbol)) - (%system-source-file (find-system system-name))) + (system-source-file (find-system system-name))) (defun* system-source-directory (system-designator) "Return a pathname object corresponding to the @@ -3918,9 +3925,7 @@ effectively disabling the output translation facility." (if output-file keys (remove-keyword :output-file keys)))))) (defun* tmpize-pathname (x) - (make-pathname - :name (strcat "ASDF-TMP-" (pathname-name x)) - :defaults x)) + (make-pathname :name (strcat "ASDF-TMP-" (pathname-name x)) :defaults x)) (defun* delete-file-if-exists (x) (when (and x (probe-file* x)) @@ -3958,16 +3963,29 @@ effectively disabling the output translation facility." #+abcl (defun* translate-jar-pathname (source wildcard) (declare (ignore wildcard)) - (let* ((p (pathname (first (pathname-device source)))) - (root (format nil "/___jar___file___root___/~@[~A/~]" - (and (find :windows *features*) - (pathname-device p))))) - (apply-output-translations - (merge-pathnames* - (relativize-pathname-directory source) - (merge-pathnames* - (relativize-pathname-directory (ensure-directory-pathname p)) - root))))) + (flet ((normalize-device (pathname) + (if (find :windows *features*) + pathname + (make-pathname :defaults pathname :device :unspecific)))) + (let* ((jar + (pathname (first (pathname-device source)))) + (target-root-directory-namestring + (format nil "/___jar___file___root___/~@[~A/~]" + (and (find :windows *features*) + (pathname-device jar)))) + (relative-source + (relativize-pathname-directory source)) + (relative-jar + (relativize-pathname-directory (ensure-directory-pathname jar))) + (target-root-directory + (normalize-device + (pathname-directory-pathname + (parse-namestring target-root-directory-namestring)))) + (target-root + (merge-pathnames* relative-jar target-root-directory)) + (target + (merge-pathnames* relative-source target-root))) + (normalize-device (apply-output-translations target))))) ;;;; ----------------------------------------------------------------- ;;;; Compatibility mode for ASDF-Binary-Locations @@ -4008,6 +4026,8 @@ call that function where you would otherwise have loaded and configured A-B-L.") (initialize-output-translations `(:output-translations ,@source-to-target-mappings + #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname)) + #+abcl (#p"/___jar___file___root___/**/*.*" (,@destination-directory)) ((:root ,*wild-inferiors* ,mapped-files) (,@destination-directory ,mapped-files)) (t t) @@ -4133,9 +4153,7 @@ with a different configuration, so the configuration would be re-read then." (collect-sub*directories subdir collectp recursep collector)))) (defun* collect-sub*directories-asd-files - (directory &key - (exclude *default-source-registry-exclusions*) - collect) + (directory &key (exclude *default-source-registry-exclusions*) collect) (collect-sub*directories directory (constantly t) @@ -4487,19 +4505,16 @@ with a different configuration, so the configuration would be re-read then." (asdf-message ";; ASDF, version ~a~%" (asdf-version))) #+mkcl -(progn - (defvar *loading-asdf-bundle* nil) - (unless *loading-asdf-bundle* - (let ((*central-registry* - (cons (translate-logical-pathname #P"CONTRIB:asdf-bundle;") *central-registry*)) - (*loading-asdf-bundle* t)) - (clear-system :asdf-bundle) ;; we hope to force a reload. - (multiple-value-bind (result bundling-error) - (ignore-errors (asdf:oos 'asdf:load-op :asdf-bundle)) - (unless result - (format *error-output* - "~&;;; ASDF: Failed to load package 'asdf-bundle'!~%;;; ASDF: Reason is: ~A.~%" - bundling-error)))))) +(handler-case + (progn + (load-sysdef "asdf-bundle" + (subpathname (translate-logical-pathname #P"CONTRIB:") + "asdf-bundle/asdf-bundle.asd")) + (load-system "asdf-bundle")) + (error (e) + (format *error-output* + "~&;;; ASDF: Failed to load package 'asdf-bundle'!~%;;; ~A~%" + e))) #+allegro (eval-when (:compile-toplevel :execute) diff --git a/contrib/asdf/ecl.lisp b/contrib/asdf/ecl.lisp deleted file mode 100644 index 7dc2ca425..000000000 --- a/contrib/asdf/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/specials.lisp b/contrib/asdf/specials.lisp deleted file mode 100644 index d624a337c..000000000 --- a/contrib/asdf/specials.lisp +++ /dev/null @@ -1,5 +0,0 @@ -;;; -*- Mode: Lisp ; Syntax: ANSI-Common-Lisp -*- - -#+xcvb (module ()) - -(in-package :asdf) diff --git a/src/compile.lsp.in b/src/compile.lsp.in index 15e2dda59..1a72f0d62 100755 --- a/src/compile.lsp.in +++ b/src/compile.lsp.in @@ -206,9 +206,7 @@ #+WANTS-ASDF (build-module "asdf" '("ext:asdf;asdf.lisp" - "ext:asdf;specials.lisp" - "ext:asdf;bundle.lisp" - "ext:asdf;ecl.lisp") + "ext:asdf;asdf-bundle.lisp") :dir "build:ext;" :prefix "EXT" :builtin #+:BUILTIN-ASDF t #-:BUILTIN-ASDF nil)