diff --git a/chicken-syntax.scm b/chicken-syntax.scm index f97c22a..16775c6 100644 --- a/chicken-syntax.scm +++ b/chicken-syntax.scm @@ -985,22 +985,41 @@ (lambda (form r c) (let ((%<> (r '<>)) (%<...> (r '<...>)) - (%apply (r 'apply))) - (let loop ([xs (cdr form)] [vars '()] [vals '()] [rest #f]) - (if (null? xs) - (let ([rvars (reverse vars)] - [rvals (reverse vals)] ) - (if rest - (let ([rv (r (gensym))]) - `(##core#lambda - (,@rvars . ,rv) - (,%apply ,(car rvals) ,@(cdr rvals) ,rv) ) ) - `(##core#lambda ,rvars ((##core#begin ,(car rvals)) ,@(cdr rvals)) ) ) ) - (cond ((c %<> (car xs)) - (let ([v (r (gensym))]) - (loop (cdr xs) (cons v vars) (cons v vals) #f) ) ) - ((c %<...> (car xs)) (loop '() vars vals #t)) - (else (loop (cdr xs) vars (cons (car xs) vals) #f)) ) ) ) ) ))) + (%apply (r 'apply)) + (%append (r 'append)) + (%list (r 'list)) + (%reverse (r 'reverse))) + (when (null? (cdr form)) + (syntax-error 'cut "You need to supply at least a procedure" form)) + (let loop ([xs (cdr form)] [vars '()] [vals '()] [vars2 '()] [vals2 '()] + [rest #f]) + (if (null? xs) + (let ([rvars (reverse vars)] + [rvals (reverse vals)] + [rvals2 (reverse vals2)]) + (if rest + (let ([rv (r (gensym))]) + `(##core#lambda (,@rvars . ,rv) + (,%apply + (##core#lambda (,@vars2 . ,rv) + (,%apply ,(car rvals) ,@(cdr rvals) + (,%append (,%reverse ,rv) (,%list ,@rvals2)))) + (,%reverse ,rv)) ) ) + `(##core#lambda ,rvars ((##core#begin ,(car rvals)) ,@(cdr rvals)) ) ) ) + (cond ((c %<> (car xs)) + (let ([v (r (gensym))]) + (if rest + (loop (cdr xs) vars vals + (cons v vars2) (cons v vals2) #t) + (loop (cdr xs) (cons v vars) (cons v vals) '() '() #f)))) + ((c %<...> (car xs)) + (if rest + (syntax-error 'cut "Only one <...> is allowed" form) + (loop (cdr xs) vars vals '() '() #t))) + (else + (if rest + (loop (cdr xs) vars vals vars2 (cons (car xs) vals2) #t) + (loop (cdr xs) vars (cons (car xs) vals) '() '() #f)))))))))) (##sys#extend-macro-environment 'cute @@ -1009,29 +1028,48 @@ (lambda (form r c) (let ((%apply (r 'apply)) (%<> (r '<>)) - (%<...> (r '<...>))) - (let loop ([xs (cdr form)] [vars '()] [bs '()] [vals '()] [rest #f]) + (%<...> (r '<...>)) + (%append (r 'append)) + (%list (r 'list)) + (%reverse (r 'reverse))) + (when (null? (cdr form)) + (syntax-error 'cute "You need to supply at least a procedure" form)) + (let loop ([xs (cdr form)] [bs '()] [vars '()] [vals '()] + [vars2 '()] [vals2 '()] [rest #f]) (if (null? xs) (let ([rvars (reverse vars)] - [rvals (reverse vals)] ) + [rvals (reverse vals)] + [rvals2 (reverse vals2)]) (if rest (let ([rv (r (gensym))]) `(##core#let ,bs - (##core#lambda (,@rvars . ,rv) - (,%apply ,(car rvals) ,@(cdr rvals) ,rv) ) ) ) + (##core#lambda (,@rvars . ,rv) + (,%apply + (##core#lambda (,@vars2 . ,rv) + (,%apply ,(car rvals) ,@(cdr rvals) + (,%append (,%reverse ,rv) (,%list ,@rvals2)))) + (,%reverse ,rv)) ) ) ) `(##core#let ,bs (##core#lambda ,rvars (,(car rvals) ,@(cdr rvals)) ) ) ) ) (cond ((c %<> (car xs)) (let ([v (r (gensym))]) - (loop (cdr xs) (cons v vars) bs (cons v vals) #f) ) ) - ((c %<...> (car xs)) (loop '() vars bs vals #t)) + (if rest + (loop (cdr xs) bs vars vals + (cons v vars2) (cons v vals2) #t) + (loop (cdr xs) bs (cons v vars) (cons v vals) + '() '() #f)))) + ((c %<...> (car xs)) + (if rest + (syntax-error 'cut "Only one <...> is allowed" form) + (loop (cdr xs) bs vars vals vars2 vals2 #t))) (else (let ([v (r (gensym))]) - (loop (cdr xs) - vars - (cons (list v (car xs)) bs) - (cons v vals) #f) ) )))))))) + (if rest + (loop (cdr xs) (cons (list v (car xs)) bs) + vars vals vars2 (cons v vals2) #t) + (loop (cdr xs) (cons (list v (car xs)) bs) + vars (cons v vals) vars2 vals2 #f)) ) )))))))) ;;; SRFI-31 diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm index c210165..f8d857a 100644 --- a/tests/syntax-tests.scm +++ b/tests/syntax-tests.scm @@ -22,7 +22,7 @@ (t 3 3) (f abc) - +#| (f (t 3 4)) ;; test syntax-rules @@ -478,3 +478,71 @@ (import (prefix rfoo f:)) (f:rbar 1) +|# +;;; SRFI-26 + +;; Cut +(t '() ((cut list))) +(t '() ((cut list <...>))) +(t '(1) ((cut list 1))) +(t '(1) ((cut list <>) 1)) +(t '(1) ((cut list <...>) 1)) +(t '(1 2) ((cut list 1 2))) +(t '(1 2) ((cut list 1 <>) 2)) +(t '(1 2) ((cut list 1 <...>) 2)) +(t '(1 2 3 4) ((cut list 1 <...>) 2 3 4)) +(t '(1 2 3 4) ((cut list 1 <> 3 <>) 2 4)) +(t '(1 2 3 4 5 6) ((cut list 1 <> 3 <...>) 2 4 5 6)) +(t '(ok) (let* ((x 'wrong) + (y (cut list x))) + (set! x 'ok) + (y))) +(t 2 (let ((a 0)) + (map (cut + (begin (set! a (+ a 1)) a) <>) + '(1 2)) + a)) +;; Extensions +(t '(1) ((cut list <...> 1))) +(t '(1) ((cut list <...> <>) 1)) +(t '(1 2) ((cut list <...> 2) 1)) +(t '(1 2 3 4) ((cut list <...> 4) 1 2 3)) +(t '(1 2 3 4) ((cut list <...> 1 <> 3 <>) 2 4)) +(t '(1 2 3 4 5 6) ((cut list <...> 3 <> 5 <>) 1 2 4 6)) +(t '(ok) (let* ((x 'wrong) + (y (cut list <...> x))) + (set! x 'ok) + (y))) +(t 2 (let ((a 0)) + (map (cut + <...> (begin (set! a (+ a 1)) a) <>) + '(1 2)) + a)) + + +;; Cute +(t '() ((cute list))) +(t '() ((cute list <...>))) +(t '(1) ((cute list 1))) +(t '(1) ((cute list <>) 1)) +(t '(1) ((cute list <...>) 1)) +(t '(1 2) ((cute list 1 2))) +(t '(1 2) ((cute list 1 <>) 2)) +(t '(1 2) ((cute list 1 <...>) 2)) +(t '(1 2 3 4) ((cute list 1 <...>) 2 3 4)) +(t '(1 2 3 4) ((cute list 1 <> 3 <>) 2 4)) +(t '(1 2 3 4 5 6) ((cute list 1 <> 3 <...>) 2 4 5 6)) +(t 1 (let ((a 0)) + (map (cute + (begin (set! a (+ a 1)) a) <>) + '(1 2)) + a)) +;; Extensions +(t '(1) ((cute list <...> 1))) +(t '(1) ((cute list <...> <>) 1)) +(t '(1 2) ((cute list <...> 2) 1)) +(t '(1 2) ((cute list 1 <...>) 2)) +(t '(1 2 3 4) ((cute list <...> 4) 1 2 3)) +(t '(1 2 3 4) ((cute list <...> 1 <> 3 <>) 2 4)) +(t '(1 2 3 4 5 6) ((cute list <...> 3 <> 5 <>) 1 2 4 6)) +(t 1 (let ((a 0)) + (map (cute + <...> (begin (set! a (+ a 1)) a) <>) + '(1 2)) + a)) \ No newline at end of file