diff options
| -rw-r--r-- | ccwl/ccwl.scm | 130 | ||||
| -rw-r--r-- | ccwl/utils.scm | 18 | ||||
| -rw-r--r-- | tests/utils.scm | 7 |
3 files changed, 77 insertions, 78 deletions
diff --git a/ccwl/ccwl.scm b/ccwl/ccwl.scm index 37f8177..09c590c 100644 --- a/ccwl/ccwl.scm +++ b/ccwl/ccwl.scm @@ -101,73 +101,75 @@ association list." ;; TODO: Add fine-grained syntax checking. (define-syntax command (lambda (x) - ((syntax-lambda** (#:key stdin #:key* inputs outputs run other) - (let ((inputs - ;; Canonicalize inputs. - (map (lambda (x) - (syntax-case x () - ((id args ...) (identifier? #'id) - #'(id args ...)) - (id (identifier? #'id) #'(id)) - (_ (error "Invalid input:" (syntax->datum x))))) - inputs))) - (unless run - (error "#:run key required in command definition" (syntax->datum x))) - #`(make-command - (list #,@(map (lambda (x) - (syntax-case x () - ((id args ...) - ;; Instantiate <input> object with - ;; position and prefix. - #`(input 'id - #:position #,(list-index (lambda (x) + (syntax-case x () + ((_ args ...) + (apply (syntax-lambda** (#:key stdin #:key* inputs outputs run other) + (let ((inputs + ;; Canonicalize inputs. + (map (lambda (x) + (syntax-case x () + ((id args ...) (identifier? #'id) + #'(id args ...)) + (id (identifier? #'id) #'(id)) + (_ (error "Invalid input:" (syntax->datum x))))) + inputs))) + (unless run + (error "#:run key required in command definition" (syntax->datum x))) + #`(make-command + (list #,@(map (lambda (x) + (syntax-case x () + ((id args ...) + ;; Instantiate <input> object with + ;; position and prefix. + #`(input 'id + #:position #,(list-index (lambda (x) + (syntax-case x () + (input (identifier? #'input) + (eq? (syntax->datum #'id) + (syntax->datum #'input))) + ((_ input) + (eq? (syntax->datum #'id) + (syntax->datum #'input))) + (_ #f))) + run) + #:prefix #,(any (lambda (x) (syntax-case x () - (input (identifier? #'input) - (eq? (syntax->datum #'id) - (syntax->datum #'input))) - ((_ input) - (eq? (syntax->datum #'id) - (syntax->datum #'input))) + ((prefix input) + (and (eq? (syntax->datum #'id) + (syntax->datum #'input)) + #'prefix)) (_ #f))) run) - #:prefix #,(any (lambda (x) - (syntax-case x () - ((prefix input) - (and (eq? (syntax->datum #'id) - (syntax->datum #'input)) - #'prefix)) - (_ #f))) - run) - args ...)))) - inputs)) - (list #,@(map (lambda (x) - ;; Instantiate <output> object. - (syntax-case x () - ((id args ...) (identifier? #'id) - #'(output 'id args ...)) - (id (identifier? #'id) #'(output 'id)) - (_ (error "Invalid output:" - (syntax->datum x))))) - outputs)) - (list #,@(map (lambda (x) - (syntax-case x () - ;; Replace input symbol with quoted symbol. - (input (identifier? #'input) - #''input) - ;; Leave string as is. - (string-arg (string? (syntax->datum #'string-arg)) - #'string-arg) - ;; Replace prefixed input symbol with - ;; quoted symbol. - ((prefix input) (and (string? (syntax->datum #'prefix)) - (identifier? #'input)) - #''input) - (_ (error "Invalid command element:" - (syntax->datum x))))) - run)) - #,(and stdin #`'#,stdin) - (list #,@other)))) - x))) + args ...)))) + inputs)) + (list #,@(map (lambda (x) + ;; Instantiate <output> object. + (syntax-case x () + ((id args ...) (identifier? #'id) + #'(output 'id args ...)) + (id (identifier? #'id) #'(output 'id)) + (_ (error "Invalid output:" + (syntax->datum x))))) + outputs)) + (list #,@(map (lambda (x) + (syntax-case x () + ;; Replace input symbol with quoted symbol. + (input (identifier? #'input) + #''input) + ;; Leave string as is. + (string-arg (string? (syntax->datum #'string-arg)) + #'string-arg) + ;; Replace prefixed input symbol with + ;; quoted symbol. + ((prefix input) (and (string? (syntax->datum #'prefix)) + (identifier? #'input)) + #''input) + (_ (error "Invalid command element:" + (syntax->datum x))))) + run)) + #,(and stdin #`'#,stdin) + (list #,@other)))) + #'(args ...)))))) (define (input=? input1 input2) (eq? (input-id input1) diff --git a/ccwl/utils.scm b/ccwl/utils.scm index 14a3c4d..d6ca964 100644 --- a/ccwl/utils.scm +++ b/ccwl/utils.scm @@ -176,29 +176,23 @@ while that for n-ary arguments is the empty list. For example, unary-arguments)))))))))))) (define-syntax-rule (syntax-lambda** formal-args body ...) - "Like lambda**, but for syntax objects. syntax-lambda** varies -slightly from lambda** in that the first identifier (or argument) -passed to the resulting function is ignored. This is useful for -writing macros that accept keyword arguments. For example, + "Like lambda**, but for syntax objects. For example, ((syntax-lambda** (a b #:key foo #:key* bar) (list a b foo bar)) - #'(foo 1 2 #:foo 123 #:bar 1 2 3)) + #'1 #'2 #'#:foo #'123 #'#:bar #'1 #'2 #'3) => (#'1 #'2 #'123 (#'1 #'2 #'3)) Just like lambda**, syntax-lambda** also supports default values for arguments. For example, ((syntax-lambda** (foo aal #:key vale (pal 9) #:key* naal (irandu 7) (sol 3 2 1)) - (list foo aal vale pal naal irandu sol)) - #'(bar 1 2 #:vale 123 #:naal 321 456)) + (list foo aal vale pal naal irandu sol)) + #'1 #'2 #'#:vale #'123 #'#:naal #'321 #'456) => (#'1 #'2 #'123 9 (#'321 #'456) (7) (3 2 1))" - (lambda (x) + (lambda args (apply (lambda** formal-args body ...) - (with-ellipsis ::: - (syntax-case x () - ((_ args :::) - (unsyntax-keywords #'(args :::)))))))) + (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 bc9315d..be0e87f 100644 --- a/tests/utils.scm +++ b/tests/utils.scm @@ -84,13 +84,16 @@ (equal? (list #'1 #'2 #'123 (list #'1 #'2 #'3)) ((syntax-lambda** (a b #:key foo #:key* bar) (list a b foo bar)) - #'(foo 1 2 #:foo 123 #:bar 1 2 3)))) + #'1 #'2 #'#:foo #'123 #'#:bar #'1 #'2 #'3))) +((syntax-lambda** (a b #:key foo #:key* bar) + (list a b foo bar)) + #'1 #'2 #'#:foo #'123 #'#:bar #'1 #'2 #'3) (test-assert "syntax-lambda** with default values" (equal? (list #'1 #'2 #'123 9 #'(321 456) '(7) '(3 2 1)) ((syntax-lambda** (foo aal #:key vale (pal 9) #:key* naal (irandu 7) (sol 3 2 1)) (list foo aal vale pal naal irandu sol)) - #'(bar 1 2 #:vale 123 #:naal 321 456)))) + #'1 #'2 #'#:vale #'123 #'#:naal #'321 #'456))) (test-equal "filter-mapi" '(1 3 5 7 9) |