From 36219c4b93b9a7cb87fc9c5f0118edab2adeab43 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 31 Aug 2011 11:58:37 -0400 Subject: [PATCH] Use reference implementation for srfi/11. Closes PR 12147. --- collects/srfi/11.rkt | 73 ++++++++++++++++++++++++- collects/tests/srfi/11/srfi-11-test.rkt | 9 +++ collects/tests/srfi/all-srfi-tests.rkt | 56 +++++++++---------- collects/tests/srfi/load-srfis.rktl | 1 + 4 files changed, 109 insertions(+), 30 deletions(-) create mode 100644 collects/tests/srfi/11/srfi-11-test.rkt diff --git a/collects/srfi/11.rkt b/collects/srfi/11.rkt index 2762552933..fdb915219f 100644 --- a/collects/srfi/11.rkt +++ b/collects/srfi/11.rkt @@ -1,3 +1,72 @@ -;; Supported by core PLT: -#lang scheme/base +;; The versions from `racket/base' don't support rest args. + +#| + +Modified to use `syntax-parse' and multiple macros by Sam +Tobin-Hochstadt, 2011. + +The original: + +Copyright (C) Lars T Hansen (1999). All Rights Reserved. + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation +files (the "Software"), to deal in the Software without restriction, +including without limitation the rights to use, copy, modify, merge, +publish, distribute, sublicense, and/or sell copies of the Software, +and to permit persons to whom the Software is furnished to do so, +subject to the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +|# + +#lang racket/base +(require (for-syntax racket/base syntax/parse)) + +(define-syntax let-values + (syntax-parser + ((let-values (?binding ...) ?body0 ?body1 ...) + #'(let-values/bind (?binding ...) () (begin ?body0 ?body1 ...))))) + +(define-syntax let-values/bind + (syntax-parser + ((let-values/bind () ?tmps ?body) + #'(let ?tmps ?body)) + ((let-values/bind ((?b0 ?e0) ?binding ...) ?tmps ?body) + #'(let-values/mktmp ?b0 ?e0 () (?binding ...) ?tmps ?body)))) + +(define-syntax let-values/mktmp + (syntax-parser + ((let-values/mktmp () ?e0 ?args ?bindings ?tmps ?body) + #'(call-with-values + (lambda () ?e0) + (lambda ?args + (let-values/bind ?bindings ?tmps ?body)))) + + ((let-values/mktmp (?a . ?b) ?e0 (?arg ...) ?bindings (?tmp ...) ?body) + #'(let-values/mktmp ?b ?e0 (?arg ... x) ?bindings (?tmp ... (?a x)) ?body)) + + ((let-values/mktmp ?a ?e0 (?arg ...) ?bindings (?tmp ...) ?body) + #'(call-with-values (lambda () ?e0) + (lambda (?arg ... . x) + (let-values/bind ?bindings (?tmp ... (?a x)) ?body)))))) + +(define-syntax let*-values + (syntax-parser + ((let*-values () ?body0 ?body1 ...) + #'(begin ?body0 ?body1 ...)) + + ((let*-values (?binding0 ?binding1 ...) ?body0 ?body1 ...) + #'(let-values (?binding0) + (let*-values (?binding1 ...) ?body0 ?body1 ...))))) + (provide let-values let*-values) diff --git a/collects/tests/srfi/11/srfi-11-test.rkt b/collects/tests/srfi/11/srfi-11-test.rkt new file mode 100644 index 0000000000..9d5c69996e --- /dev/null +++ b/collects/tests/srfi/11/srfi-11-test.rkt @@ -0,0 +1,9 @@ +#lang racket/base + +(require srfi/11 rackunit) +(provide srfi-11-tests) + +(define srfi-11-tests + (test-suite + "Tests for SRFI 11" + (check-equal? (let-values ((x (values 1 2 3))) x) '(1 2 3) "PR 12147"))) diff --git a/collects/tests/srfi/all-srfi-tests.rkt b/collects/tests/srfi/all-srfi-tests.rkt index 12933bf9cd..8c171119d6 100644 --- a/collects/tests/srfi/all-srfi-tests.rkt +++ b/collects/tests/srfi/all-srfi-tests.rkt @@ -1,28 +1,28 @@ -(module all-srfi-tests mzscheme - - (require rackunit) - (require "1/all-1-tests.rkt" - "2/and-let-test.rkt" - "4/srfi-4-test.rkt" - "13/string-test.rkt" - "14/char-set-test.rkt" - "26/cut-test.rkt" - "40/all-srfi-40-tests.rkt" - "43/all-srfi-43-tests.rkt" - "69/hash-tests.rkt") - (provide all-srfi-tests) - - (define all-srfi-tests - (test-suite - "all-srfi-tests" - all-1-tests - and-let*-tests - string-tests - char-set-tests - cut-tests - all-srfi-40-tests - all-srfi-43-tests - hash-tests - srfi-4-tests - )) - ) +#lang racket/base +(require rackunit) +(require "1/all-1-tests.rkt" + "2/and-let-test.rkt" + "4/srfi-4-test.rkt" + "11/srfi-11-test.rkt" + "13/string-test.rkt" + "14/char-set-test.rkt" + "26/cut-test.rkt" + "40/all-srfi-40-tests.rkt" + "43/all-srfi-43-tests.rkt" + "69/hash-tests.rkt") +(provide all-srfi-tests) + +(define all-srfi-tests + (test-suite + "all-srfi-tests" + all-1-tests + and-let*-tests + string-tests + char-set-tests + cut-tests + all-srfi-40-tests + all-srfi-43-tests + hash-tests + srfi-4-tests + srfi-11-tests + )) diff --git a/collects/tests/srfi/load-srfis.rktl b/collects/tests/srfi/load-srfis.rktl index 26c7bf11b8..011e9344fe 100644 --- a/collects/tests/srfi/load-srfis.rktl +++ b/collects/tests/srfi/load-srfis.rktl @@ -10,6 +10,7 @@ (require srfi/7) (require srfi/8) (require srfi/9) +(require srfi/11) (require srfi/13) (require srfi/14) (require srfi/17)