From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Mark H Weaver Newsgroups: gmane.lisp.guile.devel Subject: [PATCH] Implement R7RS 'define-values' Date: Thu, 19 Dec 2013 21:01:10 -0500 Message-ID: <87txe4cmc9.fsf@netris.org> NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: ger.gmane.org 1387505011 31776 80.91.229.3 (20 Dec 2013 02:03:31 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Fri, 20 Dec 2013 02:03:31 +0000 (UTC) To: guile-devel@gnu.org Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Fri Dec 20 03:03:36 2013 Return-path: Envelope-to: guile-devel@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by plane.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1VtpR8-0005KZ-NM for guile-devel@m.gmane.org; Fri, 20 Dec 2013 03:03:34 +0100 Original-Received: from localhost ([::1]:47414 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1VtpR7-0003Of-Tm for guile-devel@m.gmane.org; Thu, 19 Dec 2013 21:03:33 -0500 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:36453) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1VtpQv-0003LJ-7J for guile-devel@gnu.org; Thu, 19 Dec 2013 21:03:27 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1VtpQo-0003JK-Ci for guile-devel@gnu.org; Thu, 19 Dec 2013 21:03:21 -0500 Original-Received: from world.peace.net ([96.39.62.75]:52952) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1VtpQo-0003Aw-7q for guile-devel@gnu.org; Thu, 19 Dec 2013 21:03:14 -0500 Original-Received: from turntable.mit.edu ([18.160.0.29] helo=yeeloong) by world.peace.net with esmtpsa (TLS1.0:DHE_RSA_AES_128_CBC_SHA1:16) (Exim 4.72) (envelope-from ) id 1VtpQQ-0000is-Hn; Thu, 19 Dec 2013 21:02:52 -0500 X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.6.x X-Received-From: 96.39.62.75 X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.14 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Original-Sender: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.devel:16783 Archived-At: --=-=-= Content-Type: text/plain This patch implements 'define-values' as a macro, with a similar implementation strategy to the one used in the sample definition given in the R7RS. I hope to provide a more efficient implementation on the master branch at some point -- one which does not involve any mutation -- but for now I'd like to provide at least something so that code that uses it will run on the upcoming Guile 2.0.10. This patch was made on top of my earlier "custom ellipses" and "syntax-error" patches, although it does not strictly depend on those patches. Comments and suggestions welcome. Mark --=-=-= Content-Type: text/x-patch Content-Disposition: inline; filename=0001-Implement-R7RS-define-values.patch Content-Description: Implement R7RS 'define-values' >From bd4e9d720c62c9b842a59c03d443b9a8cec89432 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Thu, 19 Dec 2013 20:52:06 -0500 Subject: [PATCH] Implement R7RS 'define-values'. * module/ice-9/boot-9.scm (%define-values-arity-error): New procedure. (define-values): New macro. * doc/ref/api-binding.texi (Binding Multiple Values): Add docs. * test-suite/tests/syntax.test: Add tests. --- doc/ref/api-binding.texi | 23 ++++++ module/ice-9/boot-9.scm | 59 ++++++++++++++ test-suite/tests/syntax.test | 175 ++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 257 insertions(+), 0 deletions(-) diff --git a/doc/ref/api-binding.texi b/doc/ref/api-binding.texi index e3a9918..bf9aa81 100644 --- a/doc/ref/api-binding.texi +++ b/doc/ref/api-binding.texi @@ -17,6 +17,7 @@ and expressions. This is important for modularity and data abstraction. * Local Bindings:: Local variable bindings. * Internal Definitions:: Internal definitions. * Binding Reflection:: Querying variable bindings. +* Binding Multiple Values:: Binding multiple return values. @end menu @@ -321,6 +322,28 @@ the current module when @var{module} is not specified; otherwise return @end deffn +@node Binding Multiple Values +@subsection Binding multiple return values + +@deffn {Syntax} define-values formals expression +The @var{expression} is evaluated, and the @var{formals} are bound to +the return values in the same way that the formals in a @code{lambda} +expression are matched to the arguments in a procedure call. +@end deffn + +@example +(define-values (q r) (floor/ 10 3)) +(list q r) @result{} (3 1) + +(define-values (x . y) (values 1 2 3)) +x @result{} 1 +y @result{} (2 3) + +(define-values x (values 1 2 3)) +x @result{} (1 2 3) +@end example + + @c Local Variables: @c TeX-master: "guile.texi" @c End: diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 19c22ea..fe8920b 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -583,6 +583,65 @@ If there is no handler at all, Guile prints an error and then exits." ((do "step" x y) y))) +(define (%define-values-arity-error) + (throw 'wrong-number-of-args + #f + "define-values: wrong number of return values returned by expression" + '() + #f)) + +(define-syntax define-values + (lambda (orig-form) + (syntax-case orig-form () + ((_ () expr) + #`(define dummy + (call-with-values (lambda () expr) + (case-lambda + (() #f) + (_ (%define-values-arity-error)))))) + ((_ (var) expr) + (identifier? #'var) + #`(define var + (call-with-values (lambda () expr) + (case-lambda + ((v) v) + (_ (%define-values-arity-error)))))) + ((_ (var0 ... varn) expr) + (and-map identifier? #'(var0 ... varn)) + #`(begin + (define dummy + (call-with-values (lambda () expr) + (case-lambda + ((var0 ... varn) + (list var0 ... varn)) + (_ (%define-values-arity-error))))) + (define var0 + (let ((v (car dummy))) + (set! dummy (cdr dummy)) + v)) + ... + (define varn (car dummy)))) + ((_ var expr) + (identifier? #'var) + #'(define var + (call-with-values (lambda () expr) + list))) + ((_ (var0 ... . varn) expr) + (and-map identifier? #'(var0 ... varn)) + #`(begin + (define dummy + (call-with-values (lambda () expr) + (case-lambda + ((var0 ... . varn) + (list var0 ... varn)) + (_ (%define-values-arity-error))))) + (define var0 + (let ((v (car dummy))) + (set! dummy (cdr dummy)) + v)) + ... + (define varn (car dummy))))))) + (define-syntax-rule (delay exp) (make-promise (lambda () exp))) diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index 24fa8b0..a86a8af 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -85,6 +85,9 @@ (define exception:zero-expression-sequence "sequence of zero expressions") +(define exception:define-values-wrong-number-of-return-values + (cons 'wrong-number-of-args "^define-values: wrong number of return values returned by expression")) + ;; (put 'pass-if-syntax-error 'scheme-indent-function 1) (define-syntax pass-if-syntax-error @@ -911,6 +914,178 @@ (eval '(let () (define x #t)) (interaction-environment)))) +(with-test-prefix "top-level define-values" + + (pass-if "zero values" + (eval '(begin (define-values () (values)) + #t) + (interaction-environment))) + + (pass-if-equal "one value" + 1 + (eval '(begin (define-values (x) 1) + x) + (interaction-environment))) + + (pass-if-equal "two values" + '(2 3) + (eval '(begin (define-values (x y) (values 2 3)) + (list x y)) + (interaction-environment))) + + (pass-if-equal "three values" + '(4 5 6) + (eval '(begin (define-values (x y z) (values 4 5 6)) + (list x y z)) + (interaction-environment))) + + (pass-if-equal "one value with tail" + '(a (b c d)) + (eval '(begin (define-values (x . y) (values 'a 'b 'c 'd)) + (list x y)) + (interaction-environment))) + + (pass-if-equal "two values with tail" + '(x y (z w)) + (eval '(begin (define-values (x y . z) (values 'x 'y 'z 'w)) + (list x y z)) + (interaction-environment))) + + (pass-if-equal "just tail" + '(1 2 3) + (eval '(begin (define-values x (values 1 2 3)) + x) + (interaction-environment))) + + (pass-if-exception "expected 0 values, got 1" + exception:define-values-wrong-number-of-return-values + (eval '(define-values () 1) + (interaction-environment))) + + (pass-if-exception "expected 1 value, got 0" + exception:define-values-wrong-number-of-return-values + (eval '(define-values (x) (values)) + (interaction-environment))) + + (pass-if-exception "expected 1 value, got 2" + exception:define-values-wrong-number-of-return-values + (eval '(define-values (x) (values 1 2)) + (interaction-environment))) + + (pass-if-exception "expected 1 value with tail, got 0" + exception:define-values-wrong-number-of-return-values + (eval '(define-values (x . y) (values)) + (interaction-environment))) + + (pass-if-exception "expected 2 value with tail, got 1" + exception:define-values-wrong-number-of-return-values + (eval '(define-values (x y . z) 1) + (interaction-environment))) + + (pass-if "redefinition" + (let ((m (make-module))) + (beautify-user-module! m) + + ;; The previous values of `floor' and `round' must still be + ;; visible at the time the new `floor' and `round' are defined. + (eval '(define-values (floor round) (values floor round)) m) + (and (eq? (module-ref m 'floor) floor) + (eq? (module-ref m 'round) round)))) + + (with-test-prefix "missing expression" + + (pass-if-syntax-error "(define-values)" + exception:generic-syncase-error + (eval '(define-values) + (interaction-environment))))) + +(with-test-prefix "internal define-values" + + (pass-if "zero values" + (let () + (define-values () (values)) + #t)) + + (pass-if-equal "one value" + 1 + (let () + (define-values (x) 1) + x)) + + (pass-if-equal "two values" + '(2 3) + (let () + (define-values (x y) (values 2 3)) + (list x y))) + + (pass-if-equal "three values" + '(4 5 6) + (let () + (define-values (x y z) (values 4 5 6)) + (list x y z))) + + (pass-if-equal "one value with tail" + '(a (b c d)) + (let () + (define-values (x . y) (values 'a 'b 'c 'd)) + (list x y))) + + (pass-if-equal "two values with tail" + '(x y (z w)) + (let () + (define-values (x y . z) (values 'x 'y 'z 'w)) + (list x y z))) + + (pass-if-equal "just tail" + '(1 2 3) + (let () + (define-values x (values 1 2 3)) + x)) + + (pass-if-exception "expected 0 values, got 1" + exception:define-values-wrong-number-of-return-values + (eval '(let () + (define-values () 1) + #f) + (interaction-environment))) + + (pass-if-exception "expected 1 value, got 0" + exception:define-values-wrong-number-of-return-values + (eval '(let () + (define-values (x) (values)) + #f) + (interaction-environment))) + + (pass-if-exception "expected 1 value, got 2" + exception:define-values-wrong-number-of-return-values + (eval '(let () + (define-values (x) (values 1 2)) + #f) + (interaction-environment))) + + (pass-if-exception "expected 1 value with tail, got 0" + exception:define-values-wrong-number-of-return-values + (eval '(let () + (define-values (x . y) (values)) + #f) + (interaction-environment))) + + (pass-if-exception "expected 2 value with tail, got 1" + exception:define-values-wrong-number-of-return-values + (eval '(let () + (define-values (x y . z) 1) + #f) + (interaction-environment))) + + (with-test-prefix "missing expression" + + (pass-if-syntax-error "(define-values)" + exception:generic-syncase-error + (eval '(let () + (define-values) + #f) + (interaction-environment))))) + (with-test-prefix "set!" (with-test-prefix "missing or extra expressions" -- 1.7.5.4 --=-=-=--