[Guile-commits] 08/09: Hotfix to unify (x ...) patterns in match

[Andy Wingo]

wingo pushed a commit to branch wip-tailify
in repository guile.

commit 022e42d337d10a92a1e3f78f5d7e33ad409599a1
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Thu Jun 17 21:25:31 2021 +0200

    Hotfix to unify (x ...) patterns in match
    
    * module/ice-9/match.upstream.scm (match-gen-ellipsis): Instead of just
    binding the identifier when matching (x ...), go through match-one so
    that if the id is already bound, we unify instead.
    * test-suite/tests/match.test ("unify in list patterns"): Add test.
---
 module/ice-9/match.upstream.scm |  6 +++---
 test-suite/tests/match.test     | 13 ++++++++++++-
 2 files changed, 15 insertions(+), 4 deletions(-)

diff --git a/module/ice-9/match.upstream.scm b/module/ice-9/match.upstream.scm
index b1fc371..8c8effc 100644
--- a/module/ice-9/match.upstream.scm
+++ b/module/ice-9/match.upstream.scm
@@ -509,9 +509,9 @@
     ((_ v p () g+s (sk ...) fk i ((id id-ls) ...))
      (match-check-identifier p
        ;; simplest case equivalent to (p ...), just bind the list
-       (let ((p v))
-         (if (list? p)
-             (sk ... i)
+       (let ((w v))
+         (if (list? w)
+             (match-one w p g+s (sk ...) fk i)
              fk))
        ;; simple case, match all elements of the list
        (let loop ((ls v) (id-ls '()) ...)
diff --git a/test-suite/tests/match.test b/test-suite/tests/match.test
index 6bf5bdd..b5dface 100644
--- a/test-suite/tests/match.test
+++ b/test-suite/tests/match.test
@@ -1,6 +1,6 @@
 ;;;; match.test --- (ice-9 match)  -*- mode: scheme; coding: utf-8; -*-
 ;;;;
-;;;;   Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
+;;;;   Copyright (C) 2010, 2011, 2012, 2021 Free Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -189,6 +189,17 @@
           (($ rtd-3-slots a b c d)
            #f))))))
 
+(with-test-prefix "unify in list patterns"
+  (pass-if-equal "matching" '(1 2 3)
+    (match '((1 2 3) (1 2 3))
+      (((x ...) (x ...)) x)
+      (_ #f)))
+
+  (pass-if-equal "not matching" #f
+    (match '((1 2 3) (1 2 3 4))
+      (((x ...) (x ...)) x)
+      (_ #f))))
+
 
 ;;;
 ;;; Upstream tests, from Chibi-Scheme (3-clause BSD license).