mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-15 05:43:19 -08:00
Upgraded both ASDF and ASDF-BUNDLE
This commit is contained in:
Juan Jose Garcia Ripoll
parent
93be6ce0b5
commit
a1a474c352
5 changed files with 341 additions and 136 deletions
|
|
@ -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)
|
||||
|
|
@ -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 <asdf-devel@common-lisp.net>.
|
||||
|
|
@ -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 while invoking ~A on ~A~@:>")
|
||||
(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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
;;; -*- Mode: Lisp ; Syntax: ANSI-Common-Lisp -*-
|
||||
|
||||
#+xcvb (module ())
|
||||
|
||||
(in-package :asdf)
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue