Add SRFI 244 (define-values)

%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:

%3a244/define-values.chezscheme.sls

@@ -0,0 +1,3 @@
+(library (srfi :244 define-values)
+  (export define-values)
+  (import (chezscheme)))

%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:

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))