diff options
| -rw-r--r-- | ccwl/conditions.scm | 17 | ||||
| -rw-r--r-- | ccwl/utils.scm | 132 | ||||
| -rw-r--r-- | tests/utils.scm | 74 |
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) |