From dc1fcb45cf425eed598f03ba376eab8eec1b7a48 Mon Sep 17 00:00:00 2001 From: Daphne Preston-Kendal Date: Thu, 22 Aug 2024 15:22:24 +0200 Subject: [PATCH] Add SRFI 244 (define-values) --- %3a244.sls | 31 ++++++++++++ %3a244/define-values.chezscheme.sls | 3 ++ %3a244/define-values.sls | 74 +++++++++++++++++++++++++++++ tests/define-values.sps | 47 ++++++++++++++++++ 4 files changed, 155 insertions(+) create mode 100644 %3a244.sls create mode 100644 %3a244/define-values.chezscheme.sls create mode 100644 %3a244/define-values.sls create mode 100644 tests/define-values.sps diff --git a/%3a244.sls b/%3a244.sls new file mode 100644 index 0000000..9a3f9f9 --- /dev/null +++ b/%3a244.sls @@ -0,0 +1,31 @@ +#!r6rs + +;; Copyright (C) Marc Nieper-Wißkirchen (2022). 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. + +(library (srfi :244) + (export define-values) + (import (srfi :244 define-values))) + +;; Local Variables: +;; mode: scheme +;; End: diff --git a/%3a244/define-values.chezscheme.sls b/%3a244/define-values.chezscheme.sls new file mode 100644 index 0000000..9a8e0e7 --- /dev/null +++ b/%3a244/define-values.chezscheme.sls @@ -0,0 +1,3 @@ +(library (srfi :244 define-values) + (export define-values) + (import (chezscheme))) diff --git a/%3a244/define-values.sls b/%3a244/define-values.sls new file mode 100644 index 0000000..aaea68b --- /dev/null +++ b/%3a244/define-values.sls @@ -0,0 +1,74 @@ +#!r6rs + +;; Copyright (C) Marc Nieper-Wißkirchen (2022). 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. + +(library (srfi :244 define-values) + (export define-values) + (import (rnrs (6))) + + (define-syntax define-values + (lambda (stx) + (define who 'define-values) + (define parse-formals + (lambda (formals) + (define output + (lambda (id*) + (let f ([id* id*] [i 0]) + (if (null? id*) + '() + `((,(car id*) ,i) + ,@(f (cdr id*) (+ i 1))))))) + (syntax-case formals () + [(id ...) + (for-all identifier? #'(id ...)) + (output #'(id ...))] + [(id1 ... . id2) + (for-all identifier? #'(id1 ... id2)) + (output #'(id1 ... id2))] + [_ + (syntax-violation who "invalid formals" stx formals)]))) + (syntax-case stx () + [(_ () expr) + #'(define tmp (begin expr #f))] + [(_ (id) expr) + (identifier? #'id) + #'(define id expr)] + [(_ id expr) + (identifier? #'id) + #'(define id (let-values ([tmp expr]) + tmp))] + [(_ formals expr) + (with-syntax ([((id i) ...) (parse-formals #'formals)]) + #'(begin + (define tmp (let-values ([formals expr]) + (vector id ...))) + (define id (vector-ref tmp i)) + ...))] + [_ + (syntax-violation who "invalid syntax" stx)]))) + + ) + +;; Local Variables: +;; mode: scheme +;; End: diff --git a/tests/define-values.sps b/tests/define-values.sps new file mode 100644 index 0000000..a06d530 --- /dev/null +++ b/tests/define-values.sps @@ -0,0 +1,47 @@ +#!r6rs + +;; Copyright (C) Marc Nieper-Wißkirchen (2021). 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. + +(import (rnrs (6)) + (srfi :244)) + +(define-values (a) 1) +(assert (equal? a 1)) + +(define-values b (values 2 3)) +(assert (equal? b '(2 3))) + +(define-values (x y) (values 4 5)) +(assert (equal? 4 x)) +(assert (equal? 5 y)) + +(define-values (u . v) (values 6 7)) +(assert (equal? 6 u)) +(assert (equal? '(7) v)) + +(set! u 8) +(set! v 9) +(assert (equal? 8 u)) +(assert (equal? 9 v)) + +(define-values () (values))