Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
A
asdf
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
16
Issues
16
List
Boards
Labels
Service Desk
Milestones
Merge Requests
8
Merge Requests
8
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Operations
Operations
Incidents
Environments
Analytics
Analytics
CI / CD
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
asdf
asdf
Commits
4ab3e838
Commit
4ab3e838
authored
Jun 09, 2015
by
Francois-Rene Rideau
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Use cl-scripting/failure, to which the code in failure.lisp was moved.
parent
2a8b4f7f
Changes
5
Hide whitespace changes
Inline
Side-by-side
Showing
5 changed files
with
11 additions
and
155 deletions
+11
-155
.gitmodules
.gitmodules
+3
-0
ext/cl-scripting
ext/cl-scripting
+1
-0
tools/asdf-tools.asd
tools/asdf-tools.asd
+3
-3
tools/failure.lisp
tools/failure.lisp
+0
-147
tools/package.lisp
tools/package.lisp
+4
-5
No files found.
.gitmodules
View file @
4ab3e838
...
...
@@ -31,3 +31,6 @@
[submodule "ext/asdf-encodings"]
path = ext/asdf-encodings
url = https://gitlab.common-lisp.net/asdf/asdf-encodings.git
[submodule "ext/cl-scripting"]
path = ext/cl-scripting
url = https://github.com/fare/cl-scripting.git
cl-scripting
@
d4b06418
Subproject commit d4b064187be2c9cea8d5e687ca9853f66f0ed756
tools/asdf-tools.asd
View file @
4ab3e838
...
...
@@ -5,13 +5,13 @@
(
:version
"lisp-invocation/all"
"1.0.5"
)
(
:version
"cl-ppcre"
"2.0.4"
)
(
:version
"optima.ppcre"
"1.0"
)
"cl-scripting"
(
:feature
:sbcl
"sb-introspect"
))
:components
((
:file
"package"
)
(
:file
"failure"
:depends-on
(
"package"
))
(
:file
"main"
:depends-on
(
"failure"
))
(
:file
"main"
:depends-on
(
"package"
))
(
:file
"pathnames"
:depends-on
(
"package"
))
(
:file
"version"
:depends-on
(
"
failur
e"
))
(
:file
"version"
:depends-on
(
"
packag
e"
))
(
:file
"test-environment"
:depends-on
(
"pathnames"
"main"
))
(
:file
"build"
:depends-on
(
"test-environment"
))
(
:file
"git"
:depends-on
(
"test-environment"
))
...
...
tools/failure.lisp
deleted
100644 → 0
View file @
2a8b4f7f
;;;; Useful information when failing.
(
in-package
:asdf-tools
)
(
defvar
*fail-fast*
nil
)
(
defvar
*fail-verbose*
nil
)
(
defvar
*execution-context*
nil
)
;; context for debugging information
(
defvar
*failures*
nil
)
(
defvar
*failurep*
nil
)
;;;(defvar *failure-handler* nil)
(
define-condition
execution-error
(
error
)
())
(
defmethod
print-object
((
failure
execution-error
)
stream
)
(
if
*print-escape*
(
print-unreadable-object
(
failure
stream
:type
t
:identity
nil
)
(
let
((
*print-escape*
nil
))
(
print-object
failure
stream
)))
(
princ
"FAILED"
stream
)))
(
define-condition
execution-failure
(
execution-error
)
((
context
:initform
nil
:initarg
:context
:reader
failure-context
)
(
reason
:initarg
:reason
:reader
failure-reason
)))
(
defmethod
print-object
((
failure
execution-failure
)
stream
)
(
if
*print-escape*
(
call-next-method
)
(
format
stream
"~@[In ~{~A~^, ~}: ~]~:[FAILED~;~:*~A~]"
(
reverse
(
remove
nil
(
failure-context
failure
)))
(
failure-reason
failure
))))
(
define-condition
execution-failures
(
execution-error
)
((
failures
:initform
nil
:initarg
:failures
:reader
failure-list
)))
(
defmethod
print-object
((
failures
execution-failures
)
stream
)
(
if
*print-escape*
(
call-next-method
)
(
format
stream
"Failure~@[~P~:*~{~&~A~&~}~]"
(
reverse
(
failure-list
failures
)))))
(
defun
make-error
(
&optional
reason
&rest
arguments
)
(
etypecase
reason
(
error
reason
)
(
string
(
make-condition
'simple-error
:format-control
reason
:format-arguments
arguments
))
(
null
(
make-failures
))
(
symbol
(
apply
'make-condition
reason
arguments
))))
(
defun
fail!
(
&rest
reason-arguments
)
(
error
(
apply
'make-error
reason-arguments
)))
(
defun
success
(
&rest
values
)
"Return magic values that signal success"
(
cond
((
successp
values
)
(
apply
'values
values
))
((
failurep
values
)
(
apply
'values
values
))
(
t
(
apply
'values
t
'
#:success
values
))))
(
defun
failure
(
&optional
failures
)
"Return magic values that signal failure"
(
values
nil
'
#:failure
failures
))
(
defun
successp
(
value-list
)
(
and
(
length>=n-p
value-list
2
)
(
equal
(
subseq
value-list
0
2
)
(
multiple-value-list
(
success
)))))
(
defun
success-values
(
value-list
)
(
subseq
value-list
2
))
(
defun
failurep
(
value-list
)
(
and
(
length>=n-p
value-list
2
)
(
equal
(
subseq
value-list
0
2
)
(
subseq
(
multiple-value-list
(
failure
))
0
2
))))
(
defun
failure-failures
(
value-list
)
(
third
value-list
))
(
defun
success-if
(
test
&rest
failure-args
)
"If TEST, return success, otherwise, return failure with FAILURE-ARGS"
(
if
test
(
success
)
(
apply
'fail!
(
or
failure-args
'
(
"failed"
)))))
(
defun
failure-if
(
test
&rest
failure-args
)
"If not TEST, return success, otherwise, return failure with FAILURE-ARGS"
(
apply
'success-if
(
not
test
)
failure-args
))
(
defun
make-failure
(
&optional
reason
&rest
arguments
)
(
if
(
typep
reason
'execution-error
)
reason
(
make-condition
'execution-failure
:context
*execution-context*
:reason
(
apply
'make-error
reason
arguments
))))
(
defun
make-failures
(
&optional
list
)
(
make-condition
'execution-failures
:failures
list
))
(
defmacro
with-failure-context
((
&key
name
(
fail-fast
t
))
&body
body
)
`
(
call-with-failure-context
(
lambda
()
,@
body
)
:name
,
name
:fail-fast
,
fail-fast
))
(
defun
register-failures
(
failure
)
(
let
((
failure
(
make-failure
failure
)))
(
etypecase
failure
(
execution-failures
(
setf
*failures*
(
append
(
failure-list
failure
)
*failures*
)))
(
execution-failure
(
push
failure
*failures*
)))
failure
))
(
defun
call-with-failure-context
(
thunk
&key
name
(
fail-fast
t
))
(
let
((
toplevel
(
null
*execution-context*
))
(
*execution-context*
(
cons
name
*execution-context*
)))
(
labels
((
compute
()
(
block
nil
(
handler-bind
((
error
(
lambda
(
c
)
(
register-failures
c
)
(
cond
(
toplevel
(
return
(
failure
*failures*
)))
(
fail-fast
(
error
(
make-failures
)))
(
t
(
return
(
failure
)))))))
(
funcall
thunk
))))
(
doit
()
(
let
((
results
(
multiple-value-list
(
compute
))))
(
if
(
and
toplevel
*failures*
)
(
failure
(
reverse
*failures*
))
(
apply
'success
results
)))))
(
if
toplevel
(
let
((
*failures*
nil
))
(
doit
))
(
doit
)))))
(
defmacro
without-stopping
(()
&body
body
)
`
(
call-without-stopping
(
list
,@
(
mapcar
(
lambda
(
form
)
`
(
lambda
()
,
form
))
body
))))
(
defun
call-without-stopping
(
thunks
)
(
with-failure-context
(
:fail-fast
nil
)
(
let
((
failurep
nil
))
(
dolist
(
thunk
thunks
)
(
when
(
failurep
(
multiple-value-list
(
with-failure-context
()
(
funcall
thunk
))))
(
setf
failurep
t
)))
(
failure-if
failurep
(
make-failures
)))))
(
defun
run-command
(
fun
&rest
args
)
(
let
((
results
(
multiple-value-list
(
with-failure-context
()
(
apply
fun
args
)))))
;; Don't print anything on success for regular commands, otherwise print all values returned.
(
if
(
failurep
results
)
(
let
((
failures
(
failure-failures
results
)))
(
format
t
"~&Failure~P:~{~& ~A~}~&"
(
length
failures
)
failures
))
(
format
t
"~{~&~S~&~}"
(
if
(
successp
results
)
(
success-values
results
)
results
)))
(
apply
'values
results
)))
tools/package.lisp
View file @
4ab3e838
(
defpackage
:asdf-tools
(
:use
:common-lisp
:uiop
:asdf
:fare-utils
:inferior-shell
:lisp-invocation
:lisp-invocation/non-special
:cl-ppcre
:optima
:optima.ppcre
)
(
:export
;; TODO: export stuff
;; failure
#:with-failure-context
#:success
#:failure
#:success-if
#:failure-if
#:fail!
#:without-stopping
#:call-without-stopping
#:run-command
))
:fare-utils
:inferior-shell
:cl-scripting/failure
:lisp-invocation
:lisp-invocation/non-special
:cl-ppcre
:optima
:optima.ppcre
)
(
:export
))
;; TODO: export stuff
;; Just so we can use the name in our test scripts...
(
defpackage
:asdf-test
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment