Commit a92bfb05 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

Merge branch 'master' into syntax-control

parents 5590f976 a62ceed5
* export-subst
\ No newline at end of file
ext export-ignore
* export-subst
......@@ -48,16 +48,24 @@ lib/
test/try-reloading-dependency.asd
test/fileMissing.lisp
test/hello-world-example
test/test-include.asd
build-stamp
# Although there is no debian subdir/ in this repo any more, the
# presence of these lines helps the debian package maintainers, so
# please leave them here.
debian/cl-asdf.debhelper.log
debian/cl-asdf.postinst.debhelper
debian/cl-asdf.prerm.debhelper
debian/cl-asdf.substvars
debian/cl-asdf/
debian/patches/
debian/files
.pc
/.DS_Store
# Hack: ignore the GNUmakefile here, so you can ln -s Makefile-lisp-scripting GNUmakefile
GNUmakefile
......@@ -9,7 +9,7 @@
url = https://gitlab.common-lisp.net/frideau/fare-mop.git
[submodule "ext/closer-closer-mop"]
path = ext/closer-closer-mop
url = git://git.code.sf.net/p/closer/closer-mop
url = https://github.com/pcostanza/closer-mop.git
[submodule "ext/alexandria"]
path = ext/alexandria
url = https://gitlab.common-lisp.net/alexandria/alexandria.git
......
This diff is collapsed.
# -*- Makefile -*- This minimal Makefile delegates most work to the asdf-tools script
#
# End-Users, all you need to do is:
# make -f Makefile-lisp-scripting
#
# Vendors, you may want to test your implementation with:
# make -f Makefile-lisp-scripting test l=sbcl
# BUT you first need have installed the development-time external dependencies of ASDF;
# this will be done automatically if you are using quicklisp;
# you can do it manually with your favorite tools (e.g. clbuild or git);
# or you can do it using `git submodule update` which is also available as:
# make -f Makefile-lisp-scripting ext
# To undo the `git submodule update` you can use: `make noext`
#
# Other targets are for maintainer use only. If you want a list of all of the targets, use
# make -f Makefile-lisp-scripting help
#
### Default fall back rule: delegate to asdf-tools.
# Note that the l= L= etc. are the only way I (Faré) have found to
# pass arguments from the Makefile to the underlying script:
# l= overrides $ASDF_TEST_LISPS to specify which lisp implementations to use
# L= overrides $ASDF_UPGRADE_TEST_LISPS (defaults to the former) to lisps during upgrade
# s= overrides $ASDF_TEST_SYSTEMS to specify systems with which to test ASDF
# t= overrides $ASDF_TESTS to specify test script patterns to use (default to *.script)
# u= overrides $ASDF_UPGRADE_TEST_TAGS to specify versions to upgrade from (e.g. 3.0.3 or REQUIRE)
# U= overrides $ASDF_UPGRADE_TEST_METHODS to specify upgrade methods
# v= overrides the default next version for bump-version or bump.
# see in tools/test-environment.lisp for details.
# Note that because of how make and the shell quote arguments,
# thou shalt not use the single-quote character in any of the short x= parameters
# (but you may use them in the long variant in the exported environment variable).
# To have a list of commands, see make help or ./tools/asdf-tools help
# Note that when you call ./tools/asdf-tools directly,
# you may have to use positional parameters instead (unless you use env as below), as in
# ./tools/asdf-tools bump 3.2.1
# instead of
# make -f Makefile-lisp-scripting bump v=3.2.1
# or
# ./make-asdf.sh v=3.2.1 bump
# or
# ./tools/asdf-tools env v=3.2.1 bump
# or
# v=3.2.1 ./tools/asdf-tools bump
ifeq ($(OS),Windows_NT)
MAKE_SCRIPT := cmd /c make-asdf.bat
else
MAKE_SCRIPT := ./make-asdf.sh
endif
all ext noext driver_files defsystem_files build_asdf build_asdf_tools: force
${MAKE_SCRIPT} $@
build/asdf.lisp: build_asdf
build/asdf-tools build/asdf-tools.exe: build_asdf_tools
.PHONY: force all ext noext driver_files defsystem_files build_asdf build_asdf_tools
# The text below was automaticaly generated by
# make -f Makefile-lisp-scripting --silent makefile-targets
# then manually inserted here to provide for completion:
.PHONY: archive build-asdf build-asdf-tools bump bump-version check-all-results check-all-scripts-results check-all-upgrade-results clean debian-package doc ext-clear ext-init ext-reset ext-update extract extract-all-tagged-asdf extract-tagged-asdf fix-local-git-tags fix-remote-git-tags git-all-committed-p help install install-asdf link-archive load make-and-publish-archive make-archive makefile-targets merge-master-into-release publish-archive publish-debian-package push re show-commands show-version t test test-all test-all-basic test-all-clean-load test-all-no-stop test-all-no-upgrade test-all-no-upgrade-no-stop test-all-scripts test-all-scripts-no-stop test-all-upgrade test-all-upgrade-no-stop test-ascii test-basic test-clean-load test-load-systems test-scripts test-upgrade u wc website
archive build-asdf build-asdf-tools bump bump-version check-all-results check-all-scripts-results check-all-upgrade-results clean debian-package doc ext-clear ext-init ext-reset ext-update extract extract-all-tagged-asdf extract-tagged-asdf fix-local-git-tags fix-remote-git-tags git-all-committed-p help install install-asdf link-archive load make-and-publish-archive make-archive makefile-targets merge-master-into-release publish-archive publish-debian-package push re show-commands show-version t test test-all test-all-basic test-all-clean-load test-all-no-stop test-all-no-upgrade test-all-no-upgrade-no-stop test-all-scripts test-all-scripts-no-stop test-all-upgrade test-all-upgrade-no-stop test-ascii test-basic test-clean-load test-load-systems test-scripts test-upgrade u wc website: force
${MAKE_SCRIPT} l='$l' L='$L' u='$u' U='$U' v='$v' s='$s' t='$t' $@
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
......@@ -3,14 +3,14 @@
;;; ;;;
;;; Free Software available under an MIT-style license. ;;;
;;; ;;;
;;; Copyright (c) 2001-2014 Daniel Barlow and contributors ;;;
;;; Copyright (c) 2001-2016 Daniel Barlow and contributors ;;;
;;; ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(in-package :asdf)
#+asdf3
(defsystem :asdf/prelude
(defsystem "asdf/prelude"
;; Note that it's polite to sort the defsystem forms in dependency order,
;; and compulsory to sort them in defsystem-depends-on order.
:version (:read-file-form "version.lisp-expr")
......@@ -20,11 +20,17 @@
((:file "header")))
#+asdf3
(defsystem :asdf/driver
:depends-on (:uiop))
(defsystem "asdf/driver"
;; This is the same as "uiop", but used for transclusion in asdf.lisp.
;; Because asdf.asd can't afford to depend on reading uiop.asd
;; (which would cause circularity, since everything depends on reading asdf.asd),
;; we can't "just" :depends-on ("uiop") like we used to do.
:pathname "uiop"
:around-compile call-without-redefinition-warnings ;; we need be the same as uiop
:components #.(getf (read-file-form (subpathname *load-pathname* "uiop/uiop.asd") :at 2) :components))
#+asdf3
(defsystem :asdf/defsystem
(defsystem "asdf/defsystem"
:licence "MIT"
:description "The defsystem part of ASDF"
:long-name "Another System Definition Facility"
......@@ -40,28 +46,31 @@
:build-operation monolithic-concatenate-source-op
:build-pathname "build/asdf" ;; our target
:around-compile call-without-redefinition-warnings ;; we need be the same as uiop
:depends-on (:asdf/prelude :asdf/driver)
:depends-on ("asdf/prelude" "asdf/driver")
:encoding :utf-8
:components
((:file "upgrade")
(:file "component" :depends-on ("upgrade"))
(:file "session" :depends-on ("upgrade"))
(:file "component" :depends-on ("session"))
(:file "operation" :depends-on ("session"))
(:file "system" :depends-on ("component"))
(:file "cache" :depends-on ("upgrade"))
(:file "find-system" :depends-on ("system" "cache"))
(:file "find-component" :depends-on ("find-system"))
(:file "operation" :depends-on ("find-system"))
(:file "action" :depends-on ("find-component" "operation"))
(:file "system-registry" :depends-on ("system"))
(:file "action" :depends-on ("session" "system" "operation"))
(:file "lisp-action" :depends-on ("action"))
(:file "plan" :depends-on ("lisp-action"))
(:file "find-component" :depends-on ("component"))
(:file "forcing" :depends-on ("operation" "system-registry"))
(:file "plan" :depends-on ("lisp-action" "find-component" "forcing"))
(:file "operate" :depends-on ("plan"))
(:file "find-system" :depends-on ("system-registry" "operate"))
(:file "parse-defsystem" :depends-on ("system-registry" "lisp-action" "operate"
"find-system"))
(:file "bundle" :depends-on ("lisp-action" "parse-defsystem"))
(:file "concatenate-source" :depends-on ("bundle"))
(:file "package-inferred-system" :depends-on ("parse-defsystem"))
(:file "output-translations" :depends-on ("operate"))
(:file "source-registry" :depends-on ("find-system"))
(:file "parse-defsystem" :depends-on ("cache" "system" "lisp-action" "operate"))
(:file "bundle" :depends-on ("lisp-action" "operate" "parse-defsystem"))
(:file "concatenate-source" :depends-on ("plan" "parse-defsystem" "bundle"))
(:file "package-inferred-system" :depends-on ("system" "find-system" "parse-defsystem"))
(:file "backward-internals" :depends-on ("find-system" "parse-defsystem"))
(:file "backward-interface" :depends-on ("operate" "output-translations"))
(:file "backward-interface" :depends-on ("output-translations"))
(:file "interface" :depends-on
("parse-defsystem" "concatenate-source"
"output-translations" "source-registry" "package-inferred-system"
......@@ -69,13 +78,13 @@
(:file "user" :depends-on ("interface"))
(:file "footer" :depends-on ("user"))))
(defsystem :asdf
(defsystem "asdf"
:author ("Daniel Barlow")
:maintainer ("Robert Goldman")
:licence "MIT"
:description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems."
:version "3.1.6" ;; to be automatically updated by make bump-version
:version "3.3.0.1" ;; to be automatically updated by make bump-version
:depends-on ()
#+asdf3 :encoding #+asdf3 :utf-8
:class #+asdf3.1 package-inferred-system #-asdf3.1 system
......@@ -84,5 +93,4 @@
;; specify separate dependencies on uiop (aka asdf-driver) and asdf/defsystem.
#+asdf3 :builtin-system-p #+asdf3 t
:components ((:module "build" :components ((:file "asdf"))))
:in-order-to (#+asdf3 (prepare-op (monolithic-concatenate-source-op :asdf/defsystem))))
:in-order-to (#+asdf3 (prepare-op (monolithic-concatenate-source-op "asdf/defsystem"))))
This diff is collapsed.
......@@ -4,24 +4,11 @@
(uiop/package:define-package :asdf/backward-internals
(:recycle :asdf/backward-internals :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system)
(:export ;; for internal use
#:make-sub-operation
#:load-sysdef #:make-temporary-package))
(:export #:load-sysdef))
(in-package :asdf/backward-internals)
(when-upgrading (:when (fboundp 'make-sub-operation))
(defun make-sub-operation (c o dep-c dep-o)
(declare (ignore c o dep-c dep-o)) (asdf-upgrade-error)))
;;;; load-sysdef
(with-upgradability ()
(with-asdf-deprecation (:style-warning "3.2" :warning "3.4")
(defun load-sysdef (name pathname)
(load-asd pathname :name name))
(defun make-temporary-package ()
;; For loading a .asd file, we don't make a temporary package anymore,
;; but use ASDF-USER. I'd like to have this function do this,
;; but since whoever uses it is likely to delete-package the result afterwards,
;; this would be a bad idea, so preserve the old behavior.
(make-package (fresh-package-name :prefix :asdf :index 0) :use '(:cl :asdf))))
(declare (ignore name pathname))
;; Needed for backward compatibility with swank-asdf from SLIME 2015-12-01 or older.
(error "Use asdf:load-asd instead of asdf::load-sysdef")))
#! /usr/bin/env perl
use FindBin;
use Getopt::Long;
our $old;
our $new;
our $usage = 0;
&GetOptions("help"=>\$usage,
"usage"=>\$usage);
if ($usage) {
print "$0 [old-version] [new-version]\n";
print "\tIf only one argument, treat it as the new version argument.\n";
print "\tIf two arguments treat the first as old version number and second as new.\n";
print "\n\tBumps the version numbers in all the relevant files.\n";
exit 0;
}
our $asdf_dir = $FindBin::RealBin . "/../";
our $file = $asdf_dir . "version.lisp-expr";
our @transform_ref =
(
[ "version.lisp-expr", "\"", "\"" ],
[ "uiop/version.lisp", "(defparameter *uiop-version* \"", "\")" ],
[ "asdf.asd", " :version \"", "\" ;; to be automatically updated by make bump-version" ],
[ "header.lisp", "This is ASDF ", ": Another System Definition Facility." ],
[ "upgrade.lisp", "(asdf-version \"", "\")" ],
[ "doc/asdf.texinfo", "Manual for Version ", "" ], );
if ($#ARGV == 1) {
$old = $ARGV[0];
$new = $ARGV[1];
} elsif ($#ARGV == 0) {
$new = $ARGV[0];
$old = read_asdf_version();
} else {
$old = read_asdf_version();
$new = bump_asdf_version($old);
}
print STDERR "Bumping from $old to $new\n";
transform_files();
sub read_asdf_version {
open(FILE, $file);
my $str = <FILE>;
chomp $str;
print STDERR "Read version string $str from $file\n";
close FILE;
$str =~ s/"//g;
return $str;
}
sub bump_asdf_version {
my $oldver = shift;
my @fields = split/\./, $oldver;
$fields[$#fields]++;
return join('.', @fields);
}
sub transform_files {
foreach my $entryptr (@transform_ref) {
my @entry = @{$entryptr};
my $file = $entry[0];
print STDERR "Modifying file $file\n";
print STDERR "Prefix is $entry[1], suffix is $entry[2]\n";
my $regex = "(" . quotemeta($entry[1]) . ")" . "((\\d+\\.)+\\d+)" . "(" . quotemeta($entry[2]) .")";
my $filename = $asdf_dir . $file;
my $data = read_text($filename);
my $count = ($data =~ s/$regex/$1$new$4/g);
if ($count == 0) {
die "Unable to replace $regex with $1$new$4";
}
# print STDERR "Writing $data to $filename\n";
write_text($filename, $data);
}
}
# can't reliably find File::Slurper, or File::Slurp, so do it
# old school.
sub read_text ($) {
my $fn = shift;
local $/ = undef;
open READFILE, $fn or die "Couldn't open file: $fn";
binmode READFILE;
my $string = <READFILE>;
close READFILE;
return $string;
}
sub write_text ($$) {
my $fn = shift;
my $data = shift;
open WRITEFILE, "> $fn" or die "Couldn't open $fn for writing.";
print WRITEFILE $data;
close WRITEFILE;
return 1;
}
#+xcvb
(module
(:fullname "/asdf"
:author ("Daniel Barlow and contributors")
:licence "MIT" ;; MIT-style license. See asdf.lisp
:description "ASDF"
:long-description "Another System Definition Facility."
:build-depends-on ("/uiop")
:supersedes-asdf ("asdf")
:build-image nil
:depends-on
("upgrade"
"component"
"system"
"cache"
"find-system"
"find-component"
"operation"
"action"
"lisp-action"
"plan"
"operate"
"output-translations"
"source-registry"
"backward-internals"
"parse-defsystem"
"bundle"
"concatenate-source"
"backward-interface"
"package-inferred-system"
"interface"
"user"
"footer")))
This diff is collapsed.
;;;; -------------------------------------------------------------------------
;;;; Stamp cache
(uiop/package:define-package :asdf/cache
(:use :uiop/common-lisp :uiop :asdf/upgrade)
(:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp
#:set-asdf-cache-entry #:unset-asdf-cache-entry #:consult-asdf-cache
#:do-asdf-cache #:normalize-namestring
#:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache*
#:clear-configuration-and-retry #:retry))
(in-package :asdf/cache)
;;; This stamp cache is useful for:
;; * consistency of stamps used within a single run
;; * fewer accesses to the filesystem
;; * the ability to test with fake timestamps, without touching files
(with-upgradability ()
(defvar *asdf-cache* nil)
(defun set-asdf-cache-entry (key value-list)
(apply 'values
(if *asdf-cache*
(setf (gethash key *asdf-cache*) value-list)
value-list)))
(defun unset-asdf-cache-entry (key)
(when *asdf-cache*
(remhash key *asdf-cache*)))
(defun consult-asdf-cache (key &optional thunk)
(if *asdf-cache*
(multiple-value-bind (results foundp) (gethash key *asdf-cache*)
(if foundp
(apply 'values results)
(set-asdf-cache-entry key (multiple-value-list (call-function thunk)))))
(call-function thunk)))
(defmacro do-asdf-cache (key &body body)
`(consult-asdf-cache ,key #'(lambda () ,@body)))
(defun call-with-asdf-cache (thunk &key override key)
(let ((fun (if key #'(lambda () (consult-asdf-cache key thunk)) thunk)))
(if (and *asdf-cache* (not override))
(funcall fun)
(loop
(restart-case
(let ((*asdf-cache* (make-hash-table :test 'equal)))
(return (funcall fun)))
(retry ()
:report (lambda (s)
(format s (compatfmt "~@<Retry ASDF operation.~@:>"))))
(clear-configuration-and-retry ()
:report (lambda (s)
(format s (compatfmt "~@<Retry ASDF operation after resetting the configuration.~@:>")))
(clear-configuration)))))))
(defmacro with-asdf-cache ((&key key override) &body body)
`(call-with-asdf-cache #'(lambda () ,@body) :override ,override :key ,key))
(defun normalize-namestring (pathname)
(let ((resolved (resolve-symlinks*
(ensure-absolute-pathname
(physicalize-pathname pathname)
'get-pathname-defaults))))
(with-pathname-defaults () (namestring resolved))))
(defun compute-file-stamp (normalized-namestring)
(with-pathname-defaults ()
(safe-file-write-date normalized-namestring)))
(defun register-file-stamp (file &optional (stamp nil stampp))
(let* ((namestring (normalize-namestring file))
(stamp (if stampp stamp (compute-file-stamp namestring))))
(set-asdf-cache-entry `(get-file-stamp ,namestring) (list stamp))))
(defun get-file-stamp (file)
(when file
(let ((namestring (normalize-namestring file)))
(do-asdf-cache `(get-file-stamp ,namestring) (compute-file-stamp namestring))))))
This diff is collapsed.
......@@ -5,8 +5,8 @@
(:recycle :asdf/concatenate-source :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade
:asdf/component :asdf/operation
:asdf/system :asdf/find-system
:asdf/action :asdf/lisp-action :asdf/bundle)
:asdf/system
:asdf/action :asdf/lisp-action :asdf/plan :asdf/bundle)
(:export
#:concatenate-source-op
#:load-concatenated-source-op
......@@ -22,36 +22,49 @@
;;; Concatenate sources
;;;
(with-upgradability ()
;; Base classes for both regular and monolithic concatenate-source operations
(defclass basic-concatenate-source-op (bundle-op)
((bundle-type :initform "lisp")))
((bundle-type :initform "lisp" :allocation :class)))
(defclass basic-load-concatenated-source-op (basic-load-op selfward-operation) ())
(defclass basic-compile-concatenated-source-op (basic-compile-op selfward-operation) ())
(defclass basic-load-compiled-concatenated-source-op (basic-load-op selfward-operation) ())
(defclass concatenate-source-op (basic-concatenate-source-op non-propagating-operation) ())
;; Regular concatenate-source operations
(defclass concatenate-source-op (basic-concatenate-source-op non-propagating-operation) ()
(:documentation "Operation to concatenate all sources in a system into a single file"))
(defclass load-concatenated-source-op (basic-load-concatenated-source-op)
((selfward-operation :initform '(prepare-op concatenate-source-op) :allocation :class)))
((selfward-operation :initform '(prepare-op concatenate-source-op) :allocation :class))
(:documentation "Operation to load the result of concatenate-source-op as source"))
(defclass compile-concatenated-source-op (basic-compile-concatenated-source-op)
((selfward-operation :initform '(prepare-op concatenate-source-op) :allocation :class)))
((selfward-operation :initform '(prepare-op concatenate-source-op) :allocation :class))
(:documentation "Operation to compile the result of concatenate-source-op"))
(defclass load-compiled-concatenated-source-op (basic-load-compiled-concatenated-source-op)
((selfward-operation :initform '(prepare-op compile-concatenated-source-op) :allocation :class)))
((selfward-operation :initform '(prepare-op compile-concatenated-source-op) :allocation :class))
(:documentation "Operation to load the result of compile-concatenated-source-op"))
(defclass monolithic-concatenate-source-op (basic-concatenate-source-op monolithic-bundle-op non-propagating-operation) ())
(defclass monolithic-concatenate-source-op
(basic-concatenate-source-op monolithic-bundle-op non-propagating-operation) ()
(:documentation "Operation to concatenate all sources in a system and its dependencies
into a single file"))
(defclass monolithic-load-concatenated-source-op (basic-load-concatenated-source-op)
((selfward-operation :initform 'monolithic-concatenate-source-op :allocation :class)))
((selfward-operation :initform 'monolithic-concatenate-source-op :allocation :class))
(:documentation "Operation to load the result of monolithic-concatenate-source-op as source"))
(defclass monolithic-compile-concatenated-source-op (basic-compile-concatenated-source-op)
((selfward-operation :initform 'monolithic-concatenate-source-op :allocation :class)))
(defclass monolithic-load-compiled-concatenated-source-op (basic-load-compiled-concatenated-source-op)
((selfward-operation :initform 'monolithic-compile-concatenated-source-op :allocation :class)))
((selfward-operation :initform 'monolithic-concatenate-source-op :allocation :class))
(:documentation "Operation to compile the result of monolithic-concatenate-source-op"))
(defclass monolithic-load-compiled-concatenated-source-op
(basic-load-compiled-concatenated-source-op)
((selfward-operation :initform 'monolithic-compile-concatenated-source-op :allocation :class))
(:documentation "Operation to load the result of monolithic-compile-concatenated-source-op"))
(defmethod input-files ((operation basic-concatenate-source-op) (s system))
(loop :with encoding = (or (component-encoding s) *default-encoding*)
:with other-encodings = '()
:with around-compile = (around-compile-hook s)
:with other-around-compile = '()
:for c :in (required-components
s :goal-operation 'compile-op
:keep-operation 'compile-op
:for c :in (required-components ;; see note about similar call to required-components
s :goal-operation 'load-op ;; in bundle.lisp
:keep-operation 'basic-compile-op
:other-systems (operation-monolithic-p operation))
:append
(when (typep c 'cl-source-file)
......
(defpackage :asdf/contrib/plan (:use :cl)) ;; dummy, for use as package-inferred-system
(in-package :asdf/plan)
;; NB: Whenever compute-action-stamp is changed, this file must be updated
;; to insert the let-and-DBG statements in the current version of the function.
;; So if you find this file not working, it might be out of date.
(uiop:uiop-debug)
(progn
(defmethod compute-action-stamp (plan (o operation) (c component) &key just-done)
;; Given an action, figure out at what time in the past it has been done,
;; or if it has just been done, return the time that it has.
;; Returns two values:
;; 1- the TIMESTAMP of the action if it has already been done and is up to date,
;; or NIL is either hasn't been done or is out of date.
;; (An ASDF extension could use a cryptographic digest instead.)
;; 2- the DONE-IN-IMAGE-P boolean flag that is T if the action has already been done
;; in the current image, or NIL if it hasn't.
;; Note that if e.g. LOAD-OP only depends on up-to-date files, but
;; hasn't been done in the current image yet, then it can have a non-NIL timestamp,
;; yet a NIL done-in-image-p flag: we can predict what timestamp it will have once loaded,
;; i.e. that of the input-files.
;; If just-done is NIL, these values return are the notional fields of
;; a KEEP, REDO or TODO status (VOID is possible, but probably an error).
;; If just-done is T, they are the notional fields of DONE status
;; (or, if something went wrong, TODO).
(nest
(block ())
(let* ((dep-status ; collect timestamp from dependencies (or T if forced or out-of-date)
(reduce-direct-dependencies
o c
#'(lambda (do dc status)
;; out-of-date dependency: don't bother looking further
(let ((action-status (action-status plan do dc)))
(cond
((and action-status (or (status-keep-p action-status)
(and just-done (status-stamp action-status))))
(merge-action-status action-status status))
(just-done
;; It's OK to lose some ASDF action stamps during self-upgrade
(unless (equal "asdf" (primary-system-name dc))
(warn "Computing just-done stamp in plan ~S for action ~S, but dependency ~S wasn't done yet!"
plan
(action-path (make-action o c))
(action-path (make-action do dc))))
status)
(t
(DBG "compute-action-stamp: forced by out of date dependency" (action-path (make-action o c)) (action-path (make-action do dc)) action-status)
(return (values nil nil))))))
+status-good+))
(dep-stamp (status-stamp dep-status)))
;; DBG
(when (null dep-stamp)
(let* ((action-path (action-path (cons o c)))
(dep-statuses (loop for action in (direct-dependencies o c) for (o . c) = action collect
(list (action-path action) (action-status plan o c)))))
(DBG :nds action-path dep-statuses))))
(let* (;; collect timestamps from inputs, and exit early if any is missing
(in-files (input-files o c))
(in-stamps (mapcar #'get-file-stamp in-files))
(missing-in (loop :for f :in in-files :for s :in in-stamps :unless s :collect f))
(latest-in (stamps-latest (cons dep-stamp in-stamps))))
(when (and missing-in (not just-done))
(DBG "compute-action-stamp: missing inputs" (cons o c) missing-in)
(return (values nil nil))))
(let* (;; collect timestamps from outputs, and exit early if any is missing
(out-files (remove-if 'null (output-files o c)))
(out-stamps (mapcar (if just-done 'register-file-stamp 'get-file-stamp) out-files))
(missing-out (loop :for f :in out-files :for s :in out-stamps :unless s :collect f))
(earliest-out (stamps-earliest out-stamps)))
(when (and missing-out (not just-done))
(DBG "compute-action-stamp: missing outputs" (cons o c) missing-out)
(return (values nil nil))))
(let (;; Time stamps from the files at hand, and whether any is missing
(all-present (not (or missing-in missing-out)))
;; Has any input changed since we last generated the files?
;; Note that we use stamp<= instead of stamp< to play nice with generated files.
;; Any race condition is intrinsic to the limited timestamp resolution.
(up-to-date-p (stamp<= latest-in earliest-out))
;; If everything is up to date, the latest of inputs and outputs is our stamp
(done-stamp (stamps-latest (cons latest-in out-stamps))))
;; Warn if some files are missing:
;; either our model is wrong or some other process is messing with our files.
(when (and just-done (not all-present))
;; Shouldn't that be an error instead?
(warn "~A completed without ~:[~*~;~*its input file~:p~2:*~{ ~S~}~*~]~
~:[~; or ~]~:[~*~;~*its output file~:p~2:*~{ ~S~}~*~]"
(action-description o c)
missing-in (length missing-in) (and missing-in missing-out)
missing-out (length missing-out))))
(let (;; There are three kinds of actions:
(out-op (and out-files t)) ; those that create files on the filesystem
;;(image-op (and in-files (null out-files))) ; those that load stuff into the image
;;(null-op (and (null out-files) (null in-files))) ; placeholders that do nothing
))
;; Status of the action as previously performed in the image
(progn ;; DBG
(multiple-value-bind (perform-stamp perform-done-p)
(if just-done
(values done-stamp t)