Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
Eric Timmons
asdf
Commits
bd2c2873
Commit
bd2c2873
authored
Aug 02, 2018
by
Robert Goldman
Browse files
Merge branch 'mr-96-revised' into 'master'
Fix %DEFINE-COMPONENT-INLINE-METHODS loop. See merge request
asdf/asdf!100
parents
4b42e1d3
0f275954
Changes
2
Hide whitespace changes
Inline
Side-by-side
parse-defsystem.lisp
View file @
bd2c2873
...
...
@@ -169,7 +169,7 @@ Please only define ~S and secondary systems with a name starting with ~S (e.g. ~
;;; "inline methods"
(
with-upgradability
()
(
defparameter*
+asdf-methods+
'
(
perform-with-restarts
perform
explain
output-files
operation-done-p
))
'
(
perform-with-restarts
perform
explain
output-files
operation-done-p
))
(
defun
%remove-component-inline-methods
(
component
)
(
dolist
(
name
+asdf-methods+
)
...
...
@@ -182,19 +182,55 @@ Please only define ~S and secondary systems with a name starting with ~S (e.g. ~
(
component-inline-methods
component
)))
(
component-inline-methods
component
)
nil
)
(
defparameter
*standard-method-combination-qualifiers*
'
(
:around
:before
:after
))
;;; Find inline method definitions of the form
;;;
;;; :perform (test-op :before (operation component) ...)
;;;
;;; in REST (which is the plist of all DEFSYSTEM initargs) and define the specified methods.
(
defun
%define-component-inline-methods
(
ret
rest
)
;; find key-value pairs that look like inline method definitions in REST. For each identified
;; definition, parse it and, if it is well-formed, define the method.
(
loop*
:for
(
key
value
)
:on
rest
:by
#'
cddr
:for
name
=
(
and
(
keywordp
key
)
(
find
key
+asdf-methods+
:test
'string=
))
:when
name
:do
(
destructuring-bind
(
op
&rest
body
)
value
(
loop
:for
arg
=
(
pop
body
)
:while
(
atom
arg
)
:collect
arg
:into
qualifiers
:finally
(
destructuring-bind
(
o
c
)
arg
(
pushnew
(
eval
`
(
defmethod
,
name
,@
qualifiers
((
,
o
,
op
)
(
,
c
(
eql
,
ret
)))
,@
body
))
(
component-inline-methods
ret
)))))))
;; parse VALUE as an inline method definition of the form
;;
;; (OPERATION-NAME [QUALIFIER] (OPERATION-PARAMETER COMPONENT-PARAMETER) &rest BODY)
(
destructuring-bind
(
operation-name
&rest
rest
)
value
(
let
((
qualifiers
'
()))
;; ensure that OPERATION-NAME is a symbol.
(
unless
(
and
(
symbolp
operation-name
)
(
not
(
null
operation-name
)))
(
sysdef-error
"Ill-formed inline method: ~S. The first element is not a symbol ~
designating an operation but ~S."
value
operation-name
))
;; ensure that REST starts with either a cons (potential lambda list, further checked
;; below) or a qualifier accepted by the standard method combination. Everything else
;; is ill-formed. In case of a valid qualifier, pop it from REST so REST now definitely
;; has to start with the lambda list.
(
cond
((
consp
(
car
rest
)))
((
not
(
member
(
car
rest
)
*standard-method-combination-qualifiers*
))
(
sysdef-error
"Ill-formed inline method: ~S. Only a single of the standard ~
qualifiers ~{~S~^ ~} is allowed, not ~S."
value
*standard-method-combination-qualifiers*
(
car
rest
)))
(
t
(
setf
qualifiers
(
list
(
pop
rest
)))))
;; REST must start with a two-element lambda list.
(
unless
(
and
(
listp
(
car
rest
))
(
length=n-p
(
car
rest
)
2
)
(
null
(
cddar
rest
)))
(
sysdef-error
"Ill-formed inline method: ~S. The operation name ~S is not followed by ~
a lambda-list of the form (OPERATION COMPONENT) and a method body."
value
operation-name
))
;; define the method.
(
destructuring-bind
((
o
c
)
&rest
body
)
rest
(
pushnew
(
eval
`
(
defmethod
,
name
,@
qualifiers
((
,
o
,
operation-name
)
(
,
c
(
eql
,
ret
)))
,@
body
))
(
component-inline-methods
ret
)))))))
(
defun
%refresh-component-inline-methods
(
component
rest
)
;; clear methods, then add the new ones
...
...
test/test-defsystem-loop.script
View file @
bd2c2873
;;; -*- Lisp -*-
#+ignore #+ignore
(signals FORMATTED-SYSTEM-DEFINITION-ERROR
(signals formatted-system-definition-error
(def-test-system "foo" :perform ((test-op (o c)))))
(leave-test "Correctly detected ill-formed system definition." 0)
(leave-test "Skipping this test for bug not fixed on master." 0)
(leave-test "correctly detected ill-formed system definition." 0)
\ No newline at end of file
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