summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--ccwl/conditions.scm17
-rw-r--r--ccwl/utils.scm132
-rw-r--r--tests/utils.scm74
3 files changed, 188 insertions, 35 deletions
diff --git a/ccwl/conditions.scm b/ccwl/conditions.scm
index 756b46b..2c69cea 100644
--- a/ccwl/conditions.scm
+++ b/ccwl/conditions.scm
@@ -23,7 +23,13 @@
ccwl-violation?
ccwl-violation-file
ccwl-violation-line
- ccwl-violation-column))
+ ccwl-violation-column
+ unrecognized-keyword-assertion
+ unrecognized-keyword-assertion?
+ invalid-keyword-arity-assertion
+ invalid-keyword-arity-assertion?
+ invalid-positional-arguments-arity-assertion
+ invalid-positional-arguments-arity-assertion?))
(define-condition-type &ccwl-violation &violation
make-ccwl-violation ccwl-violation?
@@ -37,3 +43,12 @@
(make-ccwl-violation (assq-ref properties 'filename)
(assq-ref properties 'line)
(assq-ref properties 'column))))
+
+(define-condition-type &unrecognized-keyword-assertion &assertion
+ unrecognized-keyword-assertion unrecognized-keyword-assertion?)
+
+(define-condition-type &invalid-keyword-arity-assertion &assertion
+ invalid-keyword-arity-assertion invalid-keyword-arity-assertion?)
+
+(define-condition-type &invalid-positional-arguments-arity-assertion &assertion
+ invalid-positional-arguments-arity-assertion invalid-positional-arguments-arity-assertion?)
diff --git a/ccwl/utils.scm b/ccwl/utils.scm
index 2e302da..090f857 100644
--- a/ccwl/utils.scm
+++ b/ccwl/utils.scm
@@ -23,10 +23,16 @@
;;; Code:
(define-module (ccwl utils)
+ #:use-module ((rnrs conditions) #:select (condition
+ condition-irritants
+ (make-irritants-condition . irritants-condition)))
+ #:use-module ((rnrs exceptions) #:select (guard
+ (raise . raise-exception)))
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-71)
#:use-module (ice-9 match)
+ #:use-module (ccwl conditions)
#:export (indent-level
pairify
plist->alist
@@ -72,24 +78,25 @@ arity are listed in UNARY-KEYWORDS. For example,
(group-keyword-arguments (list #:spam 1 #:ham 1 2 3 #:eggs 0)
(list #:spam))
-=> (#:spam 1 #:ham (1 2 3) #:eggs (0))"
+=> (#:spam 1 #:ham (1 2 3) #:eggs (0))
+
+If a unary keyword is passed multiple arguments, a
+&invalid-keyword-arity-assertion is raised."
(match args
- (((? (lambda (keyword)
- (and (keyword? keyword)
- (not (member keyword unary-keywords))))
- this-keyword)
- tail ...)
+ (((? keyword? this-keyword) tail ...)
(let ((this-keyword-args tail (break keyword? tail)))
(cons* this-keyword
- (apply list this-keyword-args)
+ (if (member this-keyword unary-keywords)
+ ;; unary keyword argument
+ (match this-keyword-args
+ ((this-keyword-arg) this-keyword-arg)
+ (_ (raise-exception
+ (condition (invalid-keyword-arity-assertion)
+ (irritants-condition
+ (cons this-keyword this-keyword-args))))))
+ ;; n-ary keyword argument
+ (apply list this-keyword-args))
(group-keyword-arguments tail unary-keywords))))
- (((? (lambda (keyword)
- (and (keyword? keyword)
- (member keyword unary-keywords)))
- this-keyword)
- this-keyword-arg tail ...)
- (cons* this-keyword this-keyword-arg
- (group-keyword-arguments tail unary-keywords)))
((non-keyword _ ...)
(error "Invalid sequence of keywords arguments" args))
(() '())))
@@ -158,26 +165,38 @@ Like lambda*, lambda** supports #:allow-other-keys. For example,
#:foo 1 #:bar 2)
=> 1
-However, #:optional and #:rest are not supported."
+However, #:optional and #:rest are not supported.
+
+If an unrecognized keyword is passed to the lambda function, a
+&unrecognized-keyword-assertion condition is raised. If a unary
+keyword argument is passed more than one argument, a
+&invalid-keyword-arity-assertion condition is raised. If a wrong
+number of positional arguments is passed, a
+&invalid-positional-arguments-arity-assertion condition is raised."
(syntax-case x ()
((_ (args-spec ...) body ...)
#`(lambda args
- #,(let* ((args-spec (unsyntax-keywords #'(args-spec ...)))
- (positionals rest (break keyword? args-spec))
+ #,(let* ((positionals rest (break keyword?
+ (unsyntax-keywords #'(args-spec ...))))
(grouped-rest (group-keyword-arguments rest))
(unary-arguments (or (plist-ref grouped-rest #:key)
(list)))
(nary-arguments (or (plist-ref grouped-rest #:key*)
(list)))
- (allow-other-keys? (plist-ref grouped-rest #:allow-other-keys)))
- (for-each (lambda (keyword)
- (unless (memq keyword (list #:key #:key* #:allow-other-keys))
- (scm-error 'misc-error
- #f
- "Invalid keyword `~S' in `~S'"
- (list keyword (syntax->datum args-spec))
- #f)))
- (filter keyword? args-spec))
+ (allow-other-keys? (if (plist-ref grouped-rest #:allow-other-keys)
+ #t #f)))
+ (let ((unrecognized-keywords
+ (lset-difference (lambda (x y)
+ (let ((x (if (keyword? x) x (syntax->datum x)))
+ (y (if (keyword? y) y (syntax->datum x))))
+ (eq? x y)))
+ (filter (compose keyword? syntax->datum)
+ #'(args-spec ...))
+ (list #:key #:key* #:allow-other-keys))))
+ (unless (null? unrecognized-keywords)
+ (raise-exception
+ (condition (unrecognized-keyword-assertion)
+ (irritants-condition unrecognized-keywords)))))
#`(apply (lambda* #,(append positionals
(cons #:key unary-arguments)
(map (lambda (x)
@@ -191,6 +210,29 @@ However, #:optional and #:rest are not supported."
(list)))
body ...)
(let ((positionals rest (break keyword? args)))
+ ;; Test for correct number of positional
+ ;; arguments.
+ (unless (= (length positionals)
+ #,(length positionals))
+ (raise-exception
+ (condition (invalid-positional-arguments-arity-assertion)
+ (irritants-condition positionals))))
+ ;; Test if all keywords are recognized.
+ (let ((unrecognized-keywords
+ (lset-difference eq?
+ (filter keyword? rest)
+ '#,(map (lambda (x)
+ (symbol->keyword
+ (syntax->datum (syntax-case x ()
+ ((arg _ ...) #'arg)
+ (arg #'arg)))))
+ (append unary-arguments
+ nary-arguments)))))
+ (unless (or #,allow-other-keys?
+ (null? unrecognized-keywords))
+ (raise-exception
+ (condition (unrecognized-keyword-assertion)
+ (irritants-condition unrecognized-keywords)))))
(append positionals
(group-keyword-arguments
rest (list #,@(map (lambda (x)
@@ -224,10 +266,42 @@ Like lambda**, syntax-lambda** supports #:allow-other-keys.
#'#:foo #'1 #'#:bar #'2)
=> #'1
-#:optional and #:rest are not supported."
+#:optional and #:rest are not supported.
+
+If an unrecognized keyword is passed to the lambda function, a
+&unrecognized-keyword-assertion condition is raised. If a unary
+keyword argument is passed more than one argument, a
+&invalid-keyword-arity-assertion condition is raised. If a wrong
+number of positional arguments is passed, a
+&invalid-positional-arguments-arity-assertion condition is raised."
(lambda args
- (apply (lambda** formal-args body ...)
- (unsyntax-keywords args))))
+ (guard (exception
+ ((unrecognized-keyword-assertion? exception)
+ (raise-exception
+ (condition (unrecognized-keyword-assertion)
+ (irritants-condition
+ ;; Resyntax irritant keywords.
+ (map (lambda (irritant-keyword)
+ (find (lambda (arg)
+ (eq? (syntax->datum arg)
+ irritant-keyword))
+ args))
+ (condition-irritants exception))))))
+ ((invalid-keyword-arity-assertion? exception)
+ (raise-exception
+ (condition (invalid-keyword-arity-assertion)
+ (irritants-condition
+ ;; Resyntax irritant keyword.
+ (match (condition-irritants exception)
+ ((irritant-keyword . irritant-args)
+ (cons (find (lambda (arg)
+ (eq? (syntax->datum arg)
+ irritant-keyword))
+ args)
+ irritant-args))))))))
+ (apply
+ (lambda** formal-args body ...)
+ (unsyntax-keywords args)))))
(define (filter-mapi proc lst)
"Indexed filter-map. Like filter-map, but PROC calls are (proc item
diff --git a/tests/utils.scm b/tests/utils.scm
index 223e7cd..8a1e6a1 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -16,8 +16,12 @@
;;; You should have received a copy of the GNU General Public License
;;; along with ccwl. If not, see <https://www.gnu.org/licenses/>.
-(use-modules (srfi srfi-64)
+(use-modules (rnrs conditions)
+ (rnrs exceptions)
+ (srfi srfi-1)
+ (srfi srfi-64)
(srfi srfi-71)
+ (ccwl conditions)
(ccwl utils))
(test-begin "utils")
@@ -79,10 +83,15 @@
((lambda** (#:key* foo)
foo)))
-(test-error "lambda** should error out on unrecognized keywords in arguments" #t
- (macroexpand
- '(lambda** (#:key foo #:foo bar)
- foo)))
+(test-assert "lambda** should raise an &unrecognized-keyword-assertion on unrecognized keywords in arguments with syntax objects as irritants"
+ (guard (exception
+ (else (and (unrecognized-keyword-assertion? exception)
+ ;; We check with NOT keyword? because we have no
+ ;; way of directly checking for syntax?.
+ (not (any keyword? (condition-irritants exception))))))
+ (macroexpand
+ '(lambda** (#:key foo #:foo bar)
+ foo))))
(test-equal "Allow other keys in lambda**"
1
@@ -90,6 +99,27 @@
foo)
#:foo 1 #:bar 2))
+(test-assert "Unrecognized keyword argument passed to lambda** should raise an &unrecognized-keyword-assertion condition"
+ (guard (exception
+ (else (unrecognized-keyword-assertion? exception)))
+ ((lambda** (spam ham #:key eggs)
+ spam)
+ 1 2 #:foo 123)))
+
+(test-assert "Unary lambda** keyword argument passed multiple arguments should raise an &invalid-keyword-arity-assertion condition"
+ (guard (exception
+ (else (invalid-keyword-arity-assertion? exception)))
+ ((lambda** (spam ham #:key eggs)
+ (list spam ham eggs))
+ 1 2 #:eggs 123 345)))
+
+(test-assert "Wrong number of positional arguments to lambda** should raise an &invalid-positional-arguments-arity-assertion condition"
+ (guard (exception
+ (else (invalid-positional-arguments-arity-assertion? exception)))
+ ((lambda** (spam ham #:key eggs)
+ spam)
+ 1 #:eggs 123)))
+
(test-assert "syntax-lambda**"
(equal? (list #'1 #'2 #'123 (list #'1 #'2 #'3))
((syntax-lambda** (a b #:key foo #:key* bar)
@@ -111,6 +141,40 @@
foo)
#'#:foo #'1 #'#:bar #'2)))
+(test-assert "syntax-lambda** should raise an &unrecognized-keyword-assertion on unrecognized keywords in arguments"
+ (guard (exception
+ (else (unrecognized-keyword-assertion? exception)))
+ (macroexpand
+ '(syntax-lambda** (#:key foo #:foo bar)
+ foo))))
+
+(test-assert "Unrecognized keyword argument passed to syntax-lambda** should raise an &unrecognized-keyword-assertion condition with syntax objects as irritants"
+ (guard (exception
+ (else (and (unrecognized-keyword-assertion? exception)
+ ;; We check with NOT keyword? because we have no
+ ;; way of directly checking for syntax?.
+ (not (any keyword? (condition-irritants exception))))))
+ ((syntax-lambda** (spam ham #:key eggs)
+ spam)
+ #'1 #'2 #'#:foo #'123)))
+
+(test-assert "Unary syntax-lambda** keyword argument passed multiple arguments should raise an &invalid-keyword-arity-assertion condition"
+ (guard (exception
+ (else (and (invalid-keyword-arity-assertion? exception)
+ ;; We check with NOT keyword? because we have no
+ ;; way of directly checking for syntax?.
+ (not (any keyword? (condition-irritants exception))))))
+ ((syntax-lambda** (spam ham #:key eggs)
+ (list spam ham eggs))
+ #'1 #'2 #'#:eggs #'123 #'345)))
+
+(test-assert "Wrong number of positional arguments to syntax-lambda** should raise an &invalid-positional-arguments-arity-assertion condition"
+ (guard (exception
+ (else (invalid-positional-arguments-arity-assertion? exception)))
+ ((syntax-lambda** (spam ham #:key eggs)
+ spam)
+ #'1 #'#:eggs #'123)))
+
(test-equal "filter-mapi"
'(1 3 5 7 9)
(filter-mapi (lambda (item index)