>From 2465a23eae4c654524b46c535ddc83eae2694c8f Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Tue, 2 Apr 2013 22:46:54 +0200 Subject: [PATCH] Expand (and simplify a little) define-values and set!-values to allow lambda list notation in the variables list. This fixes #1002. Unfortunately, only the set!-values macro is simplified; the ##sys#canonicalize-body procedure has only grown more appendages. This needs to be looked at soon. Tests are provided, which should make simplifying ##sys#canonicalize-body a *little* less scary. --- NEWS | 3 +++ chicken-syntax.scm | 45 ++++++++++++++++++++++----------------------- expand.scm | 31 +++++++++++++++++++++---------- tests/syntax-tests.scm | 17 +++++++++++++---- 4 files changed, 59 insertions(+), 37 deletions(-) diff --git a/NEWS b/NEWS index 018d57a..b4fb299 100644 --- a/NEWS +++ b/NEWS @@ -27,6 +27,9 @@ - C API - Deprecated C_get_argument[_2] and C_get_environment_variable[_2] functions. +- Syntax expander + - define-values and set!-values now accept lambda list notation (#1002) + 4.8.1 - Security fixes diff --git a/chicken-syntax.scm b/chicken-syntax.scm index 9b3e91d..c243d1c 100644 --- a/chicken-syntax.scm +++ b/chicken-syntax.scm @@ -323,35 +323,34 @@ 'set!-values '() (##sys#er-transformer (lambda (form r c) - (##sys#check-syntax 'set!-values form '(_ #(variable 0) _)) - (let ((vars (cadr form)) - (exp (caddr form))) - (cond ((null? vars) - ;; may this be simply "exp"? - `(##sys#call-with-values - (##core#lambda () ,exp) - (##core#lambda () (##core#undefined))) ) - ((null? (cdr vars)) - `(##core#set! ,(car vars) ,exp)) - (else - (let ([aliases (map gensym vars)]) - `(##sys#call-with-values - (##core#lambda () ,exp) - (##core#lambda ,aliases - ,@(map (lambda (v a) - `(##core#set! ,v ,a)) - vars aliases) ) ) ) ) ) )))) + (##sys#check-syntax 'set!-values form '(_ lambda-list _)) + (##sys#decompose-lambda-list + (cadr form) + (lambda (vars argc rest) + (let ((exp (caddr form))) + (if (and (pair? vars) (null? (cdr vars)) (not rest)) + `(##core#set! ,(car vars) ,exp) + `(##sys#call-with-values + (##core#lambda () ,exp) + (##core#lambda ,(r (cadr form)) + ,@(map (lambda (v) + `(##core#set! ,v ,(r v))) + vars) + (##core#undefined)))))))))) (set! ##sys#define-values-definition (##sys#extend-macro-environment 'define-values '() (##sys#er-transformer (lambda (form r c) - (##sys#check-syntax 'define-values form '(_ #(variable 0) _)) - (for-each (lambda (nm) - (let ((name (##sys#get nm '##core#macro-alias nm))) - (##sys#register-export name (##sys#current-module)))) - (cadr form)) + (##sys#check-syntax 'define-values form '(_ lambda-list _)) + (##sys#decompose-lambda-list + (cadr form) + (lambda (vars argc rest) + (for-each (lambda (nm) + (let ((name (##sys#get nm '##core#macro-alias nm))) + (##sys#register-export name (##sys#current-module)))) + vars))) `(,(r 'set!-values) ,@(cdr form)))))) (##sys#extend-macro-environment diff --git a/expand.scm b/expand.scm index b278ec0..dcdf0f0 100644 --- a/expand.scm +++ b/expand.scm @@ -477,17 +477,28 @@ `(##core#let ,(##sys#map (lambda (v) (##sys#list v (##sys#list '##core#undefined))) - (apply ##sys#append vars mvars) ) + (apply ##sys#append vars + (map (lambda (x) + (##sys#decompose-lambda-list x (lambda (v a r) v))) + mvars)) ) ,@(map (lambda (v x) `(##core#set! ,v ,x)) vars (reverse vals)) ,@(map (lambda (vs x) - (let ([tmps (##sys#map gensym vs)]) - `(##sys#call-with-values - (##core#lambda () ,x) - (##core#lambda - ,tmps - ,@(map (lambda (v t) - `(##core#set! ,v ,t)) - vs tmps) ) ) ) ) + (##sys#decompose-lambda-list + vs + (lambda (vars argc rest) + (let* ((tmps (##sys#map gensym vars)) + (rtmps (reverse tmps))) + (let lp ((llst (if rest (car rtmps) '())) + (args (if rest (cdr rtmps) rtmps))) + (if (pair? args) + (lp (cons (car args) llst) (cdr args)) + `(##sys#call-with-values + (##core#lambda () ,x) + (##core#lambda + ,llst + ,@(map (lambda (v t) + `(##core#set! ,v ,t)) + vars tmps) ) ))) ))) ) (reverse mvars) (reverse mvals) ) ,@body) ) ) @@ -563,7 +574,7 @@ (fini/syntax vars vals mvars mvals body) ) ((comp 'define-values head) ;;XXX check for any of the variables being `define-values' - (##sys#check-syntax 'define-values x '(_ #(_ 0) _) #f se) + (##sys#check-syntax 'define-values x '(_ lambda-list _) #f se) (loop rest vars vals (cons (cadr x) mvars) (cons (caddr x) mvals))) ((comp '##core#begin head) (loop (##sys#append (cdr x) rest) vars vals mvars mvals) ) diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm index 6da0277..1295563 100644 --- a/tests/syntax-tests.scm +++ b/tests/syntax-tests.scm @@ -714,8 +714,9 @@ ((_) 1))) (define (f1) 3) -(define v1 9) -(define v2 10) +(define-values (v1 v2) (values 9 10)) +(define-values (v3 . v4) (values 11 12)) +(define-values v56 (values 13)) (let () (define-syntax s2 @@ -724,18 +725,26 @@ 42 (define-values (v1 v2) (values 1 2)) 43 + (define-values (v3 . v4) (values 3 4)) + (define-values v56 (values 5 6)) (define (f1) 4) (define ((f2)) 4) (assert (= 4 (f1))) (assert (= 4 ((f2)))) (assert (= 2 (s2))) (assert (= 1 v1)) - (assert (= 2 v2))) + (assert (= 2 v2)) + (assert (= 3 v3)) + (assert (equal? (list 4) v4)) + (assert (equal? (list 5 6) v56))) (assert (= 1 (s2))) (assert (= 3 (f1))) (assert (= 9 v1)) (assert (= 10 v2)) +(assert (= 11 v3)) +(assert (equal? (list 12) v4)) +(assert (equal? (list 13) v56)) ;;; redefining definition forms (disabled, since we can not catch this error easily) @@ -1078,4 +1087,4 @@ take (syntax-rules () ((_) (begin (define req 2) (display req) (newline))))) (bar) - (assert (eq? req 1))) \ No newline at end of file + (assert (eq? req 1))) -- 1.8.0.1